111 lines
3.3 KiB
Idris
111 lines
3.3 KiB
Idris
module Core.Convert
|
|
|
|
import Core.Term
|
|
import Core.Value
|
|
import Core.Misc
|
|
import Core.Normalize
|
|
|
|
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
|
|
|
|
public export
|
|
convert : {auto deftrs : RefA DTR Value}
|
|
-> {auto frst : Ref NST Nat}
|
|
-> Value -> Value -> PI Bool
|
|
convert u1 u2 = do
|
|
u1' <- whnf u1
|
|
u2' <- whnf u2
|
|
assert_total $ case (u1', u2') of
|
|
(VType, VType) => pure True
|
|
(VTop, VTop) => pure True
|
|
(VStar, VStar) => pure True
|
|
(VBot, VBot) => pure True
|
|
(VNat, VNat) => pure True
|
|
|
|
(VGen k1, VGen k2) => pure (k1 == k2)
|
|
|
|
(VApp f1 x1, VApp f2 x2) => (&&) <$> convert f1 f2 <*> delay <$> convert x1 x2
|
|
|
|
(VClos env1 (TLam sc1), VClos env2 (TLam sc2)) => do
|
|
v <- VGen <$> fresh
|
|
convert (VClos (v :: env1) sc1) (VClos (v :: env2) sc2)
|
|
|
|
(VClos env1 (TPi a1 b1), VClos env2 (TPi a2 b2)) => do
|
|
v <- VGen <$> fresh
|
|
(&&) <$> convert (VClos env1 a1) (VClos env2 a2)
|
|
<*> delay <$> convert (VClos (v :: env1) b1) (VClos (v :: env2) b2)
|
|
|
|
(VClos env1 (TSigma a1 b1), VClos env2 (TSigma a2 b2)) => do
|
|
termGuard env1 env2 a1 a2
|
|
termConv env1 env2 b1 b2
|
|
|
|
(VClos env1 (TPair a1 b1), VClos env2 (TPair a2 b2)) => do
|
|
termGuard env1 env2 a1 a2
|
|
termConv env1 env2 b1 b2
|
|
|
|
(VClos env1 (TId ty1 a1 b1), VClos env2 (TId ty2 a2 b2)) => do
|
|
termGuard env1 env2 ty1 ty2
|
|
termGuard env1 env2 a1 a2
|
|
termConv env1 env2 b1 b2
|
|
|
|
(VClos env1 (TRefl ty1 tr1), VClos env2 (TRefl ty2 tr2)) => do
|
|
termGuard env1 env2 ty1 ty2
|
|
termConv env1 env2 tr1 tr2
|
|
|
|
(VClos env1 (TNatInd c1 z1 s1), VClos env2 (TNatInd c2 z2 s2)) => do
|
|
termGuard env1 env2 c1 c2
|
|
termGuard env1 env2 z1 z2
|
|
termConv env1 env2 s1 s2
|
|
|
|
(VClos _ TZero, VClos _ TZero) => pure True
|
|
|
|
(VClos env1 (TSuc n1), VClos env2 (TSuc n2)) => do
|
|
termConv env1 env2 n1 n2
|
|
|
|
(VClos env1 (TJ ty1 a1 b1 c1 d1), VClos env2 (TJ ty2 a2 b2 c2 d2)) => do
|
|
termGuard env1 env2 ty1 ty2
|
|
termGuard env1 env2 a1 a2
|
|
termGuard env1 env2 b1 b2
|
|
termGuard env1 env2 c1 c2
|
|
termConv env1 env2 d1 d2
|
|
|
|
(VClos env1 (TSigInd a1 b1 c1 f1), VClos env2 (TSigInd a2 b2 c2 f2)) => do
|
|
termGuard env1 env2 a1 a2
|
|
termGuard env1 env2 b1 b2
|
|
termGuard env1 env2 c1 c2
|
|
termConv env1 env2 f1 f2
|
|
|
|
(VClos env1 (TBotInd c1), VClos env2 (TBotInd c2)) => termConv env1 env2 c1 c2
|
|
|
|
(VClos env1 (TTopInd c1 st1), VClos env2 (TTopInd c2 st2)) => do
|
|
termGuard env1 env2 c1 c2
|
|
termConv env1 env2 st1 st2
|
|
|
|
-- η rules
|
|
-- fresh cannot appear in vsc, so this is fine
|
|
(vsc, VClos env (TLam (TApp sc (TVar 0)))) => do
|
|
v <- VGen <$> fresh
|
|
convert vsc (VClos (v :: env) sc)
|
|
(VClos env (TLam (TApp sc (TVar 0))), vsc) => do
|
|
v <- VGen <$> fresh
|
|
convert vsc (VClos (v :: env) sc)
|
|
|
|
(v1, v2) => oops ("cannot convert \n" ++ show v1 ++ "\n\n" ++ show v2)
|
|
where
|
|
termConv : Ctx n -> Ctx m -> Term n -> Term m -> PI Bool
|
|
termConv env1 env2 a1 a2 = do
|
|
a1' <- eval env1 a1
|
|
a2' <- eval env2 a2
|
|
convert a1' a2'
|
|
termGuard : Ctx n -> Ctx m -> Term n -> Term m -> PI ()
|
|
termGuard env1 env2 a1 a2 = termConv env1 env2 a1 a2 >>=
|
|
guardS ("cannot convert \n" ++ show a1 ++ "\n\n" ++ show a2)
|