compContinue field.

1 files changed, 52 insertions, 70 deletions

diff --git a/monkeypatch.hs b/monkeypatch.hs
index f825868..d7c4282 100644
--- a/monkeypatch.hs
+++ b/monkeypatch.hs
@@ -150,12 +150,18 @@ transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)
 transField _ = []
 
 data Computation st = Computation
-    { compFree  :: Map String ()
-    , compIntro :: Map String ()
-    , comp      :: st
+    { compFree     :: Map String ()
+    , compIntro    :: Map String ()
+    , compContinue :: Maybe String
+        -- ^ The identifier name currently used to indicate the "continue;"
+        -- statement.
+    , comp         :: st
     }
  deriving (Eq,Ord,Functor)
 
+mkcomp :: x -> Computation x
+mkcomp x = Computation Map.empty Map.empty Nothing x
+
 hsvar :: String -> HS.Exp ()
 hsvar v = Var () (UnQual () (HS.Ident () v))
 
@@ -190,11 +196,12 @@ applyComputation a@Computation{ comp = FormalLambda govar exp } b =
     in case listify matchgo exp of
         (_:_:_) -> error "TODO: Multiple go-refs; make let binding."
         _       -> Computation
-            { compFree  = Map.union (compFree a) (compFree b) Map.\\ compIntro a
-            , compIntro = compIntro a `Map.union` compIntro b
-            , comp      = let subst x | matchgo x   = comp b
-                                      | otherwise   = x
-                          in everywhere (mkT subst) exp
+            { compFree     = Map.union (compFree a) (compFree b) Map.\\ compIntro a
+            , compIntro    = compIntro a `Map.union` compIntro b
+            , compContinue = Nothing
+            , comp         = let subst x | matchgo x   = comp b
+                                         | otherwise   = x
+                             in everywhere (mkT subst) exp
             }
 
 varmap :: [String] -> Map String ()
@@ -288,33 +295,24 @@ grokExpression fe (CVar cv _) =
         if isGlobalRef fe v
             then let k = uniqIdentifier "go" (varmap [v,hv])
                      s = Computation
-                            { compFree  = Map.singleton v ()
-                            , compIntro = Map.singleton hv ()
-                            , comp      = FormalLambda k
-                                            $ infixOp (App () (hsvar "peek") (hsvar v)) ">>="
-                                            $ Lambda () [hspvar hv] (hsvar k)
+                            { compFree     = Map.singleton v ()
+                            , compIntro    = Map.singleton hv ()
+                            , compContinue = Nothing
+                            , comp         = FormalLambda k
+                                               $ infixOp (App () (hsvar "peek") (hsvar v)) ">>="
+                                               $ Lambda () [hspvar hv] (hsvar k)
                             }
                      hv = "v" ++ v
-                 in (,) [s] Computation
+                 in (,) [s] (mkcomp $ hsvar hv)
                             { compFree  = Map.singleton hv ()
-                            , compIntro = Map.empty
-                            , comp      = hsvar hv
                             }
-            else (,) [] $ Computation
+            else (,) [] $ (mkcomp $ hsvar v)
                 { compFree  = Map.singleton (identToString cv) ()
-                , compIntro = Map.empty
-                , comp      = hsvar v
                 }
-grokExpression fe (CConst (CIntConst n _)) = Just $ (,) [] $ Computation
-    { compFree  = Map.empty
-    , compIntro = Map.empty
-    , comp      = Lit () (Int () (getCInteger n) (show n))
-    }
-grokExpression fe (CConst (CStrConst s _)) = Just $ (,) [] $ Computation
-    { compFree  = Map.empty
-    , compIntro = Map.empty
-    , comp      = Lit () (HS.String () (getCString s) (getCString s))
-    }
+grokExpression fe (CConst (CIntConst n _)) =
+    Just $ (,) [] $ mkcomp $ Lit () (Int () (getCInteger n) (show n))
+grokExpression fe (CConst (CStrConst s _)) =
+    Just $ (,) [] $ mkcomp $ Lit () (HS.String () (getCString s) (getCString s))
 grokExpression fe (CBinary op a b _) = do
     (as,ca) <- grokExpression fe a
     (bs0,cb0) <- grokExpression fe b
@@ -325,10 +323,8 @@ grokExpression fe (CBinary op a b _) = do
              | otherwise          = infixOp
     -- trace ("intros("++hop++"): "++show (foldr Map.union Map.empty $ map compIntro as)) $ return ()
     -- TODO: Short-circuit boolean evaluation side-effects.
-    return $ (,) ss $ Computation
+    return $ (,) ss $ (mkcomp $ infx (comp ca) hop (comp cb))
         { compFree  = compFree ca `Map.union` compFree cb
-        , compIntro = Map.empty
-        , comp      = infx (comp ca) hop (comp cb)
         }
 grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do
     let cv = identToString cv0
@@ -337,15 +333,14 @@ grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do
         ss = pure Computation
                 { compFree = Map.singleton cv ()
                 , compIntro = Map.singleton hv ()
+                , compContinue = Nothing
                 , comp = FormalLambda k
                             $ infixFn (hsvar cv)
                                       "withPointer"
                                       (Lambda () [hspvar hv] (hsvar k))
                 }
-    return $ (,) ss Computation
+    return $ (,) ss (mkcomp $ hsvar hv)
         { compFree  = Map.singleton hv ()
-        , compIntro = Map.empty
-        , comp      = hsvar hv
         }
 grokExpression fe (CCond cond (Just thn) els _) = do
     (cs,c) <- grokExpression fe cond
@@ -364,10 +359,8 @@ grokExpression fe (CCast (CDecl [ CTypeSpec (CVoidType _) ]
                              [ ( Just (CDeclr Nothing [ CPtrDeclr [] _ ] Nothing [] _) , Nothing , Nothing) ]
                              _)
                       (CConst (CIntConst zero _)) _) | 0 <- getCInteger zero = do
-    return $ (,) [] Computation
+    return $ (,) [] (mkcomp $ hsvar "nullPtr")
         { compFree  = Map.singleton "nullPtr" ()
-        , compIntro = Map.empty
-        , comp      = hsvar "nullPtr"
         }
 grokExpression fe (CComma exps _) = do
     gs <- mapM (grokExpression fe) exps
@@ -381,7 +374,7 @@ grokExpression fe (CComma exps _) = do
         k = uniqIdentifier "go" (compFree s)
         s' = fmap (\x ->  FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar k)))) s
     -- TODO: It would be cleaner if I could return only a statement and not an expression.
-    return ([s'],Computation (Map.singleton hv ()) Map.empty (hsvar hv))
+    return $ (,) [s'] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () }
 grokExpression fe (C.CCall (CVar fn _) exps _) = do
     gs <- mapM (grokExpression fe) exps
     let ss = concatMap fst gs -- TODO: resolve variable name conflicts
@@ -392,14 +385,13 @@ grokExpression fe (C.CCall (CVar fn _) exps _) = do
         s = Computation
                 { compFree = frees
                 , compIntro = Map.singleton hv ()
+                , compContinue = Nothing
                 , comp = FormalLambda k
                             $ infixOp cll ">>="
                                 $ Lambda () [hspvar hv] (hsvar k)
                 }
-    return $ (,) (ss++[s]) Computation
+    return $ (,) (ss++[s]) (mkcomp $ hsvar hv)
         { compFree  = Map.singleton hv ()
-        , compIntro = Map.empty
-        , comp      = hsvar hv
         }
 grokExpression fe (CStatExpr (CCompound idents xs _) _) = do
     let (y,ys) = splitAt 1 (reverse xs)
@@ -407,21 +399,20 @@ grokExpression fe (CStatExpr (CCompound idents xs _) _) = do
                 [CBlockStmt (CExpr mexp ni)] -> Just $ CBlockStmt (CReturn mexp ni)
                 _                            -> Just (head y) -- Nothing FIXME
     gs <- mapM (grokStatement fe) (reverse $ y' : ys)
-    let s0 = foldr applyComputation (Computation Map.empty Map.empty retUnit) gs
+    let s0 = foldr applyComputation (mkcomp retUnit) gs
         s1 = fmap (\xp -> Paren () xp) s0
         hv = uniqIdentifier "ret" (compFree s1)
         k = uniqIdentifier "go" (compFree s1)
         s = Computation
                 { compFree = compFree s1
                 , compIntro = Map.singleton hv ()
+                , compContinue = Nothing
                 , comp = FormalLambda k
                             $ infixOp (comp s1) ">>="
                                 $ Lambda () [hspvar hv] (hsvar k)
                 }
-    return $ (,) [s] Computation
+    return $ (,) [s] (mkcomp $ hsvar hv)
         { compFree  = Map.singleton hv ()
-        , compIntro = Map.empty
-        , comp      = hsvar hv
         }
 grokExpression fe (CAssign CAssignOp cvar expr _) = do
     v <- cvarName cvar
@@ -433,11 +424,7 @@ grokExpression fe (CAssign CAssignOp cvar expr _) = do
                 $ infixOp (App () (hsvar "return") (comp x)) ">>="
                     $ Lambda () [hspvar v] (hsvar k)
             }
-    return $ (,) (ss ++ [s]) Computation
-        { compFree = Map.empty
-        , compIntro = Map.empty
-        , comp = hsvar v
-        }
+    return $ (,) (ss ++ [s]) $ mkcomp (hsvar v)
 grokExpression fe _ = Nothing
 
 
@@ -470,7 +457,7 @@ grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = d
             let assigns = do
                     (ms,(ss,x)) <- gs
                     let k2 = uniqIdentifier "gopoo" (compFree ret)
-                        ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k2)) (ss ++ cs)
+                        ret = foldr applyComputation (mkcomp $ hsvar k2) (ss ++ cs)
                         cs = do
                             CMemberDesig m _ <- ms
                             let k1 = uniqIdentifier "go" (compFree x)
@@ -488,12 +475,13 @@ grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = d
             let newstruct = Computation
                         { compFree = Map.empty -- todo
                         , compIntro = Map.singleton v ()
+                        , compContinue = Nothing
                         , comp = FormalLambda k
                             $ infixOp (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) ">>="
                                       $ Lambda () [hspvar v] (hsvar k)
                         }
                 k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO
-                ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns
+                ret = foldr applyComputation (mkcomp $ hsvar k) $ newstruct : assigns
             return $ fmap (FormalLambda k) ret
         _ -> Nothing
 grokInitialization _ _ _ = Nothing
@@ -515,7 +503,7 @@ grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do
         x' = fmap (\y -> App () (hsvar "return") $ promote (fnArgs fe) y) x
     return $ fmap (\y -> FormalLambda k y) $ foldr applyComputation x' xs
 grokStatement fe (CBlockStmt (CReturn Nothing _)) =
-    Just $ Computation Map.empty Map.empty $ FormalLambda "go" retUnit
+    Just $ mkcomp $ FormalLambda "go" retUnit
 grokStatement fe (CBlockStmt (CIf exp thn els _)) = do
     (xs,x) <- grokExpression fe exp
     let mkif0 = If () (comp x)
@@ -534,17 +522,18 @@ grokStatement fe (CBlockStmt (CIf exp thn els _)) = do
         _ -> trace ("Unhandled if: "++show (fmap (const LT) thn)) $ Nothing -- TODO
 
     ss <- sequence $ map (grokStatement fe) stmts
-    let s = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) ss
+    let s = foldr applyComputation (mkcomp $ hsvar k) ss
         k = uniqIdentifier "go" (Map.union (compFree x) (compFree s))
     return $ fmap (FormalLambda k) $ flip (foldr applyComputation) xs Computation
         { compFree = compFree x `Map.union` compFree s
         , compIntro = compIntro s
+        , compContinue = Nothing
         , comp = mkif (comp s) (hsvar k)
         }
 grokStatement fe (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail" _ _) _) xs _)) _)) = do
     x <- case xs of
             (CConst (CStrConst msg _):_) -> let s = getCString msg
-                                            in Just $ Computation Map.empty Map.empty (Lit () (HS.String () s s))
+                                            in Just $ mkcomp $ Lit () (HS.String () s s)
             _                            -> Nothing
     let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x)
         x' = fmap (\y -> App () (hsvar "error") y) x
@@ -573,11 +562,7 @@ grokStatement fe (CBlockStmt (CExpr (Just
         cll = foldl (App ()) (hsvar fn) $ map (comp . snd) gs
         frees = foldr Map.union (Map.singleton fn ()) (map (compFree . snd) gs)
         x = foldr applyComputation s $ concatMap fst gs
-        s = Computation
-            { compFree = frees
-            , compIntro = Map.empty
-            , comp = infixOp cll ">>" (hsvar k)
-            }
+        s = (mkcomp $ infixOp cll ">>" (hsvar k)) { compFree = frees }
     return $ fmap (FormalLambda k) x
 grokStatement fe (CBlockStmt (CExpr (Just
                 (CAssign CAssignOp cvarnew
@@ -588,6 +573,7 @@ grokStatement fe (CBlockStmt (CExpr (Just
     return Computation
         { compFree = Map.singleton fn ()
         , compIntro = Map.singleton v ()
+        , compContinue = Nothing
         , comp = FormalLambda k
             $ infixOp (hsvar fn) ">>="
                 $ Lambda () [hspvar v] (hsvar k)
@@ -599,6 +585,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0
     return Computation
             { compFree = varmap [v]
             , compIntro = Map.empty
+            , compContinue = Nothing
             , comp = FormalLambda k1
                         $ infixOp
                             (App () (App () (App () (hsvar "modify")
@@ -616,7 +603,7 @@ grokStatement fe (CBlockStmt (CExpr (Just expr) _)) = do
     return $ fmap (FormalLambda k) $ foldr applyComputation g ss
 -}
 grokStatement fe (CBlockStmt (CExpr mexpr _)) = do
-    (ss,pre) <- maybe (Just $ (,) [] $ Computation Map.empty Map.empty id)
+    (ss,pre) <- maybe (Just $ (,) [] $ mkcomp id)
                       (fmap (second (fmap (\e -> infixFn e "seq"))) . grokExpression fe) mexpr
     let k = uniqIdentifier "go" (compFree s)
         s = foldr applyComputation (fmap ($ hsvar k) pre) ss
@@ -625,16 +612,11 @@ grokStatement fe (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do
     -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of
     -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of
     case mapMaybe (\(i,inits,_) -> fmap ((,) i) inits) (v:vs) of
-        [] ->
-            return Computation
-                { compFree  = Map.empty
-                , compIntro = Map.empty
-                , comp      = FormalLambda "go" $ hsvar "go"
-                }
+        [] -> return $ mkcomp $ FormalLambda "go" $ hsvar "go"
         initials -> do
             gs <- mapM (grokInitialization fe $ t:ts) initials
             return $ fmap (FormalLambda "go")
-                        $ foldr applyComputation (Computation Map.empty Map.empty (hsvar "go")) gs
+                        $ foldr applyComputation (mkcomp $ hsvar "go") gs
 grokStatement fe _ = Nothing
 
 isFunctionDecl :: CExternalDeclaration a -> Bool
@@ -767,7 +749,7 @@ transpile o fname incs (CTranslUnit edecls _) = do
                     else do
                         let mhask = do
                                 xs <- mapM (grokStatement fe) bdy
-                                return $ foldr applyComputation (Computation Map.empty Map.empty retUnit) xs
+                                return $ foldr applyComputation (mkcomp retUnit) xs
                         case mhask of
                             Just hask -> do printHeader
                                             mapM_ (putStrLn . ("  "++)) $ lines $ HS.prettyPrint $ applyDoSyntax' o $ comp hask