Initialize record fields.

1 files changed, 35 insertions, 3 deletions

diff --git a/monkeypatch.hs b/monkeypatch.hs
index d39ec98..90299ed 100644
--- a/monkeypatch.hs
+++ b/monkeypatch.hs
@@ -160,6 +160,8 @@ hsopApp = QVarOp () (UnQual () (Symbol () "$"))
 
 hsopBind = QVarOp () (UnQual () (Symbol () ">>="))
 
+hsopSeq = QVarOp () (UnQual () (Symbol () ">>"))
+
 hsopNeq = QVarOp () (UnQual () (Symbol () "/="))
 
 hsopUnit = HS.Con () (Special () (UnitCon ()))
@@ -263,18 +265,48 @@ grokInitialization _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do
     return $ fmap (\exp -> Lambda () [hspvar k] exp) ret
 grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do
     let v = identToString cv0
-    let k = uniqIdentifier "go" (varmap [v])
+    -- let k = uniqIdentifier "go" (varmap [v])
     case lefts $ concatMap hsTypeSpec ts of
-        (ident:_) ->
+        (ident:_) -> do
             -- TODO: intialize fields.
             let hident = HS.Ident () $ capitalize $ identToString ident
-            in return Computation
+            gs <- do
+                forM exps $ \(ms,initexpr) -> do
+                    case initexpr of
+                        CInitExpr ie _ -> grokExpression ie >>= \g -> return (ms,g)
+                        _              -> Nothing
+            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)
+                        cs = do
+                            CMemberDesig m _ <- ms
+                            let k1 = uniqIdentifier "go" (compFree x)
+                                fieldinit = comp x
+                                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)
+                                }
+                    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)
                         }
+                k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO
+                ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns
+            return $ fmap (\exp -> Lambda () [hspvar k] exp) ret
         _ -> Nothing
 grokInitialization _ _ = Nothing