some pretty printing tests

This commit is contained in:
rhiannon morris 2023-03-16 18:19:17 +01:00
parent 6dc7177be5
commit f5fa63a6df
5 changed files with 163 additions and 5 deletions

View file

@ -16,7 +16,7 @@ commas (x::xs) = (x <+> hl Delim ",") :: commas xs
private %inline private %inline
blobD : Pretty.HasEnv m => m (Doc HL) blobD : Pretty.HasEnv m => m (Doc HL)
blobD = hlF Delim $ ifUnicode "·" "@" blobD = hlF Delim $ ifUnicode "·" "%"
export %inline export %inline
prettyQtyBinds : Pretty.HasEnv m => PrettyHL q => PrettyHL a => prettyQtyBinds : Pretty.HasEnv m => PrettyHL q => PrettyHL a =>

View file

@ -85,7 +85,7 @@ export
prettyApps : PrettyHL f => PrettyHL a => Pretty.HasEnv m => prettyApps : PrettyHL f => PrettyHL a => Pretty.HasEnv m =>
Maybe (Doc HL) -> f -> List a -> m (Doc HL) Maybe (Doc HL) -> f -> List a -> m (Doc HL)
prettyApps pfx fun args = do prettyApps pfx fun args = do
fun <- withPrec Arg $ prettyM fun fun <- withPrec App $ prettyM fun
args <- traverse (withPrec Arg . prettyArg) args args <- traverse (withPrec Arg . prettyArg) args
parensIfM App $ hang 2 $ sep $ fun :: args parensIfM App $ hang 2 $ sep $ fun :: args
where where
@ -120,6 +120,11 @@ export
prettyTag : TagVal -> Doc HL prettyTag : TagVal -> Doc HL
prettyTag t = hl Tag $ "'" <+> fromString t prettyTag t = hl Tag $ "'" <+> fromString t
-- [fixme] put delimiters around tags that aren't simple names
export
prettyTagBare : TagVal -> Doc HL
prettyTagBare t = hl Tag $ fromString t
parameters (showSubsts : Bool) parameters (showSubsts : Bool)
mutual mutual
@ -139,7 +144,7 @@ parameters (showSubsts : Bool)
let GotPairs {init, last, _} = getPairs' [< s] t in let GotPairs {init, last, _} = getPairs' [< s] t in
prettyTuple $ toList $ init :< last prettyTuple $ toList $ init :< last
prettyM (Enum tags) = prettyM (Enum tags) =
pure $ delims "{" "}" . aseparate comma $ map prettyTag $ pure $ delims "{" "}" . aseparate comma $ map prettyTagBare $
Prelude.toList tags Prelude.toList tags
prettyM (Tag t) = prettyM (Tag t) =
pure $ prettyTag t pure $ prettyTag t

View file

@ -4,6 +4,7 @@ import TAP
import Tests.Reduce import Tests.Reduce
import Tests.Equal import Tests.Equal
import Tests.Typechecker import Tests.Typechecker
import Tests.PrettyTerm
import Tests.Lexer import Tests.Lexer
import Tests.Parser import Tests.Parser
import Tests.FromPTerm import Tests.FromPTerm
@ -15,11 +16,11 @@ allTests = [
Reduce.tests, Reduce.tests,
Equal.tests, Equal.tests,
Typechecker.tests, Typechecker.tests,
PrettyTerm.tests,
Lexer.tests, Lexer.tests,
Parser.tests, Parser.tests,
FromPTerm.tests, FromPTerm.tests,
todo "DimEq", todo "DimEq",
todo "Pretty term & dim",
todo "Pretty dctx/tctx/tyctx/eqctx" todo "Pretty dctx/tctx/tyctx/eqctx"
] ]

150
tests/Tests/PrettyTerm.idr Normal file
View file

@ -0,0 +1,150 @@
module Tests.PrettyTerm
import TAP
import Quox.Syntax
import Quox.Syntax.Qty.Three
import Quox.Pretty
squash : String -> String
squash = pack . squash' . unpack where
squash' : List Char -> List Char
squash' [] = []
squash' (c :: cs) =
if isSpace c then
' ' :: squash' (dropWhile isSpace cs)
else
c :: squash' cs
renderSquash : Doc HL -> String
renderSquash = squash . ($ "") . renderShow . layoutCompact
parameters (ds : NContext d) (ns : NContext n)
testPrettyT : Term Three d n -> String -> String -> Test
testPrettyT t uni asc = test {e = Info} uni $ do
let uni' = renderSquash $ prettyTerm True ds ns t
asc' = renderSquash $ prettyTerm False ds ns t
unless (squash uni == uni') $ Left [("exp", uni), ("got", uni')]
unless (squash asc == asc') $ Left [("exp", asc), ("got", asc')]
testPrettyT1 : Term Three d n -> String -> Test
testPrettyT1 t str = testPrettyT t str str
testPrettyE : Elim Three d n -> String -> String -> Test
testPrettyE e uni asc = testPrettyT (E e) uni asc
testPrettyE1 : Elim Three d n -> String -> Test
testPrettyE1 e str = testPrettyT1 (E e) str
enum : List TagVal -> Term q d n
enum = Enum . SortedSet.fromList
export
tests : Test
tests = "pretty printing terms" :- [
"free vars" :- [
testPrettyE1 [<] [<] (F "x") "x",
testPrettyE1 [<] [<] (F $ MakeName [< "A", "B", "C"] "x") "A.B.C.x"
],
"bound vars" :- [
testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (BV 0) "y",
testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (BV 1) "x",
testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (F "eq" :% BV 1) "eq @𝑖",
testPrettyE1 [< "𝑖", "𝑗"] [< "x", "y"] (F "eq" :% BV 1 :% BV 0) "eq @𝑖 @𝑗"
],
"applications" :- [
testPrettyE1 [<] [<] (F "f" :@ FT "x") "f x",
testPrettyE1 [<] [<] (F "f" :@@ [FT "x", FT "y"]) "f x y",
testPrettyE1 [<] [<] (F "f" :% K Zero) "f @0",
testPrettyE1 [<] [<] (F "f" :@ FT "x" :% K Zero) "f x @0",
testPrettyE1 [<] [<] (F "g" :% K One :@ FT "y") "g @1 y"
],
"lambda" :- [
testPrettyT [<] [<] ([< "x"] :\\ BVT 0) "λ x ⇒ x" "fun x => x",
testPrettyT [<] [<] (Lam $ SN $ FT "a") "λ _ ⇒ a" "fun _ => a",
testPrettyT [<] [< "y"] ([< "x"] :\\ BVT 1) "λ x ⇒ y" "fun x => y",
testPrettyT [<] [<]
([< "x", "y", "f"] :\\ E (BV 0 :@@ [BVT 2, BVT 1]))
"λ x y f ⇒ f x y"
"fun x y f => f x y",
testPrettyT [<] [<] (DLam $ SN $ FT "a") "δ _ ⇒ a" "dfun _ => a",
testPrettyT [<] [<] ([< "i"] :\\% FT "x") "δ i ⇒ x" "dfun i => x",
testPrettyT [<] [<]
([< "x"] :\\ [< "i"] :\\% E (BV 0 :% BV 0))
"λ x ⇒ δ i ⇒ x @i"
"fun x => dfun i => x @i"
],
"type universes" :- [
testPrettyT [<] [<] (TYPE 0) "★₀" "Type0",
testPrettyT [<] [<] (TYPE 100) "★₁₀₀" "Type100"
],
"function types" :- [
skipWith "todo: non-dependent notation" $
testPrettyT [<] [<] (Arr One (FT "A") (FT "B")) "A ⊸ B" "A -o B",
testPrettyT [<] [<]
(Pi_ One "x" (FT "A") (E $ F "B" :@ BVT 0))
"(1 · x : A) → B x"
"(1 % x : A) -> B x",
testPrettyT [<] [<]
(Pi_ Zero "A" (TYPE 0) $ Arr Any (BVT 0) (BVT 0))
"(0 · A : ★₀) → (ω · _ : A) → A"
"(0 % A : Type0) -> (# % _ : A) -> A",
todo #"print (and parse) the below as "(AA)A""#,
testPrettyT [<] [<]
(Arr Any (Arr Any (FT "A") (FT "A")) (FT "A"))
"(ω · _ : (ω · _ : A) → A) → A"
"(# % _ : (# % _ : A) -> A) -> A",
todo "non-dependent, left and right nested"
],
"pair types" :- [
skipWith "todo: non-dependent notation" $
testPrettyT [<] [<] (FT "A" `And` FT "B") "A × B" "A ** B",
testPrettyT [<] [<]
(Sig_ "x" (FT "A") (E $ F "B" :@ BVT 0))
"(x : A) × B x"
"(x : A) ** B x",
testPrettyT [<] [<]
(Sig_ "x" (FT "A") $
Sig_ "y" (E $ F "B" :@ BVT 0) $
E $ F "C" :@@ [BVT 1, BVT 0])
"(x : A) × (y : B x) × C x y"
"(x : A) ** (y : B x) ** C x y",
todo "non-dependent, left and right nested"
],
"pairs" :- [
testPrettyT1 [<] [<] (Pair (FT "A") (FT "B")) "(A, B)",
testPrettyT1 [<] [<] (Pair (FT "A") (Pair (FT "B") (FT "C"))) "(A, B, C)",
testPrettyT1 [<] [<] (Pair (Pair (FT "A") (FT "B")) (FT "C")) "((A, B), C)",
testPrettyT [<] [<]
(Pair ([< "x"] :\\ BVT 0) (Arr One (FT "B₁") (FT "B₂")))
"(λ x ⇒ x, (1 · _ : B₁) → B₂)"
"(fun x => x, (1 % _ : B₁) -> B₂)"
],
"enum types" :- [
testPrettyT1 [<] [<] (enum []) "{}",
testPrettyT1 [<] [<] (enum ["a"]) "{a}",
testPrettyT1 [<] [<] (enum ["aa", "bb", "cc"]) "{aa, bb, cc}",
skipWith "todo: quote non-identifiers" $
testPrettyT1 [<] [<] (enum ["a b c"]) #"{"a b c"}"#
],
"tags" :- [
testPrettyT1 [<] [<] (Tag "a") "'a",
testPrettyT1 [<] [<] (Tag "hello") "'hello",
testPrettyT1 [<] [<] (Tag "qualified.tag") "'qualified.tag",
skipWith "todo: quote non-identifiers" $
testPrettyT1 [<] [<] (Tag "non-identifier tag") #"'"non-identifier tag""#
],
todo "equality types",
todo "case",
todo "annotations"
]

View file

@ -10,5 +10,7 @@ modules =
Tests.Reduce, Tests.Reduce,
Tests.Equal, Tests.Equal,
Tests.Typechecker, Tests.Typechecker,
Tests.PrettyTerm,
Tests.Lexer, Tests.Lexer,
Tests.Parser Tests.Parser,
Tests.FromPTerm