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