diff options
Diffstat (limited to 'monkeypatch.hs')
-rw-r--r-- | monkeypatch.hs | 159 |
1 files changed, 80 insertions, 79 deletions
diff --git a/monkeypatch.hs b/monkeypatch.hs index ceeaf25..5ef58da 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs | |||
@@ -201,7 +201,7 @@ infixOp x op y = InfixApp () x (QVarOp () (UnQual () (Symbol () op))) y | |||
201 | infixFn :: HS.Exp () -> String -> HS.Exp () -> HS.Exp () | 201 | infixFn :: HS.Exp () -> String -> HS.Exp () -> HS.Exp () |
202 | infixFn x fn y = InfixApp () x (QVarOp () (UnQual () (HS.Ident () fn))) y | 202 | infixFn x fn y = InfixApp () x (QVarOp () (UnQual () (HS.Ident () fn))) y |
203 | 203 | ||
204 | data FormalLambda = FormalLambda { formGo :: String | 204 | data FormalLambda = FormalLambda { formGo :: Unique |
205 | , formExp :: HS.Exp () | 205 | , formExp :: HS.Exp () |
206 | } | 206 | } |
207 | 207 | ||
@@ -215,18 +215,17 @@ modifyOperand1 :: (HS.Exp l -> HS.Exp l) -> HS.Exp l -> HS.Exp l | |||
215 | modifyOperand1 f (InfixApp l x op y) = InfixApp l (f x) op y | 215 | modifyOperand1 f (InfixApp l x op y) = InfixApp l (f x) op y |
216 | 216 | ||
217 | informalize :: FormalLambda -> HS.Exp () | 217 | informalize :: FormalLambda -> HS.Exp () |
218 | informalize (FormalLambda k x) = Lambda () [hspvar k] x | 218 | informalize (FormalLambda k x) = Lambda () [uniquePattern k] x |
219 | 219 | ||
220 | 220 | ||
221 | factorOutFunction :: String -- ^ New function name to factor out. | 221 | factorOutFunction :: String -- ^ New function name to factor out. |
222 | -> [String] -- ^ Arguments to function. | 222 | -> [String] -- ^ Arguments to function. |
223 | -> HS.Exp () -- ^ Body of function. | 223 | -> HS.Exp () -- ^ Body of function. |
224 | -> String -- ^ Variable name place holder for call sites in template. | 224 | -> HS.Exp () -- ^ Variable name place holder for call sites in template. |
225 | -> HS.Exp () -- ^ Template containing place-holder call sites. | 225 | -> HS.Exp () -- ^ Template containing place-holder call sites. |
226 | -> HS.Exp () | 226 | -> HS.Exp () |
227 | factorOutFunction k vs bdy govar expr = | 227 | factorOutFunction k vs bdy govar expr = |
228 | let matchgo (Var () (UnQual () (HS.Ident () v))) = v==govar | 228 | let matchgo v = v==govar |
229 | matchgo _ = False | ||
230 | subst x | matchgo x = callsite | 229 | subst x | matchgo x = callsite |
231 | | otherwise = x | 230 | | otherwise = x |
232 | callsite = foldl (App ()) (hsvar k) $ map hsvar vs | 231 | callsite = foldl (App ()) (hsvar k) $ map hsvar vs |
@@ -245,14 +244,13 @@ multiwayContinuation a@Computation{ comp = FormalLambda govar exp } b = | |||
245 | { compFree = Map.union (compFree a) (compFree b) Map.\\ compIntro a | 244 | { compFree = Map.union (compFree a) (compFree b) Map.\\ compIntro a |
246 | , compIntro = compIntro a `Map.union` compIntro b | 245 | , compIntro = compIntro a `Map.union` compIntro b |
247 | , compContinue = Nothing | 246 | , compContinue = Nothing |
248 | , comp = factorOutFunction k vs (comp b) govar exp | 247 | , comp = factorOutFunction k vs (comp b) (uniqueSymbol govar) exp |
249 | } | 248 | } |
250 | 249 | ||
251 | 250 | ||
252 | applyComputation :: Computation FormalLambda -> Computation (HS.Exp ()) -> Computation (HS.Exp ()) | 251 | applyComputation :: Computation FormalLambda -> Computation (HS.Exp ()) -> Computation (HS.Exp ()) |
253 | applyComputation a@Computation{ comp = FormalLambda govar exp } b = | 252 | applyComputation a@Computation{ comp = FormalLambda govar exp } b = |
254 | let matchgo (Var () (UnQual () (HS.Ident () v))) = v==govar | 253 | let matchgo v = v==uniqueSymbol govar |
255 | matchgo _ = False | ||
256 | in case listify matchgo exp of | 254 | in case listify matchgo exp of |
257 | (_:_:_) -> multiwayContinuation a b | 255 | (_:_:_) -> multiwayContinuation a b |
258 | _ -> Computation | 256 | _ -> Computation |
@@ -349,24 +347,24 @@ isGlobalRef fe sym = fromMaybe False $ do | |||
349 | grokExpression :: FunctionEnvironment | 347 | grokExpression :: FunctionEnvironment |
350 | -> CExpression a | 348 | -> CExpression a |
351 | -> StateT UniqueFactory Maybe ([Computation FormalLambda], Computation (HS.Exp ())) | 349 | -> StateT UniqueFactory Maybe ([Computation FormalLambda], Computation (HS.Exp ())) |
352 | grokExpression fe (CVar cv _) = | 350 | grokExpression fe (CVar cv _) = do |
353 | let v = identToString cv | 351 | let v = identToString cv |
354 | in return $ | 352 | if isGlobalRef fe v |
355 | if isGlobalRef fe v | 353 | then do |
356 | then let k = uniqIdentifier "go" (varmap [v,hv]) | 354 | k <- StateT $ return . genUnique |
357 | s = Computation | 355 | let s = Computation |
358 | { compFree = Map.singleton v () | 356 | { compFree = Map.singleton v () |
359 | , compIntro = Map.singleton hv () | 357 | , compIntro = Map.singleton hv () |
360 | , compContinue = Nothing | 358 | , compContinue = Nothing |
361 | , comp = FormalLambda k | 359 | , comp = FormalLambda k |
362 | $ infixOp (App () (hsvar "peek") (hsvar v)) ">>=" | 360 | $ infixOp (App () (hsvar "peek") (hsvar v)) ">>=" |
363 | $ Lambda () [hspvar hv] (hsvar k) | 361 | $ Lambda () [hspvar hv] (uniqueSymbol k) |
364 | } | 362 | } |
365 | hv = "v" ++ v | 363 | hv = "v" ++ v |
366 | in (,) [s] (mkcomp $ hsvar hv) | 364 | return $ (,) [s] (mkcomp $ hsvar hv) |
367 | { compFree = Map.singleton hv () | 365 | { compFree = Map.singleton hv () |
368 | } | 366 | } |
369 | else (,) [] $ (mkcomp $ hsvar v) | 367 | else return $ (,) [] $ (mkcomp $ hsvar v) |
370 | { compFree = Map.singleton (identToString cv) () | 368 | { compFree = Map.singleton (identToString cv) () |
371 | } | 369 | } |
372 | grokExpression fe (CConst (CIntConst n _)) = | 370 | grokExpression fe (CConst (CIntConst n _)) = |
@@ -385,9 +383,9 @@ grokExpression fe (CBinary op a b _) = do | |||
385 | -- TODO: Short-circuit boolean evaluation side-effects. | 383 | -- TODO: Short-circuit boolean evaluation side-effects. |
386 | return $ (,) ss $ infx <$> ca <*> pure hop <*> cb | 384 | return $ (,) ss $ infx <$> ca <*> pure hop <*> cb |
387 | grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do | 385 | grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do |
386 | k <- StateT $ return . genUnique | ||
388 | let cv = identToString cv0 | 387 | let cv = identToString cv0 |
389 | hv = "p" ++ cv | 388 | hv = "p" ++ cv |
390 | k = uniqIdentifier "go" (Map.empty {-todo-}) | ||
391 | ss = pure Computation | 389 | ss = pure Computation |
392 | { compFree = Map.singleton cv () | 390 | { compFree = Map.singleton cv () |
393 | , compIntro = Map.singleton hv () | 391 | , compIntro = Map.singleton hv () |
@@ -395,7 +393,7 @@ grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do | |||
395 | , comp = FormalLambda k | 393 | , comp = FormalLambda k |
396 | $ infixFn (hsvar cv) | 394 | $ infixFn (hsvar cv) |
397 | "withPointer" | 395 | "withPointer" |
398 | (Lambda () [hspvar hv] (hsvar k)) | 396 | (Lambda () [hspvar hv] (uniqueSymbol k)) |
399 | } | 397 | } |
400 | return $ (,) ss (mkcomp $ hsvar hv) | 398 | return $ (,) ss (mkcomp $ hsvar hv) |
401 | { compFree = Map.singleton hv () | 399 | { compFree = Map.singleton hv () |
@@ -422,13 +420,13 @@ grokExpression fe (CComma exps _) = do | |||
422 | gs <- mapM (grokExpression fe) exps | 420 | gs <- mapM (grokExpression fe) exps |
423 | let gs2 = map (\(ss,x) -> foldr applyComputation (App () (hsvar "return") <$> x) ss) gs | 421 | let gs2 = map (\(ss,x) -> foldr applyComputation (App () (hsvar "return") <$> x) ss) gs |
424 | parn e = Paren () e | 422 | parn e = Paren () e |
425 | ps = map (\x -> let k = uniqIdentifier "go" (compFree x) | 423 | ps <- mapM (\x -> do k <- StateT $ return . genUnique |
426 | in fmap (\xx -> FormalLambda k (infixOp (parn xx) ">>" (hsvar k))) x) | 424 | return $ fmap (\xx -> FormalLambda k (infixOp (parn xx) ">>" (uniqueSymbol k))) x) |
427 | (init gs2) | 425 | (init gs2) |
428 | s = foldr applyComputation (last gs2) ps | 426 | let s = foldr applyComputation (last gs2) ps |
429 | hv = "u" | 427 | hv = "u" |
430 | k = uniqIdentifier "go" (compFree s) | 428 | k <- StateT $ return . genUnique |
431 | s' = fmap (\x -> FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar k)))) s | 429 | let s' = fmap (\x -> FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (uniqueSymbol k)))) s |
432 | -- TODO: It would be cleaner if I could return only a statement and not an expression. | 430 | -- TODO: It would be cleaner if I could return only a statement and not an expression. |
433 | return $ (,) [s'] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } | 431 | return $ (,) [s'] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } |
434 | grokExpression fe (C.CCall fn exps u) = grokCall fe True (C.CCall fn exps u) | 432 | grokExpression fe (C.CCall fn exps u) = grokCall fe True (C.CCall fn exps u) |
@@ -441,14 +439,14 @@ grokExpression fe (CStatExpr (CCompound idents xs _) _) = do | |||
441 | let s0 = foldr applyComputation (mkcomp retUnit) gs | 439 | let s0 = foldr applyComputation (mkcomp retUnit) gs |
442 | s1 = fmap (\xp -> Paren () xp) s0 | 440 | s1 = fmap (\xp -> Paren () xp) s0 |
443 | hv = uniqIdentifier "ret" (compFree s1) | 441 | hv = uniqIdentifier "ret" (compFree s1) |
444 | k = uniqIdentifier "go" (compFree s1) | 442 | k <- StateT $ return . genUnique |
445 | s = Computation | 443 | let s = Computation |
446 | { compFree = compFree s1 | 444 | { compFree = compFree s1 |
447 | , compIntro = Map.singleton hv () | 445 | , compIntro = Map.singleton hv () |
448 | , compContinue = Nothing | 446 | , compContinue = Nothing |
449 | , comp = FormalLambda k | 447 | , comp = FormalLambda k |
450 | $ infixOp (comp s1) ">>=" | 448 | $ infixOp (comp s1) ">>=" |
451 | $ Lambda () [hspvar hv] (hsvar k) | 449 | $ Lambda () [hspvar hv] (uniqueSymbol k) |
452 | } | 450 | } |
453 | return $ (,) [s] (mkcomp $ hsvar hv) | 451 | return $ (,) [s] (mkcomp $ hsvar hv) |
454 | { compFree = Map.singleton hv () | 452 | { compFree = Map.singleton hv () |
@@ -456,12 +454,12 @@ grokExpression fe (CStatExpr (CCompound idents xs _) _) = do | |||
456 | grokExpression fe (CAssign CAssignOp cvar expr _) = do | 454 | grokExpression fe (CAssign CAssignOp cvar expr _) = do |
457 | v <- mb $ cvarName cvar | 455 | v <- mb $ cvarName cvar |
458 | (ss,x) <- grokExpression fe expr | 456 | (ss,x) <- grokExpression fe expr |
459 | let k = uniqIdentifier "go" (Map.insert v () $ foldr (\s m -> compFree s `Map.union` compIntro s `Map.union` m) Map.empty ss) | 457 | k <- StateT $ return . genUnique |
460 | s = x | 458 | let s = x |
461 | { compIntro = Map.singleton v () | 459 | { compIntro = Map.singleton v () |
462 | , comp = FormalLambda k | 460 | , comp = FormalLambda k |
463 | $ infixOp (App () (hsvar "return") (comp x)) ">>=" | 461 | $ infixOp (App () (hsvar "return") (comp x)) ">>=" |
464 | $ Lambda () [hspvar v] (hsvar k) | 462 | $ Lambda () [hspvar v] (uniqueSymbol k) |
465 | } | 463 | } |
466 | return $ (,) (ss ++ [s]) $ mkcomp (hsvar v) | 464 | return $ (,) (ss ++ [s]) $ mkcomp (hsvar v) |
467 | grokExpression fe (CMember cvar fld isptr _) = do | 465 | grokExpression fe (CMember cvar fld isptr _) = do |
@@ -472,8 +470,8 @@ grokExpression fe (CMember cvar fld isptr _) = do | |||
472 | (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) | 470 | (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) |
473 | (hsvar v) | 471 | (hsvar v) |
474 | e' = (mkcomp e){ compFree = Map.singleton v () } | 472 | e' = (mkcomp e){ compFree = Map.singleton v () } |
475 | k = uniqIdentifier "go" (varmap [hv,v,fieldlbl]) | 473 | k <- StateT $ return . genUnique |
476 | s = (FormalLambda k <$> fmap (($ Lambda () [hspvar hv] (hsvar k)) . (`infixOp` ">>=")) e') | 474 | let s = (FormalLambda k <$> fmap (($ Lambda () [hspvar hv] (uniqueSymbol k)) . (`infixOp` ">>=")) e') |
477 | { compIntro = Map.singleton hv () } | 475 | { compIntro = Map.singleton hv () } |
478 | return $ (,) [s] (mkcomp $ hsvar hv){ compFree = Map.singleton hv () } | 476 | return $ (,) [s] (mkcomp $ hsvar hv){ compFree = Map.singleton hv () } |
479 | grokExpression fe _ = mzero | 477 | grokExpression fe _ = mzero |
@@ -490,11 +488,11 @@ grokCall fe wantsRet (C.CCall (CVar fn _) exps _) = do | |||
490 | -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs) | 488 | -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs) |
491 | fn' = identToString fn | 489 | fn' = identToString fn |
492 | cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn'){compFree = Map.singleton fn' ()} (map snd gs) | 490 | cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn'){compFree = Map.singleton fn' ()} (map snd gs) |
493 | k = uniqIdentifier "go" (compFree s) | 491 | k <- StateT $ return . genUnique |
494 | s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (hsvar k)) cll) | 492 | let s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (uniqueSymbol k)) cll) |
495 | { compIntro = Map.singleton hv () | 493 | { compIntro = Map.singleton hv () |
496 | } | 494 | } |
497 | | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (hsvar k)) cll | 495 | | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (uniqueSymbol k)) cll |
498 | return $ (,) (ss++[s]) (mkcomp $ hsvar hv) | 496 | return $ (,) (ss++[s]) (mkcomp $ hsvar hv) |
499 | { compFree = Map.singleton hv () | 497 | { compFree = Map.singleton hv () |
500 | } | 498 | } |
@@ -514,11 +512,11 @@ grokCall fe wantsRet (C.CCall fnx@(CMember cvar fld isptr _) exps _) = do | |||
514 | -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs) | 512 | -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs) |
515 | fn' = concat (Map.keys $ compFree fn) | 513 | fn' = concat (Map.keys $ compFree fn) |
516 | cll = foldl (\f x -> App () <$> f <*> x) fn (map snd gs) | 514 | cll = foldl (\f x -> App () <$> f <*> x) fn (map snd gs) |
517 | k = uniqIdentifier "go" (compFree s) | 515 | k <- StateT $ return . genUnique |
518 | s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (hsvar k)) cll) | 516 | let s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (uniqueSymbol k)) cll) |
519 | { compIntro = Map.singleton hv () | 517 | { compIntro = Map.singleton hv () |
520 | } | 518 | } |
521 | | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (hsvar k)) cll | 519 | | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (uniqueSymbol k)) cll |
522 | return $ (,) (ss++[s]) (mkcomp $ hsvar hv) | 520 | return $ (,) (ss++[s]) (mkcomp $ hsvar hv) |
523 | { compFree = Map.singleton hv () | 521 | { compFree = Map.singleton hv () |
524 | } | 522 | } |
@@ -534,10 +532,10 @@ grokInitialization fe _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do | |||
534 | let v = identToString cv0 | 532 | let v = identToString cv0 |
535 | (xs,x) <- grokExpression fe exp | 533 | (xs,x) <- grokExpression fe exp |
536 | let hsexp = fmap (App () (hsvar "return")) x -- Paren () ( | 534 | let hsexp = fmap (App () (hsvar "return")) x -- Paren () ( |
537 | ret = flip (foldr applyComputation) xs $ | 535 | k <- StateT $ return . genUnique |
536 | let ret = flip (foldr applyComputation) xs $ | ||
538 | fmap (\exp -> infixOp exp ">>=" | 537 | fmap (\exp -> infixOp exp ">>=" |
539 | $ Lambda () [hspvar v] (hsvar k)) hsexp | 538 | $ Lambda () [hspvar v] (uniqueSymbol k)) hsexp |
540 | k = uniqIdentifier "go" (compFree ret) | ||
541 | return $ fmap (FormalLambda k) ret | 539 | return $ fmap (FormalLambda k) ret |
542 | grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do | 540 | grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do |
543 | let v = identToString cv0 | 541 | let v = identToString cv0 |
@@ -551,14 +549,11 @@ grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = d | |||
551 | case initexpr of | 549 | case initexpr of |
552 | CInitExpr ie _ -> (grokExpression fe) ie >>= \g -> return (ms,g) | 550 | CInitExpr ie _ -> (grokExpression fe) ie >>= \g -> return (ms,g) |
553 | _ -> mzero | 551 | _ -> mzero |
554 | let assigns = do | 552 | assigns <- forM gs $ \(ms,(ss,x)) -> do |
555 | (ms,(ss,x)) <- gs | 553 | k2 <- StateT $ return . genUnique |
556 | let k2 = uniqIdentifier "gopoo" (compFree ret) | 554 | cs <- forM (mapMaybe (\case { CMemberDesig m _ -> Just m ; _ -> Nothing}) ms) $ \m -> do |
557 | ret = foldr applyComputation (mkcomp $ hsvar k2) (ss ++ cs) | 555 | k1 <- StateT $ return . genUnique |
558 | cs = do | 556 | let fieldinit = comp x |
559 | CMemberDesig m _ <- ms | ||
560 | let k1 = uniqIdentifier "go" (compFree x) | ||
561 | fieldinit = comp x | ||
562 | fieldlbl = identToString m | 557 | fieldlbl = identToString m |
563 | return x | 558 | return x |
564 | { comp = FormalLambda k1 | 559 | { comp = FormalLambda k1 |
@@ -566,19 +561,20 @@ grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = d | |||
566 | (App () (App () (App () (hsvar "set") | 561 | (App () (App () (App () (hsvar "set") |
567 | (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) | 562 | (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) |
568 | (hsvar v)) | 563 | (hsvar v)) |
569 | fieldinit) ">>" (hsvar k1) | 564 | fieldinit) ">>" (uniqueSymbol k1) |
570 | } | 565 | } |
566 | let ret = foldr applyComputation (mkcomp $ uniqueSymbol k2) (ss ++ cs) | ||
571 | return $ fmap (FormalLambda k2) ret | 567 | return $ fmap (FormalLambda k2) ret |
568 | k <- StateT $ return . genUnique | ||
572 | let newstruct = Computation | 569 | let newstruct = Computation |
573 | { compFree = Map.empty -- todo | 570 | { compFree = Map.empty -- todo |
574 | , compIntro = Map.singleton v () | 571 | , compIntro = Map.singleton v () |
575 | , compContinue = Nothing | 572 | , compContinue = Nothing |
576 | , comp = FormalLambda k | 573 | , comp = FormalLambda k |
577 | $ infixOp (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) ">>=" | 574 | $ infixOp (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) ">>=" |
578 | $ Lambda () [hspvar v] (hsvar k) | 575 | $ Lambda () [hspvar v] (uniqueSymbol k) |
579 | } | 576 | } |
580 | k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO | 577 | ret = foldr applyComputation (mkcomp $ uniqueSymbol k) $ newstruct : assigns |
581 | ret = foldr applyComputation (mkcomp $ hsvar k) $ newstruct : assigns | ||
582 | return $ fmap (FormalLambda k) ret | 578 | return $ fmap (FormalLambda k) ret |
583 | _ -> mzero | 579 | _ -> mzero |
584 | grokInitialization _ _ _ = mzero | 580 | grokInitialization _ _ _ = mzero |
@@ -597,13 +593,15 @@ promote _ y = y | |||
597 | grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> StateT UniqueFactory Maybe (Computation FormalLambda) | 593 | grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> StateT UniqueFactory Maybe (Computation FormalLambda) |
598 | grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do | 594 | grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do |
599 | (xs,x) <- grokExpression fe exp | 595 | (xs,x) <- grokExpression fe exp |
600 | let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x) | 596 | k <- StateT $ return . genUnique |
601 | x' = fmap (\y -> App () (hsvar "return") $ promote (fnArgs fe) y) x | 597 | let x' = fmap (\y -> App () (hsvar "return") $ promote (fnArgs fe) y) x |
602 | return $ fmap (\y -> FormalLambda k y) $ foldr applyComputation x' xs | 598 | return $ fmap (\y -> FormalLambda k y) $ foldr applyComputation x' xs |
603 | grokStatement fe (CBlockStmt (CReturn Nothing _)) = | 599 | grokStatement fe (CBlockStmt (CReturn Nothing _)) = do |
604 | return $ mkcomp $ FormalLambda "go" retUnit | 600 | k <- StateT $ return . genUnique |
605 | grokStatement fe (CBlockStmt (CCont _)) = | 601 | return $ mkcomp $ FormalLambda k retUnit |
606 | return (mkcomp $ FormalLambda "go" $ hsvar " continue") | 602 | grokStatement fe (CBlockStmt (CCont _)) = do |
603 | k <- StateT $ return . genUnique | ||
604 | return (mkcomp $ FormalLambda k $ hsvar " continue") | ||
607 | { compContinue = Just " continue" } | 605 | { compContinue = Just " continue" } |
608 | grokStatement fe (CBlockStmt (CIf exp thn els _)) = do | 606 | grokStatement fe (CBlockStmt (CIf exp thn els _)) = do |
609 | (xs,x) <- grokExpression fe exp | 607 | (xs,x) <- grokExpression fe exp |
@@ -623,62 +621,62 @@ grokStatement fe (CBlockStmt (CIf exp thn els _)) = do | |||
623 | _ -> trace ("Unhandled if: "++show (fmap (const LT) thn)) $ mzero -- TODO | 621 | _ -> trace ("Unhandled if: "++show (fmap (const LT) thn)) $ mzero -- TODO |
624 | 622 | ||
625 | ss <- sequence $ map (grokStatement fe) stmts | 623 | ss <- sequence $ map (grokStatement fe) stmts |
626 | let s = foldr applyComputation (mkcomp $ hsvar k) ss | 624 | k <- StateT $ return . genUnique |
627 | k = uniqIdentifier "go" (Map.union (compFree x) (compFree s)) | 625 | let s = foldr applyComputation (mkcomp $ uniqueSymbol k) ss |
628 | return $ fmap (FormalLambda k) $ flip (foldr applyComputation) xs Computation | 626 | return $ fmap (FormalLambda k) $ flip (foldr applyComputation) xs Computation |
629 | { compFree = compFree x `Map.union` compFree s | 627 | { compFree = compFree x `Map.union` compFree s |
630 | , compIntro = compIntro s | 628 | , compIntro = compIntro s |
631 | , compContinue = Nothing | 629 | , compContinue = Nothing |
632 | , comp = mkif (comp s) (hsvar k) | 630 | , comp = mkif (comp s) (uniqueSymbol k) |
633 | } | 631 | } |
634 | grokStatement fe (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail" _ _) _) xs _)) _)) = do | 632 | grokStatement fe (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail" _ _) _) xs _)) _)) = do |
635 | x <- case xs of | 633 | x <- case xs of |
636 | (CConst (CStrConst msg _):_) -> let s = getCString msg | 634 | (CConst (CStrConst msg _):_) -> let s = getCString msg |
637 | in return $ mkcomp $ Lit () (HS.String () s s) | 635 | in return $ mkcomp $ Lit () (HS.String () s s) |
638 | _ -> mzero | 636 | _ -> mzero |
639 | let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x) | 637 | k <- StateT $ return . genUnique |
640 | x' = fmap (\y -> App () (hsvar "error") y) x | 638 | let x' = fmap (\y -> App () (hsvar "error") y) x |
641 | return $ fmap (FormalLambda k) x' | 639 | return $ fmap (FormalLambda k) x' |
642 | grokStatement fe (CBlockStmt (CExpr (Just | 640 | grokStatement fe (CBlockStmt (CExpr (Just |
643 | (CAssign CAssignOp | 641 | (CAssign CAssignOp |
644 | (CMember cvar fld isptr _) expr _)) _)) = do | 642 | (CMember cvar fld isptr _) expr _)) _)) = do |
645 | (xs,x) <- grokExpression fe expr | 643 | (xs,x) <- grokExpression fe expr |
646 | v <- mb $ cvarName cvar | 644 | v <- mb $ cvarName cvar |
645 | k1 <- StateT $ return . genUnique | ||
647 | let fieldlbl = identToString fld | 646 | let fieldlbl = identToString fld |
648 | k1 = uniqIdentifier "go" (compFree x) | ||
649 | fieldinit = comp x | 647 | fieldinit = comp x |
650 | x' = x | 648 | x' = x |
651 | { comp = infixOp | 649 | { comp = infixOp |
652 | (App () (App () (App () (hsvar "set") | 650 | (App () (App () (App () (hsvar "set") |
653 | (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) | 651 | (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) |
654 | (hsvar v)) | 652 | (hsvar v)) |
655 | fieldinit) ">>" (hsvar k1) | 653 | fieldinit) ">>" (uniqueSymbol k1) |
656 | } | 654 | } |
657 | return $ fmap (FormalLambda k1) $ foldr applyComputation x' xs | 655 | return $ fmap (FormalLambda k1) $ foldr applyComputation x' xs |
658 | grokStatement fe (CBlockStmt (CExpr (Just (C.CCall cvarfun exps a)) _)) = do | 656 | grokStatement fe (CBlockStmt (CExpr (Just (C.CCall cvarfun exps a)) _)) = do |
659 | -- This case is technically not needed, but it makes slightly cleaner output | 657 | -- This case is technically not needed, but it makes slightly cleaner output |
660 | -- by avoiding a bind operation. | 658 | -- by avoiding a bind operation. |
661 | (ss,_) <- grokCall fe False (C.CCall cvarfun exps a) | 659 | (ss,_) <- grokCall fe False (C.CCall cvarfun exps a) |
662 | let k = uniqIdentifier "go" (compFree r `Map.union` compIntro r) | 660 | k <- StateT $ return . genUnique |
663 | r = FormalLambda k <$> foldr applyComputation (mkcomp $ hsvar k) ss | 661 | let r = FormalLambda k <$> foldr applyComputation (mkcomp $ uniqueSymbol k) ss |
664 | return r | 662 | return r |
665 | grokStatement fe (CBlockStmt (CExpr (Just | 663 | grokStatement fe (CBlockStmt (CExpr (Just |
666 | (CAssign CAssignOp cvarnew | 664 | (CAssign CAssignOp cvarnew |
667 | (C.CCall cvarfun [] _) _)) _)) = do | 665 | (C.CCall cvarfun [] _) _)) _)) = do |
668 | v <- mb $ cvarName cvarnew | 666 | v <- mb $ cvarName cvarnew |
669 | fn <- mb $ cvarName cvarfun | 667 | fn <- mb $ cvarName cvarfun |
670 | let k = uniqIdentifier "go" (varmap [v,fn]) | 668 | k <- StateT $ return . genUnique |
671 | return Computation | 669 | return Computation |
672 | { compFree = Map.singleton fn () | 670 | { compFree = Map.singleton fn () |
673 | , compIntro = Map.singleton v () | 671 | , compIntro = Map.singleton v () |
674 | , compContinue = Nothing | 672 | , compContinue = Nothing |
675 | , comp = FormalLambda k | 673 | , comp = FormalLambda k |
676 | $ infixOp (hsvar fn) ">>=" | 674 | $ infixOp (hsvar fn) ">>=" |
677 | $ Lambda () [hspvar v] (hsvar k) | 675 | $ Lambda () [hspvar v] (uniqueSymbol k) |
678 | } | 676 | } |
679 | grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 _) fld True _) _)) _)) = do | 677 | grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 _) fld True _) _)) _)) = do |
680 | let k1 = uniqIdentifier "go" (varmap [fieldlbl,v]) | 678 | k1 <- StateT $ return . genUnique |
681 | fieldlbl = identToString fld | 679 | let fieldlbl = identToString fld |
682 | v = identToString cv0 | 680 | v = identToString cv0 |
683 | return Computation | 681 | return Computation |
684 | { compFree = varmap [v] | 682 | { compFree = varmap [v] |
@@ -689,7 +687,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 | |||
689 | (App () (App () (App () (hsvar "modify") | 687 | (App () (App () (App () (hsvar "modify") |
690 | (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) | 688 | (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) |
691 | (hsvar v)) | 689 | (hsvar v)) |
692 | (hsvar "succ")) ">>" (hsvar k1) | 690 | (hsvar "succ")) ">>" (uniqueSymbol k1) |
693 | } | 691 | } |
694 | grokStatement fe (CBlockStmt (CExpr mexpr _)) = do | 692 | grokStatement fe (CBlockStmt (CExpr mexpr _)) = do |
695 | -- trace ("CExpr statement: " ++ take 50 (show $ fmap (fmap $ const ()) mexpr)) $ return () | 693 | -- trace ("CExpr statement: " ++ take 50 (show $ fmap (fmap $ const ()) mexpr)) $ return () |
@@ -700,18 +698,20 @@ grokStatement fe (CBlockStmt (CExpr mexpr _)) = do | |||
700 | -- keep = fmap (\e -> infixFn e "seq") | 698 | -- keep = fmap (\e -> infixFn e "seq") |
701 | in (fmap (second discard) . grokExpression fe)) | 699 | in (fmap (second discard) . grokExpression fe)) |
702 | mexpr | 700 | mexpr |
703 | let k = uniqIdentifier "go" (compFree s) | 701 | k <- StateT $ return . genUnique |
704 | s = foldr applyComputation (fmap ($ hsvar k) pre) ss | 702 | let s = foldr applyComputation (fmap ($ uniqueSymbol k) pre) ss |
705 | return $ fmap (FormalLambda k) s | 703 | return $ fmap (FormalLambda k) s |
706 | grokStatement fe (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do | 704 | grokStatement fe (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do |
707 | -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of | 705 | -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of |
708 | -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of | 706 | -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of |
707 | k <- StateT $ return . genUnique | ||
709 | case mapMaybe (\(i,inits,_) -> fmap ((,) i) inits) (v:vs) of | 708 | case mapMaybe (\(i,inits,_) -> fmap ((,) i) inits) (v:vs) of |
710 | [] -> return $ mkcomp $ FormalLambda "go" $ hsvar "go" | 709 | [] -> return $ mkcomp $ FormalLambda k (uniqueSymbol k) |
711 | initials -> do | 710 | initials -> do |
712 | gs <- mapM (grokInitialization fe $ t:ts) initials | 711 | gs <- mapM (grokInitialization fe $ t:ts) initials |
713 | return $ fmap (FormalLambda "go") | 712 | k <- StateT $ return . genUnique |
714 | $ foldr applyComputation (mkcomp $ hsvar "go") gs | 713 | return $ fmap (FormalLambda k) |
714 | $ foldr applyComputation (mkcomp $ uniqueSymbol k) gs | ||
715 | grokStatement fe (CBlockStmt (CWhile cond (CCompound [] bdy _) isDoWhile _)) = do | 715 | grokStatement fe (CBlockStmt (CWhile cond (CCompound [] bdy _) isDoWhile _)) = do |
716 | gs <- mapM (grokStatement fe) bdy | 716 | gs <- mapM (grokStatement fe) bdy |
717 | (ss,c) <- grokExpression fe cond | 717 | (ss,c) <- grokExpression fe cond |
@@ -723,7 +723,8 @@ grokStatement fe (CBlockStmt (CWhile cond (CCompound [] bdy _) isDoWhile _)) = d | |||
723 | c' = fmap (\cnd -> If () cnd (Paren () loopcall) (hsvar "fin")) c | 723 | c' = fmap (\cnd -> If () cnd (Paren () loopcall) (hsvar "fin")) c |
724 | x = foldr applyComputation c' ss -- continue function | 724 | x = foldr applyComputation c' ss -- continue function |
725 | vs = [] -- Map.keys $ compIntro g | 725 | vs = [] -- Map.keys $ compIntro g |
726 | return $ fmap (FormalLambda "fin") $ fmap (factorOutFunction "continue" vs (comp x) " continue") g | 726 | fin <- StateT $ return . genUnique |
727 | return $ fmap (FormalLambda fin) $ fmap (factorOutFunction "continue" vs (comp x) (hsvar " continue")) g | ||
727 | grokStatement fe _ = mzero | 728 | grokStatement fe _ = mzero |
728 | 729 | ||
729 | isFunctionDecl :: CExternalDeclaration a -> Bool | 730 | isFunctionDecl :: CExternalDeclaration a -> Bool |