aboutsummaryrefslogtreecommitdiff
path: root/typecheck
diff options
context:
space:
mode:
Diffstat (limited to 'typecheck')
-rw-r--r--typecheck/CC/Typecheck.hs14
1 files changed, 14 insertions, 0 deletions
diff --git a/typecheck/CC/Typecheck.hs b/typecheck/CC/Typecheck.hs
index 6c9a22b..455465a 100644
--- a/typecheck/CC/Typecheck.hs
+++ b/typecheck/CC/Typecheck.hs
@@ -55,6 +55,7 @@ class FreeTypeVars a where
instance FreeTypeVars TypeT where
freeTypeVars (TFunT t1 t2) = freeTypeVars t1 <> freeTypeVars t2
freeTypeVars TIntT = mempty
+ freeTypeVars (TTupT ts) = Set.unions (map freeTypeVars ts)
freeTypeVars (TyVar var) = Set.singleton var
instance FreeTypeVars Scheme where
@@ -72,6 +73,7 @@ instance Substitute TypeT where
theta@(Subst mp) >>! ty = case ty of
TFunT t1 t2 -> TFunT (theta >>! t1) (theta >>! t2)
TIntT -> TIntT
+ TTupT ts -> TTupT (map (theta >>!) ts)
TyVar i -> fromMaybe ty (Map.lookup i mp)
instance Substitute Scheme where
@@ -88,6 +90,7 @@ instance Substitute ExprT where
theta >>! CallT ty e1 e2 =
CallT (theta >>! ty) (theta >>! e1) (theta >>! e2)
_ >>! expr@(IntT _) = expr
+ theta >>! TupT es = TupT (map (theta >>!) es)
theta >>! VarT (Occ name ty) = VarT (Occ name (theta >>! ty))
@@ -127,6 +130,8 @@ unify sr t1 t2 = unify' (UnifyContext sr t1 t2) t1 t2
unify' :: UnifyContext -> TypeT -> TypeT -> TM Subst
unify' _ TIntT TIntT = return mempty
unify' ctx (TFunT t1 t2) (TFunT u1 u2) = (<>) <$> unify' ctx t1 u1 <*> unify' ctx t2 u2
+unify' ctx (TTupT ts) (TTupT us)
+ | length ts == length us = mconcat <$> zipWithM (unify' ctx) ts us
unify' _ (TyVar var) ty = return (substVar var ty)
unify' _ ty (TyVar var) = return (substVar var ty)
unify' (UnifyContext sr t1 t2) _ _ = throwError (TypeError sr t1 t2)
@@ -134,6 +139,7 @@ unify' (UnifyContext sr t1 t2) _ _ = throwError (TypeError sr t1 t2)
convertType :: Type -> TypeT
convertType (TFun t1 t2) = TFunT (convertType t1) (convertType t2)
convertType TInt = TIntT
+convertType (TTup ts) = TTupT (map convertType ts)
infer :: Env -> Expr -> TM (Subst, ExprT)
infer env expr = case expr of
@@ -155,6 +161,7 @@ infer env expr = case expr of
((theta3 <> theta2) >>! func') -- TODO: quadratic complexity
(theta3 >>! arg')) -- TODO: quadratic complexity
Int _ val -> return (mempty, IntT val)
+ Tup _ es -> fmap TupT <$> inferList env es
Var sr name
| Just sty <- envFind name env -> do
ty <- instantiate sty
@@ -166,6 +173,13 @@ infer env expr = case expr of
theta2 <- unify sr (exprType subex') (convertType ty)
return (theta2 <> theta1, theta2 >>! subex') -- TODO: quadratic complexity
+inferList :: Env -> [Expr] -> TM (Subst, [ExprT])
+inferList _ [] = return (mempty, [])
+inferList env (expr : exprs) = do
+ (theta, expr') <- infer env expr
+ (theta', res) <- inferList (theta >>! env) exprs
+ return (theta <> theta', expr' : res)
+
runPass :: Context -> Program -> Either TCError ProgramT
runPass _ prog = runTM (typeCheck prog)