|
|
|
@ -2,13 +2,17 @@ |
|
|
|
{-# LANGUAGE TupleSections #-} |
|
|
|
{-# LANGUAGE DeriveAnyClass #-} |
|
|
|
{-# LANGUAGE ScopedTypeVariables #-} |
|
|
|
{-# LANGUAGE DerivingStrategies #-} |
|
|
|
module Elab where |
|
|
|
|
|
|
|
import Control.Arrow (Arrow(first)) |
|
|
|
import Control.Monad.Reader |
|
|
|
import Control.Exception |
|
|
|
|
|
|
|
import qualified Data.Map.Strict as Map |
|
|
|
import qualified Data.Sequence as Seq |
|
|
|
import qualified Data.Set as Set |
|
|
|
import qualified Data.Text as T |
|
|
|
import Data.Traversable |
|
|
|
import Data.Text (Text) |
|
|
|
import Data.Map (Map) |
|
|
|
@ -190,11 +194,79 @@ check (P.LamSystem bs) ty = do |
|
|
|
mkB _ (Nothing, b) = b |
|
|
|
pure (Lam P.Ex name (System (Map.fromList (map (\(_, (x, y)) -> (quote x, mkB name y)) eqns)))) |
|
|
|
|
|
|
|
check (P.LamCase pats) ty = do |
|
|
|
porp <- isPiType P.Ex ty |
|
|
|
case porp of |
|
|
|
It'sProd dom rng wp -> do |
|
|
|
name <- newName |
|
|
|
liftIO . print $ show pats |
|
|
|
cases <- for pats $ \(pat, rhs) -> do |
|
|
|
checkPattern pat dom \pat wp -> do |
|
|
|
pat_nf <- eval pat |
|
|
|
rhs <- check rhs (rng pat_nf) |
|
|
|
pure (pat, wp rhs) |
|
|
|
pure (wp (Lam P.Ex name (Case (Ref name) cases))) |
|
|
|
_ -> do |
|
|
|
dom <- newMeta VTypeω |
|
|
|
n <- newName' (Bound (T.singleton 'x') 0) |
|
|
|
assume n dom \_ -> do |
|
|
|
rng <- newMeta VTypeω |
|
|
|
throwElab $ NotEqual (VPi P.Ex dom (Closure n (const rng))) ty |
|
|
|
|
|
|
|
check exp ty = do |
|
|
|
(tm, has) <- switch $ infer exp |
|
|
|
wp <- isConvertibleTo has ty |
|
|
|
pure (wp tm) |
|
|
|
|
|
|
|
checkPattern :: P.Pattern -> NFSort -> (Term -> (Term -> Term) -> ElabM a) -> ElabM a |
|
|
|
checkPattern (P.PCap var) dom cont = do |
|
|
|
name <- asks (Map.lookup var . nameMap) |
|
|
|
case name of |
|
|
|
Just name@(ConName _ _ skip arity) -> do |
|
|
|
unless (arity == 0) $ throwElab $ UnsaturatedCon name |
|
|
|
ty <- instantiate =<< getNfType name |
|
|
|
_ <- isConvertibleTo ty dom |
|
|
|
wrap <- skipLams skip |
|
|
|
cont (Con name) wrap |
|
|
|
Just name -> throwElab $ NotACon name |
|
|
|
Nothing -> assume (Bound var 0) dom \name -> cont (Ref name) (Lam P.Ex name) |
|
|
|
checkPattern (P.PCon var args) dom cont = |
|
|
|
do |
|
|
|
name <- asks (Map.lookup var . nameMap) |
|
|
|
case name of |
|
|
|
Just name@(ConName _ _ nskip arity) -> do |
|
|
|
unless (arity == length args) $ throwElab $ UnsaturatedCon name |
|
|
|
ty <- instantiate =<< getNfType name |
|
|
|
_ <- isConvertibleTo (skipBinders arity ty) dom |
|
|
|
skip <- skipLams nskip |
|
|
|
bindNames args ty $ \_ wrap -> |
|
|
|
cont (Con name) (skip . wrap) |
|
|
|
Just name -> throwElab $ NotACon name |
|
|
|
_ -> throwElab $ NotInScope (Bound var 0) |
|
|
|
where |
|
|
|
skipBinders :: Int -> NFType -> NFType |
|
|
|
skipBinders 0 t = t |
|
|
|
skipBinders n (VPi _ _ (Closure v r)) = skipBinders (n - 1) (r (VVar v)) |
|
|
|
skipBinders _ _ = error $ "constructor type is wrong?" |
|
|
|
|
|
|
|
bindNames (n:ns) (VPi p d (Closure _ r)) k = |
|
|
|
assume (Bound n 0) d \n -> bindNames ns (r (VVar n)) \ns w -> |
|
|
|
k (n:ns) (Lam p n . w) |
|
|
|
bindNames [] _ k = k [] id |
|
|
|
bindNames xs t _ = error $ show (xs, t) |
|
|
|
|
|
|
|
instantiate :: NFType -> ElabM NFType |
|
|
|
instantiate (VPi P.Im d (Closure _ k)) = do |
|
|
|
t <- newMeta d |
|
|
|
instantiate (k t) |
|
|
|
instantiate x = pure x |
|
|
|
|
|
|
|
skipLams :: Int -> ElabM (Term -> Term) |
|
|
|
skipLams 0 = pure id |
|
|
|
skipLams k = do |
|
|
|
n <- newName |
|
|
|
(Lam P.Im n . ) <$> skipLams (k - 1) |
|
|
|
|
|
|
|
checkLetItems :: Map Text (Maybe NFType) -> [P.LetItem] -> ([(Name, Term, Term)] -> ElabM a) -> ElabM a |
|
|
|
checkLetItems _ [] cont = cont [] |
|
|
|
checkLetItems map (P.LetDecl v t:xs) cont = do |
|
|
|
@ -333,7 +405,7 @@ checkStatement (P.Defn name rhs) k = do |
|
|
|
when t $ throwElab (Redefinition (Defined name 0)) |
|
|
|
|
|
|
|
rhs <- check rhs ty_nf |
|
|
|
rhs_nf <- eval rhs |
|
|
|
rhs_nf <- evalFix (Defined name 0) ty_nf rhs |
|
|
|
makeLetDef (Defined name 0) ty_nf rhs_nf $ \name -> |
|
|
|
local (\e -> e { definedNames = Set.insert name (definedNames e) }) k |
|
|
|
|
|
|
|
@ -371,6 +443,58 @@ checkStatement (P.ReplTy e) k = do |
|
|
|
liftIO (h ty) |
|
|
|
k |
|
|
|
|
|
|
|
checkStatement (P.Data name tele retk constrs) k = |
|
|
|
do |
|
|
|
checkTeleRetk True tele retk \kind tele -> do |
|
|
|
kind_nf <- eval kind |
|
|
|
defineInternal (Bound name 0) kind_nf (\name' -> VNe (HData name') mempty) \name' -> do |
|
|
|
checkCons tele (VNe (HData name') (Seq.fromList (map makeProj tele))) constrs k |
|
|
|
where |
|
|
|
makeProj (x, p, _) = PApp p (VVar x) |
|
|
|
|
|
|
|
checkTeleRetk allKan [] retk cont = do |
|
|
|
t <- check retk VTypeω |
|
|
|
t_nf <- eval t |
|
|
|
when allKan $ unify t_nf VType |
|
|
|
cont t [] |
|
|
|
checkTeleRetk allKan ((x, p, t):xs) retk cont = do |
|
|
|
(t, ty) <- infer t |
|
|
|
_ <- isConvertibleTo ty VTypeω |
|
|
|
let |
|
|
|
allKan' = case ty of |
|
|
|
VType -> allKan |
|
|
|
_ -> False |
|
|
|
t_nf <- eval t |
|
|
|
assume (Bound x 0) t_nf $ \nm -> checkTeleRetk allKan' xs retk \k xs -> cont (Pi p nm t k) ((nm, p, t_nf):xs) |
|
|
|
|
|
|
|
checkCons _ _et [] k = k |
|
|
|
|
|
|
|
checkCons n ret ((x, ty):xs) k = do |
|
|
|
t <- check ty VTypeω |
|
|
|
ty_nf <- eval t |
|
|
|
let |
|
|
|
(args, ret') = splitPi ty_nf |
|
|
|
closed = close n t |
|
|
|
n' = map (\(x, _, y) -> (x, P.Im, y)) n |
|
|
|
unify ret' ret |
|
|
|
closed_nf <- eval closed |
|
|
|
defineInternal (ConName x 0 (length n') (length args)) closed_nf (makeCon closed_nf mempty n' args) \_ -> checkCons n ret xs k |
|
|
|
|
|
|
|
close [] t = t |
|
|
|
close ((x, _, y):xs) t = Pi P.Im x (quote y) (close xs t) |
|
|
|
|
|
|
|
splitPi (VPi p y (Closure x k)) = first ((x, p, y):) $ splitPi (k (VVar x)) |
|
|
|
splitPi t = ([], t) |
|
|
|
|
|
|
|
makeCon cty sp [] [] con = VNe (HCon cty con) sp |
|
|
|
makeCon cty sp ((nm, p, _):xs) ys con = VLam p $ Closure nm \a -> makeCon cty (sp Seq.:|> PApp p a) xs ys con |
|
|
|
makeCon cty sp [] ((nm, p, _):ys) con = VLam p $ Closure nm \a -> makeCon cty (sp Seq.:|> PApp p a) [] ys con |
|
|
|
|
|
|
|
evalFix :: Name -> NFType -> Term -> ElabM Value |
|
|
|
evalFix name nft term = do |
|
|
|
env <- ask |
|
|
|
pure . fix $ \val -> eval' env{ getEnv = Map.insert name (nft, val) (getEnv env) } term |
|
|
|
|
|
|
|
checkProgram :: [P.Statement] -> ElabM a -> ElabM a |
|
|
|
checkProgram [] k = k |
|
|
|
checkProgram (st:sts) k = checkStatement st $ checkProgram sts k |
|
|
|
@ -380,3 +504,11 @@ newtype Redefinition = Redefinition { getRedefName :: Name } |
|
|
|
|
|
|
|
data WhenCheckingEndpoint = WhenCheckingEndpoint { leftEndp :: Value, rightEndp :: Value, whichIsWrong :: NFEndp, exc :: SomeException } |
|
|
|
deriving (Show, Typeable, Exception) |
|
|
|
|
|
|
|
data UnsaturatedCon = UnsaturatedCon { theConstr :: Name } |
|
|
|
deriving (Show, Typeable) |
|
|
|
deriving anyclass (Exception) |
|
|
|
|
|
|
|
data NotACon = NotACon { theNotConstr :: Name } |
|
|
|
deriving (Show, Typeable) |
|
|
|
deriving anyclass (Exception) |
