remove old replaced stuff
This commit is contained in:
parent
d115672d49
commit
310822ffa5
3 changed files with 0 additions and 378 deletions
|
|
@ -1,144 +0,0 @@
|
||||||
module Tests.Lexer
|
|
||||||
|
|
||||||
import Quox.Lexer
|
|
||||||
import TAP
|
|
||||||
|
|
||||||
|
|
||||||
RealError = Quox.Lexer.Error
|
|
||||||
%hide Quox.Lexer.Error
|
|
||||||
|
|
||||||
export
|
|
||||||
ToInfo RealError where
|
|
||||||
toInfo (Err reason line col char) =
|
|
||||||
[("reason", show reason),
|
|
||||||
("line", show line),
|
|
||||||
("col", show col),
|
|
||||||
("char", show char)]
|
|
||||||
|
|
||||||
data Error
|
|
||||||
= LexerError RealError
|
|
||||||
| WrongAnswer (List Token) (List Token)
|
|
||||||
| TestFailed (List Token)
|
|
||||||
|
|
||||||
ToInfo Error where
|
|
||||||
toInfo (LexerError err) = toInfo err
|
|
||||||
toInfo (WrongAnswer exp got) =
|
|
||||||
[("expected", show exp), ("received", show got)]
|
|
||||||
toInfo (TestFailed got) =
|
|
||||||
[("failed", show got)]
|
|
||||||
|
|
||||||
|
|
||||||
lex' : String -> Either Error (List Token)
|
|
||||||
lex' = bimap LexerError (map val) . lex
|
|
||||||
|
|
||||||
parameters (label : String) (input : String)
|
|
||||||
acceptsSuchThat' : (List Token -> Maybe Error) -> Test
|
|
||||||
acceptsSuchThat' p = test label $ delay $ do
|
|
||||||
res <- bimap LexerError (map val) $ lex input
|
|
||||||
case p res of
|
|
||||||
Just err => throwError err
|
|
||||||
Nothing => pure ()
|
|
||||||
|
|
||||||
acceptsSuchThat : (List Token -> Bool) -> Test
|
|
||||||
acceptsSuchThat p = acceptsSuchThat' $ \res =>
|
|
||||||
if p res then Nothing else Just $ TestFailed res
|
|
||||||
|
|
||||||
acceptsWith : List Token -> 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 label (\case LexerError _ => True; _ => False) $ delay $
|
|
||||||
bimap LexerError (map val) $ lex input
|
|
||||||
|
|
||||||
parameters (input : String) {default False esc : Bool}
|
|
||||||
show' : String -> String
|
|
||||||
show' s = if esc then show s else "\"\{s}\""
|
|
||||||
|
|
||||||
acceptsWith' : List Token -> 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 RSquare, P RBrace, P RParen],
|
|
||||||
acceptsWith' " ( { [ : , ] } ) "
|
|
||||||
[P LParen, P LBrace, P LSquare,
|
|
||||||
P Colon, P Comma,
|
|
||||||
P RSquare, P RBrace, P RParen],
|
|
||||||
acceptsWith' "→ ⇒ × ⊲ ∷"
|
|
||||||
[P Arrow, P DblArrow, P Times, P Triangle, P DblColon],
|
|
||||||
acceptsWith' "_" [P Wild]
|
|
||||||
],
|
|
||||||
|
|
||||||
"names & symbols" :- [
|
|
||||||
acceptsWith' "a" [Name "a"],
|
|
||||||
acceptsWith' "abc" [Name "abc"],
|
|
||||||
acceptsWith' "_a" [Name "_a"],
|
|
||||||
acceptsWith' "a_" [Name "a_"],
|
|
||||||
acceptsWith' "a_b" [Name "a_b"],
|
|
||||||
acceptsWith' "abc'" [Name "abc'"],
|
|
||||||
acceptsWith' "a'b'c''" [Name "a'b'c''"],
|
|
||||||
acceptsWith' "abc123" [Name "abc123"],
|
|
||||||
acceptsWith' "_1" [Name "_1"],
|
|
||||||
acceptsWith' "ab cd" [Name "ab", Name "cd"],
|
|
||||||
acceptsWith' "ab{--}cd" [Name "ab", Name "cd"],
|
|
||||||
acceptsWith' "'a" [Symbol "a"],
|
|
||||||
acceptsWith' "'ab" [Symbol "ab"],
|
|
||||||
acceptsWith' "'_b" [Symbol "_b"],
|
|
||||||
acceptsWith' "a.b.c" [Name "a", P Dot, Name "b", P Dot, Name "c"],
|
|
||||||
rejects' "'",
|
|
||||||
rejects' "1abc"
|
|
||||||
],
|
|
||||||
|
|
||||||
"keywords" :- [
|
|
||||||
acceptsWith' "λ" [K Lam],
|
|
||||||
acceptsWith' "let" [K Let],
|
|
||||||
acceptsWith' "in" [K In],
|
|
||||||
acceptsWith' "case" [K Case],
|
|
||||||
acceptsWith' "of" [K Of],
|
|
||||||
acceptsWith' "ω" [K Omega],
|
|
||||||
acceptsWith' "Π" [K Pi],
|
|
||||||
acceptsWith' "Σ" [K Sigma],
|
|
||||||
acceptsWith' "W" [K W],
|
|
||||||
acceptsWith' "WAAA" [Name "WAAA"]
|
|
||||||
],
|
|
||||||
|
|
||||||
"universes" :- [
|
|
||||||
acceptsWith' "★10" [TYPE 10],
|
|
||||||
rejects' "★"
|
|
||||||
],
|
|
||||||
|
|
||||||
"numbers" :- [
|
|
||||||
acceptsWith' "0" [N Zero],
|
|
||||||
acceptsWith' "1" [N One],
|
|
||||||
acceptsWith' "2" [N $ Other 2],
|
|
||||||
acceptsWith' "69" [N $ Other 69]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
@ -1,144 +0,0 @@
|
||||||
module Tests.Parser
|
|
||||||
|
|
||||||
import Quox.Syntax
|
|
||||||
import Quox.Parser
|
|
||||||
import Quox.Lexer
|
|
||||||
import Tests.Lexer
|
|
||||||
import Quox.Pretty
|
|
||||||
|
|
||||||
import TermImpls
|
|
||||||
import Data.SnocVect
|
|
||||||
import Text.Parser
|
|
||||||
import TAP
|
|
||||||
|
|
||||||
|
|
||||||
export
|
|
||||||
Show tok => ToInfo (ParsingError tok) where
|
|
||||||
toInfo (Error msg Nothing) = [("msg", msg)]
|
|
||||||
toInfo (Error msg (Just loc)) = [("loc", show loc), ("msg", msg)]
|
|
||||||
|
|
||||||
|
|
||||||
numberErrs : List1 Info -> Info
|
|
||||||
numberErrs (head ::: []) = head
|
|
||||||
numberErrs (head ::: tail) = go 0 (head :: tail) where
|
|
||||||
number1 : Nat -> Info -> Info
|
|
||||||
number1 n = map $ \(k, v) => (show n ++ k, v)
|
|
||||||
|
|
||||||
go : Nat -> List Info -> Info
|
|
||||||
go k [] = []
|
|
||||||
go k (x :: xs) = number1 k x ++ go (S k) xs
|
|
||||||
|
|
||||||
export
|
|
||||||
ToInfo Parser.Error where
|
|
||||||
toInfo (Lex err) = toInfo err
|
|
||||||
toInfo (Parse errs) = numberErrs $ map toInfo errs
|
|
||||||
toInfo (Leftover toks) = toInfo [("leftover", toks)]
|
|
||||||
|
|
||||||
|
|
||||||
RealError = Quox.Parser.Error
|
|
||||||
%hide Lexer.RealError
|
|
||||||
%hide Quox.Parser.Error
|
|
||||||
|
|
||||||
data Error a
|
|
||||||
= Parser RealError
|
|
||||||
| Unexpected a a
|
|
||||||
| ShouldFail a
|
|
||||||
|
|
||||||
export
|
|
||||||
Show a => ToInfo (Error a) where
|
|
||||||
toInfo (Parser err) = toInfo err
|
|
||||||
toInfo (Unexpected exp got) = toInfo $
|
|
||||||
[("expected", exp), ("received", got)]
|
|
||||||
toInfo (ShouldFail got) = toInfo [("success", got)]
|
|
||||||
|
|
||||||
|
|
||||||
parameters {c : Bool} (grm : Grammar c a) (note : String) (input : String)
|
|
||||||
parsesNote : (Show a, Eq a) => a -> Test
|
|
||||||
parsesNote exp = test "\"\{input}\"\{note}" $ delay $
|
|
||||||
case lexParseAll grm input of
|
|
||||||
Right got => if got == exp then Right ()
|
|
||||||
else Left $ Unexpected exp got
|
|
||||||
Left err => Left $ Parser err
|
|
||||||
|
|
||||||
rejectsNote : Show a => Test
|
|
||||||
rejectsNote = test "\"\{input}\"\{note} ‹reject›" $ do
|
|
||||||
case lexParseAll grm input of
|
|
||||||
Left err => Right ()
|
|
||||||
Right val => Left $ ShouldFail val
|
|
||||||
|
|
||||||
parameters {c : Bool} (grm : Grammar c a) (input : String)
|
|
||||||
parses : (Show a, Eq a) => a -> Test
|
|
||||||
parses = parsesNote grm "" input
|
|
||||||
|
|
||||||
rejects : Show a => Test
|
|
||||||
rejects = rejectsNote grm "" input
|
|
||||||
|
|
||||||
tests = "parser" :- [
|
|
||||||
"numbers" :-
|
|
||||||
let parses = parses number
|
|
||||||
in [
|
|
||||||
parses "0" 0,
|
|
||||||
parses "1" 1,
|
|
||||||
parses "1000" 1000
|
|
||||||
],
|
|
||||||
|
|
||||||
"bound vars (x, y, z | a ⊢)" :-
|
|
||||||
let grm = bound "test" {bound = [< "x", "y", "z"], avoid = [< "a"]}
|
|
||||||
parses = parses grm; rejects = rejects grm; rejectsNote = rejectsNote grm
|
|
||||||
in [
|
|
||||||
parses "x" (V 2),
|
|
||||||
parses "y" (V 1),
|
|
||||||
parses "z" (V 0),
|
|
||||||
rejects "M.x",
|
|
||||||
rejects "x.a",
|
|
||||||
rejectsNote " (avoid)" "a",
|
|
||||||
rejectsNote " (not in scope)" "c"
|
|
||||||
],
|
|
||||||
|
|
||||||
"bound or free vars (x, y, z ⊢)" :-
|
|
||||||
let parses = parses $ nameWith {bound = [< "x", "y", "z"], avoid = [<]}
|
|
||||||
in [
|
|
||||||
parses "x" (Left (V 2)),
|
|
||||||
parses "y" (Left (V 1)),
|
|
||||||
parses "z" (Left (V 0)),
|
|
||||||
parses "a" (Right (MakeName [<] (UN "a"))),
|
|
||||||
parses "a.b.c" (Right (MakeName [< "a", "b"] (UN "c"))),
|
|
||||||
parses "a . b . c" (Right (MakeName [< "a", "b"] (UN "c"))),
|
|
||||||
parses "M.x" (Right (MakeName [< "M"] (UN "x"))),
|
|
||||||
parses "x.a" (Right (MakeName [< "x"] (UN "a")))
|
|
||||||
],
|
|
||||||
|
|
||||||
"dimension (i, j | x, y, z ⊢)" :-
|
|
||||||
let grm = dimension {dvars = [< "i", "j"], tvars = [< "x", "y", "z"]}
|
|
||||||
parses = parses grm; rejects = rejects grm; rejectsNote = rejectsNote grm
|
|
||||||
in [
|
|
||||||
parses "0" (K Zero),
|
|
||||||
parses "1" (K One),
|
|
||||||
rejects "2",
|
|
||||||
parses "i" (B (V 1)),
|
|
||||||
rejectsNote " (tvar)" "x",
|
|
||||||
rejectsNote " (not in scope)" "a"
|
|
||||||
],
|
|
||||||
|
|
||||||
"terms & elims (i, j | x, y, z ⊢)" :-
|
|
||||||
let dvars = [< "i", "j"]; tvars = [< "x", "y", "z"]
|
|
||||||
tgrm = term {dvars, tvars}; egrm = elim {dvars, tvars}
|
|
||||||
tparses = parsesNote tgrm " (term)"
|
|
||||||
eparses = parsesNote egrm " (elim)"
|
|
||||||
trejects = rejectsNote tgrm " (term)"
|
|
||||||
erejects = rejectsNote egrm " (elim)"
|
|
||||||
in [
|
|
||||||
"universes" :- [
|
|
||||||
tparses "★0" (TYPE 0),
|
|
||||||
tparses "★1000" (TYPE 1000)
|
|
||||||
],
|
|
||||||
|
|
||||||
"variables" :- [
|
|
||||||
eparses "a" (F "a"),
|
|
||||||
eparses "x" (BV 2),
|
|
||||||
trejects "a",
|
|
||||||
tparses "[a]" (FT "a"),
|
|
||||||
tparses "[x]" (BVT 2)
|
|
||||||
]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
@ -1,90 +0,0 @@
|
||||||
module Tests.Unicode
|
|
||||||
|
|
||||||
import Quox.NatExtra
|
|
||||||
import Quox.Unicode
|
|
||||||
import Data.List
|
|
||||||
import Data.String
|
|
||||||
import Data.Maybe
|
|
||||||
import TAP
|
|
||||||
|
|
||||||
|
|
||||||
maxLatin1 = '\xFF'
|
|
||||||
|
|
||||||
escape : Char -> Maybe String
|
|
||||||
escape '\'' = Nothing
|
|
||||||
escape c =
|
|
||||||
if c > maxLatin1 then Nothing else
|
|
||||||
case unpack $ show c of
|
|
||||||
'\'' :: '\\' :: cs => pack . ('\\' ::) <$> init' cs
|
|
||||||
_ => Nothing
|
|
||||||
|
|
||||||
codepoint : Char -> String
|
|
||||||
codepoint = padLeft 4 '0' . showHex . cast
|
|
||||||
|
|
||||||
display : Char -> String
|
|
||||||
display c =
|
|
||||||
let c' = fromMaybe (singleton c) $ escape c in
|
|
||||||
if '\x20' <= c && c <= maxLatin1
|
|
||||||
then "｢\{c'}｣"
|
|
||||||
else "｢\{c'}｣ (U+\{codepoint c})"
|
|
||||||
|
|
||||||
displayS' : String -> String
|
|
||||||
displayS' =
|
|
||||||
foldMap (\c => if c <= maxLatin1 then singleton c else "\\x\{codepoint c}") .
|
|
||||||
unpack
|
|
||||||
|
|
||||||
displayS : String -> String
|
|
||||||
displayS str =
|
|
||||||
if all (<= maxLatin1) (unpack str)
|
|
||||||
then "｢\{str}｣"
|
|
||||||
else "｢\{str}｣ (\"\{displayS' str}\")"
|
|
||||||
|
|
||||||
testOneChar : (Char -> Bool) -> Char -> Test
|
|
||||||
testOneChar pred c = test (display c) $ unless (pred c) $ Left ()
|
|
||||||
|
|
||||||
testAllChars : String -> (Char -> Bool) -> List Char -> Test
|
|
||||||
testAllChars label pred chars = label :- map (testOneChar pred) chars
|
|
||||||
|
|
||||||
|
|
||||||
testNfc : String -> String -> Test
|
|
||||||
testNfc input result =
|
|
||||||
test (displayS input) $
|
|
||||||
let norm = normalizeNfc input in
|
|
||||||
unless (norm == result) $
|
|
||||||
Left [("expected", displayS result), ("received", displayS norm)]
|
|
||||||
|
|
||||||
testAlreadyNfc : String -> Test
|
|
||||||
testAlreadyNfc input = testNfc input input
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
tests = "unicode" :- [
|
|
||||||
"general categories" :- [
|
|
||||||
testAllChars "id starts" isIdStart
|
|
||||||
['a', 'á', '𝕕', '개', 'ʨ', '𒁙', '𝟙'],
|
|
||||||
testAllChars "not id starts" (not . isIdStart)
|
|
||||||
['0', '_', '-', '‿', ' ', '[', ',', '.', '\1'],
|
|
||||||
testAllChars "id continuations" isIdCont
|
|
||||||
['a', 'á', '𝕕', '개', 'ʨ', '𒁙', '0', '\''],
|
|
||||||
testAllChars "not id continuations" (not . isIdCont)
|
|
||||||
['_', '‿', ' ', '[', ',', '.', '\1'],
|
|
||||||
testAllChars "id connectors" isIdConnector
|
|
||||||
['_', '‿'],
|
|
||||||
testAllChars "not id connectors" (not . isIdConnector)
|
|
||||||
['a', ' ', ',', '-'],
|
|
||||||
testAllChars "white space" isWhitespace
|
|
||||||
[' ', '\t', '\r', '\n',
|
|
||||||
'\x2028', -- line separator
|
|
||||||
'\x2029' -- paragraph separator
|
|
||||||
],
|
|
||||||
testAllChars "not white space" (not . isWhitespace)
|
|
||||||
['a', '-', '_', '\1']
|
|
||||||
],
|
|
||||||
|
|
||||||
"normalisation" :- [
|
|
||||||
testNfc "e\x301" "é",
|
|
||||||
testAlreadyNfc "é",
|
|
||||||
testAlreadyNfc ""
|
|
||||||
-- idk if this is wrong it's chez's fault. or unicode's
|
|
||||||
]
|
|
||||||
]
|
|
||||||
Loading…
Reference in a new issue