some DimEq tests

lib/Quox/Syntax/DimEq.idr

@@ -138,9 +138,9 @@ setConst (VS i) e (eqs :< p)      = setConst i e eqs :<? ifVar i (K e) p
 
 mutual
   private
-  setVar' : (i, j : Var d) -> i `LT` j -> DimEq' d -> DimEq d
+  setVar' : (i, j : Var d) -> (0 _ : i `LT` j) -> DimEq' d -> DimEq d
   setVar' VZ (VS i) LTZ (eqs :< Nothing) =
-    C $ eqs :< Just (B i)
+    C eqs :<? Just (B i)
   setVar' VZ (VS i) LTZ (eqs :< Just (K e)) =
     setConst i e eqs :<? Just (K e)
   setVar' VZ (VS i) LTZ (eqs :< Just (B j)) =
@@ -272,9 +272,3 @@ public export
 wf : DimEq d -> Bool
 wf ZeroIsOne = True
 wf (C eqs)   = wf' eqs
-
-
--- [todo] "well formed" dimeqs
--- [todo] operations maintain well-formedness
--- [todo] if 'Wf eqs' then 'equal eqs' is an equivalence
--- [todo] 'set' never breaks existing equalities

tests/PrettyExtra.idr

@@ -0,0 +1,31 @@
+module PrettyExtra
+
+import public Quox.Pretty
+import public Quox.Name
+import TAP
+
+export
+squash : String -> String
+squash = pack . squash' . unpack . trim where
+  squash' : List Char -> List Char
+  squash' [] = []
+  squash' (c :: cs) =
+    if isSpace c then
+      ' ' :: squash' (dropWhile isSpace cs)
+    else
+      c :: squash' cs
+
+export
+renderSquash : Doc HL -> String
+renderSquash doc = squash $ renderShow (layoutCompact doc) ""
+
+export
+testPretty : PrettyHL a => (dnames, tnames : SnocList BaseName) ->
+             a -> (uni, asc : String) ->
+             {default uni label : String} -> Test
+testPretty dnames tnames t uni asc {label} = test {e = Info} label $ do
+  let uni  = squash uni; asc = squash asc
+      uni' = renderSquash $ pretty0With True  dnames tnames t
+      asc' = renderSquash $ pretty0With False dnames tnames t
+  unless (uni == uni') $ Left [("exp", uni), ("got", uni')]
+  unless (asc == asc') $ Left [("exp", asc), ("got", asc')]

tests/Tests.idr

@@ -1,6 +1,7 @@
 module Tests
 
 import TAP
+import Tests.DimEq
 import Tests.Reduce
 import Tests.Equal
 import Tests.Typechecker
@@ -13,6 +14,7 @@ import System
 
 allTests : List Test
 allTests = [
+  DimEq.tests,
   Reduce.tests,
   Equal.tests,
   Typechecker.tests,

tests/Tests/DimEq.idr

@@ -0,0 +1,173 @@
+module Tests.DimEq
+
+import Quox.Syntax.DimEq
+import PrettyExtra
+
+import TAP
+import Data.Maybe
+import Data.Nat
+import Data.So
+
+
+-- [✓ todo] "well formed" dimeqs
+-- [todo] operations maintain well-formedness
+-- [todo] if 'Wf eqs' then 'equal eqs' is an equivalence
+-- [todo] 'set' never breaks existing equalities
+
+private
+prettyDimEq' : {default Arg prec : PPrec} -> NContext d -> DimEq d -> Doc HL
+prettyDimEq' ds eqs = case ds of
+  [<] => "·"
+  _   => runPrettyWith False (toSnocList' ds) [<] $ withPrec prec $ prettyM eqs
+
+private
+testPrettyD : NContext d -> DimEq d -> (str : String) ->
+              {default str label : String} -> Test
+testPrettyD ds eqs str {label} =
+  testPretty (toSnocList' ds) [<] eqs str str {label}
+
+private
+testWf : NContext d -> DimEq d -> Test
+testWf ds eqs =
+  test (renderSquash $ sep [prettyDimEq' {prec = Outer} ds eqs, "⊢", "✓"]) $
+    unless (wf eqs) $ Left ()
+
+private
+testNwf : NContext d -> DimEq d -> Test
+testNwf ds eqs =
+  test (renderSquash $ sep [prettyDimEq' {prec = Outer} ds eqs, "⊬", "✓"]) $
+    when (wf eqs) $ Left ()
+
+
+private
+testEqLabel : String -> (ds : NContext d) -> (exp, got : DimEq d) -> String
+testEqLabel op ds exp got = renderSquash $
+  sep [prettyDimEq' ds exp, fromString op, prettyDimEq' ds got]
+
+private
+testNeq : (ds : NContext d) -> (exp, got : DimEq d) ->
+          {default (testEqLabel "≠" ds exp got) label : String} -> Test
+testNeq {label} ds exp got =
+  test label $ unless (exp /= got) $ Left ()
+
+private
+testEq : (ds : NContext d) -> (exp, got : DimEq d) ->
+         {default (testEqLabel "=" ds exp got) label : String} -> Test
+testEq {label} ds exp got =
+  test label $ unless (exp == got) $
+    Left [("exp", renderSquash $ prettyDimEq' ds exp),
+          ("got", renderSquash $ prettyDimEq' ds got)]
+
+private
+testSetLabel : String -> NContext d -> DimEq d ->
+               DimEq d -> List (Dim d, Dim d) -> String
+testSetLabel op ds exp start sets = renderSquash $
+  sep [parens $ sep $ intersperse "/" $
+         prettyDimEq' {prec = Outer} ds start :: map prettySet sets,
+       fromString op, prettyDimEq' ds exp]
+where
+  prettySet : (Dim d, Dim d) -> Doc HL
+  prettySet (p, q) = hsep [prettyDim ds p, "≔", prettyDim ds q]
+
+private
+testSet : (ds : NContext d) -> (exp, start : DimEq d) ->
+          (sets : List (Dim d, Dim d)) ->
+          (0 _ : (So (wf start), So (wf exp))) =>
+          Test
+testSet ds exp start sets =
+  testEq {label = testSetLabel "=" ds exp start sets} ds exp $
+    foldl (\eqs, (p, q) => set p q eqs) start sets
+
+private
+ii, iijj, iijjkk, iijjkkll : NContext ?
+ii = [< "𝑖"]
+iijj = [< "𝑖", "𝑗"]
+iijjkk = [< "𝑖", "𝑗", "𝑘"]
+iijjkkll = [< "𝑖", "𝑗", "𝑘", "𝑙"]
+
+export
+tests : Test
+tests = "dimension constraints" :- [
+  "printing" :- [
+    testPrettyD [<] ZeroIsOne "0 = 1",
+    testPrettyD iijj ZeroIsOne "𝑖, 𝑗, 0 = 1",
+    testPrettyD [<] new "" {label = "[empty output from empty context]"},
+    testPrettyD ii new "𝑖",
+    testPrettyD iijj (fromGround [< Zero, One])
+      "𝑖, 𝑗, 𝑖 = 0, 𝑗 = 1",
+    testPrettyD iijj (C [< Just (K Zero), Nothing])
+      "𝑖, 𝑗, 𝑖 = 0",
+    testPrettyD iijjkk (C [< Nothing, Just (BV 0), Just (BV 1)])
+      "𝑖, 𝑗, 𝑘, 𝑗 = 𝑖, 𝑘 = 𝑖"
+  ],
+
+  "equality" :- [
+    testEq [<] ZeroIsOne ZeroIsOne,
+    testEq [<] new new,
+    testEq iijj new new,
+    testNeq [<] new ZeroIsOne,
+    testNeq iijj new ZeroIsOne,
+    testSet iijj
+      (C [< Nothing, Just (BV 0)])
+      new [(BV 1, BV 0)],
+    testSet iijj
+      (C [< Nothing, Just (BV 0)])
+      new [(BV 0, BV 1)],
+    testNeq iijj
+      new
+      (C [< Nothing, Just (BV 0)]),
+    testSet [<]
+      ZeroIsOne
+      new [(K Zero, K One)],
+    testSet iijjkk
+      (C [< Nothing, Just (BV 0), Just (BV 1)])
+      new [(BV 0, BV 1), (BV 1, BV 2)],
+    testSet iijjkk
+      (C [< Nothing, Just (BV 0), Just (BV 1)])
+      new [(BV 0, BV 1), (BV 0, BV 2)],
+    testSet iijjkk
+      (C [< Nothing, Nothing, Just (BV 0)])
+      new [(BV 0, BV 1), (BV 0, BV 1)],
+    testSet iijj
+      (C [< Just (K Zero), Just (K Zero)])
+      new [(BV 1, K Zero), (BV 0, BV 1)],
+    testSet iijjkk
+      (C [< Just (K Zero), Just (K Zero), Just (K Zero)])
+      new [(BV 2, K Zero), (BV 1, BV 2), (BV 0, BV 1)],
+    testSet iijjkk
+      (C [< Just (K Zero), Just (K Zero), Just (K Zero)])
+      new [(BV 2, K Zero), (BV 0, BV 1), (BV 1, BV 2)],
+    testSet iijjkk
+      (C [< Just (K Zero), Just (K Zero), Just (K Zero)])
+      new [(BV 0, BV 2), (BV 1, K Zero), (BV 2, BV 1)],
+    testSet iijjkk
+      (C [< Nothing, Just (BV 0), Just (BV 1)])
+      new [(BV 0, BV 2), (BV 2, BV 1)],
+    testSet iijjkkll
+      (C [< Nothing, Just (BV 0), Just (BV 1), Just (BV 2)])
+      new [(BV 2, BV 1), (BV 3, BV 0), (BV 2, BV 3)],
+    testSet iijjkk
+      (C [< Just (K One), Just (K One), Just (K One)])
+      (C [< Just (K One), Nothing, Just (BV 0)])
+      [(BV 1, BV 2)],
+    testSet iijj
+      ZeroIsOne
+      (C [< Just (K One), Just (K Zero)])
+      [(BV 1, BV 0)],
+    testSet iijj
+      ZeroIsOne
+      (C [< Nothing, Just (BV 0)])
+      [(BV 1, K Zero), (BV 0, K One)]
+  ],
+
+  "wf" :- [
+    testWf [<] ZeroIsOne,
+    testWf ii ZeroIsOne,
+    testWf [<] new,
+    testWf iijjkk new,
+    testWf iijjkk (C [< Nothing, Just (BV 0), Just (BV 1)]),
+    testNwf iijjkk (C [< Nothing, Just (BV 0), Just (BV 0)]),
+    testWf iijj (C [< Just (K Zero), Just (K Zero)]),
+    testNwf iijj (C [< Just (K Zero), Just (BV 0)])
+  ]
+]

tests/Tests/PrettyTerm.idr

@@ -3,31 +3,14 @@ module Tests.PrettyTerm
 import TAP
 import Quox.Syntax
 import Quox.Syntax.Qty.Three
-import Quox.Pretty
+import PrettyExtra
 
 
-squash : String -> String
-squash = pack . squash' . unpack . trim 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 -> (uni, asc : String) ->
                 {default uni label : String} -> Test
-  testPrettyT t uni asc {label} = test {e = Info} label $ do
+  testPrettyT t uni asc {label} =
-    let uni  = squash uni; asc = squash asc
+    testPretty (toSnocList' ds) (toSnocList' ns) t uni asc {label}
-        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 -> (str : String) ->
                  {default str label : String} -> Test

tests/quox-tests.ipkg

@@ -7,6 +7,8 @@ main = Tests
 modules =
   TermImpls,
   TypingImpls,
+  PrettyExtra,
+  Tests.DimEq,
   Tests.Reduce,
   Tests.Equal,
   Tests.Typechecker,