Implemented C comma operator.

1 files changed, 37 insertions, 28 deletions

diff --git a/monkeypatch.hs b/monkeypatch.hs
index a835e86..3b78c9f 100644
--- a/monkeypatch.hs
+++ b/monkeypatch.hs
@@ -156,16 +156,12 @@ hspvar v = PVar () (HS.Ident () v)
 cvarName (CVar (C.Ident n _ _) _) = Just n
 cvarName _                        = Nothing
 
-hsopApp = QVarOp () (UnQual () (Symbol () "$"))
-
-hsopBind = QVarOp () (UnQual () (Symbol () ">>="))
+hsopUnit = HS.Con () (Special () (UnitCon ()))
 
-hsopSeq = QVarOp () (UnQual () (Symbol () ">>"))
 
-hsopNeq = QVarOp () (UnQual () (Symbol () "/="))
-
-hsopUnit = HS.Con () (Special () (UnitCon ()))
+infixOp x op y = InfixApp () x (QVarOp () (UnQual () (Symbol () op))) y
 
+infixFn x fn y = InfixApp () x (QVarOp () (UnQual () (HS.Ident () fn))) y
 
 
 
@@ -212,7 +208,7 @@ grokExpression (CBinary CNeqOp a b _) = do
     return $ (,) ss $ Computation
         { compFree  = compFree ca `Map.union` compFree cb
         , compIntro = Map.empty
-        , comp      = InfixApp () (comp ca) hsopNeq (comp cb)
+        , comp      = infixOp (comp ca) "/=" (comp cb)
         }
 grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do
     let cv = identToString cv0
@@ -222,10 +218,9 @@ grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do
                 { compFree = Map.singleton cv ()
                 , compIntro = Map.singleton hv ()
                 , comp = Lambda () [hspvar k]
-                            $ InfixApp ()
-                                (hsvar cv)
-                                (QVarOp () (UnQual () (HS.Ident () "withPointer")))
-                                (Lambda () [hspvar hv] (hsvar k))
+                            $ infixFn (hsvar cv)
+                                      "withPointer"
+                                      (Lambda () [hspvar hv] (hsvar k))
                 }
     return $ (,) ss Computation
         { compFree  = Map.singleton hv ()
@@ -241,6 +236,10 @@ grokExpression (CCond cond (Just thn) els _) = do
     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
+    return $ (,) xs $ fmap (App () (hsvar "sizeOf")) x
+grokExpression (CCast (CDecl [CTypeSpec (CVoidType _)] [] _) expr _) = grokExpression expr
 grokExpression (CCast (CDecl [ CTypeSpec (CVoidType _) ]
                              [ ( Just (CDeclr Nothing [ CPtrDeclr [] _ ] Nothing [] _) , Nothing , Nothing) ]
                              _)
@@ -250,6 +249,17 @@ grokExpression (CCast (CDecl [ CTypeSpec (CVoidType _) ]
         , compIntro = Map.empty
         , comp      = hsvar "nullPtr"
         }
+grokExpression (CComma exps _) = do
+    gs <- mapM grokExpression 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)
+        k = uniqIdentifier "go" frees
+    return $ (,) ss Computation
+                        { compFree  = frees
+                        , compIntro = Map.empty
+                        , comp      = cll
+                        }
 grokExpression (C.CCall (CVar fn _) exps _) = do
     gs <- mapM grokExpression exps
     let ss = concatMap fst gs -- TODO: resolve variable name conflicts
@@ -261,8 +271,8 @@ grokExpression (C.CCall (CVar fn _) exps _) = do
                 { compFree = frees
                 , compIntro = Map.singleton hv ()
                 , comp = Lambda () [hspvar k]
-                            $ InfixApp () cll hsopBind
-                            $ Lambda () [hspvar hv] (hsvar k)
+                            $ infixOp cll ">>="
+                                $ Lambda () [hspvar hv] (hsvar k)
                 }
     return $ (,) (ss++[s]) Computation
         { compFree  = Map.singleton hv ()
@@ -277,7 +287,7 @@ grokInitialization _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do
     (xs,x) <- grokExpression exp
     let hsexp = fmap (App () (hsvar "return")) x -- Paren () (
         ret = flip (foldr applyComputation) xs $
-                fmap (\exp -> InfixApp () exp hsopBind
+                fmap (\exp -> infixOp exp ">>="
                                 $ Lambda () [hspvar v] (hsvar k)) hsexp
         k = uniqIdentifier "go" (compFree ret)
     return $ fmap (\exp -> Lambda () [hspvar k] exp) ret
@@ -304,23 +314,19 @@ grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do
                                 fieldlbl = identToString m
                             return x
                                 { comp = Lambda () [hspvar k1]
-                                            $ InfixApp ()
-                                                (App ()
-                                                 (App ()
-                                                    (App ()
-                                                       (hsvar "set")
-                                                       (TypeApp
-                                                          () (TyPromoted () (PromotedString () fieldlbl fieldlbl))))
-                                                    (hsvar v))
-                                                   fieldinit) hsopSeq (hsvar k1)
+                                            $ infixOp
+                                                (App () (App () (App () (hsvar "set")
+                                                                   (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl))))
+                                                                (hsvar v))
+                                                        fieldinit) ">>" (hsvar k1)
                                 }
                     return $ fmap (\exp -> Lambda () [hspvar k2] exp) ret
             let newstruct = Computation
                         { compFree = Map.empty -- todo
                         , compIntro = Map.singleton v ()
                         , comp = Lambda () [hspvar k]
-                            $ InfixApp () (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) hsopBind
-                            $ Lambda () [hspvar v] (hsvar 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
@@ -345,8 +351,8 @@ grokStatement (CBlockStmt (CExpr (Just
         { compFree = Map.singleton fn ()
         , compIntro = Map.singleton v ()
         , comp = Lambda () [hspvar k]
-            $ InfixApp () (hsvar fn) hsopBind
-            $ Lambda () [hspvar v] (hsvar k)
+            $ infixOp (hsvar fn) ">>="
+                $ Lambda () [hspvar v] (hsvar k)
         }
 grokStatement (CBlockStmt (CIf exp (CCompound [] stmts _) Nothing _)) = do
     (xs,x) <- grokExpression exp
@@ -358,6 +364,9 @@ grokStatement (CBlockStmt (CIf exp (CCompound [] stmts _) Nothing _)) = do
         , compIntro = compIntro s
         , comp = Lambda () [hspvar k] $ If () (comp x) (comp s) (hsvar k)
         }
+-- TODO CStatExpr
+-- TODO (CBlockStmt (CExpr Nothing _) -- semicolon
+-- TODO (CBlockStmt (CExpr (Just (CComma exs _) _) _))
 grokStatement (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