78 lines
2.0 KiB
Idris
78 lines
2.0 KiB
Idris
module Core.Normalize
|
|
|
|
import Core.Term
|
|
import Core.Value
|
|
import Core.Misc
|
|
|
|
import Control.Monad.RWS
|
|
import Control.Monad.Identity
|
|
import Control.Monad.Either
|
|
|
|
import Data.Nat
|
|
import Data.Vect
|
|
import Data.IOArray
|
|
import Data.IORef
|
|
|
|
%default total
|
|
|
|
mutual
|
|
public export
|
|
app : {auto deftrs : RefA DTR Value}
|
|
-> {auto frst : Ref NST Nat}
|
|
-> Value -> Value -> PI Value
|
|
app (VClos env (TLam sc)) x = eval (x :: env) sc
|
|
|
|
app (VClos env (TTopInd c st)) VTop = eval env st
|
|
|
|
app (VClos env1 (TNatInd _ z s)) (VClos env2 TZero) = eval env1 z
|
|
app f@(VClos env1 (TNatInd _ z s)) (VClos env2 (TSuc n)) = assert_total $ do
|
|
s' <- eval env1 s
|
|
sn <- app (VClos env1 s) (VClos env2 n)
|
|
app sn =<< app f (VClos env2 n)
|
|
|
|
app (VClos env1 (TSigInd _ _ c f)) (VClos env2 (TPair a b)) = assert_total $ do
|
|
f' <- eval env1 f
|
|
fa <- app f' (VClos env2 a)
|
|
app fa (VClos env2 b)
|
|
|
|
app (VClos env (TJ _ _ _ _ d)) (VClos _ (TRefl _ _)) = eval env d
|
|
|
|
app f x = pure (VApp f x)
|
|
|
|
public export
|
|
eval : {auto deftrs : RefA DTR Value}
|
|
-> {auto frst : Ref NST Nat}
|
|
-> Ctx n -> Term n -> PI Value
|
|
eval env (TVar i) = pure (index i env)
|
|
eval env (TDef i) = do
|
|
res <- getArr DTR i
|
|
case res of
|
|
Just x => pure x
|
|
Nothing => oops "TDef term lookup"
|
|
eval env TType = pure VType
|
|
eval env TTop = pure VTop
|
|
eval env TStar = pure VStar
|
|
eval env TBot = pure VBot
|
|
eval env TNat = pure VNat
|
|
eval env (TApp f x) = do
|
|
f' <- eval env f
|
|
x' <- eval env x
|
|
assert_total (app f' x') -- :(
|
|
|
|
eval env (TLet ty tr tri) = do
|
|
tr' <- eval env tr
|
|
eval (tr' :: env) tri
|
|
|
|
eval env tr = pure (VClos env tr)
|
|
|
|
public export
|
|
whnf : {auto deftrs : RefA DTR Value}
|
|
-> {auto frst : Ref NST Nat}
|
|
-> Value -> PI Value
|
|
whnf (VClos env tr) = eval env tr
|
|
whnf (VApp f x) = do
|
|
f' <- whnf f
|
|
x' <- whnf x
|
|
app f' x'
|
|
whnf v = pure v
|