Implemented pattern-based iteration. (#36)

Harper.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 9cf264509f7287d5c5583b7b55d5aa9a3a16c4ec8a231aab9c58056a97d6a5c1
+-- hash: 3ca63641eaf11b752a2c7f66c43ca0ae3cd9380a30a25e6f66bd121a2bda2dd7
 
 name:           Harper
 version:        0.1.0.0
@@ -50,6 +50,7 @@ library
       Harper.TypeSystem.Declarations
       Harper.TypeSystem.GlobalDeclarations
       Harper.TypeSystem.GlobalTypes
+      Harper.TypeSystem.Interfaces
       Harper.TypeSystem.StaticAnalysis
       Harper.TypeSystem.Traits
       Harper.TypeSystem.Typing

lang/Harper.cf

@@ -153,6 +153,9 @@ WhileStmt.       Statement3 ::= "while" Expression Statement5 ;
 ForInStmt.       Statement3 ::= "for" Pattern "in" Expression Statement5 ;
 CondStmt.        Statement3 ::= ConditionalStatement ;
 _.               Statement3 ::= Statement4 ;
+-- Used to convert to `iterate` calls.
+internal ForInVStmt. Statement3 ::= "for" Pattern "in" Expression Statement5 ;
+internal ForInRStmt. Statement3 ::= "for" Pattern "in" Expression Statement5 ;
 
 DconStmt.        Statement2 ::= Pattern "=" Expression ";" ;
 DeclStmt.        Statement2 ::= LocalObjDecl1 ";" ;

src/Harper/Abs.hs

@@ -230,6 +230,8 @@ data Statement a
     | WhileStmt a (Expression a) (Statement a)
     | ForInStmt a (Pattern a) (Expression a) (Statement a)
     | CondStmt a (ConditionalStatement a)
+    | ForInVStmt a (Pattern a) (Expression a) (Statement a)
+    | ForInRStmt a (Pattern a) (Expression a) (Statement a)
     | DconStmt a (Pattern a) (Expression a)
     | DeclStmt a (LocalObjDecl a)
     | AssStmt a Ident (Expression a)
@@ -264,6 +266,8 @@ instance Functor Statement where
         WhileStmt a expression statement -> WhileStmt (f a) (fmap f expression) (fmap f statement)
         ForInStmt a pattern expression statement -> ForInStmt (f a) (fmap f pattern) (fmap f expression) (fmap f statement)
         CondStmt a conditionalstatement -> CondStmt (f a) (fmap f conditionalstatement)
+        ForInVStmt a pattern expression statement -> ForInVStmt (f a) (fmap f pattern) (fmap f expression) (fmap f statement)
+        ForInRStmt a pattern expression statement -> ForInRStmt (f a) (fmap f pattern) (fmap f expression) (fmap f statement)
         DconStmt a pattern expression -> DconStmt (f a) (fmap f pattern) (fmap f expression)
         DeclStmt a localobjdecl -> DeclStmt (f a) (fmap f localobjdecl)
         AssStmt a ident expression -> AssStmt (f a) ident (fmap f expression)

src/Harper/Abs/Pos.hs

@@ -129,7 +129,9 @@ instance (Position a) => Position (Statement a) where
     pos (YieldRetStmt a       ) = pos a
     pos (MatchStmt a _ _      ) = pos a
     pos (WhileStmt a _ _      ) = pos a
-    pos (ForInStmt a _ _ _    ) = pos a
+    pos (ForInStmt  a _ _ _   ) = pos a
+    pos (ForInVStmt a _ _ _   ) = pos a
+    pos (ForInRStmt a _ _ _   ) = pos a
     pos (CondStmt a _         ) = pos a
     pos (DconStmt a _ _       ) = pos a
     pos (DeclStmt a _         ) = pos a

src/Harper/Abs/Typed.hs

@@ -125,7 +125,9 @@ instance (Typed a) => Typed (Statement a) where
     typ (YieldRetStmt a       ) = typ a
     typ (MatchStmt a _ _      ) = typ a
     typ (WhileStmt a _ _      ) = typ a
-    typ (ForInStmt a _ _ _    ) = typ a
+    typ (ForInStmt  a _ _ _   ) = typ a
+    typ (ForInVStmt a _ _ _   ) = typ a
+    typ (ForInRStmt a _ _ _   ) = typ a
     typ (CondStmt a _         ) = typ a
     typ (DconStmt a _ _       ) = typ a
     typ (DeclStmt a _         ) = typ a

src/Harper/Error.hs

@@ -121,6 +121,30 @@ invPredType t e ctx = do
         ctx
     typeErr
 
+notIterable
+    :: (Position p1, Print p2, Position p2)
+    => Type
+    -> Type
+    -> Expression p1
+    -> p2
+    -> HarperOutput a
+notIterable t1 t2 e ctx = do
+    outputErr
+        ( ("expression `" ++)
+        . showsPrt e
+        . ("` of type `" ++)
+        . shows t1
+        . ("` does not implement `Iterable " ++)
+        . showsPrec 3 t2
+        . ("` or `RefIterable " ++)
+        . showsPrec 3 t2
+        . (" impure` or `RefIterable " ++)
+        . showsPrec 3 t2
+        . (" sideeffect` and cannot be used in a `for` `in` statement." ++)
+        )
+        ctx
+    typeErr
+
 invApp :: (Position p) => Type -> Expression p -> HarperOutput a
 invApp t1 ctx = do
     outputErr
@@ -493,7 +517,7 @@ invCtorType t ctor ctx = do
         . shows t
         . ("` has an invalid type `" ++)
         . shows ctor
-        . ("`. The constructor must return an instance of `" ++)
+        . ("`. The constructor must be an impure function returning an instance of `" ++)
         . shows t
         . ("`." ++)
         )

src/Harper/Interpreter.hs

@@ -401,6 +401,69 @@ exec w@(WhileStmt _ pred s) kRet k = do
                 ++ show w
                 ++ " "
                 ++ show o
+-- See issue #30 for these semantics written in Harper instead of raw AST.
+exec f@(ForInVStmt a pat e s) kRet k = do
+    vars <- newvars 4
+    let iterVar       = vars !! 0
+        hasNextVar    = vars !! 1
+        iter'Var      = vars !! 2
+        hasNext'Var   = vars !! 3
+        iter          = ObjExpr a iterVar
+        hasNext       = ObjExpr a hasNextVar
+        iter'         = ObjExpr a iter'Var
+        hasNext'      = ObjExpr a hasNext'Var
+        iterateAccess = MembExpr a e [MembAcc a iterateI]
+        nextAccess    = MembExpr a iter [MembAcc a iterNextI]
+        currentAccess = MembExpr a iter [MembAcc a iterCurrentI]
+        iterInit =
+            DconStmt a (PatDecl a (LocVarDecl a (Decl a iterVar))) iterateAccess
+        hasNextDecl = DeclStmt a (LocVarDecl a (Decl a hasNextVar))
+        updateStmt  = DconStmt
+            a
+            (PatTup
+                a
+                (PatTupTail a
+                            (PatDecl a (LocValDecl a (Decl a hasNext'Var)))
+                            (PatDecl a (LocValDecl a (Decl a iter'Var)))
+                )
+            )
+            nextAccess
+        updateIter = AssStmt a iterVar iter'
+        updateHasNext = AssStmt a hasNextVar hasNext'
+        initStmt = DconStmt a pat (MembExpr a iter [MembAcc a iterCurrentI])
+        whileBody =
+            StmtBlock a [initStmt, s, updateStmt, updateIter, updateHasNext]
+        whileStmt = WhileStmt a hasNext whileBody
+        block     = StmtBlock
+            a
+            [ iterInit
+            , hasNextDecl
+            , updateStmt
+            , updateIter
+            , updateHasNext
+            , whileStmt
+            ]
+    exec block kRet k
+exec f@(ForInRStmt a pat e s) kRet k = do
+    iterVar <- newvar
+    let iter          = ObjExpr a iterVar
+        iterateAccess = MembExpr a e [MembAcc a iterateI]
+        nextAccess    = MembExpr a iter [MembAcc a iterNextI]
+        currentAccess = MembExpr a iter [MembAcc a iterCurrentI]
+        unit          = LitExpr a (UnitLit a)
+        pred          = AppExpr a nextAccess unit
+        iterInit =
+            DconStmt a (PatDecl a (LocValDecl a (Decl a iterVar))) iterateAccess
+        initStmt  = DconStmt a pat (AppExpr a currentAccess unit)
+        whileBody = StmtBlock a [initStmt, s]
+        whileStmt = WhileStmt a pred whileBody
+        block     = StmtBlock a [iterInit, whileStmt]
+    exec block kRet k
+
+exec f@ForInStmt{} _ _ =
+    error
+        $ "ForInStmt in interpreter, should've been converted during type check."
+        ++ show f
 exec m@(MatchStmt _ e cs) kRet k = execMatches e cs
   where
     execMatches e (MatchStmtClause _ p s : cs) =

src/Harper/Interpreter/Declarations.hs

@@ -17,6 +17,7 @@ import           Harper.Interpreter.Alloc
 import           Harper.Interpreter.Core
 import           Harper.Interpreter.Iterator
 import           Harper.Interpreter.Thunk
+import           Harper.Output
 import           Harper.TypeSystem.Core         ( ctorIdent
                                                 , thisIdent
                                                 )

src/Harper/Interpreter/Iterator.hs

@@ -18,53 +18,73 @@ import           Harper.Interpreter.Thunk
 import qualified Harper.Error                  as Error
 import           Harper.Output
 import           Harper.TypeSystem.Core         ( thisIdent )
+import           Harper.TypeSystem.GlobalTypes
 
 iteratorBody :: Statement Meta -> ContExec -> Interpreter Object
 iteratorBody s exec = do
     ctor <- iteratorCtor (ValueCtor (UIdent "Iterator") (UIdent "Iterator"))
                          valueCurrentImpl
                          valueNextImpl
-    l <- alloc (Thunk $ iteratorCont s exec)
-    return $ Inst ctor (Map.fromList [(iterContI, l)])
-
+    contL      <- alloc (Thunk $ iteratorCont s exec)
+    lookupThis <- lookupObj thisIdent
+    case lookupThis of
+        Just this -> do
+            funThisL <- alloc this
+            return $ Inst
+                ctor
+                (Map.fromList [(iterContI, contL), (iterFunThisI, funThisL)])
+        Nothing -> return $ Inst ctor (Map.fromList [(iterContI, contL)])
 refIteratorBody :: Statement Meta -> ContExec -> Interpreter Object
 refIteratorBody s exec = do
     ctor <- iteratorCtor (RefCtor (UIdent "RefIterator"))
                          refCurrentImpl
                          refNextImpl
-    contL    <- alloc (Thunk $ refIteratorCont s exec)
-    contVarL <- alloc (Var $ Just contL)
-    elemVarL <- alloc (Var Nothing)
-    ref      <- alloc $ Inst
-        ctor
-        (Map.fromList [(iterContI, contVarL), (iterElemI, elemVarL)])
+    contL      <- alloc (Thunk $ refIteratorCont s exec)
+    contVarL   <- alloc (Var $ Just contL)
+    elemVarL   <- alloc (Var Nothing)
+    lookupThis <- lookupObj thisIdent
+    ref        <- case lookupThis of
+        Just this -> do
+            funThisL <- alloc this
+            alloc $ Inst
+                ctor
+                (Map.fromList
+                    [ (iterContI   , contVarL)
+                    , (iterElemI   , elemVarL)
+                    , (iterFunThisI, funThisL)
+                    ]
+                )
+        Nothing -> alloc $ Inst
+            ctor
+            (Map.fromList [(iterContI, contVarL), (iterElemI, elemVarL)])
     return $ Ref ref
 
 iteratorCtor
     :: (OEnv -> TCtor)
     -> Interpreter Object
-    -> (TCtor -> Interpreter Object)
+    -> Interpreter Object
     -> Interpreter TCtor
 iteratorCtor ctorCtor currentImpl nextImpl = do
     oenv <- asks objs
-    ls   <- newlocs 2
-    let isls = zip [iterCurrentI, iterNextI] ls
+    ls   <- newlocs 3
+    let isls = zip [iterCurrentI, iterNextI, iterateI] ls
     let t     = ctorCtor (Map.fromList isls)
-        membs = [current oenv, next t oenv]
+        membs = [current oenv, next oenv, iterate oenv]
     modifyObjs (Map.union (Map.fromList $ zip ls membs))
     return t
   where
     current = Fun [thisIdent] currentImpl
-    next iter = Fun [thisIdent] (nextImpl iter)
+    next    = Fun [thisIdent] nextImpl
+    iterate = Fun [thisIdent] iterateImpl
 
 valueCurrentImpl :: Interpreter Object
 valueCurrentImpl = do
     this <- getThis
     case Map.lookup iterElemI (_data this) of
         Just ptr -> getByPtr ptr
         Nothing  -> raise Error.iterCurrNoElem
-valueNextImpl :: TCtor -> Interpreter Object
-valueNextImpl iter = do
+valueNextImpl :: Interpreter Object
+valueNextImpl = do
     this <- getThis
     let contPtr = _data this Map.! iterContI
     cont <- getByPtr contPtr
@@ -78,15 +98,17 @@ refCurrentImpl = do
     case elemVar of
         Var (Just ptr) -> getByPtr ptr
         Var Nothing    -> raise Error.iterCurrNoElem
-refNextImpl :: TCtor -> Interpreter Object
-refNextImpl iter = do
+refNextImpl :: Interpreter Object
+refNextImpl = do
     this <- getThis
     let contVarPtr = _data this Map.! iterContI
     contVar <- getByPtr contVarPtr
     let Var (Just contPtr) = contVar
     cont <- getByPtr contPtr
     let Thunk t = cont
     t
+iterateImpl :: Interpreter Object
+iterateImpl = getThis
 
 iteratorCont :: Statement Meta -> ContExec -> Interpreter Object
 iteratorCont = startIterator kElem
@@ -130,16 +152,15 @@ startIterator
 startIterator kElem s exec = do
     kRet <- inCurrentScope2 kElem
     k    <- inCurrentScope $ kElem PUnit
-    exec s kRet k
+    this <- getThis
+    let funThisL = _data this Map.! iterFunThisI
+    localObjs (Map.insert thisIdent funThisL) (exec s kRet k)
 
 iterContI :: Ident
 iterContI = Ident "~cont"
 
 iterElemI :: Ident
 iterElemI = Ident "~elem"
 
-iterCurrentI :: Ident
-iterCurrentI = Ident "current"
-
-iterNextI :: Ident
-iterNextI = Ident "next"
+iterFunThisI :: Ident
+iterFunThisI = Ident "~funThis"

src/Harper/Printer.hs

@@ -232,6 +232,8 @@ instance Print (Statement a) where
     WhileStmt _ expression statement -> prPrec i 3 (concatD [doc (showString "while"), prt 0 expression, prt 5 statement])
     ForInStmt _ pattern expression statement -> prPrec i 3 (concatD [doc (showString "for"), prt 0 pattern, doc (showString "in"), prt 0 expression, prt 5 statement])
     CondStmt _ conditionalstatement -> prPrec i 3 (concatD [prt 0 conditionalstatement])
+    ForInVStmt _ pattern expression statement -> prPrec i 3 (concatD [doc (showString "for"), prt 0 pattern, doc (showString "in"), prt 0 expression, prt 5 statement])
+    ForInRStmt _ pattern expression statement -> prPrec i 3 (concatD [doc (showString "for"), prt 0 pattern, doc (showString "in"), prt 0 expression, prt 5 statement])
     DconStmt _ pattern expression -> prPrec i 2 (concatD [prt 0 pattern, doc (showString "="), prt 0 expression, doc (showString ";")])
     DeclStmt _ localobjdecl -> prPrec i 2 (concatD [prt 1 localobjdecl, doc (showString ";")])
     AssStmt _ id expression -> prPrec i 1 (concatD [prt 0 id, doc (showString ":="), prt 0 expression, doc (showString ";")])

src/Harper/TypeChecker.hs

@@ -363,7 +363,7 @@ annotateExpr e@(DataExpr _ []) =
 annotateExpr e@(DataExpr a (MembAcc a' i : as)) = do
     lookup <- lookupObj thisIdent
     case lookup of
-        Just (Obj (RType _ _ _ _ flds) _) -> case Map.lookup i flds of
+        Just (Obj RType { rData = flds } _) -> case Map.lookup i flds of
             Just ptr -> do
                 o         <- gets ((Map.! ptr) . objData)
                 (t', as') <- annotateAccess (objType o) e as
@@ -726,6 +726,21 @@ analStmt w@(WhileStmt a e s) = do
             mayEnterOneOf [after]
             return $ WhileStmt (annWith unitT a) e' s'
         else raise $ Error.invPredType t e w
+analStmt f@(ForInStmt a pat e s) = do
+    e' <- annotateExpr e
+    (pat', oenv) <- annotatePat pat
+    let t = typ e'
+        t' = typ pat'
+    (s', after) <- blockScope (localObjs (Map.union oenv) (analStmt s))
+    mayEnterOneOf [after]
+    if iterable t t'
+        then return $ ForInVStmt (annWith unitT a) pat' e' s'
+        else if refIterable t t' 
+        then return $ ForInRStmt (annWith unitT a) pat' e' s'
+        else raise $ Error.notIterable t t' e f
+analStmt f@ForInVStmt{} = error $ "ForInVStmt in TypeCheck. This should be impossible." ++ show f
+analStmt f@ForInRStmt{} = error $ "ForInRStmt in TypeCheck. This should be impossible." ++ show f
+
 analStmt m@(MatchStmt a e cs) = do
     e'        <- annotateExpr e
     clauseRes <- mapM (blockScope . annotateMatchStmtClause (typ e')) cs
@@ -816,7 +831,7 @@ analDataAss
 analDataAss i e ctx = do
     lookup <- lookupObj thisIdent
     case lookup of
-        Just (Obj (RType _ _ _ _ flds) _) -> case Map.lookup i flds of
+        Just (Obj RType { rData = flds } _) -> case Map.lookup i flds of
             Just ptr -> do
                 o <- gets ((Map.! ptr) . objData)
                 if assignable o
@@ -880,32 +895,6 @@ analElse c@(ElseStmt a s) = do
     s' <- analStmt s
     return $ ElseStmt (annWith unitT a) s'
 
-funParams
-    :: [FunParam (TypeMetaData Pos)]
-    -> BlockState
-    -> [FunParam (TypeMetaData Pos)]
-funParams ps st | hasSideeffects st = case mLast ps of
-    Just (FParam (SEType, _) _) -> ps
-    _                           -> ps ++ [FParam (SEType, Nothing) (Ident "()")]
-funParams ps _ | any (\(FParam (t, _) _) -> paramIsImpure t) ps =
-    case mLast ps of
-        Just (FParam (t, _) _) | t == ImpType || t == SEType -> ps
-        _ -> ps ++ [FParam (ImpType, Nothing) (Ident "()")]
-funParams ps _ = ps
-
-lamParams
-    :: [LambdaParam (TypeMetaData Pos)]
-    -> BlockState
-    -> [LambdaParam (TypeMetaData Pos)]
-lamParams ps st | hasSideeffects st = case mLast ps of
-    Just (LamParam (SEType, _) _) -> ps
-    _ -> ps ++ [LamParam (SEType, Nothing) (PatDisc (SEType, Nothing))]
-lamParams ps _ | any (\(LamParam (t, _) _) -> paramIsImpure t) ps =
-    case mLast ps of
-        Just (LamParam (t, _) _) | t == ImpType || t == SEType -> ps
-        _ -> ps ++ [LamParam (ImpType, Nothing) (PatDisc (ImpType, Nothing))]
-lamParams ps _ = ps
-
 paramIsImpure :: Type -> Bool
 paramIsImpure RType{}                   = True
 paramIsImpure (FType ImpType r        ) = True