Implemented tuples. (#31)

Harper.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: f0fe4eaf472121631e9ae194f16abb76e42855db5ea795aec6a5baa4b98deda9
+-- hash: 0d246899876691ea91b6478226ee4a46e8ff6f6aa41392cc8506b74f3de68a52
 
 name:           Harper
 version:        0.1.0.0
@@ -29,6 +29,7 @@ library
       ErrM
       Harper.Abs
       Harper.Abs.Pos
+      Harper.Abs.Tuple
       Harper.Abs.Typed
       Harper.Error
       Harper.Expressions

src/Harper/Abs/Tuple.hs

@@ -0,0 +1,27 @@
+module Harper.Abs.Tuple where
+import           Harper.Abs
+import           Harper.Abs.Pos
+
+tTupToList :: TupleType a -> [TypeExpr a]
+tTupToList (TTupTail _ tExpr1 tExpr2) = [tExpr1, tExpr2]
+tTupToList (TTupList _ tExpr  tail  ) = tExpr : tTupToList tail
+
+tupToList :: TupleExpression a -> [Expression a]
+tupToList (TupExprTail _ e1 e2  ) = [e1, e2]
+tupToList (TupExprList _ e  tail) = e : tupToList tail
+
+tupFromList :: (Expression a -> a) -> [Expression a] -> TupleExpression a
+tupFromList _ []       = error "tupFromList empty"
+tupFromList _ [e]      = error "tupFromList singleton"
+tupFromList f [e1, e2] = TupExprTail (f e1) e1 e2
+tupFromList f (e : es) = TupExprList (f e) e $ tupFromList f es
+
+patTupToList :: TuplePattern a -> [Pattern a]
+patTupToList (PatTupTail _ pat1 pat2) = [pat1, pat2]
+patTupToList (PatTupList _ pat1 tail) = pat1 : patTupToList tail
+
+patTupFromList :: (Pattern a -> a) -> [Pattern a] -> TuplePattern a
+patTupFromList _ []           = error "patTupFromList empty"
+patTupFromList _ [pat]        = error "patTupFromList singleton"
+patTupFromList f [pat1, pat2] = PatTupTail (f pat1) pat1 pat2
+patTupFromList f (pat : pats) = PatTupList (f pat) pat $ patTupFromList f pats

src/Harper/Interpreter.hs

@@ -15,6 +15,7 @@ import           Data.List
 
 import           Harper.Abs
 import           Harper.Abs.Pos
+import           Harper.Abs.Tuple
 import           Harper.Interpreter.Alloc
 import           Harper.Printer
 import           Harper.Interpreter.Conditionals
@@ -91,6 +92,13 @@ eval e@(VCtorExpr _ ctor flds           ) = do
         (ptr, _) <- makeThunk e eval
         return (i, ptr)
 
+-- Tuple.
+
+eval (TupExpr _ tup) = do
+    let es = tupToList tup
+    os <- mapM eval es
+    return $ Tup os
+
 -- Object access.
 
 eval e@(ObjExpr _ i) = do
@@ -530,10 +538,6 @@ evalCmpOp e = do
                 ++ " "
                 ++ show ts
 
-evalThunk :: Object -> Interpreter Object
-evalThunk (Thunk x) = x
-evalThunk o         = return o
-
 -- Continuation passing style - kMatch is called when object matches the pattern, kElse otherwise.
 patMatch
     :: Pattern Meta
@@ -545,35 +549,51 @@ patMatch PatDisc{}  _ kMatch _     = kMatch
 patMatch p@PatLit{} e kMatch kElse = do
     o <- eval e
     patMatch' p o kMatch kElse
+patMatch p@PatTup{} e kMatch kElse = do
+    o <- eval e
+    patMatch' p o kMatch kElse
 patMatch (PatDecl _ decl) e kMatch _ = do
     env <- declLocal decl e eval
     localObjs (const env) kMatch
 patMatch p@PatCtor{} e kMatch kElse = do
     o <- eval e
     patMatch' p o kMatch kElse
+patMatch p _ _ _ =
+    error $ "Pattern matching this type of patterns is unsupported: " ++ show p
 
 patMatch'
     :: Pattern Meta -> Object -> Interpreter a -> Interpreter a -> Interpreter a
 patMatch' PatDisc{}      _ kMatch _     = kMatch
 patMatch' (PatLit _ lit) o kMatch kElse = do
-    o' <- evalThunk o
+    o' <- evalObj o
     case (lit, o') of
-        (IntLit _ n1, PInt n2) | n1 == n2   -> kMatch
-        (BoolLit _ (BTrue  _), PBool True ) -> kMatch
-        (BoolLit _ (BFalse _), PBool False) -> kMatch
-        (CharLit _ c1, PChar c2) | c1 == c2 -> kMatch
-        (StrLit _ s1, PStr s2) | s1 == s2   -> kMatch
-        (UnitLit _, PUnit)                  -> kMatch
-        _                                   -> kElse
+        (IntLit _ n1, Just (PInt n2)) | n1 == n2   -> kMatch
+        (BoolLit _ (BTrue  _), Just (PBool True) ) -> kMatch
+        (BoolLit _ (BFalse _), Just (PBool False)) -> kMatch
+        (CharLit _ c1, Just (PChar c2)) | c1 == c2 -> kMatch
+        (StrLit _ s1, Just (PStr s2)) | s1 == s2   -> kMatch
+        (UnitLit _, Just PUnit)                    -> kMatch
+        _                                          -> kElse
+patMatch' (PatTup _ tup) o kMatch kElse = do
+    let pats = patTupToList tup
+    o' <- evalObj o
+    case o' of
+        Just (Tup os) | length os == length pats ->
+            patMatchSeq pats os kMatch kElse
+        _ -> kElse
+  where
+    patMatchSeq [] [] kMatch _ = kMatch
+    patMatchSeq (pat : pats) (o : os) kMatch kElse =
+        patMatch' pat o (patMatchSeq pats os kMatch kElse) kElse
 patMatch' (PatDecl _ decl) o kMatch _ = do
     l   <- alloc o
     env <- declLocal' decl l
     localObjs (const env) kMatch
 patMatch' p@(PatCtor _ c flds) o kMatch kElse = do
-    o' <- evalThunk o
+    o' <- evalObj o
     case o' of
-        v@(Inst t _) | ctorName t == c -> matchFlds v flds kMatch kElse
-        _                              -> kElse
+        Just v@(Inst t _) | ctorName t == c -> matchFlds v flds kMatch kElse
+        _ -> kElse
   where
     matchFlds v@(Inst t d) (PatFld _ i p : flds) kMatch kElse =
         case Map.lookup i d of
@@ -594,8 +614,12 @@ printObj p@PBool{} = return $ shows p
 printObj p@PStr{}  = return $ shows p
 printObj p@PChar{} = return $ shows p
 printObj PUnit     = return $ shows PUnit
-printObj e@Thunk{} = do
-    o <- evalThunk e
+printObj (Tup os)  = do
+    ss <- mapM printObj os
+    let s = foldr (.) id (intersperse (", " ++) ss)
+    return $ showParen True s
+printObj (Thunk t) = do
+    o <- t
     printObj o
 printObj (Var (Just ptr)) = do
     o <- getsObjs (Map.! ptr)

src/Harper/Interpreter/Core.hs

@@ -42,6 +42,7 @@ data Object = Fun { params :: [Ident],
             | Inst { _type :: TCtor, _data :: OEnv }
             | Ref   { ref :: Ptr }
             | Var   { var :: Maybe Ptr }
+            | Tup { tupElems :: [Object] }
             | PInt Integer
             | PBool Bool
             | PStr String

src/Harper/Interpreter/Thunk.hs

@@ -8,6 +8,7 @@ import           Control.Monad.State
 import qualified Data.Map                      as Map
 
 import           Harper.Abs
+import           Harper.Abs.Tuple
 import           Harper.Abs.Typed
 import           Harper.Interpreter.Alloc
 import           Harper.Interpreter.Core
@@ -53,6 +54,20 @@ thunkPrep e@(VCtorExpr a ctor flds) eval = do
         (ptr, _) <- makeThunk e eval
         return (DataAss a i (ObjExpr a var), ptr)
 
+-- Tuples.
+
+thunkPrep e@(TupExpr a tup) eval = do
+    let es = tupToList tup
+    eThunks <- mapM (`makeThunk` eval) es
+    let ls = map fst eThunks
+        n  = length ls
+    vars <- newvars n
+    let vsls = zip vars ls
+        vses = zip vars es
+        es'  = map (\(v, e) -> ObjExpr (meta e) v) vses
+        tup' = tupFromList meta es'
+    return $ localObjs (Map.union $ Map.fromList vsls) (eval $ TupExpr a tup')
+
 -- Object access.
 
 thunkPrep e@(ObjExpr a i) eval = do

src/Harper/TypeChecker.hs

@@ -4,12 +4,14 @@ module Harper.TypeChecker
 where
 import           Control.Monad.Reader
 import           Control.Monad.State
+import           Data.List
 import qualified Data.Map                      as Map
 import qualified Data.Set                      as Set
 import           Data.Maybe
 
 import           Harper.Abs
 import           Harper.Abs.Pos
+import           Harper.Abs.Tuple
 import qualified Harper.Error                  as Error
 import           Harper.Output
 import           Harper.Printer                 ( Print(..) )
@@ -179,6 +181,15 @@ annotateExpr e@(VCtorExpr a ctor fldAss) = do
                     Nothing    -> raise $ Error.invType t' t e' e
         Nothing -> raise $ Error.undeclaredCtor ctor e
 
+-- Tuples.
+
+annotateExpr e@(TupExpr a tup) = do
+    let es = tupToList tup
+    es' <- mapM annotateExpr es
+    let t    = TupType (map typ es')
+        tup' = tupFromList (\e -> (typ e, pos e)) es'
+    return $ TupExpr (annWith t a) tup'
+
 -- Object access.
 
 annotateExpr e@(ObjExpr a i) = do
@@ -504,6 +515,14 @@ annotatePat p@(PatDecl a decl) = do
     let t' = bindAllVars (typ decl')
     bindAllVarsInOEnv oenv
     return (PatDecl (annWith t' a) decl', oenv)
+annotatePat p@(PatTup a tup) = do
+    let pats = patTupToList tup
+    patsResults <- mapM annotatePat pats
+    let (pats', oenvs) = unzip patsResults
+        oenv           = foldl' Map.union Map.empty oenvs
+        t              = TupType (map typ pats')
+        tup'           = patTupFromList (\p -> (typ p, pos p)) pats'
+    return (PatTup (annWith t a) tup', oenv)
 annotatePat p@(PatCtor a i flds) = do
     cInst <- getFreshValInst i
     case cInst of
@@ -541,6 +560,8 @@ annotatePat p@(PatCtor a i flds) = do
                             )
                     Nothing -> raise $ Error.patInvType t'' t' e
             Nothing -> raise $ Error.invFldAcc ctor i p
+annotatePat p =
+    error $ "This type of patterns is not supported yet. " ++ show p
 
 annotateBody
     :: FunBody Pos -> TypeChecker (FunBody (TypeMetaData Pos), BlockState)

src/Harper/TypeSystem/Core.hs

@@ -28,6 +28,7 @@ newtype Env = Env { objs :: OEnv } deriving (Show, Eq)
 data Type = VType { vName :: UIdent, vParams :: [Ident], vArgs :: [Type], ctors :: Set.Set UIdent, vMembs :: OEnv }
           | RType { rName :: UIdent, rParams :: [Ident], rArgs :: [Type], rMembs :: OEnv, rData :: OEnv }
           | FType { param :: Type, ret :: Type }
+          | TupType { tupElems :: [Type] }
           | TypeVar Ident
           | TypeBound Ident
           | PType UIdent
@@ -65,11 +66,14 @@ instance Show Type where
         (intersperse (" " ++) (map (showsPrec 11) targs))
     showsPrec p (FType pt rt) =
         showParen (p > 10) (showsPrec 11 pt . (" -> " ++) . showsPrec p rt)
-    showsPrec p (TypeVar   i) = showsPrt i
-    showsPrec p (TypeBound i) = showsPrt i . ("&" ++)
-    showsPrec p (PType     i) = showsPrt i
-    showsPrec p SEType        = ("sideeffect" ++)
-    showsPrec p ImpType       = ("impure" ++)
+    showsPrec p (TypeVar   i    ) = showsPrt i
+    showsPrec p (TypeBound i    ) = showsPrt i . ("&" ++)
+    showsPrec p (PType     i    ) = showsPrt i
+    showsPrec p (TupType   elems) = showParen
+        True
+        (foldr (.) id (intersperse (", " ++) (map (showsPrec 1) elems)))
+    showsPrec p SEType  = ("sideeffect" ++)
+    showsPrec p ImpType = ("impure" ++)
 
 instance Show TypeCtor where
     showsPrec p (TypeCtor i c _) = showsPrt i . ("." ++) . showsPrt c
@@ -141,4 +145,4 @@ raise = lift . lift
 type TypeMetaData a = (Type, a)
 
 annWith :: Type -> Pos -> TypeMetaData Pos
-annWith t p = (t, p)
+annWith t p = (t, p)

src/Harper/TypeSystem/Declarations.hs

@@ -18,6 +18,7 @@ import           Data.Traversable
 
 import           Harper.Abs
 import           Harper.Abs.Pos
+import           Harper.Abs.Tuple
 import           Harper.Abs.Typed
 import qualified Harper.Error                  as Error
 import           Harper.Output
@@ -319,6 +320,9 @@ parseType e@(TApp _ u es) = do
         Just t | n == 0 -> return t
         Just t          -> raise $ Error.typeInvArity t 0 n e
         Nothing         -> raise $ Error.undeclaredType u e
+parseType (TTup _ tup) = do
+    ts <- mapM parseType $ tTupToList tup
+    return $ TupType ts
 parseType (TPur _ (TSideE  _)) = return SEType
 parseType (TPur _ (TImpure _)) = return ImpType
 

src/Harper/TypeSystem/Typing.hs

@@ -100,12 +100,14 @@ instance Types Type where
     apply s v@(VType _ _ args _ _) = v { vArgs = apply s args }
     apply s r@(RType _ _ args _ _) = r { rArgs = apply s args }
     apply s (  FType p r         ) = FType (apply s p) (apply s r)
+    apply s (  TupType ts        ) = TupType (map (apply s) ts)
     apply s t                      = t
 
     tVars (TypeVar i         ) = [i]
     tVars (VType _ _ args _ _) = tVars args
     tVars (RType _ _ args _ _) = tVars args
     tVars (FType p r         ) = tVars p `union` tVars r
+    tVars (TupType ts        ) = concatMap tVars ts
     tVars t                    = []
 
 instance Types ObjData where
@@ -147,9 +149,10 @@ unify t1 t2 = fromMaybe
         foldM accSubst Map.empty (zip ps1 ps2)
     unify' (RType i1 _ ps1 _ _) (RType i2 _ ps2 _ _) | i1 == i2 =
         foldM accSubst Map.empty (zip ps1 ps2)
-    unify' SEType ImpType   = return Map.empty
-    unify' t1 t2 | t1 == t2 = return Map.empty
-    unify' t1 t2            = Nothing
+    unify' (TupType ts1) (TupType ts2) = foldM accSubst Map.empty (zip ts1 ts2)
+    unify' SEType        ImpType       = return Map.empty
+    unify' t1 t2 | t1 == t2            = return Map.empty
+    unify' t1 t2                       = Nothing
 
 accSubst :: Subst -> (Type, Type) -> Maybe Subst
 accSubst s (p1, p2) = do

test/Harper/Tests/Good/issue028_nestedTypes.har

@@ -0,0 +1,11 @@
+f :: (a, (b, c, (d, e, f), g), a, (b, b, c)) -> (a, (b, c, (d, e, f), g), a, (b, b, c));
+f x = g x;
+
+g :: (a, (b, c, d, e), a, (b, b, f)) -> (a, (b, c, d, e), a, (b, b, f));
+g x = h x;
+
+h :: (a, b, c, d) -> (a, b, c, d);
+h x = x;
+
+main :: ();
+main = ();

test/Harper/Tests/Good/issue028_nestedTypes.out

@@ -0,0 +1 @@
+Execution ended with value: ()

test/Harper/Tests/Good/issue028_tupleMatch.har

@@ -0,0 +1,9 @@
+gcd :: Integer -> Integer -> Integer;
+gcd a b = match (a, b) {
+  (_, 0) => a,
+  _      => gcd b | a mod b
+};
+
+main :: Integer;
+main = gcd 65482732497 4738130263965527;
+

test/Harper/Tests/Good/issue028_tupleMatch.out

@@ -0,0 +1 @@
+Execution ended with value: 1400191

test/Harper/Tests/Good/issue028_tuples.har

@@ -0,0 +1,2 @@
+main :: (Integer, Integer, String);
+main = (42, 100, "Str");

test/Harper/Tests/Good/issue028_tuples.out

@@ -0,0 +1 @@
+Execution ended with value: (42, 100, Str)

test/Harper/Tests/Good/issue028_tuples2.har

@@ -0,0 +1,12 @@
+main :: sideeffect -> ();
+main = {
+  var (x :: (Integer, (Integer, Bool))) = (0, (42, true));
+  eval printLn x ();
+
+  (0, (tup :: (Integer, Bool))) = x;
+  eval printLn tup ();
+
+  x := (42, (0, false));
+  eval printLn x ();
+  eval printLn tup ();
+};

test/Harper/Tests/Good/issue028_tuples2.out

@@ -0,0 +1,6 @@
+(0, (42, true))
+(42, true)
+(42, (0, false))
+(42, true)
+
+Execution ended with value: ()