Propagate function environment throughout transpiling.

1 files changed, 51 insertions, 52 deletions

diff --git a/monkeypatch.hs b/monkeypatch.hs
index 8ed6ada..f12552e 100644
--- a/monkeypatch.hs
+++ b/monkeypatch.hs
@@ -198,35 +198,34 @@ varmap vs = Map.fromList $ map (,()) vs
 
 -- Returns a list of statements bringing variables into scope and an
 -- expression.
---
--- TODO: FunctionEnvironment argument.
-grokExpression :: CExpression a
+grokExpression :: FunctionEnvironment
+                  -> CExpression a
                   -> Maybe ([Computation (HS.Exp ())], Computation (HS.Exp ()))
-grokExpression (CVar cv _) = Just $ (,) [] $ Computation
+grokExpression fe (CVar cv _) = Just $ (,) [] $ Computation
     { compFree  = Map.singleton (identToString cv) ()
     , compIntro = Map.empty
     , comp      = hsvar (identToString cv)
     }
-grokExpression (CConst (CIntConst n _)) = Just $ (,) [] $ Computation
+grokExpression fe (CConst (CIntConst n _)) = Just $ (,) [] $ Computation
     { compFree  = Map.empty
     , compIntro = Map.empty
     , comp      = Lit () (Int () (getCInteger n) (show n))
     }
-grokExpression (CConst (CStrConst s _)) = Just $ (,) [] $ Computation
+grokExpression fe (CConst (CStrConst s _)) = Just $ (,) [] $ Computation
     { compFree  = Map.empty
     , compIntro = Map.empty
     , comp      = Lit () (HS.String () (getCString s) (getCString s))
     }
-grokExpression (CBinary CNeqOp a b _) = do
-    (as,ca) <- grokExpression a
-    (bs,cb) <- grokExpression b
+grokExpression fe (CBinary CNeqOp a b _) = do
+    (as,ca) <- grokExpression fe a
+    (bs,cb) <- grokExpression fe b
     let ss = as ++ bs -- TODO: resolve variable name conflicts
     return $ (,) ss $ Computation
         { compFree  = compFree ca `Map.union` compFree cb
         , compIntro = Map.empty
         , comp      = infixOp (comp ca) "/=" (comp cb)
         }
-grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do
+grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do
     let cv = identToString cv0
         hv = "p" ++ cv
         k = uniqIdentifier "go" (Map.empty {-todo-})
@@ -243,20 +242,20 @@ grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do
         , compIntro = Map.empty
         , comp      = hsvar hv
         }
-grokExpression (CCond cond (Just thn) els _) = do
-    (cs,c) <- grokExpression cond
-    (ts,t) <- grokExpression thn
-    (es,e) <- grokExpression els
+grokExpression fe (CCond cond (Just thn) els _) = do
+    (cs,c) <- grokExpression fe cond
+    (ts,t) <- grokExpression fe thn
+    (es,e) <- grokExpression fe els
     let tt = foldr applyComputation t ts
         ee = foldr applyComputation e es
     return $ (,) cs $ fmap (\cnd -> If () cnd (comp tt) (comp ee)) c
         { compFree = compFree ee `Map.union` compFree tt `Map.union` compFree c
         }
-grokExpression (CSizeofExpr expr _) = do
-    (xs,x) <- grokExpression expr
+grokExpression fe (CSizeofExpr expr _) = do
+    (xs,x) <- grokExpression fe expr
     return $ (,) xs $ fmap (App () (hsvar "sizeOf")) x
-grokExpression (CCast (CDecl [CTypeSpec (CVoidType _)] [] _) expr _) = grokExpression expr
-grokExpression (CCast (CDecl [ CTypeSpec (CVoidType _) ]
+grokExpression fe (CCast (CDecl [CTypeSpec (CVoidType _)] [] _) expr _) = (grokExpression fe) expr
+grokExpression fe (CCast (CDecl [ CTypeSpec (CVoidType _) ]
                              [ ( Just (CDeclr Nothing [ CPtrDeclr [] _ ] Nothing [] _) , Nothing , Nothing) ]
                              _)
                       (CConst (CIntConst zero _)) _) | 0 <- getCInteger zero = do
@@ -265,8 +264,8 @@ grokExpression (CCast (CDecl [ CTypeSpec (CVoidType _) ]
         , compIntro = Map.empty
         , comp      = hsvar "nullPtr"
         }
-grokExpression (CComma exps _) = do
-    gs <- mapM grokExpression exps
+grokExpression fe (CComma exps _) = do
+    gs <- mapM (grokExpression fe) exps
     let ss = concatMap fst gs -- TODO: resolve variable name conflicts
         cll = foldr1 (\x y -> infixFn x "seq" y) $ map (comp . snd) gs
         frees = foldr1 Map.union (map (compFree . snd) gs)
@@ -276,8 +275,8 @@ grokExpression (CComma exps _) = do
                         , compIntro = Map.empty
                         , comp      = cll
                         }
-grokExpression (C.CCall (CVar fn _) exps _) = do
-    gs <- mapM grokExpression exps
+grokExpression fe (C.CCall (CVar fn _) exps _) = do
+    gs <- mapM (grokExpression fe) exps
     let ss = concatMap fst gs -- TODO: resolve variable name conflicts
         hv = "r" ++ identToString fn
         cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs
@@ -295,12 +294,12 @@ grokExpression (C.CCall (CVar fn _) exps _) = do
         , compIntro = Map.empty
         , comp      = hsvar hv
         }
-grokExpression (CStatExpr (CCompound idents xs _) _) = do
+grokExpression fe (CStatExpr (CCompound idents xs _) _) = do
     let (y,ys) = splitAt 1 (reverse xs)
     y' <- case y of
                 [CBlockStmt (CExpr mexp ni)] -> Just $ CBlockStmt (CReturn mexp ni)
                 _                            -> Just (head y) -- Nothing FIXME
-    gs <- mapM grokStatement (reverse $ y' : ys)
+    gs <- mapM (grokStatement fe) (reverse $ y' : ys)
     let s0 = foldr applyComputation (Computation Map.empty Map.empty (App () (hsvar "return") hsopUnit)) gs
         s1 = fmap (\xp -> Paren () xp) s0
         hv = uniqIdentifier "ret" (compFree s1)
@@ -317,23 +316,24 @@ grokExpression (CStatExpr (CCompound idents xs _) _) = do
         , compIntro = Map.empty
         , comp      = hsvar hv
         }
-grokExpression _ = Nothing
+grokExpression fe _ = Nothing
 
 
 grokInitialization :: Foldable t1 =>
-                      t1 (CDeclarationSpecifier t2)
+                      FunctionEnvironment
+                      -> t1 (CDeclarationSpecifier t2)
                       -> (Maybe (CDeclarator a1), CInitializer a2)
                       -> Maybe (Computation (HS.Exp ()))
-grokInitialization _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do
+grokInitialization fe _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do
     let v = identToString cv0
-    (xs,x) <- grokExpression exp
+    (xs,x) <- grokExpression fe exp
     let hsexp = fmap (App () (hsvar "return")) x -- Paren () (
         ret = flip (foldr applyComputation) xs $
                 fmap (\exp -> infixOp exp ">>="
                                 $ Lambda () [hspvar v] (hsvar k)) hsexp
         k = uniqIdentifier "go" (compFree ret)
     return $ fmap (\exp -> Lambda () [hspvar k] exp) ret
-grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do
+grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do
     let v = identToString cv0
     -- let k = uniqIdentifier "go" (varmap [v])
     case lefts $ concatMap hsTypeSpec ts of
@@ -343,7 +343,7 @@ grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do
             gs <- do
                 forM exps $ \(ms,initexpr) -> do
                     case initexpr of
-                        CInitExpr ie _ -> grokExpression ie >>= \g -> return (ms,g)
+                        CInitExpr ie _ -> (grokExpression fe) ie >>= \g -> return (ms,g)
                         _              -> Nothing
             let assigns = do
                     (ms,(ss,x)) <- gs
@@ -374,17 +374,16 @@ grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do
                 ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns
             return $ fmap (\exp -> Lambda () [hspvar k] exp) ret
         _ -> Nothing
-grokInitialization _ _ = Nothing
+grokInitialization _ _ _ = Nothing
 
 
--- TODO: FunctionEnvironment argument.
-grokStatement :: CCompoundBlockItem a -> Maybe (Computation (HS.Exp ()))
-grokStatement (CBlockStmt (CReturn (Just exp) _)) = do
-    (xs,x) <- grokExpression exp
+grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> Maybe (Computation (HS.Exp ()))
+grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do
+    (xs,x) <- grokExpression fe exp
     let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x)
         x' = fmap (\y -> App () (hsvar "return") y) x
     return $ fmap (\y -> Lambda () [hspvar k] y) $ foldr applyComputation x' xs
-grokStatement (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail" _ _) _) xs _)) _)) = do
+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))
@@ -392,10 +391,10 @@ grokStatement (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail" _
     let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x)
         x' = fmap (\y -> App () (hsvar "error") y) x
     return $ fmap (\y -> Lambda () [hspvar k] y) x'
-grokStatement (CBlockStmt (CExpr (Just
+grokStatement fe (CBlockStmt (CExpr (Just
                 (CAssign CAssignOp
                    (CMember cvar fld isptr _) expr _)) _)) = do
-    (xs,x) <- grokExpression expr
+    (xs,x) <- grokExpression fe expr
     v <- cvarName cvar
     let fieldlbl = identToString fld
         k1 = uniqIdentifier "go" (compFree x)
@@ -408,10 +407,10 @@ grokStatement (CBlockStmt (CExpr (Just
                                     fieldinit) ">>" (hsvar k1)
             }
     return $ fmap (\y -> Lambda () [hspvar k1] y) $ foldr applyComputation x' xs
-grokStatement (CBlockStmt (CExpr (Just
+grokStatement fe (CBlockStmt (CExpr (Just
                     (C.CCall cvarfun exps _)) _)) = do
     fn <- cvarName cvarfun
-    gs <- mapM grokExpression exps
+    gs <- mapM (grokExpression fe) exps
     let k = uniqIdentifier "go" frees
         cll = foldl (App ()) (hsvar fn) $ map (comp . snd) gs
         frees = foldr Map.union (Map.singleton fn ()) (map (compFree . snd) gs)
@@ -422,7 +421,7 @@ grokStatement (CBlockStmt (CExpr (Just
             , comp = infixOp cll ">>" (hsvar k)
             }
     return $ fmap (Lambda () [hspvar k]) x
-grokStatement (CBlockStmt (CExpr (Just
+grokStatement fe (CBlockStmt (CExpr (Just
                 (CAssign CAssignOp cvarnew
                     (C.CCall cvarfun [] _) _)) _)) = do
     v <- cvarName cvarnew
@@ -435,8 +434,8 @@ grokStatement (CBlockStmt (CExpr (Just
             $ infixOp (hsvar fn) ">>="
                 $ Lambda () [hspvar v] (hsvar k)
         }
-grokStatement (CBlockStmt (CIf exp thn els _)) = do
-    (xs,x) <- grokExpression exp
+grokStatement fe (CBlockStmt (CIf exp thn els _)) = do
+    (xs,x) <- grokExpression fe exp
     let mkif0 = If () (comp x)
     (mkif,stmts) <- case (thn,els) of
 
@@ -451,7 +450,7 @@ grokStatement (CBlockStmt (CIf exp thn els _)) = do
 
         _ -> Nothing -- TODO
 
-    ss <- sequence $ map grokStatement stmts
+    ss <- sequence $ map (grokStatement fe) stmts
     let s = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) ss
         k = uniqIdentifier "go" (Map.union (compFree x) (compFree s))
     return $ flip (foldr applyComputation) xs Computation
@@ -459,7 +458,7 @@ grokStatement (CBlockStmt (CIf exp thn els _)) = do
         , compIntro = compIntro s
         , comp = Lambda () [hspvar k] $ mkif (comp s) (hsvar k)
         }
-grokStatement (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 _) fld True _) _)) _)) = do
+grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 _) fld True _) _)) _)) = do
     let k1 = uniqIdentifier "go" (varmap [fieldlbl,v])
         fieldlbl = identToString fld
         v = identToString cv0
@@ -473,13 +472,13 @@ grokStatement (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 _)
                                             (hsvar v))
                                     (hsvar "succ")) ">>" (hsvar k1)
             }
-grokStatement (CBlockStmt (CExpr mexpr _)) = do
+grokStatement fe (CBlockStmt (CExpr mexpr _)) = do
     (ss,pre) <- maybe (Just $ (,) [] $ Computation Map.empty Map.empty id)
-                      (fmap (second (fmap (\e -> infixFn e "seq"))) . grokExpression) mexpr
+                      (fmap (second (fmap (\e -> infixFn e "seq"))) . grokExpression fe) mexpr
     let k = uniqIdentifier "go" (compFree s)
         s = foldr applyComputation (fmap ($ hsvar k) pre) ss
     return $ fmap (Lambda () [hspvar k]) s
-grokStatement (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do
+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
@@ -490,10 +489,10 @@ grokStatement (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do
                 , comp      = Lambda () [hspvar "go"] $ hsvar "go"
                 }
         initials -> do
-            gs <- mapM (grokInitialization $ t:ts) initials
+            gs <- mapM (grokInitialization fe $ t:ts) initials
             return $ fmap (\exp -> Lambda () [hspvar "go"] exp)
                         $ foldr applyComputation (Computation Map.empty Map.empty (hsvar "go")) gs
-grokStatement _ = Nothing
+grokStatement fe _ = Nothing
 
 isFunctionDecl :: CExternalDeclaration a -> Bool
 isFunctionDecl (CDeclExt (CDecl _ [(Just (CDeclr _ [CFunDeclr _ _ _] _ _ _),_,_)] _)) = True
@@ -614,7 +613,7 @@ transpile o fname incs (CTranslUnit edecls _) = do
                             forM_ bdy $ \d -> putStrLn $ ppShow $ cleanTree d
                     else do
                         let mhask = do
-                                xs <- mapM grokStatement bdy
+                                xs <- mapM (grokStatement fe) bdy
                                 return $ foldr applyComputation (Computation Map.empty Map.empty hsopUnit) xs
                         case mhask of
                             Just hask -> do printHeader
@@ -623,7 +622,7 @@ transpile o fname incs (CTranslUnit edecls _) = do
                                 printHeader
                                 forM_ bdy $ \d -> do
                                     putStrLn $ " C: " ++ show (pretty d)
-                                    case grokStatement d of
+                                    case grokStatement fe d of
 
                                         Just hd -> do putStrLn $ "fr: " ++ intercalate " " (Map.keys (compFree hd))
                                                       putStrLn $ "HS: " ++ HS.prettyPrint (comp hd)