diff options
Diffstat (limited to 'monkeypatch.hs')
-rw-r--r-- | monkeypatch.hs | 87 |
1 files changed, 62 insertions, 25 deletions
diff --git a/monkeypatch.hs b/monkeypatch.hs index 8e2dcf8..14359fe 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs | |||
@@ -199,6 +199,15 @@ data FormalLambda = FormalLambda { formGo :: String | |||
199 | , formExp :: HS.Exp () | 199 | , formExp :: HS.Exp () |
200 | } | 200 | } |
201 | 201 | ||
202 | modifyFormal :: (HS.Exp () -> HS.Exp ()) | ||
203 | -> FormalLambda -> FormalLambda | ||
204 | modifyFormal f (FormalLambda s x) = FormalLambda s (f x) | ||
205 | |||
206 | -- modifyLambda f (Lambda l p x) = Lambda l p (f x) | ||
207 | |||
208 | modifyOperand1 :: (HS.Exp l -> HS.Exp l) -> HS.Exp l -> HS.Exp l | ||
209 | modifyOperand1 f (InfixApp l x op y) = InfixApp l (f x) op y | ||
210 | |||
202 | informalize :: FormalLambda -> HS.Exp () | 211 | informalize :: FormalLambda -> HS.Exp () |
203 | informalize (FormalLambda k x) = Lambda () [hspvar k] x | 212 | informalize (FormalLambda k x) = Lambda () [hspvar k] x |
204 | 213 | ||
@@ -384,21 +393,7 @@ grokExpression fe (CComma exps _) = do | |||
384 | s' = fmap (\x -> FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar k)))) s | 393 | s' = fmap (\x -> FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar k)))) s |
385 | -- TODO: It would be cleaner if I could return only a statement and not an expression. | 394 | -- TODO: It would be cleaner if I could return only a statement and not an expression. |
386 | return $ (,) [s'] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } | 395 | return $ (,) [s'] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } |
387 | grokExpression fe (C.CCall (CVar fn _) exps _) = do | 396 | grokExpression fe (C.CCall fn exps u) = grokCall fe True (C.CCall fn exps u) |
388 | gs <- mapM (grokExpression fe) exps | ||
389 | let ss = concatMap fst gs -- TODO: resolve variable name conflicts | ||
390 | hv = "r" ++ identToString fn | ||
391 | -- cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs | ||
392 | -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs) | ||
393 | fn' = identToString fn | ||
394 | cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn'){compFree = Map.singleton fn' ()} (map snd gs) | ||
395 | k = uniqIdentifier "go" (compFree s) | ||
396 | s = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (hsvar k)) cll) | ||
397 | { compIntro = Map.singleton hv () | ||
398 | } | ||
399 | return $ (,) (ss++[s]) (mkcomp $ hsvar hv) | ||
400 | { compFree = Map.singleton hv () | ||
401 | } | ||
402 | grokExpression fe (CStatExpr (CCompound idents xs _) _) = do | 397 | grokExpression fe (CStatExpr (CCompound idents xs _) _) = do |
403 | let (y,ys) = splitAt 1 (reverse xs) | 398 | let (y,ys) = splitAt 1 (reverse xs) |
404 | y' <- case y of | 399 | y' <- case y of |
@@ -445,6 +440,51 @@ grokExpression fe (CMember cvar fld isptr _) = do | |||
445 | return $ (,) [s] (mkcomp $ hsvar hv){ compFree = Map.singleton hv () } | 440 | return $ (,) [s] (mkcomp $ hsvar hv){ compFree = Map.singleton hv () } |
446 | grokExpression fe _ = Nothing | 441 | grokExpression fe _ = Nothing |
447 | 442 | ||
443 | grokCall :: FunctionEnvironment | ||
444 | -> Bool | ||
445 | -> CExpression a | ||
446 | -> Maybe ([Computation FormalLambda], Computation (HS.Exp ())) | ||
447 | grokCall fe wantsRet (C.CCall (CVar fn _) exps _) = do | ||
448 | gs <- mapM (grokExpression fe) exps | ||
449 | let ss = concatMap fst gs -- TODO: resolve variable name conflicts | ||
450 | hv = "r" ++ identToString fn | ||
451 | -- cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs | ||
452 | -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs) | ||
453 | fn' = identToString fn | ||
454 | cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn'){compFree = Map.singleton fn' ()} (map snd gs) | ||
455 | k = uniqIdentifier "go" (compFree s) | ||
456 | s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (hsvar k)) cll) | ||
457 | { compIntro = Map.singleton hv () | ||
458 | } | ||
459 | | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (hsvar k)) cll | ||
460 | return $ (,) (ss++[s]) (mkcomp $ hsvar hv) | ||
461 | { compFree = Map.singleton hv () | ||
462 | } | ||
463 | grokCall fe wantsRet (C.CCall fnx@(CMember cvar fld isptr _) exps _) = do | ||
464 | -- We're calling a FunPtr so a "dynamic" import will need to be declared. | ||
465 | -- We'll assume that a dynCall type class method points to it. | ||
466 | -- fun <- dynCall <$> get @fld cvar | ||
467 | -- fun arg1 arg2 ... | ||
468 | (fss,fn) <- grokExpression fe fnx | ||
469 | let getfn = case reverse fss of | ||
470 | fnst:fs -> reverse $ (modifyFormal (modifyOperand1 $ infixOp (hsvar "callDyn") "<$>") <$> fnst) : fs | ||
471 | [] -> [] | ||
472 | gs <- mapM (grokExpression fe) exps | ||
473 | let ss = getfn ++ concatMap fst gs -- TODO: resolve variable name conflicts | ||
474 | hv = "r" ++ fn' | ||
475 | -- cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs | ||
476 | -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs) | ||
477 | fn' = concat (Map.keys $ compFree fn) | ||
478 | cll = foldl (\f x -> App () <$> f <*> x) fn (map snd gs) | ||
479 | k = uniqIdentifier "go" (compFree s) | ||
480 | s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (hsvar k)) cll) | ||
481 | { compIntro = Map.singleton hv () | ||
482 | } | ||
483 | | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (hsvar k)) cll | ||
484 | return $ (,) (ss++[s]) (mkcomp $ hsvar hv) | ||
485 | { compFree = Map.singleton hv () | ||
486 | } | ||
487 | grokCall _ _ _ = Nothing | ||
448 | 488 | ||
449 | 489 | ||
450 | grokInitialization :: Foldable t1 => | 490 | grokInitialization :: Foldable t1 => |
@@ -515,6 +555,7 @@ promote fe y@(Lit () (Int () n _)) | (n==0 || n==1) && hasBool (fe Map.! "") = | |||
515 | 1 -> "True" | 555 | 1 -> "True" |
516 | promote _ y = y | 556 | promote _ y = y |
517 | 557 | ||
558 | |||
518 | grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> Maybe (Computation FormalLambda) | 559 | grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> Maybe (Computation FormalLambda) |
519 | grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do | 560 | grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do |
520 | (xs,x) <- grokExpression fe exp | 561 | (xs,x) <- grokExpression fe exp |
@@ -573,18 +614,13 @@ grokStatement fe (CBlockStmt (CExpr (Just | |||
573 | fieldinit) ">>" (hsvar k1) | 614 | fieldinit) ">>" (hsvar k1) |
574 | } | 615 | } |
575 | return $ fmap (FormalLambda k1) $ foldr applyComputation x' xs | 616 | return $ fmap (FormalLambda k1) $ foldr applyComputation x' xs |
576 | grokStatement fe (CBlockStmt (CExpr (Just | 617 | grokStatement fe (CBlockStmt (CExpr (Just (C.CCall cvarfun exps a)) _)) = do |
577 | (C.CCall cvarfun exps _)) _)) = do | ||
578 | -- This case is technically not needed, but it makes slightly cleaner output | 618 | -- This case is technically not needed, but it makes slightly cleaner output |
579 | -- by avoiding a bind operation. | 619 | -- by avoiding a bind operation. |
580 | fn <- cvarName cvarfun | 620 | (ss,_) <- grokCall fe False (C.CCall cvarfun exps a) |
581 | gs <- mapM (grokExpression fe) exps | 621 | let k = uniqIdentifier "go" (compFree r `Map.union` compIntro r) |
582 | let k = uniqIdentifier "go" (compFree s1) | 622 | r = FormalLambda k <$> foldr applyComputation (mkcomp $ hsvar k) ss |
583 | cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn){compFree = Map.singleton fn ()} $ map snd gs | 623 | return r |
584 | s1 = fmap (`infixOp` ">>") cll | ||
585 | s = s1 <*> mkcomp (hsvar k) | ||
586 | x = foldr applyComputation s $ concatMap fst gs | ||
587 | return $ fmap (FormalLambda k) x | ||
588 | grokStatement fe (CBlockStmt (CExpr (Just | 624 | grokStatement fe (CBlockStmt (CExpr (Just |
589 | (CAssign CAssignOp cvarnew | 625 | (CAssign CAssignOp cvarnew |
590 | (C.CCall cvarfun [] _) _)) _)) = do | 626 | (C.CCall cvarfun [] _) _)) _)) = do |
@@ -615,6 +651,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 | |||
615 | (hsvar "succ")) ">>" (hsvar k1) | 651 | (hsvar "succ")) ">>" (hsvar k1) |
616 | } | 652 | } |
617 | grokStatement fe (CBlockStmt (CExpr mexpr _)) = do | 653 | grokStatement fe (CBlockStmt (CExpr mexpr _)) = do |
654 | -- trace ("CExpr statement: " ++ take 50 (show $ fmap (fmap $ const ()) mexpr)) $ return () | ||
618 | (ss,pre) <- maybe (Just $ (,) [] $ mkcomp id) | 655 | (ss,pre) <- maybe (Just $ (,) [] $ mkcomp id) |
619 | (let -- Discard pure value since we are interested only in side-effects. | 656 | (let -- Discard pure value since we are interested only in side-effects. |
620 | discard = const $ mkcomp id | 657 | discard = const $ mkcomp id |