Support tuples

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)