108 lines
4.1 KiB
Idris
108 lines
4.1 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"
|
||
|
||
-- pi and sigma could be inferred /shrug
|
||
TPi a b => case xpt of
|
||
VType => do
|
||
v <- VGen <$> fresh
|
||
guardS "Pi a" =<< check trs tys VType a
|
||
check (v :: trs) (VClos trs a :: tys) VType b
|
||
_ => oops "expected type"
|
||
|
||
TSigma a b => case xpt of
|
||
VType => do
|
||
v <- VGen <$> fresh
|
||
guardS "Σ a" =<< check trs tys VType a
|
||
check trs tys (VClos trs (TPi a TType)) b
|
||
_ => oops "expected type"
|
||
|
||
TPair x y => case xpt of
|
||
(VClos env (TSigma a b)) => do
|
||
guardS "Pair a" =<< check trs tys (VClos env a) x
|
||
check trs tys (VClos env b `VApp` VClos trs x) y
|
||
_ => oops "expected sigma"
|
||
|
||
_ => 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
|
||
guardS "app x" =<< 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
|
||
guardS "suc n" =<< check trs tys VNat n
|
||
pure VNat
|
||
|
||
infer trs tys (TTopInd c st) = do
|
||
guardS "⊤ C" =<< check trs tys (VClos trs (TPi TTop TType)) c
|
||
guardS "⊤ ★" =<< 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
|
||
guardS "⊥ C" =<< 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
|
||
guardS "ℕ C" =<< check trs tys (VClos trs (TPi TNat TType)) c
|
||
guardS "ℕ z" =<< check trs tys (VApp (VClos trs c) (VNatTr 0)) z
|
||
guardS "ℕ s" =<< 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 (TSigInd a b c f) = do
|
||
guardS "Σ A" =<< check trs tys VType a
|
||
guardS "Σ B" =<< check trs tys (VClos trs (TPi a TType)) b
|
||
guardS "Σ C" =<< check trs tys (VClos trs (TPi (TSigma a b) TType)) c
|
||
guardS "Σ f" =<< check trs tys (VClos trs (TPi a {-a:A-}
|
||
(TPi (weakTr b `TApp` TVar 0) {-b:Ba-}
|
||
(weakTr2 c `TApp` TPair (TVar (FS FZ)) (TVar 0))))) f
|
||
pure (VClos trs (TPi (TSigma a b) (weakTr c `TApp` TVar 0)))
|
||
|
||
|
||
infer trs tys x = oops ("cannot infer type" ++ show x)
|
||
|
||
public export
|
||
typecheck : Term 0 -> Term 0 -> Either String (Bool, List String)
|
||
typecheck tr ty = resolve $ (&&) <$> check [] [] VType ty
|
||
<*> delay <$> check [] [] (VClos [] ty) tr
|