You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
161 lines
4.2 KiB
161 lines
4.2 KiB
{-# LANGUAGE TupleSections, OverloadedStrings #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
module Elab where
|
|
|
|
import Control.Monad.Reader
|
|
import Control.Exception
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Typeable
|
|
|
|
import Elab.Monad
|
|
import Elab.Eval
|
|
|
|
import qualified Presyntax.Presyntax as P
|
|
|
|
import Syntax
|
|
|
|
infer :: P.Expr -> ElabM (Term, NFType)
|
|
infer (P.Span ex a b) = do
|
|
env <- ask
|
|
liftIO $
|
|
runElab (infer ex) env
|
|
`catches` [ Handler $ \e@WhileChecking{} -> throwIO e
|
|
, Handler $ \e -> throwIO (WhileChecking a b e)
|
|
]
|
|
|
|
infer (P.Var t) = do
|
|
name <- getNameFor t
|
|
case name of
|
|
Builtin _ wi -> elabWiredIn wi name
|
|
_ -> do
|
|
nft <- getNfType name
|
|
pure (Ref name, nft)
|
|
|
|
infer (P.App p f x) = do
|
|
(f, f_ty) <- infer f
|
|
(d, r, w) <- isPiType p f_ty
|
|
x <- check x d
|
|
x_nf <- eval x
|
|
pure (App p (w f) x, r x_nf)
|
|
|
|
infer (P.Pi p s d r) = do
|
|
d <- check d VType
|
|
d_nf <- eval d
|
|
assume (Bound s) d_nf $ do
|
|
r <- check r VType
|
|
pure (Pi p s d r, VType)
|
|
|
|
infer (P.Sigma s d r) = do
|
|
d <- check d VType
|
|
d_nf <- eval d
|
|
assume (Bound s) d_nf $ do
|
|
r <- check r VType
|
|
pure (Sigma s d r, VType)
|
|
|
|
infer (P.Proj1 x) = do
|
|
(tm, ty) <- infer x
|
|
(d, _, wp) <- isSigmaType ty
|
|
pure (Proj1 (wp tm), d)
|
|
|
|
infer (P.Proj2 x) = do
|
|
(tm, ty) <- infer x
|
|
tm_nf <- eval tm
|
|
(_, r, wp) <- isSigmaType ty
|
|
pure (Proj2 (wp tm), r (vProj1 tm_nf))
|
|
|
|
infer exp = do
|
|
t <- newMeta VType
|
|
tm <- switch $ check exp t
|
|
pure (tm, t)
|
|
|
|
check :: P.Expr -> NFType -> ElabM Term
|
|
check (P.Span ex a b) ty = do
|
|
env <- ask
|
|
liftIO $
|
|
runElab (check ex ty) env
|
|
`catches` [ Handler $ \e@WhileChecking{} -> throwIO e
|
|
, Handler $ \e -> throwIO (WhileChecking a b e)
|
|
]
|
|
|
|
check (P.Lam p var body) (VPi p' dom (Closure _ rng)) | p == p' =
|
|
assume (Bound var) dom $
|
|
Lam p var <$> check body (rng (VVar (Bound var)))
|
|
|
|
check tm (VPi P.Im dom (Closure var rng)) =
|
|
assume (Bound var) dom $
|
|
Lam P.Im var <$> check tm (rng (VVar (Bound var)))
|
|
|
|
check (P.Lam p v b) ty = do
|
|
(d, r, wp) <- isPiType p ty
|
|
assume (Bound v) d $
|
|
wp . Lam P.Im v <$> check b (r (VVar (Bound v)))
|
|
|
|
check (P.Pair a b) ty = do
|
|
(d, r, wp) <- isSigmaType ty
|
|
a <- check a d
|
|
a_nf <- eval a
|
|
b <- check b (r a_nf)
|
|
pure (wp (Pair a b))
|
|
|
|
check exp ty = do
|
|
(tm, has) <- switch $ infer exp
|
|
unify has ty
|
|
pure tm
|
|
|
|
elabWiredIn :: WiredIn -> Name -> ElabM (Term, NFType)
|
|
elabWiredIn WiType _ = pure (Type, VType)
|
|
|
|
isPiType :: P.Plicity -> NFType -> ElabM (Value, NFType -> NFType, Term -> Term)
|
|
isPiType p (VPi p' d (Closure _ k)) | p == p' = pure (d, k, id)
|
|
isPiType p t = do
|
|
dom <- newMeta VType
|
|
name <- newName
|
|
assume (Bound name) dom $ do
|
|
rng <- newMeta VType
|
|
wp <- isConvertibleTo t (VPi p dom (Closure name (const rng)))
|
|
pure (dom, const rng, wp)
|
|
|
|
isSigmaType :: NFType -> ElabM (Value, NFType -> NFType, Term -> Term)
|
|
isSigmaType (VSigma d (Closure _ k)) = pure (d, k, id)
|
|
isSigmaType t = do
|
|
dom <- newMeta VType
|
|
name <- newName
|
|
assume (Bound name) dom $ do
|
|
rng <- newMeta VType
|
|
wp <- isConvertibleTo t (VSigma dom (Closure name (const rng)))
|
|
pure (dom, const rng, wp)
|
|
|
|
identityTy :: NFType
|
|
identityTy = VPi P.Im VType (Closure "A" $ \t -> VPi P.Ex t (Closure "_" (const t)))
|
|
|
|
checkStatement :: P.Statement -> ElabM a -> ElabM a
|
|
checkStatement (P.Decl name ty) k = do
|
|
ty <- check ty VType
|
|
ty_nf <- eval ty
|
|
assume (Defined name) ty_nf k
|
|
|
|
checkStatement (P.Defn name rhs) k = do
|
|
ty <- asks (Map.lookup (Defined name) . getEnv)
|
|
case ty of
|
|
Nothing -> do
|
|
(tm, ty) <- infer rhs
|
|
tm_nf <- eval tm
|
|
define (Defined name) ty tm_nf k
|
|
Just (ty_nf, nm) -> do
|
|
unless (nm == VVar (Defined name)) . liftIO . throwIO $
|
|
Redefinition (Defined name)
|
|
|
|
rhs <- check rhs ty_nf
|
|
rhs_nf <- eval rhs
|
|
define (Defined name) ty_nf rhs_nf k
|
|
|
|
checkProgram :: [P.Statement] -> ElabM ElabEnv
|
|
checkProgram [] = ask
|
|
checkProgram (st:sts) = checkStatement st $ checkProgram sts
|
|
|
|
newtype Redefinition = Redefinition { getRedefName :: Name }
|
|
deriving (Show, Typeable, Exception)
|
|
|
|
data WhileChecking = WhileChecking { startPos :: P.Posn, endPos :: P.Posn, exc :: SomeException }
|
|
deriving (Show, Typeable, Exception)
|