|
| 1 | +module Test.BasicSpecs where |
| 2 | + |
| 3 | +import Prelude hiding (between) |
| 4 | + |
| 5 | +import Test.Utils (AnyParser(..), mkAnyParser) |
| 6 | +import Control.Alt ((<|>)) |
| 7 | +import Control.Monad.Writer (Writer, execWriter, tell) |
| 8 | +import Data.Either (isRight) |
| 9 | +import Data.List (List) |
| 10 | +import Data.List as List |
| 11 | +import Data.Traversable (traverse) |
| 12 | +import Effect (Effect) |
| 13 | +import Effect.Class.Console (log) |
| 14 | +import Test.Assert (assert') |
| 15 | +import Text.Parsing.StringParser (Parser, runParser, try) |
| 16 | +import Text.Parsing.StringParser.CodePoints (anyChar, anyDigit, anyLetter, char, eof, skipSpaces, string) |
| 17 | +import Text.Parsing.StringParser.Combinators (between, chainl, chainl1, endBy, endBy1, lookAhead, many, many1, manyTill, sepBy, sepBy1, sepEndBy, sepEndBy1) |
| 18 | + |
| 19 | +type TestInputs = { successes :: Array String, failures :: Array String } |
| 20 | +type TestCase = { name :: String, parser :: AnyParser, inputs :: TestInputs } |
| 21 | + |
| 22 | +testCases :: Array TestCase |
| 23 | +testCases = |
| 24 | + [ { name: "anyChar" |
| 25 | + , parser: mkAnyParser anyChar |
| 26 | + -- TODO: test "🙂" which should fail |
| 27 | + -- this is an open upstream issue https://github.com/purescript/purescript-strings/issues/153 |
| 28 | + , inputs: { successes: [ "a", "%" ], failures: [ "" ] } |
| 29 | + } |
| 30 | + , { name: "anyLetter" |
| 31 | + , parser: mkAnyParser anyLetter |
| 32 | + , inputs: { successes: [ "a" ], failures: [ "9" ] } |
| 33 | + } |
| 34 | + , { name: "skipSpaces" |
| 35 | + , parser: mkAnyParser $ skipSpaces *> anyChar |
| 36 | + , inputs: { successes: [ " 9", "9" ], failures: [ "9 " ] } |
| 37 | + } |
| 38 | + , { name: "map" |
| 39 | + , parser: mkAnyParser $ anyChar <#> const 3 |
| 40 | + , inputs: { successes: [ "9" ], failures: [ "" ] } |
| 41 | + } |
| 42 | + , { name: "applicative" |
| 43 | + , parser: mkAnyParser $ (anyLetter <#> (\c -> (\c2 -> [ c, c2 ]))) <*> anyDigit |
| 44 | + , inputs: { successes: [ "a9" ], failures: [ "", "-", "a", "9" ] } |
| 45 | + } |
| 46 | + , { name: "alt" |
| 47 | + , parser: mkAnyParser $ anyLetter <|> anyDigit |
| 48 | + , inputs: { successes: [ "x", "9" ], failures: [ "", "-", "aa" ] } |
| 49 | + } |
| 50 | + , { name: "bind" |
| 51 | + , parser: mkAnyParser $ anyLetter >>= \letter -> char letter |
| 52 | + , inputs: { successes: [ "xx" ], failures: [ "", "-", "a", "aaa" ] } |
| 53 | + } |
| 54 | + , { name: "try" |
| 55 | + , parser: mkAnyParser $ try (anyLetter *> anyDigit) <|> char 'a' |
| 56 | + , inputs: { successes: [ "b9", "a6", "a" ], failures: [ "", "b", "-", "6" ] } |
| 57 | + } |
| 58 | + , { name: "lookAhead" |
| 59 | + , parser: mkAnyParser $ lookAhead (char 'a') *> anyLetter |
| 60 | + , inputs: { successes: [ "a" ], failures: [ "", "b" ] } |
| 61 | + } |
| 62 | + , { name: "many" |
| 63 | + , parser: mkAnyParser $ many (char 'a') |
| 64 | + , inputs: { successes: [ "", "a", "aaaa" ], failures: [ "b" ] } |
| 65 | + } |
| 66 | + , { name: "many1" |
| 67 | + , parser: mkAnyParser $ many1 (char 'a') |
| 68 | + , inputs: { successes: [ "a", "aaaa" ], failures: [ "", "b" ] } |
| 69 | + } |
| 70 | + , { name: "between" |
| 71 | + , parser: mkAnyParser $ between (char 'a') (char 'b') (char 'x') |
| 72 | + , inputs: { successes: [ "axb" ], failures: [ "", "x", "a", "b", "ab" ] } |
| 73 | + } |
| 74 | + , { name: "sepBy" |
| 75 | + , parser: mkAnyParser $ sepBy anyLetter (char ';') |
| 76 | + , inputs: { successes: [ "", "a", "a;b", "a;b;c" ], failures: [ ";", ";a", "a;", "ab", "a;ab" ] } |
| 77 | + } |
| 78 | + , { name: "sepBy1" |
| 79 | + , parser: mkAnyParser $ sepBy1 anyLetter (char ';') |
| 80 | + , inputs: { successes: [ "a", "a;b", "a;b;c" ], failures: [ "", ";", ";a", "a;", "ab", "a;ab" ] } |
| 81 | + } |
| 82 | + , { name: "sepEndBy" |
| 83 | + , parser: mkAnyParser $ sepEndBy anyLetter (char ';') |
| 84 | + , inputs: { successes: [ "", ";", "a", "a;b", "a;b;c", "a;" ], failures: [ ";a", "ab", "a;ab" ] } |
| 85 | + } |
| 86 | + , { name: "sepEndBy1" |
| 87 | + , parser: mkAnyParser $ sepEndBy1 anyLetter (char ';') |
| 88 | + , inputs: { successes: [ "a", "a;b", "a;b;c", "a;" ], failures: [ "", ";", ";a", "ab", "a;ab" ] } |
| 89 | + } |
| 90 | + , { name: "endBy" |
| 91 | + , parser: mkAnyParser $ endBy anyLetter (char ';') |
| 92 | + , inputs: { successes: [ ";", "a;", "a;b;", "a;b;c;" ], failures: [ "", "a", ";a", "ab", "a;b", "a;b;c" ] } |
| 93 | + } |
| 94 | + , { name: "endBy1" |
| 95 | + , parser: mkAnyParser $ endBy1 anyLetter (char ';') |
| 96 | + , inputs: { successes: [ "a;", "a;b;", "a;b;c;" ], failures: [ "", ";", "a", ";a", "ab", "a;b", "a;b;c" ] } |
| 97 | + } |
| 98 | + , { name: "manyTill" |
| 99 | + , parser: mkAnyParser $ manyTill anyLetter (char ';') |
| 100 | + , inputs: { successes: [ ";", "a;", "abc;" ], failures: [ "", "a", ";a", "ab", "a;b", "a;b;c" ] } |
| 101 | + } |
| 102 | + , { name: "manyTill overlapping" |
| 103 | + , parser: mkAnyParser $ manyTill anyLetter (char 'z') |
| 104 | + , inputs: { successes: [ "z", "az", "abcz" ], failures: [ "", "a", "za", "ab", "azb", "azbzc" ] } |
| 105 | + } |
| 106 | + , { name: "chainl" |
| 107 | + , parser: mkAnyParser $ chainl (string "x") (char '+' $> (<>)) "" |
| 108 | + , inputs: { successes: [ "", "x", "x+x+x+x" ], failures: [ "+", "+x", "x+", "x+x+", "xx", "xx+" ] } |
| 109 | + } |
| 110 | + , { name: "chainl1" |
| 111 | + , parser: mkAnyParser $ chainl1 (string "x") (char '+' $> (<>)) |
| 112 | + , inputs: { successes: [ "x", "x+x+x+x" ], failures: [ "", "+", "+x", "x+", "x+x+", "xx", "xx+" ] } |
| 113 | + } |
| 114 | + ] |
| 115 | + |
| 116 | +type TestResult = Writer (List String) Unit |
| 117 | + |
| 118 | +reportError :: String -> TestResult |
| 119 | +reportError = tell <<< List.singleton |
| 120 | + |
| 121 | +runTestCases :: Effect Unit |
| 122 | +runTestCases = do |
| 123 | + let errors = execWriter $ traverse evalTestCase testCases |
| 124 | + when (List.length errors > 0) do |
| 125 | + _ <- traverse log errors |
| 126 | + assert' "Errors found" false |
| 127 | + |
| 128 | +evalTestCase :: TestCase -> TestResult |
| 129 | +evalTestCase tc = do |
| 130 | + _ <- traverse assertSuccess tc.inputs.successes |
| 131 | + _ <- traverse assertFailure tc.inputs.failures |
| 132 | + pure unit |
| 133 | + where |
| 134 | + assertSuccess input = |
| 135 | + when (not (evalAnyParser tc.parser input)) do |
| 136 | + reportError ("Expected " <> tc.name <> " to succeed on '" <> input <> "' but it failed") |
| 137 | + assertFailure input = |
| 138 | + when (evalAnyParser tc.parser input) do |
| 139 | + reportError ("Expected " <> tc.name <> " to fail on '" <> input <> "' but it succeeded") |
| 140 | + |
| 141 | +evalAnyParser :: AnyParser -> String -> Boolean |
| 142 | +evalAnyParser (AnyParser anyP) input = anyP canFullyParse input |
| 143 | + |
| 144 | +canFullyParse :: forall a. Parser a -> String -> Boolean |
| 145 | +canFullyParse p input = isRight $ runParser (p *> eof) input |
0 commit comments