86 lines
2.8 KiB
Idris
86 lines
2.8 KiB
Idris
module Check
|
|
|
|
import Control.Monad.RWS
|
|
import Control.Monad.Either
|
|
import Control.Monad.Identity
|
|
import Data.Vect
|
|
import Data.Fin
|
|
|
|
import Term
|
|
import Value
|
|
import Normalize
|
|
import Misc
|
|
import Convert
|
|
|
|
|
|
%default total
|
|
|
|
mutual
|
|
public export
|
|
-- terms types expected term
|
|
check : Ctx n -> Ctx n -> Value -> Term n -> PI Bool
|
|
check trs tys xpt' tr = do
|
|
xpt <- whnf xpt'
|
|
case tr of
|
|
TLam sc => case xpt of
|
|
VClos env (TPi a b) => do
|
|
v <- VGen <$> fresh
|
|
check (v :: trs) (VClos env a :: tys) (VClos (v :: env) b) sc
|
|
_ => oops "expected pi"
|
|
|
|
TPi a b => case xpt of
|
|
VType => do
|
|
v <- VGen <$> fresh
|
|
(&&) <$> check trs tys VType a
|
|
<*> delay <$> check (v :: trs) (VClos trs a :: tys) VType b
|
|
|
|
|
|
_ => oops "expected type"
|
|
|
|
_ => convert xpt =<< infer trs tys tr
|
|
|
|
-- terms types term
|
|
infer : Ctx n -> Ctx n -> Term n -> PI Value
|
|
infer trs tys (TVar i) = pure (index i tys)
|
|
infer trs tys TType = pure VType
|
|
infer trs tys (TApp f x) = infer trs tys f >>= whnf >>=
|
|
\case
|
|
VClos env (TPi a b) => do
|
|
guard =<< check trs tys (VClos env a) x
|
|
pure (VClos (VClos trs x :: env) b)
|
|
|
|
_ => oops "expected infer pi"
|
|
|
|
infer trs tys TTop = pure VType
|
|
infer trs tys TBot = pure VType
|
|
infer trs tys TNat = pure VType
|
|
infer trs tys TStar = pure VTop
|
|
infer trs tys TZero = pure VNat
|
|
infer trs tys (TSuc n) = do
|
|
guard =<< check trs tys VNat n
|
|
pure VNat
|
|
|
|
infer trs tys (TTopInd c st) = do
|
|
guard =<< check trs tys (VClos trs (TPi TTop TType)) c
|
|
guard =<< check trs tys (VApp (VClos trs c) VStar) st
|
|
pure (VClos trs (TPi TTop (TApp (weakTr c) (TVar 0))))
|
|
|
|
infer trs tys (TBotInd c) = do
|
|
guard =<< check trs tys (VClos trs (TPi TBot TType)) c
|
|
pure (VClos trs (TPi TBot (TApp (weakTr c) (TVar 0))))
|
|
|
|
infer trs tys (TNatInd c z s) = do
|
|
guard =<< check trs tys (VClos trs (TPi TNat TType)) c
|
|
guard =<< check trs tys (VApp (VClos trs c) (VNatTr 0)) z
|
|
guard =<< check trs tys (VClos trs (TPi TNat
|
|
(TPi (TApp (weakTr c) (TVar 0))
|
|
(TApp (weakTr2 c) (TSuc (TVar (FS FZ))))))) s
|
|
pure (VClos trs (TPi TNat (TApp (weakTr c) (TVar 0))))
|
|
|
|
infer trs tys _ = oops "cannot infer type"
|
|
|
|
public export
|
|
typecheck : Term 0 -> Term 0 -> Either String (Bool, List String)
|
|
typecheck tr ty = resolve $ (&&) <$> check [] [] VType ty
|
|
<*> delay <$> check [] [] (VClos [] ty) tr
|