aboutsummaryrefslogtreecommitdiff
path: root/typecheck
diff options
context:
space:
mode:
authorTom Smeding <tom.smeding@gmail.com>2020-07-24 22:25:50 +0200
committerTom Smeding <tom.smeding@gmail.com>2020-07-24 22:25:50 +0200
commitf7c3b21c0a10b11730bdce64e7e895bd1eb65fd0 (patch)
tree56a4456840b053d7c8e44d67247de0e4637e2c75 /typecheck
parentd951a11b1141b9f4c1ee50c7f89b68c552883c16 (diff)
Lift TypeScheme to AST.Typed
Diffstat (limited to 'typecheck')
-rw-r--r--typecheck/CC/Typecheck.hs28
1 files changed, 13 insertions, 15 deletions
diff --git a/typecheck/CC/Typecheck.hs b/typecheck/CC/Typecheck.hs
index 195fc19..0c926f3 100644
--- a/typecheck/CC/Typecheck.hs
+++ b/typecheck/CC/Typecheck.hs
@@ -42,9 +42,7 @@ runTM :: TM a -> Either TCError a
runTM m = evalState (runExceptT m) 1
-data Scheme = Scheme [Int] TypeT
-
-newtype Env = Env (Map Name Scheme)
+newtype Env = Env (Map Name TypeSchemeT)
newtype Subst = Subst (Map Int TypeT)
@@ -58,8 +56,8 @@ instance FreeTypeVars TypeT where
freeTypeVars (TTupT ts) = Set.unions (map freeTypeVars ts)
freeTypeVars (TyVar var) = Set.singleton var
-instance FreeTypeVars Scheme where
- freeTypeVars (Scheme bnds ty) = foldr Set.delete (freeTypeVars ty) bnds
+instance FreeTypeVars TypeSchemeT where
+ freeTypeVars (TypeSchemeT bnds ty) = foldr Set.delete (freeTypeVars ty) bnds
instance FreeTypeVars Env where
freeTypeVars (Env mp) = foldMap freeTypeVars (Map.elems mp)
@@ -76,9 +74,9 @@ instance Substitute TypeT where
TTupT ts -> TTupT (map (theta >>!) ts)
TyVar i -> fromMaybe ty (Map.lookup i mp)
-instance Substitute Scheme where
- Subst mp >>! Scheme bnds ty =
- Scheme bnds (Subst (foldr Map.delete mp bnds) >>! ty)
+instance Substitute TypeSchemeT where
+ Subst mp >>! TypeSchemeT bnds ty =
+ TypeSchemeT bnds (Subst (foldr Map.delete mp bnds) >>! ty)
instance Substitute Env where
theta >>! Env mp = Env (Map.map (theta >>!) mp)
@@ -103,21 +101,21 @@ instance Monoid Subst where
emptyEnv :: Env
emptyEnv = Env mempty
-envAdd :: Name -> Scheme -> Env -> Env
+envAdd :: Name -> TypeSchemeT -> Env -> Env
envAdd name sty (Env mp) = Env (Map.insert name sty mp)
-envFind :: Name -> Env -> Maybe Scheme
+envFind :: Name -> Env -> Maybe TypeSchemeT
envFind name (Env mp) = Map.lookup name mp
substVar :: Int -> TypeT -> Subst
substVar var ty = Subst (Map.singleton var ty)
-generalise :: Env -> TypeT -> Scheme
+generalise :: Env -> TypeT -> TypeSchemeT
generalise env ty =
- Scheme (Set.toList (freeTypeVars ty Set.\\ freeTypeVars env)) ty
+ TypeSchemeT (Set.toList (freeTypeVars ty Set.\\ freeTypeVars env)) ty
-instantiate :: Scheme -> TM TypeT
-instantiate (Scheme bnds ty) = do
+instantiate :: TypeSchemeT -> TM TypeT
+instantiate (TypeSchemeT bnds ty) = do
vars <- traverse (const genTyVar) bnds
let theta = Subst (Map.fromList (zip bnds vars))
return (theta >>! ty)
@@ -147,7 +145,7 @@ infer env expr = case expr of
Lam sr args@(_:_:_) body -> infer env (foldr (Lam sr . pure) body args)
Lam _ [(arg, _)] body -> do
argVar <- genTyVar
- let augEnv = envAdd arg (Scheme [] argVar) env
+ let augEnv = envAdd arg (TypeSchemeT [] argVar) env
(theta, body') <- infer augEnv body
let argType = theta >>! argVar
return (theta, LamT (TFunT argType (exprType body')) (Occ arg argType) body')