87 lines
2.7 KiB
Idris
87 lines
2.7 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
|
|
|
|
%default total
|
|
|
|
public export
|
|
convert : Value -> Value -> PI Bool
|
|
convert u1 u2 = do
|
|
u1' <- whnf u1
|
|
u2' <- whnf u2
|
|
logS ("checking equality of terms '" ++ show u1 ++ "' and '" ++ show u2 ++ "'.")
|
|
logS ("with value representations '" ++ show u1' ++ "' and '" ++ show u2' ++ "'.")
|
|
assert_total $ -- :(
|
|
case (u1', u2') of
|
|
(VGen k1, VGen k2) => pure (k1 == k2)
|
|
(VType, VType) => pure True
|
|
(VTop, VTop) => pure True
|
|
(VStar, VStar) => pure True
|
|
(VBot, VBot) => pure True
|
|
(VNat, VNat) => pure True
|
|
|
|
(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
|
|
guardS (show a1 ++ " | " ++ show a2) =<< convert (VClos env1 a1) (VClos env2 a2)
|
|
convert (VClos (v :: env1) b1) (VClos (v :: env2) b2)
|
|
|
|
(VNatTr n, VNatTr m) => pure (n == m)
|
|
|
|
(VPair a1 b1, VPair a2 b2) => (&&) <$> convert a1 a2 <*> delay <$> convert b1 b2
|
|
|
|
(VClos env1 (TTopInd c1 st1), VClos env2 (TTopInd c2 st2)) => do
|
|
termGuard env1 env2 c1 c2
|
|
termConv env1 env2 st1 st2
|
|
|
|
(VClos env1 (TBotInd c1), VClos env2 (TBotInd c2)) => termConv env1 env2 c1 c2
|
|
|
|
(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 env1 (TSigma a1 b1), VClos env2 (TSigma a2 b2)) => do
|
|
termGuard env1 env2 a1 a2
|
|
termConv env1 env2 b1 b2
|
|
|
|
(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
|
|
|
|
-- η 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)
|
|
|
|
_ => pure False
|
|
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 = guardS "termGuard" =<< termConv env1 env2 a1 a2
|