diff options
| -rw-r--r-- | ast/CC/Source.hs | 7 | ||||
| -rw-r--r-- | ast/CC/Typed.hs | 8 | ||||
| -rw-r--r-- | parser/CC/Parser.hs | 24 | ||||
| -rw-r--r-- | typecheck/CC/Typecheck.hs | 14 |
4 files changed, 51 insertions, 2 deletions
diff --git a/ast/CC/Source.hs b/ast/CC/Source.hs index 080b850..c10f910 100644 --- a/ast/CC/Source.hs +++ b/ast/CC/Source.hs @@ -1,5 +1,7 @@ module CC.Source(module CC.Source, module CC.Types) where +import Data.List + import CC.Pretty import CC.Types @@ -18,11 +20,13 @@ data Def = Function (Maybe Type) data Type = TFun Type Type | TInt + | TTup [Type] deriving (Show, Read) data Expr = Lam SourceRange [(Name, SourceRange)] Expr | Call SourceRange Expr Expr | Int SourceRange Int + | Tup SourceRange [Expr] | Var SourceRange Name | Annot SourceRange Expr Type deriving (Show, Read) @@ -31,10 +35,13 @@ instance Pretty Type where prettyPrec _ TInt = "Int" prettyPrec p (TFun a b) = precParens p 2 (prettyPrec 3 a ++ " -> " ++ prettyPrec 2 b) + prettyPrec _ (TTup ts) = + "(" ++ intercalate ", " (map pretty ts) ++ ")" instance HasRange Expr where range (Lam sr _ _) = sr range (Call sr _ _) = sr range (Int sr _) = sr + range (Tup sr _) = sr range (Var sr _) = sr range (Annot sr _ _) = sr diff --git a/ast/CC/Typed.hs b/ast/CC/Typed.hs index 535fd31..53caa29 100644 --- a/ast/CC/Typed.hs +++ b/ast/CC/Typed.hs @@ -3,6 +3,8 @@ module CC.Typed( module CC.Types ) where +import Data.List + import CC.Pretty import CC.Types @@ -15,12 +17,14 @@ data DefT = DefT Name ExprT data TypeT = TFunT TypeT TypeT | TIntT + | TTupT [TypeT] | TyVar Int deriving (Show, Read) data ExprT = LamT TypeT Occ ExprT | CallT TypeT ExprT ExprT | IntT Int + | TupT [ExprT] | VarT Occ deriving (Show, Read) @@ -31,12 +35,15 @@ exprType :: ExprT -> TypeT exprType (LamT typ _ _) = typ exprType (CallT typ _ _) = typ exprType (IntT _) = TIntT +exprType (TupT es) = TTupT (map exprType es) exprType (VarT (Occ _ typ)) = typ instance Pretty TypeT where prettyPrec _ TIntT = "Int" prettyPrec p (TFunT a b) = precParens p 2 (prettyPrec 3 a ++ " -> " ++ prettyPrec 2 b) + prettyPrec _ (TTupT ts) = + "(" ++ intercalate ", " (map pretty ts) ++ ")" prettyPrec _ (TyVar i) = 't' : show i instance Pretty ExprT where @@ -48,6 +55,7 @@ instance Pretty ExprT where precParens p 2 $ prettyPrec 3 e1 ++ " " ++ prettyPrec 3 e2 ++ " :: " ++ pretty ty prettyPrec _ (IntT i) = show i + prettyPrec _ (TupT es) = "(" ++ intercalate ", " (map pretty es) ++ ")" prettyPrec p (VarT (Occ n t)) = precParens p 2 $ show n ++ " :: " ++ pretty t diff --git a/parser/CC/Parser.hs b/parser/CC/Parser.hs index 856a7b9..a097f98 100644 --- a/parser/CC/Parser.hs +++ b/parser/CC/Parser.hs @@ -51,7 +51,16 @@ pType :: Parser Type pType = chainr1 pTypeAtom (symbol "->" >> return TFun) pTypeAtom :: Parser Type -pTypeAtom = (wordToken "Int" >> return TInt) <|> between (token "(") (token ")") pType +pTypeAtom = (wordToken "Int" >> return TInt) <|> pParenType + +pParenType :: Parser Type +pParenType = do + token "(" + tys <- pType `sepBy` token "," + token ")" + case tys of + [ty] -> return ty + _ -> return (TTup tys) pExpr :: Parser Expr pExpr = label (pCall <|> pLam) "expression" @@ -84,7 +93,18 @@ pExprAtom :: Parser Expr pExprAtom = choice [ uncurry (flip Int) <$> pInt , uncurry (flip Var) <$> pName - , between (token "(") (token ")") pExpr ] + , pParenExpr ] + +pParenExpr :: Parser Expr +pParenExpr = do + p1 <- getPosition + token "(" + exprs <- pExpr `sepBy` token "," + token ")" + p2 <- getPosition + case exprs of + [expr] -> return expr + _ -> return (Tup (SourceRange p1 p2) exprs) pInt :: Parser (Int, SourceRange) pInt = try (whitespace >> pInt0) 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) |