some DimEq tests
This commit is contained in:
parent
50c682f715
commit
5945265867
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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')]
|
||||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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)])
|
||||
]
|
||||
]
|
||||
|
|
@ -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
|
||||
let uni = squash uni; asc = squash asc
|
||||
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')]
|
||||
testPrettyT t uni asc {label} =
|
||||
testPretty (toSnocList' ds) (toSnocList' ns) t uni asc {label}
|
||||
|
||||
testPrettyT1 : Term Three d n -> (str : String) ->
|
||||
{default str label : String} -> Test
|
||||
|
|
|
|||
|
|
@ -7,6 +7,8 @@ main = Tests
|
|||
modules =
|
||||
TermImpls,
|
||||
TypingImpls,
|
||||
PrettyExtra,
|
||||
Tests.DimEq,
|
||||
Tests.Reduce,
|
||||
Tests.Equal,
|
||||
Tests.Typechecker,
|
||||
|
|
|
|||
Loading…
Reference in New Issue