diff options
author | Joe Crayne <joe@jerkface.net> | 2019-03-23 22:00:58 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-03-23 22:00:58 -0400 |
commit | 30799e391ddfa9ca56289b3f300c373a727171d9 (patch) | |
tree | 06b7a073655a2153f407e8d81c9eba0615148cca /monkeypatch.hs | |
parent | 53bcb23e6a57fed66da8e3cd1a388ac6ab29cc4e (diff) |
compContinue field.
Diffstat (limited to 'monkeypatch.hs')
-rw-r--r-- | monkeypatch.hs | 122 |
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 [] _) _) | |||
150 | transField _ = [] | 150 | transField _ = [] |
151 | 151 | ||
152 | data Computation st = Computation | 152 | data Computation st = Computation |
153 | { compFree :: Map String () | 153 | { compFree :: Map String () |
154 | , compIntro :: Map String () | 154 | , compIntro :: Map String () |
155 | , comp :: st | 155 | , compContinue :: Maybe String |
156 | -- ^ The identifier name currently used to indicate the "continue;" | ||
157 | -- statement. | ||
158 | , comp :: st | ||
156 | } | 159 | } |
157 | deriving (Eq,Ord,Functor) | 160 | deriving (Eq,Ord,Functor) |
158 | 161 | ||
162 | mkcomp :: x -> Computation x | ||
163 | mkcomp x = Computation Map.empty Map.empty Nothing x | ||
164 | |||
159 | hsvar :: String -> HS.Exp () | 165 | hsvar :: String -> HS.Exp () |
160 | hsvar v = Var () (UnQual () (HS.Ident () v)) | 166 | hsvar v = Var () (UnQual () (HS.Ident () v)) |
161 | 167 | ||
@@ -190,11 +196,12 @@ applyComputation a@Computation{ comp = FormalLambda govar exp } b = | |||
190 | in case listify matchgo exp of | 196 | in case listify matchgo exp of |
191 | (_:_:_) -> error "TODO: Multiple go-refs; make let binding." | 197 | (_:_:_) -> error "TODO: Multiple go-refs; make let binding." |
192 | _ -> Computation | 198 | _ -> Computation |
193 | { compFree = Map.union (compFree a) (compFree b) Map.\\ compIntro a | 199 | { compFree = Map.union (compFree a) (compFree b) Map.\\ compIntro a |
194 | , compIntro = compIntro a `Map.union` compIntro b | 200 | , compIntro = compIntro a `Map.union` compIntro b |
195 | , comp = let subst x | matchgo x = comp b | 201 | , compContinue = Nothing |
196 | | otherwise = x | 202 | , comp = let subst x | matchgo x = comp b |
197 | in everywhere (mkT subst) exp | 203 | | otherwise = x |
204 | in everywhere (mkT subst) exp | ||
198 | } | 205 | } |
199 | 206 | ||
200 | varmap :: [String] -> Map String () | 207 | varmap :: [String] -> Map String () |
@@ -288,33 +295,24 @@ grokExpression fe (CVar cv _) = | |||
288 | if isGlobalRef fe v | 295 | if isGlobalRef fe v |
289 | then let k = uniqIdentifier "go" (varmap [v,hv]) | 296 | then let k = uniqIdentifier "go" (varmap [v,hv]) |
290 | s = Computation | 297 | s = Computation |
291 | { compFree = Map.singleton v () | 298 | { compFree = Map.singleton v () |
292 | , compIntro = Map.singleton hv () | 299 | , compIntro = Map.singleton hv () |
293 | , comp = FormalLambda k | 300 | , compContinue = Nothing |
294 | $ infixOp (App () (hsvar "peek") (hsvar v)) ">>=" | 301 | , comp = FormalLambda k |
295 | $ Lambda () [hspvar hv] (hsvar k) | 302 | $ infixOp (App () (hsvar "peek") (hsvar v)) ">>=" |
303 | $ Lambda () [hspvar hv] (hsvar k) | ||
296 | } | 304 | } |
297 | hv = "v" ++ v | 305 | hv = "v" ++ v |
298 | in (,) [s] Computation | 306 | in (,) [s] (mkcomp $ hsvar hv) |
299 | { compFree = Map.singleton hv () | 307 | { compFree = Map.singleton hv () |
300 | , compIntro = Map.empty | ||
301 | , comp = hsvar hv | ||
302 | } | 308 | } |
303 | else (,) [] $ Computation | 309 | else (,) [] $ (mkcomp $ hsvar v) |
304 | { compFree = Map.singleton (identToString cv) () | 310 | { compFree = Map.singleton (identToString cv) () |
305 | , compIntro = Map.empty | ||
306 | , comp = hsvar v | ||
307 | } | 311 | } |
308 | grokExpression fe (CConst (CIntConst n _)) = Just $ (,) [] $ Computation | 312 | grokExpression fe (CConst (CIntConst n _)) = |
309 | { compFree = Map.empty | 313 | Just $ (,) [] $ mkcomp $ Lit () (Int () (getCInteger n) (show n)) |
310 | , compIntro = Map.empty | 314 | grokExpression fe (CConst (CStrConst s _)) = |
311 | , comp = Lit () (Int () (getCInteger n) (show n)) | 315 | Just $ (,) [] $ mkcomp $ Lit () (HS.String () (getCString s) (getCString s)) |
312 | } | ||
313 | grokExpression fe (CConst (CStrConst s _)) = Just $ (,) [] $ Computation | ||
314 | { compFree = Map.empty | ||
315 | , compIntro = Map.empty | ||
316 | , comp = Lit () (HS.String () (getCString s) (getCString s)) | ||
317 | } | ||
318 | grokExpression fe (CBinary op a b _) = do | 316 | grokExpression fe (CBinary op a b _) = do |
319 | (as,ca) <- grokExpression fe a | 317 | (as,ca) <- grokExpression fe a |
320 | (bs0,cb0) <- grokExpression fe b | 318 | (bs0,cb0) <- grokExpression fe b |
@@ -325,10 +323,8 @@ grokExpression fe (CBinary op a b _) = do | |||
325 | | otherwise = infixOp | 323 | | otherwise = infixOp |
326 | -- trace ("intros("++hop++"): "++show (foldr Map.union Map.empty $ map compIntro as)) $ return () | 324 | -- trace ("intros("++hop++"): "++show (foldr Map.union Map.empty $ map compIntro as)) $ return () |
327 | -- TODO: Short-circuit boolean evaluation side-effects. | 325 | -- TODO: Short-circuit boolean evaluation side-effects. |
328 | return $ (,) ss $ Computation | 326 | return $ (,) ss $ (mkcomp $ infx (comp ca) hop (comp cb)) |
329 | { compFree = compFree ca `Map.union` compFree cb | 327 | { compFree = compFree ca `Map.union` compFree cb |
330 | , compIntro = Map.empty | ||
331 | , comp = infx (comp ca) hop (comp cb) | ||
332 | } | 328 | } |
333 | grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do | 329 | grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do |
334 | let cv = identToString cv0 | 330 | let cv = identToString cv0 |
@@ -337,15 +333,14 @@ grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do | |||
337 | ss = pure Computation | 333 | ss = pure Computation |
338 | { compFree = Map.singleton cv () | 334 | { compFree = Map.singleton cv () |
339 | , compIntro = Map.singleton hv () | 335 | , compIntro = Map.singleton hv () |
336 | , compContinue = Nothing | ||
340 | , comp = FormalLambda k | 337 | , comp = FormalLambda k |
341 | $ infixFn (hsvar cv) | 338 | $ infixFn (hsvar cv) |
342 | "withPointer" | 339 | "withPointer" |
343 | (Lambda () [hspvar hv] (hsvar k)) | 340 | (Lambda () [hspvar hv] (hsvar k)) |
344 | } | 341 | } |
345 | return $ (,) ss Computation | 342 | return $ (,) ss (mkcomp $ hsvar hv) |
346 | { compFree = Map.singleton hv () | 343 | { compFree = Map.singleton hv () |
347 | , compIntro = Map.empty | ||
348 | , comp = hsvar hv | ||
349 | } | 344 | } |
350 | grokExpression fe (CCond cond (Just thn) els _) = do | 345 | grokExpression fe (CCond cond (Just thn) els _) = do |
351 | (cs,c) <- grokExpression fe cond | 346 | (cs,c) <- grokExpression fe cond |
@@ -364,10 +359,8 @@ grokExpression fe (CCast (CDecl [ CTypeSpec (CVoidType _) ] | |||
364 | [ ( Just (CDeclr Nothing [ CPtrDeclr [] _ ] Nothing [] _) , Nothing , Nothing) ] | 359 | [ ( Just (CDeclr Nothing [ CPtrDeclr [] _ ] Nothing [] _) , Nothing , Nothing) ] |
365 | _) | 360 | _) |
366 | (CConst (CIntConst zero _)) _) | 0 <- getCInteger zero = do | 361 | (CConst (CIntConst zero _)) _) | 0 <- getCInteger zero = do |
367 | return $ (,) [] Computation | 362 | return $ (,) [] (mkcomp $ hsvar "nullPtr") |
368 | { compFree = Map.singleton "nullPtr" () | 363 | { compFree = Map.singleton "nullPtr" () |
369 | , compIntro = Map.empty | ||
370 | , comp = hsvar "nullPtr" | ||
371 | } | 364 | } |
372 | grokExpression fe (CComma exps _) = do | 365 | grokExpression fe (CComma exps _) = do |
373 | gs <- mapM (grokExpression fe) exps | 366 | gs <- mapM (grokExpression fe) exps |
@@ -381,7 +374,7 @@ grokExpression fe (CComma exps _) = do | |||
381 | k = uniqIdentifier "go" (compFree s) | 374 | k = uniqIdentifier "go" (compFree s) |
382 | s' = fmap (\x -> FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar k)))) s | 375 | s' = fmap (\x -> FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar k)))) s |
383 | -- TODO: It would be cleaner if I could return only a statement and not an expression. | 376 | -- TODO: It would be cleaner if I could return only a statement and not an expression. |
384 | return ([s'],Computation (Map.singleton hv ()) Map.empty (hsvar hv)) | 377 | return $ (,) [s'] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } |
385 | grokExpression fe (C.CCall (CVar fn _) exps _) = do | 378 | grokExpression fe (C.CCall (CVar fn _) exps _) = do |
386 | gs <- mapM (grokExpression fe) exps | 379 | gs <- mapM (grokExpression fe) exps |
387 | let ss = concatMap fst gs -- TODO: resolve variable name conflicts | 380 | let ss = concatMap fst gs -- TODO: resolve variable name conflicts |
@@ -392,14 +385,13 @@ grokExpression fe (C.CCall (CVar fn _) exps _) = do | |||
392 | s = Computation | 385 | s = Computation |
393 | { compFree = frees | 386 | { compFree = frees |
394 | , compIntro = Map.singleton hv () | 387 | , compIntro = Map.singleton hv () |
388 | , compContinue = Nothing | ||
395 | , comp = FormalLambda k | 389 | , comp = FormalLambda k |
396 | $ infixOp cll ">>=" | 390 | $ infixOp cll ">>=" |
397 | $ Lambda () [hspvar hv] (hsvar k) | 391 | $ Lambda () [hspvar hv] (hsvar k) |
398 | } | 392 | } |
399 | return $ (,) (ss++[s]) Computation | 393 | return $ (,) (ss++[s]) (mkcomp $ hsvar hv) |
400 | { compFree = Map.singleton hv () | 394 | { compFree = Map.singleton hv () |
401 | , compIntro = Map.empty | ||
402 | , comp = hsvar hv | ||
403 | } | 395 | } |
404 | grokExpression fe (CStatExpr (CCompound idents xs _) _) = do | 396 | grokExpression fe (CStatExpr (CCompound idents xs _) _) = do |
405 | let (y,ys) = splitAt 1 (reverse xs) | 397 | let (y,ys) = splitAt 1 (reverse xs) |
@@ -407,21 +399,20 @@ grokExpression fe (CStatExpr (CCompound idents xs _) _) = do | |||
407 | [CBlockStmt (CExpr mexp ni)] -> Just $ CBlockStmt (CReturn mexp ni) | 399 | [CBlockStmt (CExpr mexp ni)] -> Just $ CBlockStmt (CReturn mexp ni) |
408 | _ -> Just (head y) -- Nothing FIXME | 400 | _ -> Just (head y) -- Nothing FIXME |
409 | gs <- mapM (grokStatement fe) (reverse $ y' : ys) | 401 | gs <- mapM (grokStatement fe) (reverse $ y' : ys) |
410 | let s0 = foldr applyComputation (Computation Map.empty Map.empty retUnit) gs | 402 | let s0 = foldr applyComputation (mkcomp retUnit) gs |
411 | s1 = fmap (\xp -> Paren () xp) s0 | 403 | s1 = fmap (\xp -> Paren () xp) s0 |
412 | hv = uniqIdentifier "ret" (compFree s1) | 404 | hv = uniqIdentifier "ret" (compFree s1) |
413 | k = uniqIdentifier "go" (compFree s1) | 405 | k = uniqIdentifier "go" (compFree s1) |
414 | s = Computation | 406 | s = Computation |
415 | { compFree = compFree s1 | 407 | { compFree = compFree s1 |
416 | , compIntro = Map.singleton hv () | 408 | , compIntro = Map.singleton hv () |
409 | , compContinue = Nothing | ||
417 | , comp = FormalLambda k | 410 | , comp = FormalLambda k |
418 | $ infixOp (comp s1) ">>=" | 411 | $ infixOp (comp s1) ">>=" |
419 | $ Lambda () [hspvar hv] (hsvar k) | 412 | $ Lambda () [hspvar hv] (hsvar k) |
420 | } | 413 | } |
421 | return $ (,) [s] Computation | 414 | return $ (,) [s] (mkcomp $ hsvar hv) |
422 | { compFree = Map.singleton hv () | 415 | { compFree = Map.singleton hv () |
423 | , compIntro = Map.empty | ||
424 | , comp = hsvar hv | ||
425 | } | 416 | } |
426 | grokExpression fe (CAssign CAssignOp cvar expr _) = do | 417 | grokExpression fe (CAssign CAssignOp cvar expr _) = do |
427 | v <- cvarName cvar | 418 | v <- cvarName cvar |
@@ -433,11 +424,7 @@ grokExpression fe (CAssign CAssignOp cvar expr _) = do | |||
433 | $ infixOp (App () (hsvar "return") (comp x)) ">>=" | 424 | $ infixOp (App () (hsvar "return") (comp x)) ">>=" |
434 | $ Lambda () [hspvar v] (hsvar k) | 425 | $ Lambda () [hspvar v] (hsvar k) |
435 | } | 426 | } |
436 | return $ (,) (ss ++ [s]) Computation | 427 | return $ (,) (ss ++ [s]) $ mkcomp (hsvar v) |
437 | { compFree = Map.empty | ||
438 | , compIntro = Map.empty | ||
439 | , comp = hsvar v | ||
440 | } | ||
441 | grokExpression fe _ = Nothing | 428 | grokExpression fe _ = Nothing |
442 | 429 | ||
443 | 430 | ||
@@ -470,7 +457,7 @@ grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = d | |||
470 | let assigns = do | 457 | let assigns = do |
471 | (ms,(ss,x)) <- gs | 458 | (ms,(ss,x)) <- gs |
472 | let k2 = uniqIdentifier "gopoo" (compFree ret) | 459 | let k2 = uniqIdentifier "gopoo" (compFree ret) |
473 | ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k2)) (ss ++ cs) | 460 | ret = foldr applyComputation (mkcomp $ hsvar k2) (ss ++ cs) |
474 | cs = do | 461 | cs = do |
475 | CMemberDesig m _ <- ms | 462 | CMemberDesig m _ <- ms |
476 | let k1 = uniqIdentifier "go" (compFree x) | 463 | let k1 = uniqIdentifier "go" (compFree x) |
@@ -488,12 +475,13 @@ grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = d | |||
488 | let newstruct = Computation | 475 | let newstruct = Computation |
489 | { compFree = Map.empty -- todo | 476 | { compFree = Map.empty -- todo |
490 | , compIntro = Map.singleton v () | 477 | , compIntro = Map.singleton v () |
478 | , compContinue = Nothing | ||
491 | , comp = FormalLambda k | 479 | , comp = FormalLambda k |
492 | $ infixOp (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) ">>=" | 480 | $ infixOp (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) ">>=" |
493 | $ Lambda () [hspvar v] (hsvar k) | 481 | $ Lambda () [hspvar v] (hsvar k) |
494 | } | 482 | } |
495 | k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO | 483 | k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO |
496 | ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns | 484 | ret = foldr applyComputation (mkcomp $ hsvar k) $ newstruct : assigns |
497 | return $ fmap (FormalLambda k) ret | 485 | return $ fmap (FormalLambda k) ret |
498 | _ -> Nothing | 486 | _ -> Nothing |
499 | grokInitialization _ _ _ = Nothing | 487 | grokInitialization _ _ _ = Nothing |
@@ -515,7 +503,7 @@ grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do | |||
515 | x' = fmap (\y -> App () (hsvar "return") $ promote (fnArgs fe) y) x | 503 | x' = fmap (\y -> App () (hsvar "return") $ promote (fnArgs fe) y) x |
516 | return $ fmap (\y -> FormalLambda k y) $ foldr applyComputation x' xs | 504 | return $ fmap (\y -> FormalLambda k y) $ foldr applyComputation x' xs |
517 | grokStatement fe (CBlockStmt (CReturn Nothing _)) = | 505 | grokStatement fe (CBlockStmt (CReturn Nothing _)) = |
518 | Just $ Computation Map.empty Map.empty $ FormalLambda "go" retUnit | 506 | Just $ mkcomp $ FormalLambda "go" retUnit |
519 | grokStatement fe (CBlockStmt (CIf exp thn els _)) = do | 507 | grokStatement fe (CBlockStmt (CIf exp thn els _)) = do |
520 | (xs,x) <- grokExpression fe exp | 508 | (xs,x) <- grokExpression fe exp |
521 | let mkif0 = If () (comp x) | 509 | let mkif0 = If () (comp x) |
@@ -534,17 +522,18 @@ grokStatement fe (CBlockStmt (CIf exp thn els _)) = do | |||
534 | _ -> trace ("Unhandled if: "++show (fmap (const LT) thn)) $ Nothing -- TODO | 522 | _ -> trace ("Unhandled if: "++show (fmap (const LT) thn)) $ Nothing -- TODO |
535 | 523 | ||
536 | ss <- sequence $ map (grokStatement fe) stmts | 524 | ss <- sequence $ map (grokStatement fe) stmts |
537 | let s = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) ss | 525 | let s = foldr applyComputation (mkcomp $ hsvar k) ss |
538 | k = uniqIdentifier "go" (Map.union (compFree x) (compFree s)) | 526 | k = uniqIdentifier "go" (Map.union (compFree x) (compFree s)) |
539 | return $ fmap (FormalLambda k) $ flip (foldr applyComputation) xs Computation | 527 | return $ fmap (FormalLambda k) $ flip (foldr applyComputation) xs Computation |
540 | { compFree = compFree x `Map.union` compFree s | 528 | { compFree = compFree x `Map.union` compFree s |
541 | , compIntro = compIntro s | 529 | , compIntro = compIntro s |
530 | , compContinue = Nothing | ||
542 | , comp = mkif (comp s) (hsvar k) | 531 | , comp = mkif (comp s) (hsvar k) |
543 | } | 532 | } |
544 | grokStatement fe (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail" _ _) _) xs _)) _)) = do | 533 | grokStatement fe (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail" _ _) _) xs _)) _)) = do |
545 | x <- case xs of | 534 | x <- case xs of |
546 | (CConst (CStrConst msg _):_) -> let s = getCString msg | 535 | (CConst (CStrConst msg _):_) -> let s = getCString msg |
547 | in Just $ Computation Map.empty Map.empty (Lit () (HS.String () s s)) | 536 | in Just $ mkcomp $ Lit () (HS.String () s s) |
548 | _ -> Nothing | 537 | _ -> Nothing |
549 | let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x) | 538 | let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x) |
550 | x' = fmap (\y -> App () (hsvar "error") y) x | 539 | x' = fmap (\y -> App () (hsvar "error") y) x |
@@ -573,11 +562,7 @@ grokStatement fe (CBlockStmt (CExpr (Just | |||
573 | cll = foldl (App ()) (hsvar fn) $ map (comp . snd) gs | 562 | cll = foldl (App ()) (hsvar fn) $ map (comp . snd) gs |
574 | frees = foldr Map.union (Map.singleton fn ()) (map (compFree . snd) gs) | 563 | frees = foldr Map.union (Map.singleton fn ()) (map (compFree . snd) gs) |
575 | x = foldr applyComputation s $ concatMap fst gs | 564 | x = foldr applyComputation s $ concatMap fst gs |
576 | s = Computation | 565 | s = (mkcomp $ infixOp cll ">>" (hsvar k)) { compFree = frees } |
577 | { compFree = frees | ||
578 | , compIntro = Map.empty | ||
579 | , comp = infixOp cll ">>" (hsvar k) | ||
580 | } | ||
581 | return $ fmap (FormalLambda k) x | 566 | return $ fmap (FormalLambda k) x |
582 | grokStatement fe (CBlockStmt (CExpr (Just | 567 | grokStatement fe (CBlockStmt (CExpr (Just |
583 | (CAssign CAssignOp cvarnew | 568 | (CAssign CAssignOp cvarnew |
@@ -588,6 +573,7 @@ grokStatement fe (CBlockStmt (CExpr (Just | |||
588 | return Computation | 573 | return Computation |
589 | { compFree = Map.singleton fn () | 574 | { compFree = Map.singleton fn () |
590 | , compIntro = Map.singleton v () | 575 | , compIntro = Map.singleton v () |
576 | , compContinue = Nothing | ||
591 | , comp = FormalLambda k | 577 | , comp = FormalLambda k |
592 | $ infixOp (hsvar fn) ">>=" | 578 | $ infixOp (hsvar fn) ">>=" |
593 | $ Lambda () [hspvar v] (hsvar k) | 579 | $ Lambda () [hspvar v] (hsvar k) |
@@ -599,6 +585,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 | |||
599 | return Computation | 585 | return Computation |
600 | { compFree = varmap [v] | 586 | { compFree = varmap [v] |
601 | , compIntro = Map.empty | 587 | , compIntro = Map.empty |
588 | , compContinue = Nothing | ||
602 | , comp = FormalLambda k1 | 589 | , comp = FormalLambda k1 |
603 | $ infixOp | 590 | $ infixOp |
604 | (App () (App () (App () (hsvar "modify") | 591 | (App () (App () (App () (hsvar "modify") |
@@ -616,7 +603,7 @@ grokStatement fe (CBlockStmt (CExpr (Just expr) _)) = do | |||
616 | return $ fmap (FormalLambda k) $ foldr applyComputation g ss | 603 | return $ fmap (FormalLambda k) $ foldr applyComputation g ss |
617 | -} | 604 | -} |
618 | grokStatement fe (CBlockStmt (CExpr mexpr _)) = do | 605 | grokStatement fe (CBlockStmt (CExpr mexpr _)) = do |
619 | (ss,pre) <- maybe (Just $ (,) [] $ Computation Map.empty Map.empty id) | 606 | (ss,pre) <- maybe (Just $ (,) [] $ mkcomp id) |
620 | (fmap (second (fmap (\e -> infixFn e "seq"))) . grokExpression fe) mexpr | 607 | (fmap (second (fmap (\e -> infixFn e "seq"))) . grokExpression fe) mexpr |
621 | let k = uniqIdentifier "go" (compFree s) | 608 | let k = uniqIdentifier "go" (compFree s) |
622 | s = foldr applyComputation (fmap ($ hsvar k) pre) ss | 609 | s = foldr applyComputation (fmap ($ hsvar k) pre) ss |
@@ -625,16 +612,11 @@ grokStatement fe (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do | |||
625 | -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of | 612 | -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of |
626 | -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of | 613 | -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of |
627 | case mapMaybe (\(i,inits,_) -> fmap ((,) i) inits) (v:vs) of | 614 | case mapMaybe (\(i,inits,_) -> fmap ((,) i) inits) (v:vs) of |
628 | [] -> | 615 | [] -> return $ mkcomp $ FormalLambda "go" $ hsvar "go" |
629 | return Computation | ||
630 | { compFree = Map.empty | ||
631 | , compIntro = Map.empty | ||
632 | , comp = FormalLambda "go" $ hsvar "go" | ||
633 | } | ||
634 | initials -> do | 616 | initials -> do |
635 | gs <- mapM (grokInitialization fe $ t:ts) initials | 617 | gs <- mapM (grokInitialization fe $ t:ts) initials |
636 | return $ fmap (FormalLambda "go") | 618 | return $ fmap (FormalLambda "go") |
637 | $ foldr applyComputation (Computation Map.empty Map.empty (hsvar "go")) gs | 619 | $ foldr applyComputation (mkcomp $ hsvar "go") gs |
638 | grokStatement fe _ = Nothing | 620 | grokStatement fe _ = Nothing |
639 | 621 | ||
640 | isFunctionDecl :: CExternalDeclaration a -> Bool | 622 | isFunctionDecl :: CExternalDeclaration a -> Bool |
@@ -767,7 +749,7 @@ transpile o fname incs (CTranslUnit edecls _) = do | |||
767 | else do | 749 | else do |
768 | let mhask = do | 750 | let mhask = do |
769 | xs <- mapM (grokStatement fe) bdy | 751 | xs <- mapM (grokStatement fe) bdy |
770 | return $ foldr applyComputation (Computation Map.empty Map.empty retUnit) xs | 752 | return $ foldr applyComputation (mkcomp retUnit) xs |
771 | case mhask of | 753 | case mhask of |
772 | Just hask -> do printHeader | 754 | Just hask -> do printHeader |
773 | mapM_ (putStrLn . (" "++)) $ lines $ HS.prettyPrint $ applyDoSyntax' o $ comp hask | 755 | mapM_ (putStrLn . (" "++)) $ lines $ HS.prettyPrint $ applyDoSyntax' o $ comp hask |