quox/tests/Tests/Reduce.idr

module Tests.Reduce

import Quox.Syntax as Lib
import Quox.Equal
import TypingImpls
import AstExtra
import TAP
import Control.Eff

%hide Prelude.App
%hide Pretty.App


parameters {0 isRedex : RedexTest tm} {auto _ : Whnf tm isRedex} {d, n : Nat}
           {auto _ : (Eq (tm d n), Show (tm d n))}
           {default empty defs : Definitions}
  private
  testWhnf : String -> WhnfContext d n -> tm d n -> tm d n -> Test
  testWhnf label ctx from to = test "\{label}  (whnf)" $ do
    result <- mapFst toInfo $ runWhnf $ whnf0 defs ctx from
    unless (result == to) $ Left [("exp", show to), ("got", show result)]

  private
  testNoStep : String -> WhnfContext d n -> tm d n -> Test
  testNoStep label ctx e = testWhnf label ctx e e

private
ctx : Context (\n => (BindName, Term 0 n)) n -> WhnfContext 0 n
ctx xs = let (ns, ts) = unzip xs in MkWhnfContext [<] ns ts


export
tests : Test
tests = "whnf" :- [
  "head constructors" :- [
    testNoStep "★₀" empty $ ^TYPE 0,
    testNoStep "1.A → B" empty $
      ^Arr One (^FT "A") (^FT "B"),
    testNoStep "(x: A) ⊸ B x" empty $
      ^PiY One "x" (^FT "A") (E $ ^App (^F "B") (^BVT 0)),
    testNoStep "λ x ⇒ x" empty $
      ^LamY "x" (^BVT 0),
    testNoStep "f a" empty $
      E $ ^App (^F "f") (^FT "a")
  ],

  "neutrals" :- [
    testNoStep "x" (ctx [< ("A", ^Nat)]) $ ^BV 0,
    testNoStep "a"       empty $ ^F "a",
    testNoStep "f a"     empty $ ^App (^F "f") (^FT "a"),
    testNoStep "★₀ ∷ ★₁" empty $ ^Ann (^TYPE 0) (^TYPE 1)
  ],

  "redexes" :- [
    testWhnf "a ∷ A" empty
      (^Ann (^FT "a") (^FT "A"))
      (^F "a"),
    testWhnf "★₁ ∷ ★₃" empty
      (E $ ^Ann (^TYPE 1) (^TYPE 3))
      (^TYPE 1),
    testWhnf "(λ x ⇒ x ∷ 1.A → A) a" empty
      (^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A")))
            (^FT "a"))
      (^F "a")
  ],

  "definitions" :- [
    testWhnf "a  (transparent)" empty
      {defs = fromList [("a", ^mkDef gzero (^TYPE 1) (^TYPE 0))]}
      (^F "a") (^Ann (^TYPE 0) (^TYPE 1)),
    testNoStep "a  (opaque)" empty
      {defs = fromList [("a", ^mkPostulate gzero (^TYPE 1))]}
      (^F "a")
  ],

  "elim closure" :- [
    testWhnf "x{}" (ctx [< ("x", ^Nat)])
      (CloE (Sub (^BV 0) id))
      (^BV 0),
    testWhnf "x{a/x}" empty
      (CloE (Sub (^BV 0) (^F "a" ::: id)))
      (^F "a"),
    testWhnf "x{a/y}" (ctx [< ("x", ^Nat)])
      (CloE (Sub (^BV 0) (^BV 0 ::: ^F "a" ::: id)))
      (^BV 0),
    testWhnf "x{(y{a/y})/x}" empty
      (CloE (Sub (^BV 0) ((CloE (Sub (^BV 0) (^F "a" ::: id))) ::: id)))
      (^F "a"),
    testWhnf "(x y){f/x,a/y}" empty
      (CloE (Sub (^App (^BV 0) (^BVT 1)) (^F "f" ::: ^F "a" ::: id)))
      (^App (^F "f") (^FT "a")),
    testWhnf "(y ∷ x){A/x}" (ctx [< ("x", ^Nat)])
      (CloE (Sub (^Ann (^BVT 1) (^BVT 0)) (^F "A" ::: id)))
      (^BV 0),
    testWhnf "(y ∷ x){A/x,a/y}" empty
      (CloE (Sub (^Ann (^BVT 1) (^BVT 0)) (^F "A" ::: ^F "a" ::: id)))
      (^F "a")
  ],

  "term closure" :- [
    testWhnf "(λ y ⇒ x){a/x}" empty
      (CloT (Sub (^LamN (^BVT 0)) (^F "a" ::: id)))
      (^LamN (^FT "a")),
    testWhnf "(λy. y){a/x}" empty
      (CloT (Sub (^LamY "y" (^BVT 0)) (^F "a" ::: id)))
      (^LamY "y" (^BVT 0))
  ],

  "looking inside `E`" :- [
    testWhnf "(λx. x ∷ A ⊸ A) a" empty
      (E $ ^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A")))
              (^FT "a"))
      (^FT "a")
  ],

  "nested redex" :- [
    testNoStep "λ y ⇒ ((λ x ⇒ x) ∷ 1.A → A) y" empty $
      ^LamY "y" (E $
        ^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A")))
             (^BVT 0)),
    testNoStep "f (((λ x ⇒ x) ∷ 1.A → A) a)" empty $
      ^App (^F "f")
        (E $ ^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A") (^FT "A")))
              (^FT "a")),
    testNoStep "λx. (y x){x/x,a/y}" (ctx [< ("y", ^Nat)]) $
      ^LamY "x" (CloT $ Sub (E $ ^App (^BV 1) (^BVT 0))
                            (^BV 0 ::: ^F "a" ::: id)),
    testNoStep "f (y x){x/x,a/y}" (ctx [< ("y", ^Nat)]) $
      ^App (^F "f")
        (CloT (Sub (E $ ^App (^BV 1) (^BVT 0))
                   (^BV 0 ::: ^F "a" ::: id)))
  ]
]