GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-22 09:32:53 -06:00
Code Issues Packages Projects Releases Wiki Activity

the experimental type checker in GF.Compile.TypeCheck.ConcreteNew is now rewriten to use the complete evaluator in GF.Compile.Compute.ConcreteNew. The old sketchy implementation in GF.Compile.Compute.ConcreteNew1 is now removed.

Browse Source
This commit is contained in:
krasimir
2016-03-02 13:38:02 +00:00
parent 672c1e8df5
commit 47eb774cdf
5 changed files with 309 additions and 387 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -177,7 +177,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
mty <- case mty of mty <- case mty of
Just (L loc typ) -> chIn loc "linearization type of" $ Just (L loc typ) -> chIn loc "linearization type of" $
(if False --flag optNewComp opts (if False --flag optNewComp opts
then do (typ,_) <- CN.checkLType gr typ typeType then do (typ,_) <- CN.checkLType (CN.resourceValues opts gr) typ typeType
typ <- computeLType gr [] typ typ <- computeLType gr [] typ
return (Just (L loc typ)) return (Just (L loc typ))
else do (typ,_) <- checkLType gr [] typ typeType else do (typ,_) <- checkLType gr [] typ typeType
@@ -224,17 +224,17 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
(Just (L loct ty), Just (L locd de)) -> do (Just (L loct ty), Just (L locd de)) -> do
ty' <- chIn loct "operation" $ ty' <- chIn loct "operation" $
(if False --flag optNewComp opts (if False --flag optNewComp opts
then CN.checkLType gr ty typeType >>= return . CN.normalForm (CN.resourceValues opts gr) (L loct c) . fst -- !! then CN.checkLType (CN.resourceValues opts gr) ty typeType >>= return . CN.normalForm (CN.resourceValues opts gr) (L loct c) . fst -- !!
else checkLType gr [] ty typeType >>= computeLType gr [] . fst) else checkLType gr [] ty typeType >>= computeLType gr [] . fst)
(de',_) <- chIn locd "operation" $ (de',_) <- chIn locd "operation" $
(if False -- flag optNewComp opts (if False -- flag optNewComp opts
then CN.checkLType gr de ty' then CN.checkLType (CN.resourceValues opts gr) de ty'
else checkLType gr [] de ty') else checkLType gr [] de ty')
return (Just (L loct ty'), Just (L locd de')) return (Just (L loct ty'), Just (L locd de'))
(Nothing , Just (L locd de)) -> do (Nothing , Just (L locd de)) -> do
(de',ty') <- chIn locd "operation" $ (de',ty') <- chIn locd "operation" $
(if False -- flag optNewComp opts (if False -- flag optNewComp opts
then CN.inferLType gr de then CN.inferLType (CN.resourceValues opts gr) de
else inferLType gr [] de) else inferLType gr [] de)
return (Just (L locd ty'), Just (L locd de')) return (Just (L locd ty'), Just (L locd de'))
(Just (L loct ty), Nothing) -> do (Just (L loct ty), Nothing) -> do

5
src/compiler/GF/Compile/Compute/ConcreteNew.hs
View File

@@ -1,8 +1,9 @@
-- | Functions for computing the values of terms in the concrete syntax, in -- | Functions for computing the values of terms in the concrete syntax, in
-- | preparation for PMCFG generation. -- | preparation for PMCFG generation.
module GF.Compile.Compute.ConcreteNew module GF.Compile.Compute.ConcreteNew
(GlobalEnv, resourceValues, normalForm, (GlobalEnv(..), GLocation, resourceValues, normalForm,
--, Value(..), Env, value2term, eval, apply Value(..), Bind(..), Env, value2term,
eval, value, toplevel
) where ) where
import GF.Grammar hiding (Env, VGen, VApp, VRecType) import GF.Grammar hiding (Env, VGen, VApp, VRecType)

107
src/compiler/GF/Compile/Compute/ConcreteNew1.hs
View File

@@ -1,107 +0,0 @@
module GF.Compile.Compute.ConcreteNew1
( normalForm
, Value(..), Env, eval, apply, value2term
) where
import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Data.Operations
import Data.List (intersect)
import GF.Text.Pretty
normalForm :: SourceGrammar -> Term -> Term
normalForm gr t = value2term gr [] (eval gr [] t)
data Value
= VApp QIdent [Value]
| VGen Int [Value]
| VMeta MetaId Env [Value]
| VClosure Env Term
| VInt Int
| VFloat Double
| VString String
| VSort Ident
| VImplArg Value
| VTblType Value Value
| VRecType [(Label,Value)]
| VRec [(Label,Value)]
| VTbl Type [Value]
-- | VC Value Value
| VPatt Patt
| VPattType Value
| VFV [Value]
| VAlts Value [(Value, Value)]
| VError String
deriving Show
type Env = [(Ident,Value)]
eval :: SourceGrammar -> Env -> Term -> Value
eval gr env (Vr x) = case lookup x env of
Just v -> v
Nothing -> error ("Unknown variable "++showIdent x)
eval gr env (Q x)
| x == (cPredef,cErrorType) -- to be removed
= let varP = identS "P"
in eval gr [] (mkProd [(Implicit,varP,typeType)] (Vr varP) [])
| fst x == cPredef = VApp x []
| otherwise = case lookupResDef gr x of
Ok t -> eval gr [] t
Bad err -> error err
eval gr env (QC x) = VApp x []
eval gr env (App e1 e2) = apply gr env e1 [eval gr env e2]
eval gr env (Meta i) = VMeta i env []
eval gr env t@(Prod _ _ _ _) = VClosure env t
eval gr env t@(Abs _ _ _) = VClosure env t
eval gr env (EInt n) = VInt n
eval gr env (EFloat f) = VFloat f
eval gr env (K s) = VString s
eval gr env Empty = VString ""
eval gr env (Sort s)
| s == cTok = VSort cStr -- to be removed
| otherwise = VSort s
eval gr env (ImplArg t) = VImplArg (eval gr env t)
eval gr env (Table p res) = VTblType (eval gr env p) (eval gr env res)
eval gr env (RecType rs) = VRecType [(l,eval gr env ty) | (l,ty) <- rs]
eval gr env t@(ExtR t1 t2) =
let error = VError (show ("The term" <+> ppTerm Unqualified 0 t <+> "is not reducible"))
in case (eval gr env t1, eval gr env t2) of
(VRecType rs1, VRecType rs2) -> case intersect (map fst rs1) (map fst rs2) of
[] -> VRecType (rs1 ++ rs2)
_ -> error
(VRec rs1, VRec rs2) -> case intersect (map fst rs1) (map fst rs2) of
[] -> VRec (rs1 ++ rs2)
_ -> error
_ -> error
eval gr env (FV ts) = VFV (map (eval gr env) ts)
eval gr env t = error ("unimplemented: eval "++show t)
apply gr env t [] = eval gr env t
apply gr env (Q x) vs
| fst x == cPredef = VApp x vs -- hmm
| otherwise = case lookupResDef gr x of
Ok t -> apply gr [] t vs
Bad err -> error err
apply gr env (App t1 t2) vs = apply gr env t1 (eval gr env t2 : vs)
apply gr env (Abs b x t) (v:vs) = case (b,v) of
(Implicit,VImplArg v) -> apply gr ((x,v):env) t vs
(Explicit, v) -> apply gr ((x,v):env) t vs
apply gr env t vs = error ("apply "++show t)
value2term :: SourceGrammar -> [Ident] -> Value -> Term
value2term gr xs (VApp f vs) = foldl App (Q f) (map (value2term gr xs) vs)
value2term gr xs (VGen j vs) = foldl App (Vr (reverse xs !! j)) (map (value2term gr xs) vs)
value2term gr xs (VMeta j env vs) = foldl App (Meta j) (map (value2term gr xs) vs)
value2term gr xs (VClosure env (Prod bt x t1 t2)) = Prod bt x (value2term gr xs (eval gr env t1))
(value2term gr (x:xs) (eval gr ((x,VGen (length xs) []) : env) t2))
value2term gr xs (VClosure env (Abs bt x t)) = Abs bt x (value2term gr (x:xs) (eval gr ((x,VGen (length xs) []) : env) t))
value2term gr xs (VInt n) = EInt n
value2term gr xs (VFloat f) = EFloat f
value2term gr xs (VString s) = if null s then Empty else K s
value2term gr xs (VSort s) = Sort s
value2term gr xs (VImplArg v) = ImplArg (value2term gr xs v)
value2term gr xs (VTblType p res) = Table (value2term gr xs p) (value2term gr xs res)
value2term gr xs (VRecType rs) = RecType [(l,value2term gr xs v) | (l,v) <- rs]
value2term gr xs (VFV vs) = FV (map (value2term gr xs) vs)
value2term gr xs v = error ("unimplemented: value2term "++show v)

4
src/compiler/GF/Compile/Compute/Predef.hs
View File

@@ -2,7 +2,6 @@
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module GF.Compile.Compute.Predef(predef,predefName,delta) where module GF.Compile.Compute.Predef(predef,predefName,delta) where
--import GF.Text.Pretty(render,hang)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Array(array,(!)) import Data.Array(array,(!))
import Data.List (isInfixOf) import Data.List (isInfixOf)
@@ -15,7 +14,6 @@ import GF.Compile.Compute.Value
import GF.Infra.Ident (Ident,showIdent) --,varX import GF.Infra.Ident (Ident,showIdent) --,varX
import GF.Data.Operations(Err) -- ,err import GF.Data.Operations(Err) -- ,err
import GF.Grammar.Predef import GF.Grammar.Predef
--import PGF.Data(BindType(..))
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
class Predef a where class Predef a where
@@ -166,4 +164,4 @@ swap (x,y) = (y,x)
bug msg = ppbug msg bug msg = ppbug msg
ppbug doc = error $ render $ ppbug doc = error $ render $
hang "Internal error in Compute.Predef:" 4 doc hang "Internal error in Compute.Predef:" 4 doc
-} -}

572
src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -1,10 +1,16 @@
module GF.Compile.TypeCheck.ConcreteNew( checkLType, inferLType ) where module GF.Compile.TypeCheck.ConcreteNew( checkLType, inferLType ) where
-- The code here is based on the paper:
-- Simon Peyton Jones, Dimitrios Vytiniotis, Stephanie Weirich.
-- Practical type inference for arbitrary-rank types.
-- 14 September 2011
import GF.Grammar hiding (Env, VGen, VApp, VRecType) import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup import GF.Grammar.Lookup
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Grammar.Lockfield import GF.Grammar.Lockfield
import GF.Compile.Compute.ConcreteNew1 import GF.Compile.Compute.ConcreteNew
import GF.Compile.Compute.Predef(predef)
import GF.Compile.TypeCheck.Primitives import GF.Compile.TypeCheck.Primitives
import GF.Infra.CheckM import GF.Infra.CheckM
--import GF.Infra.UseIO --import GF.Infra.UseIO
@@ -16,253 +22,275 @@ import GF.Text.Pretty
import Data.List (nub, (\\), tails) import Data.List (nub, (\\), tails)
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
--import GF.Grammar.Parser checkLType :: GlobalEnv -> Term -> Type -> Check (Term, Type)
--import System.IO checkLType ge t ty = runTcM $ do
--import Debug.Trace vty <- runErr (eval ge ty)
t <- checkSigma ge [] t vty
checkLType :: SourceGrammar -> Term -> Type -> Check (Term, Type)
checkLType gr t ty = runTcM $ do
t <- checkSigma gr [] t (eval gr [] ty)
t <- zonkTerm t t <- zonkTerm t
return (t,ty) return (t,ty)
inferLType :: SourceGrammar -> Term -> Check (Term, Type) inferLType :: GlobalEnv -> Term -> Check (Term, Type)
inferLType gr t = runTcM $ do inferLType ge@(GE _ _ _ gloc) t = runTcM $ do
(t,ty) <- inferSigma gr [] t (t,ty) <- inferSigma ge [] t
t <- zonkTerm t t <- zonkTerm t
ty <- zonkTerm (value2term gr [] ty) ty <- zonkTerm (value2term gloc [] ty)
return (t,ty) return (t,ty)
inferSigma :: SourceGrammar -> Scope -> Term -> TcM (Term,Sigma) inferSigma :: GlobalEnv -> Scope -> Term -> TcM (Term,Sigma)
inferSigma gr scope t = do -- GEN1 inferSigma ge scope t = do -- GEN1
(t,ty) <- tcRho gr scope t Nothing (t,ty) <- tcRho ge scope t Nothing
env_tvs <- getMetaVars gr (scopeTypes scope) let GE _ _ _ loc = ge
res_tvs <- getMetaVars gr [(scope,ty)] env_tvs <- getMetaVars loc (scopeTypes scope)
res_tvs <- getMetaVars loc [(scope,ty)]
let forall_tvs = res_tvs \\ env_tvs let forall_tvs = res_tvs \\ env_tvs
quantify gr scope t forall_tvs ty quantify ge scope t forall_tvs ty
checkSigma :: SourceGrammar -> Scope -> Term -> Sigma -> TcM Term checkSigma :: GlobalEnv -> Scope -> Term -> Sigma -> TcM Term
checkSigma gr scope t sigma = do -- GEN2 checkSigma ge scope t sigma = do -- GEN2
(abs, scope, t, rho) <- skolemise id gr scope t sigma (abs, scope, t, rho) <- skolemise id scope t sigma
let skol_tvs = [] let skol_tvs = []
(t,rho) <- tcRho gr scope t (Just rho) (t,rho) <- tcRho ge scope t (Just rho)
esc_tvs <- getFreeVars gr ((scope,sigma) : scopeTypes scope) let GE _ _ _ loc = ge
esc_tvs <- getFreeVars loc ((scope,sigma) : scopeTypes scope)
let bad_tvs = filter (`elem` esc_tvs) skol_tvs let bad_tvs = filter (`elem` esc_tvs) skol_tvs
if null bad_tvs if null bad_tvs
then return (abs t) then return (abs t)
else tcError (pp "Type not polymorphic enough") else tcError (pp "Type not polymorphic enough")
tcRho :: SourceGrammar -> Scope -> Term -> Maybe Rho -> TcM (Term, Rho) Just vtypeInt = fmap (flip VApp []) (predef cInt)
tcRho gr scope t@(EInt _) mb_ty = instSigma gr scope t (eval gr [] typeInt) mb_ty Just vtypeFloat = fmap (flip VApp []) (predef cFloat)
tcRho gr scope t@(EFloat _) mb_ty = instSigma gr scope t (eval gr [] typeFloat) mb_ty vtypeStr = VSort cStr
tcRho gr scope t@(K _) mb_ty = instSigma gr scope t (eval gr [] typeStr) mb_ty vtypeStrs = VSort cStrs
tcRho gr scope t@(Empty) mb_ty = instSigma gr scope t (eval gr [] typeStr) mb_ty vtypeType = VSort cType
tcRho gr scope t@(Vr v) mb_ty = do -- VAR vtypePType = VSort cPType
tcRho :: GlobalEnv -> Scope -> Term -> Maybe Rho -> TcM (Term, Rho)
tcRho ge scope t@(EInt _) mb_ty = instSigma ge scope t vtypeInt mb_ty
tcRho ge scope t@(EFloat _) mb_ty = instSigma ge scope t vtypeFloat mb_ty
tcRho ge scope t@(K _) mb_ty = instSigma ge scope t vtypeStr mb_ty
tcRho ge scope t@(Empty) mb_ty = instSigma ge scope t vtypeStr mb_ty
tcRho ge scope t@(Vr v) mb_ty = do -- VAR
case lookup v scope of case lookup v scope of
Just v_sigma -> instSigma gr scope t v_sigma mb_ty Just v_sigma -> instSigma ge scope t v_sigma mb_ty
Nothing -> tcError ("Unknown variable" <+> v) Nothing -> tcError ("Unknown variable" <+> v)
tcRho gr scope t@(Q id) mb_ty tcRho ge scope t@(Q id) mb_ty =
| elem (fst id) [cPredef,cPredefAbs] = let GE gr _ _ _ = ge
case typPredefined (snd id) of in case lookupResType gr id of
Just ty -> instSigma gr scope t (eval gr [] ty) mb_ty Ok ty -> do vty <- runErr (eval ge ty)
Nothing -> tcError (pp "unknown in Predef:" <+> ppQIdent Qualified id) instSigma ge scope t vty mb_ty
| otherwise = do Bad err -> tcError (pp err)
case lookupResType gr id of tcRho ge scope t@(QC id) mb_ty =
Ok ty -> instSigma gr scope t (eval gr [] ty) mb_ty let GE gr _ _ _ = ge
Bad err -> tcError (pp err) in case lookupResType gr id of
tcRho gr scope t@(QC id) mb_ty = do Ok ty -> do vty <- runErr (eval ge ty)
case lookupResType gr id of instSigma ge scope t vty mb_ty
Ok ty -> instSigma gr scope t (eval gr [] ty) mb_ty Bad err -> tcError (pp err)
Bad err -> tcError (pp err) tcRho ge scope (App fun arg) mb_ty = do -- APP
tcRho gr scope (App fun arg) mb_ty = do -- APP (fun,fun_ty) <- tcRho ge scope fun Nothing
(fun,fun_ty) <- tcRho gr scope fun Nothing varg <- runErr (value (toplevel ge) arg)
(arg_ty, res_ty) <- unifyFun gr scope (eval gr (scopeEnv scope) arg) fun_ty let GE _ _ _ loc = ge
arg <- checkSigma gr scope arg arg_ty (arg_ty, res_ty) <- unifyFun loc scope (varg (scopeStack scope)) fun_ty
instSigma gr scope (App fun arg) res_ty mb_ty arg <- checkSigma ge scope arg arg_ty
instSigma ge scope (App fun arg) res_ty mb_ty
tcRho gr scope (Abs bt var body) Nothing = do -- ABS1 tcRho gr scope (Abs bt var body) Nothing = do -- ABS1
i <- newMeta (eval gr [] typeType) i <- newMeta vtypeType
(body,body_ty) <- tcRho gr ((var,VMeta i (scopeEnv scope) []):scope) body Nothing let arg_ty = VMeta i (scopeEnv scope) []
return (Abs bt var body, (VClosure (scopeEnv scope) (body,body_ty) <- tcRho gr ((var,arg_ty):scope) body Nothing
(Prod bt identW (Meta i) (value2term gr (scopeVars scope) body_ty)))) return (Abs bt var body, (VProd bt arg_ty identW (Bind (const body_ty))))
tcRho gr scope (Abs bt var body) (Just ty) = do -- ABS2 tcRho ge scope (Abs bt var body) (Just ty) = do -- ABS2
(var_ty, body_ty) <- unifyFun gr scope (VGen (length scope) []) ty let GE _ _ _ loc = ge
(body, body_ty) <- tcRho gr ((var,var_ty):scope) body (Just body_ty) (var_ty, body_ty) <- unifyFun loc scope (VGen (length scope) []) ty
(body, body_ty) <- tcRho ge ((var,var_ty):scope) body (Just body_ty)
return (Abs bt var body,ty) return (Abs bt var body,ty)
tcRho gr scope (Let (var, (mb_ann_ty, rhs)) body) mb_ty = do -- LET tcRho ge scope (Let (var, (mb_ann_ty, rhs)) body) mb_ty = do -- LET
(rhs,var_ty) <- case mb_ann_ty of (rhs,var_ty) <- case mb_ann_ty of
Nothing -> inferSigma gr scope rhs Nothing -> inferSigma ge scope rhs
Just ann_ty -> do (ann_ty, _) <- tcRho gr scope ann_ty (Just (eval gr [] typeType)) Just ann_ty -> do (ann_ty, _) <- tcRho ge scope ann_ty (Just vtypeType)
let v_ann_ty = eval gr (scopeEnv scope) ann_ty ov_ann_ty <- runErr (value (toplevel ge) ann_ty)
rhs <- checkSigma gr scope rhs v_ann_ty let v_ann_ty = ov_ann_ty (scopeStack scope)
rhs <- checkSigma ge scope rhs v_ann_ty
return (rhs, v_ann_ty) return (rhs, v_ann_ty)
(body, body_ty) <- tcRho gr ((var,var_ty):scope) body mb_ty (body, body_ty) <- tcRho ge ((var,var_ty):scope) body mb_ty
return (Let (var, (Just (value2term gr (scopeVars scope) var_ty), rhs)) body, body_ty) let GE _ _ _ loc = ge
tcRho gr scope (Typed body ann_ty) mb_ty = do -- ANNOT return (Let (var, (Just (value2term loc (scopeVars scope) var_ty), rhs)) body, body_ty)
(ann_ty, _) <- tcRho gr scope ann_ty (Just (eval gr [] typeType)) tcRho ge scope (Typed body ann_ty) mb_ty = do -- ANNOT
let v_ann_ty = eval gr (scopeEnv scope) ann_ty (ann_ty, _) <- tcRho ge scope ann_ty (Just vtypeType)
body <- checkSigma gr scope body v_ann_ty ov_ann_ty <- runErr (value (toplevel ge) ann_ty)
instSigma gr scope (Typed body ann_ty) v_ann_ty mb_ty let v_ann_ty = ov_ann_ty (scopeStack scope)
tcRho gr scope (FV ts) mb_ty = do body <- checkSigma ge scope body v_ann_ty
instSigma ge scope (Typed body ann_ty) v_ann_ty mb_ty
tcRho ge scope (FV ts) mb_ty = do
case ts of case ts of
[] -> do i <- newMeta (eval gr [] typeType) [] -> do i <- newMeta vtypeType
instSigma gr scope (FV []) (VMeta i (scopeEnv scope) []) mb_ty instSigma ge scope (FV []) (VMeta i (scopeEnv scope) []) mb_ty
(t:ts) -> do (t,ty) <- tcRho gr scope t mb_ty (t:ts) -> do (t,ty) <- tcRho ge scope t mb_ty
let go [] ty = return ([],ty) let go [] ty = return ([],ty)
go (t:ts) ty = do (t, ty) <- tcRho gr scope t (Just ty) go (t:ts) ty = do (t, ty) <- tcRho ge scope t (Just ty)
(ts,ty) <- go ts ty (ts,ty) <- go ts ty
return (t:ts,ty) return (t:ts,ty)
(ts,ty) <- go ts ty (ts,ty) <- go ts ty
return (FV (t:ts), ty) return (FV (t:ts), ty)
tcRho gr scope t@(Sort s) mb_ty = do tcRho ge scope t@(Sort s) mb_ty = do
instSigma gr scope t (eval gr [] typeType) mb_ty instSigma ge scope t vtypeType mb_ty
tcRho gr scope t@(RecType rs) mb_ty = do tcRho ge scope t@(RecType rs) mb_ty = do
mapM_ (\(l,ty) -> tcRho gr scope ty (Just (eval gr [] typeType))) rs mapM_ (\(l,ty) -> tcRho ge scope ty (Just vtypeType)) rs
instSigma gr scope t (eval gr [] typeType) mb_ty instSigma ge scope t vtypeType mb_ty
tcRho gr scope t@(Table p res) mb_ty = do tcRho ge scope t@(Table p res) mb_ty = do
(p, p_ty) <- tcRho gr scope p (Just (eval gr [] typePType)) (p, p_ty) <- tcRho ge scope p (Just vtypePType)
(res,res_ty) <- tcRho gr scope res Nothing (res,res_ty) <- tcRho ge scope res Nothing
subsCheckRho gr scope t res_ty (eval gr [] typeType) let GE _ _ _ loc = ge
instSigma gr scope (Table p res) res_ty mb_ty subsCheckRho loc scope t res_ty vtypeType
tcRho gr scope (Prod bt x ty1 ty2) mb_ty = do instSigma ge scope (Table p res) res_ty mb_ty
(ty1,ty1_ty) <- tcRho gr scope ty1 (Just (eval gr [] typeType)) tcRho ge scope (Prod bt x ty1 ty2) mb_ty = do
(ty2,ty2_ty) <- tcRho gr ((x,eval gr (scopeEnv scope) ty1):scope) ty2 (Just (eval gr [] typeType)) (ty1,ty1_ty) <- tcRho ge scope ty1 (Just vtypeType)
instSigma gr scope (Prod bt x ty1 ty2) (eval gr [] typeType) mb_ty ov_ty1 <- runErr (value (toplevel ge) ty1)
tcRho gr scope (S t p) mb_ty = do let vty1 = ov_ty1 (scopeStack scope)
p_ty <- fmap Meta $ newMeta (eval gr [] typePType) (ty2,ty2_ty) <- tcRho ge ((x,vty1):scope) ty2 (Just vtypeType)
res_ty <- fmap Meta $ newMeta (eval gr [] typeType) instSigma ge scope (Prod bt x ty1 ty2) vtypeType mb_ty
let t_ty = eval gr (scopeEnv scope) (Table p_ty res_ty) tcRho ge scope (S t p) mb_ty = do
(t,t_ty) <- tcRho gr scope t (Just t_ty) p_ty <- fmap (\i -> VMeta i (scopeEnv scope) []) $ newMeta vtypePType
p <- checkSigma gr scope p (eval gr (scopeEnv scope) p_ty) res_ty <- fmap (\i -> VMeta i (scopeEnv scope) []) $ newMeta vtypeType
instSigma gr scope (S t p) (eval gr (scopeEnv scope) res_ty) mb_ty let t_ty = VTblType p_ty res_ty
tcRho gr scope (T tt ps) mb_ty = do (t,t_ty) <- tcRho ge scope t (Just t_ty)
p <- checkSigma ge scope p p_ty
instSigma ge scope (S t p) res_ty mb_ty
tcRho ge scope (T tt ps) mb_ty = do
p_ty <- case tt of p_ty <- case tt of
TRaw -> fmap Meta $ newMeta (eval gr [] typePType) TRaw -> fmap (\i -> VMeta i (scopeEnv scope) []) $ newMeta vtypePType
TTyped ty -> do (ty, _) <- tcRho gr scope ty (Just (eval gr [] typeType)) TTyped ty -> do (ty, _) <- tcRho ge scope ty (Just vtypeType)
return ty ov_arg <- runErr (value (toplevel ge) ty)
res_ty <- fmap Meta $ newMeta (eval gr [] typeType) return (ov_arg (scopeStack scope))
ps <- mapM (tcCase gr scope (eval gr (scopeEnv scope) p_ty) (eval gr (scopeEnv scope) res_ty)) ps res_ty <- fmap (\i -> VMeta i (scopeEnv scope) []) $ newMeta vtypeType
instSigma gr scope (T (TTyped p_ty) ps) (eval gr (scopeEnv scope) (Table p_ty res_ty)) mb_ty ps <- mapM (tcCase ge scope p_ty res_ty) ps
tcRho gr scope t@(R rs) mb_ty = do let GE _ _ _ loc = ge
instSigma ge scope (T (TTyped (value2term loc [] p_ty)) ps) (VTblType p_ty res_ty) mb_ty
tcRho ge scope t@(R rs) mb_ty = do
let GE _ _ _ loc = ge
lttys <- case mb_ty of lttys <- case mb_ty of
Nothing -> inferRecFields gr scope rs Nothing -> inferRecFields ge scope rs
Just ty -> case ty of Just ty -> case ty of
VRecType ltys -> checkRecFields gr scope rs ltys VRecType ltys -> checkRecFields ge scope rs ltys
VMeta _ _ _ -> inferRecFields gr scope rs VMeta _ _ _ -> inferRecFields ge scope rs
_ -> tcError ("Record type is inferred but:" $$ _ -> tcError ("Record type is inferred but:" $$
nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) ty)) $$ nest 2 (ppTerm Unqualified 0 (value2term loc (scopeVars scope) ty)) $$
"is expected in the expresion:" $$ "is expected in the expresion:" $$
nest 2 (ppTerm Unqualified 0 t)) nest 2 (ppTerm Unqualified 0 t))
return (R [(l, (Just (value2term gr (scopeVars scope) ty), t)) | (l,t,ty) <- lttys], return (R [(l, (Just (value2term loc (scopeVars scope) ty), t)) | (l,t,ty) <- lttys],
VRecType [(l, ty) | (l,t,ty) <- lttys] VRecType [(l, ty) | (l,t,ty) <- lttys]
) )
tcRho gr scope (P t l) mb_ty = do tcRho ge scope (P t l) mb_ty = do
x_ty <- case mb_ty of x_ty <- case mb_ty of
Just ty -> return ty Just ty -> return ty
Nothing -> do i <- newMeta (eval gr [] typeType) Nothing -> do i <- newMeta vtypeType
return (VMeta i (scopeEnv scope) []) return (VMeta i (scopeEnv scope) [])
(t,t_ty) <- tcRho gr scope t (Just (VRecType [(l,x_ty)])) (t,t_ty) <- tcRho ge scope t (Just (VRecType [(l,x_ty)]))
return (P t l,x_ty) return (P t l,x_ty)
tcRho gr scope (C t1 t2) mb_ty = do tcRho ge scope (C t1 t2) mb_ty = do
(t1,t1_ty) <- tcRho gr scope t1 (Just (eval gr [] typeStr)) (t1,t1_ty) <- tcRho ge scope t1 (Just vtypeStr)
(t2,t2_ty) <- tcRho gr scope t2 (Just (eval gr [] typeStr)) (t2,t2_ty) <- tcRho ge scope t2 (Just vtypeStr)
instSigma gr scope (C t1 t2) (eval gr [] typeStr) mb_ty instSigma ge scope (C t1 t2) vtypeStr mb_ty
tcRho gr scope (Glue t1 t2) mb_ty = do tcRho ge scope (Glue t1 t2) mb_ty = do
(t1,t1_ty) <- tcRho gr scope t1 (Just (eval gr [] typeStr)) (t1,t1_ty) <- tcRho ge scope t1 (Just vtypeStr)
(t2,t2_ty) <- tcRho gr scope t2 (Just (eval gr [] typeStr)) (t2,t2_ty) <- tcRho ge scope t2 (Just vtypeStr)
instSigma gr scope (Glue t1 t2) (eval gr [] typeStr) mb_ty instSigma ge scope (Glue t1 t2) vtypeStr mb_ty
tcRho gr scope t@(ExtR t1 t2) mb_ty = do tcRho ge scope t@(ExtR t1 t2) mb_ty = do
(t1,t1_ty) <- tcRho gr scope t1 Nothing (t1,t1_ty) <- tcRho ge scope t1 Nothing
(t2,t2_ty) <- tcRho gr scope t2 Nothing (t2,t2_ty) <- tcRho ge scope t2 Nothing
case (t1_ty,t2_ty) of case (t1_ty,t2_ty) of
(VSort s1,VSort s2) (VSort s1,VSort s2)
| s1 == cType && s2 == cType -> instSigma gr scope (ExtR t1 t2) (VSort cType) mb_ty | s1 == cType && s2 == cType -> instSigma ge scope (ExtR t1 t2) (VSort cType) mb_ty
(VRecType rs1, VRecType rs2) (VRecType rs1, VRecType rs2)
| otherwise -> do tcWarn (pp "bbbb") | otherwise -> do tcWarn (pp "bbbb")
instSigma gr scope (ExtR t1 t2) (VRecType (rs1 ++ rs2)) mb_ty instSigma ge scope (ExtR t1 t2) (VRecType (rs1 ++ rs2)) mb_ty
_ -> tcError ("Cannot type check" <+> ppTerm Unqualified 0 t) _ -> tcError ("Cannot type check" <+> ppTerm Unqualified 0 t)
tcRho gr scope (ELin cat t) mb_ty = do -- this could be done earlier, i.e. in the parser tcRho ge scope (ELin cat t) mb_ty = do -- this could be done earlier, i.e. in the parser
tcRho gr scope (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty tcRho ge scope (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty
tcRho gr scope (ELincat cat t) mb_ty = do -- this could be done earlier, i.e. in the parser tcRho ge scope (ELincat cat t) mb_ty = do -- this could be done earlier, i.e. in the parser
tcRho gr scope (ExtR t (RecType [(lockLabel cat,RecType [])])) mb_ty tcRho ge scope (ExtR t (RecType [(lockLabel cat,RecType [])])) mb_ty
tcRho gr scope (Alts t ss) mb_ty = do tcRho ge scope (Alts t ss) mb_ty = do
(t,_) <- tcRho gr scope t (Just (eval gr [] typeStr)) (t,_) <- tcRho ge scope t (Just vtypeStr)
ss <- flip mapM ss $ \(t1,t2) -> do ss <- flip mapM ss $ \(t1,t2) -> do
(t1,_) <- tcRho gr scope t1 (Just (eval gr [] typeStr)) (t1,_) <- tcRho ge scope t1 (Just vtypeStr)
(t2,_) <- tcRho gr scope t2 (Just (eval gr [] typeStrs)) (t2,_) <- tcRho ge scope t2 (Just vtypeStrs)
return (t1,t2) return (t1,t2)
instSigma gr scope (Alts t ss) (eval gr [] typeStr) mb_ty instSigma ge scope (Alts t ss) vtypeStr mb_ty
tcRho gr scope (Strs ss) mb_ty = do tcRho ge scope (Strs ss) mb_ty = do
ss <- flip mapM ss $ \t -> do ss <- flip mapM ss $ \t -> do
(t,_) <- tcRho gr scope t (Just (eval gr [] typeStr)) (t,_) <- tcRho ge scope t (Just vtypeStr)
return t return t
instSigma gr scope (Strs ss) (eval gr [] typeStrs) mb_ty instSigma ge scope (Strs ss) vtypeStrs mb_ty
tcRho gr scope t _ = error ("tcRho "++show t) tcRho gr scope t _ = error ("tcRho "++show t)
tcCase gr scope p_ty res_ty (p,t) = do tcCase ge scope p_ty res_ty (p,t) = do
scope <- tcPatt gr scope p p_ty scope <- tcPatt ge scope p p_ty
(t,res_ty) <- tcRho gr scope t (Just res_ty) (t,res_ty) <- tcRho ge scope t (Just res_ty)
return (p,t) return (p,t)
tcPatt gr scope PW ty0 = tcPatt ge scope PW ty0 =
return scope return scope
tcPatt gr scope (PV x) ty0 = tcPatt ge scope (PV x) ty0 =
return ((x,ty0):scope) return ((x,ty0):scope)
tcPatt gr scope (PP c ps) ty0 = tcPatt ge scope (PP c ps) ty0 =
case lookupResType gr c of let GE gr _ _ loc = ge
Ok ty -> do let go scope ty [] = return (scope,ty) in case lookupResType gr c of
go scope ty (p:ps) = do (arg_ty,res_ty) <- unifyFun gr scope (VGen (length scope) []) ty Ok ty -> do let go scope ty [] = return (scope,ty)
scope <- tcPatt gr scope p arg_ty go scope ty (p:ps) = do (arg_ty,res_ty) <- unifyFun loc scope (VGen (length scope) []) ty
go scope res_ty ps scope <- tcPatt ge scope p arg_ty
(scope,ty) <- go scope (eval gr [] ty) ps go scope res_ty ps
unify gr scope ty0 ty vty <- runErr (eval ge ty)
return scope (scope,ty) <- go scope vty ps
Bad err -> tcError (pp err) unify loc scope ty0 ty
tcPatt gr scope (PString s) ty0 = do return scope
unify gr scope ty0 (eval gr [] typeStr) Bad err -> tcError (pp err)
tcPatt ge scope (PString s) ty0 = do
let GE _ _ _ loc = ge
unify loc scope ty0 vtypeStr
return scope return scope
tcPatt gr scope PChar ty0 = do tcPatt ge scope PChar ty0 = do
unify gr scope ty0 (eval gr [] typeStr) let GE _ _ _ loc = ge
unify loc scope ty0 vtypeStr
return scope return scope
tcPatt gr scope (PSeq p1 p2) ty0 = do tcPatt ge scope (PSeq p1 p2) ty0 = do
unify gr scope ty0 (eval gr [] typeStr) let GE _ _ _ loc = ge
scope <- tcPatt gr scope p1 (eval gr [] typeStr) unify loc scope ty0 vtypeStr
scope <- tcPatt gr scope p2 (eval gr [] typeStr) scope <- tcPatt ge scope p1 vtypeStr
scope <- tcPatt ge scope p2 vtypeStr
return scope return scope
tcPatt gr scope (PAs x p) ty0 = do tcPatt ge scope (PAs x p) ty0 = do
tcPatt gr ((x,ty0):scope) p ty0 tcPatt ge ((x,ty0):scope) p ty0
tcPatt gr scope (PR rs) ty0 = do tcPatt ge scope (PR rs) ty0 = do
let go scope [] = return (scope,[]) let go scope [] = return (scope,[])
go scope ((l,p):rs) = do i <- newMeta (eval gr [] typePType) go scope ((l,p):rs) = do i <- newMeta vtypePType
let ty = VMeta i (scopeEnv scope) [] let ty = VMeta i (scopeEnv scope) []
scope <- tcPatt gr scope p ty scope <- tcPatt ge scope p ty
(scope,rs) <- go scope rs (scope,rs) <- go scope rs
return (scope,(l,ty) : rs) return (scope,(l,ty) : rs)
(scope',rs) <- go scope rs (scope',rs) <- go scope rs
unify gr scope ty0 (VRecType rs) let GE _ _ _ loc = ge
unify loc scope ty0 (VRecType rs)
return scope' return scope'
tcPatt gr scope (PAlt p1 p2) ty0 = do tcPatt gr scope (PAlt p1 p2) ty0 = do
tcPatt gr scope p1 ty0 tcPatt gr scope p1 ty0
tcPatt gr scope p2 ty0 tcPatt gr scope p2 ty0
return scope return scope
tcPatt gr scope p ty = unimplemented ("tcPatt "++show p) tcPatt ge scope p ty = unimplemented ("tcPatt "++show p)
inferRecFields ge scope rs =
mapM (\(l,r) -> tcRecField ge scope l r Nothing) rs
inferRecFields gr scope rs = checkRecFields ge scope [] ltys
mapM (\(l,r) -> tcRecField gr scope l r Nothing) rs
checkRecFields gr scope [] ltys
| null ltys = return [] | null ltys = return []
| otherwise = tcError ("Missing fields:" <+> hsep (map fst ltys)) | otherwise = tcError ("Missing fields:" <+> hsep (map fst ltys))
checkRecFields gr scope ((l,t):lts) ltys = checkRecFields ge scope ((l,t):lts) ltys =
case takeIt l ltys of case takeIt l ltys of
(Just ty,ltys) -> do ltty <- tcRecField gr scope l t (Just ty) (Just ty,ltys) -> do ltty <- tcRecField ge scope l t (Just ty)
lttys <- checkRecFields gr scope lts ltys lttys <- checkRecFields ge scope lts ltys
return (ltty : lttys) return (ltty : lttys)
(Nothing,ltys) -> do tcWarn ("Discarded field:" <+> l) (Nothing,ltys) -> do tcWarn ("Discarded field:" <+> l)
ltty <- tcRecField gr scope l t Nothing ltty <- tcRecField ge scope l t Nothing
lttys <- checkRecFields gr scope lts ltys lttys <- checkRecFields ge scope lts ltys
return lttys -- ignore the field return lttys -- ignore the field
where where
takeIt l1 [] = (Nothing, []) takeIt l1 [] = (Nothing, [])
@@ -271,63 +299,64 @@ checkRecFields gr scope ((l,t):lts) ltys =
| otherwise = let (mb_ty,ltys') = takeIt l1 ltys | otherwise = let (mb_ty,ltys') = takeIt l1 ltys
in (mb_ty,lty:ltys') in (mb_ty,lty:ltys')
tcRecField gr scope l (mb_ann_ty,t) mb_ty = do tcRecField ge scope l (mb_ann_ty,t) mb_ty = do
(t,ty) <- case mb_ann_ty of (t,ty) <- case mb_ann_ty of
Just ann_ty -> do (ann_ty, _) <- tcRho gr scope ann_ty (Just (eval gr [] typeType)) Just ann_ty -> do (ann_ty, _) <- tcRho ge scope ann_ty (Just vtypeType)
let v_ann_ty = eval gr (scopeEnv scope) ann_ty ov_ann_ty <- runErr (value (toplevel ge) ann_ty)
t <- checkSigma gr scope t v_ann_ty let v_ann_ty = ov_ann_ty (scopeStack scope)
instSigma gr scope t v_ann_ty mb_ty t <- checkSigma ge scope t v_ann_ty
Nothing -> tcRho gr scope t mb_ty instSigma ge scope t v_ann_ty mb_ty
Nothing -> tcRho ge scope t mb_ty
return (l,t,ty) return (l,t,ty)
-- | Invariant: if the third argument is (Just rho), -- | Invariant: if the third argument is (Just rho),
-- then rho is in weak-prenex form -- then rho is in weak-prenex form
instSigma :: SourceGrammar -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho) instSigma :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho)
instSigma gr scope t ty1 Nothing = instantiate gr t ty1 -- INST1 instSigma ge scope t ty1 Nothing = instantiate t ty1 -- INST1
instSigma gr scope t ty1 (Just ty2) = do -- INST2 instSigma ge scope t ty1 (Just ty2) = do -- INST2
t <- subsCheckRho gr scope t ty1 ty2 let GE _ _ _ loc = ge
t <- subsCheckRho loc scope t ty1 ty2
return (t,ty2) return (t,ty2)
-- | (subsCheck scope args off exp) checks that -- | (subsCheck scope args off exp) checks that
-- 'off' is at least as polymorphic as 'args -> exp' -- 'off' is at least as polymorphic as 'args -> exp'
subsCheck :: SourceGrammar -> Scope -> Term -> Sigma -> Sigma -> TcM Term subsCheck :: GLocation -> Scope -> Term -> Sigma -> Sigma -> TcM Term
subsCheck gr scope t sigma1 sigma2 = do -- DEEP-SKOL subsCheck loc scope t sigma1 sigma2 = do -- DEEP-SKOL
(abs, scope, t, rho2) <- skolemise id gr scope t sigma2 (abs, scope, t, rho2) <- skolemise id scope t sigma2
let skol_tvs = [] let skol_tvs = []
t <- subsCheckRho gr scope t sigma1 rho2 t <- subsCheckRho loc scope t sigma1 rho2
esc_tvs <- getFreeVars gr [(scope,sigma1),(scope,sigma2)] esc_tvs <- getFreeVars loc [(scope,sigma1),(scope,sigma2)]
let bad_tvs = filter (`elem` esc_tvs) skol_tvs let bad_tvs = filter (`elem` esc_tvs) skol_tvs
if null bad_tvs if null bad_tvs
then return (abs t) then return (abs t)
else tcError (vcat [pp "Subsumption check failed:", else tcError (vcat [pp "Subsumption check failed:",
nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) sigma1)), nest 2 (ppTerm Unqualified 0 (value2term loc (scopeVars scope) sigma1)),
pp "is not as polymorphic as", pp "is not as polymorphic as",
nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) sigma2))]) nest 2 (ppTerm Unqualified 0 (value2term loc (scopeVars scope) sigma2))])
-- | Invariant: the second argument is in weak-prenex form -- | Invariant: the second argument is in weak-prenex form
subsCheckRho :: SourceGrammar -> Scope -> Term -> Sigma -> Rho -> TcM Term subsCheckRho :: GLocation -> Scope -> Term -> Sigma -> Rho -> TcM Term
subsCheckRho gr scope t sigma1@(VClosure env (Prod Implicit _ _ _)) rho2 = do -- Rule SPEC subsCheckRho loc scope t sigma1@(VProd Implicit _ _ _) rho2 = do -- Rule SPEC
(t,rho1) <- instantiate gr t sigma1 (t,rho1) <- instantiate t sigma1
subsCheckRho gr scope t rho1 rho2 subsCheckRho loc scope t rho1 rho2
subsCheckRho gr scope t rho1 (VClosure env (Prod Explicit _ a2 r2)) = do -- Rule FUN subsCheckRho loc scope t rho1 (VProd Explicit a2 _ (Bind r2)) = do -- Rule FUN
(a1,r1) <- unifyFun gr scope (VGen (length scope) []) rho1 (a1,r1) <- unifyFun loc scope (VGen (length scope) []) rho1
subsCheckFun gr scope t a1 r1 (eval gr env a2) (eval gr env r2) subsCheckFun loc scope t a1 r1 a2 (r2 (VGen (length scope) []))
subsCheckRho gr scope t (VClosure env (Prod Explicit _ a1 r1)) rho2 = do -- Rule FUN subsCheckRho loc scope t (VProd Explicit a1 _ (Bind r1)) rho2 = do -- Rule FUN
(a2,r2) <- unifyFun gr scope (VGen (length scope) []) rho2 (a2,r2) <- unifyFun loc scope (VGen (length scope) []) rho2
subsCheckFun gr scope t (eval gr env a1) (eval gr env r1) a2 r2 subsCheckFun loc scope t a1 (r1 (VGen (length scope) [])) a2 r2
subsCheckRho gr scope t (VSort s1) (VSort s2) subsCheckRho loc scope t (VSort s1) (VSort s2)
| s1 == cPType && s2 == cType = return t | s1 == cPType && s2 == cType = return t
subsCheckRho gr scope t tau1 tau2 = do -- Rule MONO subsCheckRho loc scope t tau1 tau2 = do -- Rule MONO
unify gr scope tau1 tau2 -- Revert to ordinary unification unify loc scope tau1 tau2 -- Revert to ordinary unification
return t return t
subsCheckFun :: SourceGrammar -> Scope -> Term -> Sigma -> Rho -> Sigma -> Rho -> TcM Term subsCheckFun :: GLocation -> Scope -> Term -> Sigma -> Rho -> Sigma -> Rho -> TcM Term
subsCheckFun gr scope t a1 r1 a2 r2 = do subsCheckFun loc scope t a1 r1 a2 r2 = do
let v = newVar scope let v = newVar scope
vt <- subsCheck gr scope (Vr v) a2 a1 vt <- subsCheck loc scope (Vr v) a2 a1
t <- subsCheckRho gr ((v,eval gr [] typeType):scope) (App t vt) r1 r2 ; t <- subsCheckRho loc ((v,vtypeType):scope) (App t vt) r1 r2 ;
return (Abs Explicit v t) return (Abs Explicit v t)
@@ -335,102 +364,97 @@ subsCheckFun gr scope t a1 r1 a2 r2 = do
-- Unification -- Unification
----------------------------------------------------------------------- -----------------------------------------------------------------------
unifyFun :: SourceGrammar -> Scope -> Value -> Rho -> TcM (Sigma, Rho) unifyFun :: GLocation -> Scope -> Value -> Rho -> TcM (Sigma, Rho)
unifyFun gr scope arg_v (VClosure env (Prod Explicit x arg res)) unifyFun loc scope arg_v (VProd Explicit arg x (Bind res)) =
| x /= identW = return (eval gr env arg,eval gr ((x,arg_v):env) res) return (arg,res arg_v)
| otherwise = return (eval gr env arg,eval gr env res) unifyFun loc scope arg_v tau = do
unifyFun gr scope arg_v tau = do arg_ty <- newMeta vtypeType
arg_ty <- newMeta (eval gr [] typeType) res_ty <- newMeta vtypeType
res_ty <- newMeta (eval gr [] typeType) unify loc scope tau (VProd Explicit (VMeta arg_ty [] []) identW (Bind (const (VMeta arg_ty [] []))))
unify gr scope tau (VClosure [] (Prod Explicit identW (Meta arg_ty) (Meta res_ty)))
return (VMeta arg_ty [] [], VMeta res_ty [] []) return (VMeta arg_ty [] [], VMeta res_ty [] [])
unify gr scope (VApp f1 vs1) (VApp f2 vs2) unify loc scope (VApp f1 vs1) (VApp f2 vs2)
| f1 == f2 = sequence_ (zipWith (unify gr scope) vs1 vs2) | f1 == f2 = sequence_ (zipWith (unify loc scope) vs1 vs2)
unify gr scope (VSort s1) (VSort s2) unify loc scope (VSort s1) (VSort s2)
| s1 == s2 = return () | s1 == s2 = return ()
unify gr scope (VGen i vs1) (VGen j vs2) unify loc scope (VGen i vs1) (VGen j vs2)
| i == j = sequence_ (zipWith (unify gr scope) vs1 vs2) | i == j = sequence_ (zipWith (unify loc scope) vs1 vs2)
unify gr scope (VMeta i env1 vs1) (VMeta j env2 vs2) unify loc scope (VMeta i env1 vs1) (VMeta j env2 vs2)
| i == j = sequence_ (zipWith (unify gr scope) vs1 vs2) | i == j = sequence_ (zipWith (unify loc scope) vs1 vs2)
| otherwise = do mv <- getMeta j | otherwise = do mv <- getMeta j
case mv of case mv of
Bound t2 -> unify gr scope (VMeta i env1 vs1) (apply gr env2 t2 vs2) --Bound t2 -> unify gr scope (VMeta i env1 vs1) (apply gr env2 t2 vs2)
Unbound _ -> setMeta i (Bound (Meta j)) Unbound _ -> setMeta i (Bound (Meta j))
unify gr scope (VMeta i env vs) v = unifyVar gr scope i env vs v unify loc scope (VMeta i env vs) v = unifyVar loc scope i env vs v
unify gr scope v (VMeta i env vs) = unifyVar gr scope i env vs v unify loc scope v (VMeta i env vs) = unifyVar loc scope i env vs v
unify gr scope (VTblType p1 res1) (VTblType p2 res2) = do unify loc scope (VTblType p1 res1) (VTblType p2 res2) = do
unify gr scope p1 p2 unify loc scope p1 p2
unify gr scope res1 res2 unify loc scope res1 res2
unify gr scope (VRecType rs1) (VRecType rs2) = do unify loc scope (VRecType rs1) (VRecType rs2) = do
sequence_ [unify gr scope ty1 ty2 | (l,ty1) <- rs1, Just ty2 <- [lookup l rs2]] sequence_ [unify loc scope ty1 ty2 | (l,ty1) <- rs1, Just ty2 <- [lookup l rs2]]
unify gr scope v1 v2 = do unify loc scope v1 v2 = do
t1 <- zonkTerm (value2term gr (scopeVars scope) v1) t1 <- zonkTerm (value2term loc (scopeVars scope) v1)
t2 <- zonkTerm (value2term gr (scopeVars scope) v2) t2 <- zonkTerm (value2term loc (scopeVars scope) v2)
tcError ("Cannot unify types:" <+> (ppTerm Unqualified 0 t1 $$ tcError ("Cannot unify types:" <+> (ppTerm Unqualified 0 t1 $$
ppTerm Unqualified 0 t2)) ppTerm Unqualified 0 t2))
-- | Invariant: tv1 is a flexible type variable -- | Invariant: tv1 is a flexible type variable
unifyVar :: SourceGrammar -> Scope -> MetaId -> Env -> [Value] -> Tau -> TcM () unifyVar :: GLocation -> Scope -> MetaId -> Env -> [Value] -> Tau -> TcM ()
unifyVar gr scope i env vs ty2 = do -- Check whether i is bound unifyVar loc scope i env vs ty2 = do -- Check whether i is bound
mv <- getMeta i mv <- getMeta i
case mv of case mv of
Bound ty1 -> unify gr scope (apply gr env ty1 vs) ty2 -- Bound ty1 -> unify gr scope (apply gr env ty1 vs) ty2
Unbound _ -> do let ty2' = value2term gr (scopeVars scope) ty2 Unbound _ -> do let ty2' = value2term loc (scopeVars scope) ty2
ms2 <- getMetaVars gr [(scope,ty2)] ms2 <- getMetaVars loc [(scope,ty2)]
if i `elem` ms2 if i `elem` ms2
then tcError ("Occurs check for" <+> ppMeta i <+> "in:" $$ then tcError ("Occurs check for" <+> ppMeta i <+> "in:" $$
nest 2 (ppTerm Unqualified 0 ty2')) nest 2 (ppTerm Unqualified 0 ty2'))
else setMeta i (Bound ty2') else setMeta i (Bound ty2')
----------------------------------------------------------------------- -----------------------------------------------------------------------
-- Instantiation and quantification -- Instantiation and quantification
----------------------------------------------------------------------- -----------------------------------------------------------------------
-- | Instantiate the topmost for-alls of the argument type -- | Instantiate the topmost for-alls of the argument type
-- with metavariables -- with metavariables
instantiate :: SourceGrammar -> Term -> Sigma -> TcM (Term,Rho) instantiate :: Term -> Sigma -> TcM (Term,Rho)
instantiate gr t (VClosure env (Prod Implicit x ty1 ty2)) = do instantiate t (VProd Implicit ty1 x (Bind ty2)) = do
i <- newMeta (eval gr env ty1) i <- newMeta ty1
instantiate gr (App t (ImplArg (Meta i))) (eval gr ((x,VMeta i [] []):env) ty2) instantiate (App t (ImplArg (Meta i))) (ty2 (VMeta i [] []))
instantiate gr t ty = do instantiate t ty = do
return (t,ty) return (t,ty)
skolemise f gr scope t (VClosure env (Prod Implicit x arg_ty res_ty)) -- Rule PRPOLY skolemise f scope t (VProd Implicit arg_ty x (Bind res_ty)) -- Rule PRPOLY
| x /= identW = | x /= identW =
let (y,body) = case t of let (y,body) = case t of
Abs Implicit y body -> (y, body) Abs Implicit y body -> (y, body)
body -> (newVar scope, body) body -> (newVar scope, body)
in skolemise (f . Abs Implicit y) in skolemise (f . Abs Implicit y)
gr ((y,arg_ty):scope) body
((y,eval gr env arg_ty):scope) body (res_ty (VGen (length scope) []))
(eval gr ((x,VGen (length scope) []):env) res_ty) skolemise f scope t (VProd Explicit arg_ty x (Bind res_ty)) -- Rule PRFUN
skolemise f gr scope t (VClosure env (Prod Explicit x arg_ty res_ty)) -- Rule PRFUN | x /= identW =
| x /= identW =
let (y,body) = case t of let (y,body) = case t of
Abs Explicit y body -> (y, body) Abs Explicit y body -> (y, body)
body -> let y = newVar scope body -> let y = newVar scope
in (y, App body (Vr y)) in (y, App body (Vr y))
in skolemise (f . Abs Explicit y) in skolemise (f . Abs Explicit y)
gr ((y,arg_ty):scope) body
((y,eval gr env arg_ty):scope) body (res_ty (VGen (length scope) []))
(eval gr ((x,VGen (length scope) []):env) res_ty) skolemise f scope t ty -- Rule PRMONO
skolemise f gr scope t ty -- Rule PRMONO
= return (f, scope, t, ty) = return (f, scope, t, ty)
-- | Quantify over the specified type variables (all flexible) -- | Quantify over the specified type variables (all flexible)
quantify :: SourceGrammar -> Scope -> Term -> [MetaId] -> Rho -> TcM (Term,Sigma) quantify :: GlobalEnv -> Scope -> Term -> [MetaId] -> Rho -> TcM (Term,Sigma)
quantify gr scope t tvs ty0 = do quantify ge scope t tvs ty0 = do
mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way
ty <- zonkTerm ty -- of doing the substitution ty <- zonkTerm ty -- of doing the substitution
return (foldr (Abs Implicit) t new_bndrs vty <- runErr (eval ge (foldr (\v ty -> Prod Implicit v typeType ty) ty new_bndrs))
,eval gr [] (foldr (\v ty -> Prod Implicit v typeType ty) ty new_bndrs) return (foldr (Abs Implicit) t new_bndrs,vty)
)
where where
ty = value2term gr (scopeVars scope) ty0 GE _ _ _ loc = ge
ty = value2term loc (scopeVars scope) ty0
used_bndrs = nub (bndrs ty) -- Avoid quantified type variables in use used_bndrs = nub (bndrs ty) -- Avoid quantified type variables in use
new_bndrs = take (length tvs) (allBinders \\ used_bndrs) new_bndrs = take (length tvs) (allBinders \\ used_bndrs)
bind (i, name) = setMeta i (Bound (Vr name)) bind (i, name) = setMeta i (Bound (Vr name))
@@ -491,6 +515,10 @@ runTcM f = case unTcM f IntMap.empty [] of
TcOk x _ msgs -> do checkWarnings msgs; return x TcOk x _ msgs -> do checkWarnings msgs; return x
TcFail (msg:msgs) -> do checkWarnings msgs; checkError msg TcFail (msg:msgs) -> do checkWarnings msgs; checkError msg
runErr :: Err a -> TcM a
runErr (Bad msg) = TcM (\ms msgs -> TcFail (pp msg:msgs))
runErr (Ok x) = TcM (\ms msgs -> TcOk x ms msgs)
newMeta :: Sigma -> TcM MetaId newMeta :: Sigma -> TcM MetaId
newMeta ty = TcM (\ms msgs -> newMeta ty = TcM (\ms msgs ->
let i = IntMap.size ms let i = IntMap.size ms
@@ -514,14 +542,15 @@ newVar scope = head [x | i <- [1..],
isFree ((y,_):scope) x = x /= y && isFree scope x isFree ((y,_):scope) x = x /= y && isFree scope x
scopeEnv scope = zipWith (\(x,ty) i -> (x,VGen i [])) (reverse scope) [0..] scopeEnv scope = zipWith (\(x,ty) i -> (x,VGen i [])) (reverse scope) [0..]
scopeStack scope = zipWith (\(x,ty) i -> VGen i []) (reverse scope) [0..]
scopeVars scope = map fst scope scopeVars scope = map fst scope
scopeTypes scope = zipWith (\(_,ty) scope -> (scope,ty)) scope (tails scope) scopeTypes scope = zipWith (\(_,ty) scope -> (scope,ty)) scope (tails scope)
-- | This function takes account of zonking, and returns a set -- | This function takes account of zonking, and returns a set
-- (no duplicates) of unbound meta-type variables -- (no duplicates) of unbound meta-type variables
getMetaVars :: SourceGrammar -> [(Scope,Sigma)] -> TcM [MetaId] getMetaVars :: GLocation -> [(Scope,Sigma)] -> TcM [MetaId]
getMetaVars gr sc_tys = do getMetaVars loc sc_tys = do
tys <- mapM (\(scope,ty) -> zonkTerm (value2term gr (scopeVars scope) ty)) sc_tys tys <- mapM (\(scope,ty) -> zonkTerm (value2term loc (scopeVars scope) ty)) sc_tys
return (foldr go [] tys) return (foldr go [] tys)
where where
-- Get the MetaIds from a term; no duplicates in result -- Get the MetaIds from a term; no duplicates in result
@@ -539,9 +568,9 @@ getMetaVars gr sc_tys = do
-- | This function takes account of zonking, and returns a set -- | This function takes account of zonking, and returns a set
-- (no duplicates) of free type variables -- (no duplicates) of free type variables
getFreeVars :: SourceGrammar -> [(Scope,Sigma)] -> TcM [Ident] getFreeVars :: GLocation -> [(Scope,Sigma)] -> TcM [Ident]
getFreeVars gr sc_tys = do getFreeVars loc sc_tys = do
tys <- mapM (\(scope,ty) -> zonkTerm (value2term gr (scopeVars scope) ty)) sc_tys tys <- mapM (\(scope,ty) -> zonkTerm (value2term loc (scopeVars scope) ty)) sc_tys
return (foldr (go []) [] tys) return (foldr (go []) [] tys)
where where
go bound (Vr tv) acc go bound (Vr tv) acc
@@ -566,3 +595,4 @@ zonkTerm (Meta i) = do
return t return t
zonkTerm t = composOp zonkTerm t zonkTerm t = composOp zonkTerm t