quox/tests/Tests/Reduce.idr

141 lines
4.5 KiB
Idris
Raw Normal View History

2022-05-25 10:10:19 -04:00
module Tests.Reduce
import Quox.Syntax as Lib
import Quox.Equal
2023-09-18 18:41:47 -04:00
import Control.Monad.ST.Extra
2023-02-22 01:40:19 -05:00
import TypingImpls
2023-05-01 21:06:25 -04:00
import AstExtra
2022-05-25 10:10:19 -04:00
import TAP
2023-05-01 21:06:25 -04:00
import Control.Eff
%hide Prelude.App
%hide Pretty.App
2022-05-25 10:10:19 -04:00
2023-08-25 12:09:06 -04:00
runWhnf : Eff Whnf a -> Either Error a
runWhnf act = runSTErr $ do
runEff act [handleExcept (\e => stLeft e),
handleStateSTRef !(liftST $ newSTRef 0)]
2023-08-25 12:09:06 -04:00
2023-05-21 14:09:34 -04:00
parameters {0 isRedex : RedexTest tm} {auto _ : CanWhnf tm isRedex} {d, n : Nat}
2023-04-15 09:13:01 -04:00
{auto _ : (Eq (tm d n), Show (tm d n))}
2023-04-01 13:16:43 -04:00
{default empty defs : Definitions}
{default SOne sg : SQty}
2023-04-15 09:13:01 -04:00
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 sg from
2023-02-22 01:40:19 -05:00
unless (result == to) $ Left [("exp", show to), ("got", show result)]
2022-05-25 10:10:19 -04:00
2023-04-15 09:13:01 -04:00
private
testNoStep : String -> WhnfContext d n -> tm d n -> Test
testNoStep label ctx e = testWhnf label ctx e e
2022-05-25 10:10:19 -04:00
2023-04-15 09:13:01 -04:00
private
ctx : {n : Nat} -> Context (\n => (BindName, Term 0 n)) n -> WhnfContext 0 n
ctx xs = let (ns, ts) = unzip xs in MkWhnfContext [<] ns (locals ts)
2022-05-25 10:10:19 -04:00
2023-04-15 09:13:01 -04:00
export
tests : Test
2022-05-25 10:10:19 -04:00
tests = "whnf" :- [
"head constructors" :- [
2023-05-01 21:06:25 -04:00
testNoStep "★₀" empty $ ^TYPE 0,
testNoStep "1.A → B" empty $
2023-05-21 14:09:34 -04:00
^Arr One (^FT "A" 0) (^FT "B" 0),
2023-05-01 21:06:25 -04:00
testNoStep "(x: A) ⊸ B x" empty $
2023-05-21 14:09:34 -04:00
^PiY One "x" (^FT "A" 0) (E $ ^App (^F "B" 0) (^BVT 0)),
2023-05-01 21:06:25 -04:00
testNoStep "λ x ⇒ x" empty $
^LamY "x" (^BVT 0),
testNoStep "f a" empty $
2023-05-21 14:09:34 -04:00
E $ ^App (^F "f" 0) (^FT "a" 0)
2022-05-25 10:10:19 -04:00
],
"neutrals" :- [
2023-11-02 13:14:22 -04:00
testNoStep "x" (ctx [< ("A", ^NAT)]) $ ^BV 0,
2023-05-21 14:09:34 -04:00
testNoStep "a" empty $ ^F "a" 0,
testNoStep "f a" empty $ ^App (^F "f" 0) (^FT "a" 0),
2023-05-01 21:06:25 -04:00
testNoStep "★₀ ∷ ★₁" empty $ ^Ann (^TYPE 0) (^TYPE 1)
2022-05-25 10:10:19 -04:00
],
"redexes" :- [
2023-05-01 21:06:25 -04:00
testWhnf "a ∷ A" empty
2023-05-21 14:09:34 -04:00
(^Ann (^FT "a" 0) (^FT "A" 0))
(^F "a" 0),
2023-05-01 21:06:25 -04:00
testWhnf "★₁ ∷ ★₃" empty
(E $ ^Ann (^TYPE 1) (^TYPE 3))
(^TYPE 1),
testWhnf "(λ x ⇒ x ∷ 1.A → A) a" empty
2023-05-21 14:09:34 -04:00
(^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A" 0) (^FT "A" 0)))
(^FT "a" 0))
(^F "a" 0)
2022-05-25 10:10:19 -04:00
],
"definitions" :- [
2023-04-15 09:13:01 -04:00
testWhnf "a (transparent)" empty
{defs = fromList [("a", ^mkDef GZero (^TYPE 1) (^TYPE 0) Nothing False)]}
2023-05-21 14:09:34 -04:00
(^F "a" 0) (^Ann (^TYPE 0) (^TYPE 1)),
2023-05-01 21:06:25 -04:00
testNoStep "a (opaque)" empty
{defs = fromList [("a", ^mkPostulate GZero (^TYPE 1) Nothing False)]}
2023-05-21 14:09:34 -04:00
(^F "a" 0)
],
2022-05-25 10:10:19 -04:00
"elim closure" :- [
2023-11-02 13:14:22 -04:00
testWhnf "x{}" (ctx [< ("x", ^NAT)])
2023-05-01 21:06:25 -04:00
(CloE (Sub (^BV 0) id))
(^BV 0),
2023-04-15 09:13:01 -04:00
testWhnf "x{a/x}" empty
2023-05-21 14:09:34 -04:00
(CloE (Sub (^BV 0) (^F "a" 0 ::: id)))
(^F "a" 0),
2023-11-02 13:14:22 -04:00
testWhnf "x{a/y}" (ctx [< ("x", ^NAT)])
2023-05-21 14:09:34 -04:00
(CloE (Sub (^BV 0) (^BV 0 ::: ^F "a" 0 ::: id)))
2023-05-01 21:06:25 -04:00
(^BV 0),
2023-04-15 09:13:01 -04:00
testWhnf "x{(y{a/y})/x}" empty
2023-05-21 14:09:34 -04:00
(CloE (Sub (^BV 0) ((CloE (Sub (^BV 0) (^F "a" 0 ::: id))) ::: id)))
(^F "a" 0),
2023-04-15 09:13:01 -04:00
testWhnf "(x y){f/x,a/y}" empty
2023-05-21 14:09:34 -04:00
(CloE (Sub (^App (^BV 0) (^BVT 1)) (^F "f" 0 ::: ^F "a" 0 ::: id)))
(^App (^F "f" 0) (^FT "a" 0)),
2023-11-02 13:14:22 -04:00
testWhnf "(y ∷ x){A/x}" (ctx [< ("x", ^NAT)])
2023-05-21 14:09:34 -04:00
(CloE (Sub (^Ann (^BVT 1) (^BVT 0)) (^F "A" 0 ::: id)))
2023-05-01 21:06:25 -04:00
(^BV 0),
testWhnf "(y ∷ x){A/x,a/y}" empty
2023-05-21 14:09:34 -04:00
(CloE (Sub (^Ann (^BVT 1) (^BVT 0)) (^F "A" 0 ::: ^F "a" 0 ::: id)))
(^F "a" 0)
2022-05-25 10:10:19 -04:00
],
"term closure" :- [
2023-05-01 21:06:25 -04:00
testWhnf "(λ y ⇒ x){a/x}" empty
2023-05-21 14:09:34 -04:00
(CloT (Sub (^LamN (^BVT 0)) (^F "a" 0 ::: id)))
(^LamN (^FT "a" 0)),
2023-04-15 09:13:01 -04:00
testWhnf "(λy. y){a/x}" empty
2023-05-21 14:09:34 -04:00
(CloT (Sub (^LamY "y" (^BVT 0)) (^F "a" 0 ::: id)))
2023-05-01 21:06:25 -04:00
(^LamY "y" (^BVT 0))
2022-05-25 10:10:19 -04:00
],
2023-05-01 21:06:25 -04:00
"looking inside `E`" :- [
testWhnf "(λx. x ∷ A ⊸ A) a" empty
2023-05-21 14:09:34 -04:00
(E $ ^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A" 0) (^FT "A" 0)))
(^FT "a" 0))
(^FT "a" 0)
2022-05-25 10:10:19 -04:00
],
"nested redex" :- [
2023-05-01 21:06:25 -04:00
testNoStep "λ y ⇒ ((λ x ⇒ x) ∷ 1.A → A) y" empty $
^LamY "y" (E $
2023-05-21 14:09:34 -04:00
^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A" 0) (^FT "A" 0)))
2023-05-01 21:06:25 -04:00
(^BVT 0)),
testNoStep "f (((λ x ⇒ x) ∷ 1.A → A) a)" empty $
2023-05-21 14:09:34 -04:00
^App (^F "f" 0)
(E $ ^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A" 0) (^FT "A" 0)))
(^FT "a" 0)),
2023-11-02 13:14:22 -04:00
testNoStep "λx. (y x){x/x,a/y}" (ctx [< ("y", ^NAT)]) $
2023-05-01 21:06:25 -04:00
^LamY "x" (CloT $ Sub (E $ ^App (^BV 1) (^BVT 0))
2023-05-21 14:09:34 -04:00
(^BV 0 ::: ^F "a" 0 ::: id)),
2023-11-02 13:14:22 -04:00
testNoStep "f (y x){x/x,a/y}" (ctx [< ("y", ^NAT)]) $
2023-05-21 14:09:34 -04:00
^App (^F "f" 0)
2023-05-01 21:06:25 -04:00
(CloT (Sub (E $ ^App (^BV 1) (^BVT 0))
2023-05-21 14:09:34 -04:00
(^BV 0 ::: ^F "a" 0 ::: id)))
2022-05-25 10:10:19 -04:00
]
]