start some lexer stuff

tests/Tests.idr

@@ -7,7 +7,10 @@ import Tests.Equal
 import System
 
 
-allTests = [Equal.tests]
+allTests = [
+  Lexer.tests,
+  skip Equal.tests
+]
 
 main = do
   opts <- getTestOpts

tests/Tests/Lexer.idr

@@ -0,0 +1,105 @@
+module Tests.Lexer
+
+import Quox.Lexer
+import TAP
+
+
+export
+ToInfo Error where
+  toInfo (Err line col char) =
+    [("line", show line), ("col", show col), ("char", show char)]
+
+data ExtraError
+= WrongAnswer (List Kind) (List Kind)
+| TestFailed  (List Kind)
+
+ToInfo ExtraError where
+  toInfo (WrongAnswer exp got) =
+    [("expected", show exp), ("received", show got)]
+  toInfo (TestFailed got) = [("failed", show got)]
+
+
+parameters (label : String) (input : String)
+  acceptsSuchThat' : (List Kind -> Maybe ExtraError) -> Test
+  acceptsSuchThat' p = test {es = [Lexer.Error, ExtraError]} label $ do
+    res <- map (kind . val) <$> lex input
+    case p res of
+         Just err => throw err
+         Nothing  => pure ()
+
+  acceptsSuchThat : (List Kind -> Bool) -> Test
+  acceptsSuchThat p = acceptsSuchThat' $ \res =>
+    if p res then Nothing else Just $ TestFailed res
+
+  acceptsWith : List Kind -> Test
+  acceptsWith expect = acceptsSuchThat' $ \res =>
+    if res == expect then Nothing else Just $ WrongAnswer expect res
+
+  accepts : Test
+  accepts = acceptsSuchThat $ const True
+
+  rejects : Test
+  rejects = testThrows {es = [Lexer.Error]} label $ delay $
+    map (kind . val) <$> lex input
+
+parameters (input : String) {default False esc : Bool}
+  show' : String -> String
+  show' s = if esc then show s else "\"\{s}\""
+
+  acceptsWith' : List Kind -> Test
+  acceptsWith' = acceptsWith (show' input) input
+
+  accepts' : Test
+  accepts' = accepts (show' input) input
+
+  rejects' : Test
+  rejects' = rejects "\{show' input}  (reject)" input
+
+
+tests = "lexer" :- [
+  "comments" :- [
+    acceptsWith' ""            [],
+    acceptsWith' "  \n \t\t "  [] {esc = True},
+    acceptsWith' "-- a"        [],
+    acceptsWith' "{- -}"       [],
+    acceptsWith' "{--}"        [],
+    acceptsWith' "{------}"    [],
+    acceptsWith' "{- {- -} -}" [],
+    acceptsWith' "{- } -}"     [],
+    rejects' "{-}",
+    rejects' "{- {- -}",
+    acceptsWith' "( -- comment \n )" [P LParen, P RParen] {esc = True}
+  ],
+
+  "punctuation" :- [
+    acceptsWith' "({[:,::]})"
+      [P LParen, P LBrace, P LSquare,
+       P Colon, P Comma, P DblColon,
+       P RSquare, P RBrace, P RParen],
+    acceptsWith' " ( { [ : , :: ] } ) "
+      [P LParen, P LBrace, P LSquare,
+       P Colon, P Comma, P DblColon,
+       P RSquare, P RBrace, P RParen],
+    acceptsWith' "-> → => ⇒ ** × << ⊲ ∷"
+      [P Arrow, P Arrow, P DblArrow, P DblArrow,
+       P Times, P Times, P Triangle, P Triangle, P DblColon],
+    acceptsWith' "_" [P Wild]
+  ],
+
+  "names & symbols" :- [
+    acceptsWith' "a"        [Name],
+    acceptsWith' "abc"      [Name],
+    acceptsWith' "_a"       [Name],
+    acceptsWith' "a_"       [Name],
+    acceptsWith' "a_b"      [Name],
+    acceptsWith' "abc'"     [Name],
+    acceptsWith' "a'b'c''"  [Name],
+    acceptsWith' "abc123"   [Name],
+    acceptsWith' "ab cd"    [Name, Name],
+    acceptsWith' "ab{--}cd" [Name, Name],
+    acceptsWith' "'a"       [Symbol],
+    acceptsWith' "'ab"      [Symbol],
+    acceptsWith' "'_b"      [Symbol],
+    rejects'     "'"
+  ]
+]