some pretty printing tests

lib/Quox/Syntax/Qty.idr

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

lib/Quox/Syntax/Term/Pretty.idr

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

tests/Tests.idr

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

tests/Tests/PrettyTerm.idr

@@ -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 "(A ↠ A) ↠ 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"
+]

tests/quox-tests.ipkg

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