quox/tests/Tests/DimEq.idr

173 lines
5.3 KiB
Idris
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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' [<] (C _) = "·"
prettyDimEq' ds eqs =
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)])
]
]