quox/tests/Tests/DimEq.idr

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' : {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)])
  ]
]