diff options
Diffstat (limited to 'typecheck/CC')
| -rw-r--r-- | typecheck/CC/Typecheck.hs | 14 |
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) |