diff options
author | Joe Crayne <joe@jerkface.net> | 2019-03-18 21:30:21 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-03-18 21:30:21 -0400 |
commit | a6299c4d8b4dedb5c8f3b83d2caaa69ed025b202 (patch) | |
tree | ae5e1d7b8b458e1a49e898b0e49b9c96f0dbc4b6 /monkeypatch.hs | |
parent | 1541cb7d36aa8aff07ac4a45fa467e131408c8df (diff) |
Initialize record fields.
Diffstat (limited to 'monkeypatch.hs')
-rw-r--r-- | monkeypatch.hs | 38 |
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 () "$")) | |||
160 | 160 | ||
161 | hsopBind = QVarOp () (UnQual () (Symbol () ">>=")) | 161 | hsopBind = QVarOp () (UnQual () (Symbol () ">>=")) |
162 | 162 | ||
163 | hsopSeq = QVarOp () (UnQual () (Symbol () ">>")) | ||
164 | |||
163 | hsopNeq = QVarOp () (UnQual () (Symbol () "/=")) | 165 | hsopNeq = QVarOp () (UnQual () (Symbol () "/=")) |
164 | 166 | ||
165 | hsopUnit = HS.Con () (Special () (UnitCon ())) | 167 | hsopUnit = HS.Con () (Special () (UnitCon ())) |
@@ -263,18 +265,48 @@ grokInitialization _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do | |||
263 | return $ fmap (\exp -> Lambda () [hspvar k] exp) ret | 265 | return $ fmap (\exp -> Lambda () [hspvar k] exp) ret |
264 | grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do | 266 | grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do |
265 | let v = identToString cv0 | 267 | let v = identToString cv0 |
266 | let k = uniqIdentifier "go" (varmap [v]) | 268 | -- let k = uniqIdentifier "go" (varmap [v]) |
267 | case lefts $ concatMap hsTypeSpec ts of | 269 | case lefts $ concatMap hsTypeSpec ts of |
268 | (ident:_) -> | 270 | (ident:_) -> do |
269 | -- TODO: intialize fields. | 271 | -- TODO: intialize fields. |
270 | let hident = HS.Ident () $ capitalize $ identToString ident | 272 | let hident = HS.Ident () $ capitalize $ identToString ident |
271 | in return Computation | 273 | gs <- do |
274 | forM exps $ \(ms,initexpr) -> do | ||
275 | case initexpr of | ||
276 | CInitExpr ie _ -> grokExpression ie >>= \g -> return (ms,g) | ||
277 | _ -> Nothing | ||
278 | let assigns = do | ||
279 | (ms,(ss,x)) <- gs | ||
280 | let k2 = uniqIdentifier "gopoo" (compFree ret) | ||
281 | ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k2)) (ss ++ cs) | ||
282 | cs = do | ||
283 | CMemberDesig m _ <- ms | ||
284 | let k1 = uniqIdentifier "go" (compFree x) | ||
285 | fieldinit = comp x | ||
286 | fieldlbl = identToString m | ||
287 | return x | ||
288 | { comp = Lambda () [hspvar k1] | ||
289 | $ InfixApp () | ||
290 | (App () | ||
291 | (App () | ||
292 | (App () | ||
293 | (hsvar "set") | ||
294 | (TypeApp | ||
295 | () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) | ||
296 | (hsvar v)) | ||
297 | fieldinit) hsopSeq (hsvar k1) | ||
298 | } | ||
299 | return $ fmap (\exp -> Lambda () [hspvar k2] exp) ret | ||
300 | let newstruct = Computation | ||
272 | { compFree = Map.empty -- todo | 301 | { compFree = Map.empty -- todo |
273 | , compIntro = Map.singleton v () | 302 | , compIntro = Map.singleton v () |
274 | , comp = Lambda () [hspvar k] | 303 | , comp = Lambda () [hspvar k] |
275 | $ InfixApp () (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) hsopBind | 304 | $ InfixApp () (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) hsopBind |
276 | $ Lambda () [hspvar v] (hsvar k) | 305 | $ Lambda () [hspvar v] (hsvar k) |
277 | } | 306 | } |
307 | k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO | ||
308 | ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns | ||
309 | return $ fmap (\exp -> Lambda () [hspvar k] exp) ret | ||
278 | _ -> Nothing | 310 | _ -> Nothing |
279 | grokInitialization _ _ = Nothing | 311 | grokInitialization _ _ = Nothing |
280 | 312 | ||