quox/tests/Tests/DimEq.idr

177 lines
5.5 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 AstExtra
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_ : {opts : _} -> {default Arg prec : PPrec} ->
BContext d -> DimEq d -> Eff Pretty (Doc opts)
prettyDimEq_ [<] (C _) = pure "·"
prettyDimEq_ ds eqs = prettyDimEq ds eqs
private
testPrettyD : BContext d -> DimEq d -> (str : String) ->
{default str label : String} -> Test
testPrettyD ds eqs str {label} =
testPretty (prettyDimEq ds) eqs str str {label}
private
testWf : BContext d -> DimEq d -> Test
testWf ds eqs =
test (prettySquash (prettyDimEq_ ds) Unicode eqs ++ "⊢ ✓") $
unless (wf eqs) $ Left ()
private
testNwf : BContext d -> DimEq d -> Test
testNwf ds eqs =
test (prettySquash (prettyDimEq_ ds) Unicode eqs ++ "⊢ ✗") $
when (wf eqs) $ Left ()
private
testEqLabel : String -> (ds : BContext d) -> (exp, got : DimEq d) -> String
testEqLabel op ds exp got =
renderSquash $ runPrettyDef $ do
pure $ sep [!(prettyDimEq_ ds exp), text op, !(prettyDimEq_ ds got)]
private
testNeq : (ds : BContext 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 : BContext 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", prettySquash (prettyDimEq_ ds) Unicode exp),
("got", prettySquash (prettyDimEq_ ds) Unicode got)]
private
testSetLabel : String -> BContext d -> DimEq d ->
DimEq d -> List (Dim d, Dim d) -> String
testSetLabel op ds exp start sets = renderSquash $ runPrettyDef $ do
pure $ sep
[parens $ sep $ intersperse "/" $
!(prettyDimEq_ {prec = Outer} ds start) :: !(traverse prettySet sets),
text op, !(prettyDimEq_ ds exp)]
where
prettySet : {opts : _} -> (Dim d, Dim d) -> Eff Pretty (Doc opts)
prettySet (p, q) = pure $
hsep [!(prettyDim ds p), "", !(prettyDim ds q)]
private
testSet : (ds : BContext 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 : BContext ?
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)])
]
]