diff options
Diffstat (limited to 'monkeypatch.hs')
-rw-r--r-- | monkeypatch.hs | 79 |
1 files changed, 51 insertions, 28 deletions
diff --git a/monkeypatch.hs b/monkeypatch.hs index b3bbe2d..3b93e5b 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs | |||
@@ -11,7 +11,9 @@ | |||
11 | module Main where | 11 | module Main where |
12 | 12 | ||
13 | import Debug.Trace | 13 | import Debug.Trace |
14 | import Control.Arrow (left,first,second) | 14 | |
15 | import Control.Arrow (first, left, second) | ||
16 | import Control.Monad.Trans.State.Lazy | ||
15 | import Data.Bool | 17 | import Data.Bool |
16 | import Data.Either | 18 | import Data.Either |
17 | import Data.Generics.Aliases | 19 | import Data.Generics.Aliases |
@@ -21,39 +23,40 @@ import Control.Monad | |||
21 | import qualified Data.ByteString.Char8 as B | 23 | import qualified Data.ByteString.Char8 as B |
22 | import Data.Char | 24 | import Data.Char |
23 | import Data.Data | 25 | import Data.Data |
24 | import Data.List | ||
25 | import qualified Data.IntMap as IntMap | 26 | import qualified Data.IntMap as IntMap |
26 | ;import Data.IntMap (IntMap) | 27 | ;import Data.IntMap (IntMap) |
27 | import qualified Data.Map as Map | 28 | import Data.List |
28 | ;import Data.Map (Map) | 29 | import qualified Data.Map as Map |
30 | ;import Data.Map (Map) | ||
29 | import Data.Maybe | 31 | import Data.Maybe |
30 | import Data.Ord | 32 | import Data.Ord |
31 | import qualified Data.Set as Set | 33 | import qualified Data.Set as Set |
32 | ;import Data.Set (Set) | 34 | ;import Data.Set (Set) |
33 | import Language.C.Data.Ident as C | 35 | import qualified Language.C as C |
34 | import Language.C.Data.Node as C | 36 | ;import Language.C as C hiding (prettyUsingInclude) |
35 | import Language.C as C hiding (prettyUsingInclude) | 37 | import Language.C.Data.Ident as C |
36 | import qualified Language.C as C | 38 | import Language.C.Data.Node as C |
39 | import Language.C.Data.Position | ||
37 | import Language.C.System.GCC | 40 | import Language.C.System.GCC |
38 | import Language.C.System.Preprocess | 41 | import Language.C.System.Preprocess |
39 | import Language.C.Data.Position | 42 | import Language.Haskell.Exts.Parser as HS |
40 | import Language.Haskell.Exts.Parser as HS | 43 | import Language.Haskell.Exts.Pretty as HS |
41 | import Language.Haskell.Exts.Pretty as HS | 44 | import Language.Haskell.Exts.Syntax as HS |
42 | import Language.Haskell.Exts.Syntax as HS | ||
43 | import Language.Haskell.TH | 45 | import Language.Haskell.TH |
44 | import Language.Haskell.TH.Ppr | 46 | import Language.Haskell.TH.Ppr |
45 | import Language.Haskell.TH.Syntax as TH | 47 | import Language.Haskell.TH.Syntax as TH |
46 | import System.Directory | 48 | import System.Directory |
47 | import System.Environment | 49 | import System.Environment |
50 | import System.Exit | ||
48 | import System.IO | 51 | import System.IO |
49 | import System.Process | 52 | import System.Process |
50 | import System.Exit | 53 | import Text.PrettyPrint (Doc, doubleQuotes, empty, text, vcat, |
51 | import Text.PrettyPrint (Doc, doubleQuotes, empty, text, vcat, ($$), | 54 | ($$), (<+>)) |
52 | (<+>)) | ||
53 | import Text.Show.Pretty | 55 | import Text.Show.Pretty |
54 | 56 | ||
55 | import Sweeten | 57 | import Sweeten |
56 | import GrepNested | 58 | import GrepNested |
59 | import Unique | ||
57 | 60 | ||
58 | {- | 61 | {- |
59 | trace :: p -> a -> a | 62 | trace :: p -> a -> a |
@@ -212,26 +215,34 @@ informalize :: FormalLambda -> HS.Exp () | |||
212 | informalize (FormalLambda k x) = Lambda () [hspvar k] x | 215 | informalize (FormalLambda k x) = Lambda () [hspvar k] x |
213 | 216 | ||
214 | 217 | ||
218 | factorOutFunction :: String -- ^ New function name to factor out. | ||
219 | -> [String] -- ^ Arguments to function. | ||
220 | -> HS.Exp () -- ^ Body of function. | ||
221 | -> String -- ^ Variable name place holder for call sites in template. | ||
222 | -> HS.Exp () -- ^ Template containing place-holder call sites. | ||
223 | -> HS.Exp () | ||
224 | factorOutFunction k vs bdy govar expr = | ||
225 | let matchgo (Var () (UnQual () (HS.Ident () v))) = v==govar | ||
226 | matchgo _ = False | ||
227 | subst x | matchgo x = callsite | ||
228 | | otherwise = x | ||
229 | callsite = foldl (App ()) (hsvar k) $ map hsvar vs | ||
230 | pats = map hspvar vs | ||
231 | in Let () (BDecls () [FunBind () [HS.Match () (HS.Ident () k) pats | ||
232 | (UnGuardedRhs () bdy) Nothing]]) | ||
233 | (everywhere (mkT subst) expr) | ||
234 | |||
215 | 235 | ||
216 | -- Like applyComputation, but creates a let-binding rather than inlining the continuation. | 236 | -- Like applyComputation, but creates a let-binding rather than inlining the continuation. |
217 | multiwayContinuation :: Computation FormalLambda -> Computation (HS.Exp ()) -> Computation (HS.Exp ()) | 237 | multiwayContinuation :: Computation FormalLambda -> Computation (HS.Exp ()) -> Computation (HS.Exp ()) |
218 | multiwayContinuation a@Computation{ comp = FormalLambda govar exp } b = | 238 | multiwayContinuation a@Computation{ comp = FormalLambda govar exp } b = |
219 | let k = uniqIdentifier "go" (foldr Map.union Map.empty [compFree a,compIntro a,compFree b,compIntro b]) | 239 | let k = uniqIdentifier "go" (foldr Map.union Map.empty [compFree a,compIntro a,compFree b,compIntro b]) |
220 | vs = Map.keys $ compIntro a `Map.intersection` compFree b | 240 | vs = Map.keys $ compIntro a `Map.intersection` compFree b |
221 | matchgo (Var () (UnQual () (HS.Ident () v))) = v==govar | ||
222 | matchgo _ = False | ||
223 | subst x | matchgo x = callsite | ||
224 | | otherwise = x | ||
225 | callsite = foldl (App ()) (hsvar k) $ map hsvar vs | ||
226 | pats = map hspvar vs | ||
227 | letexpr = Let () (BDecls () [FunBind () [HS.Match () (HS.Ident () k) pats | ||
228 | (UnGuardedRhs () (comp b)) Nothing]]) | ||
229 | (everywhere (mkT subst) exp) | ||
230 | in Computation | 241 | in Computation |
231 | { compFree = Map.union (compFree a) (compFree b) Map.\\ compIntro a | 242 | { compFree = Map.union (compFree a) (compFree b) Map.\\ compIntro a |
232 | , compIntro = compIntro a `Map.union` compIntro b | 243 | , compIntro = compIntro a `Map.union` compIntro b |
233 | , compContinue = Nothing | 244 | , compContinue = Nothing |
234 | , comp = letexpr | 245 | , comp = factorOutFunction k vs (comp b) govar exp |
235 | } | 246 | } |
236 | 247 | ||
237 | 248 | ||
@@ -698,6 +709,18 @@ grokStatement fe (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do | |||
698 | gs <- mapM (grokInitialization fe $ t:ts) initials | 709 | gs <- mapM (grokInitialization fe $ t:ts) initials |
699 | return $ fmap (FormalLambda "go") | 710 | return $ fmap (FormalLambda "go") |
700 | $ foldr applyComputation (mkcomp $ hsvar "go") gs | 711 | $ foldr applyComputation (mkcomp $ hsvar "go") gs |
712 | grokStatement fe (CBlockStmt (CWhile cond (CCompound [] bdy _) isDoWhile _)) = do | ||
713 | gs <- mapM (grokStatement fe) bdy | ||
714 | (ss,c) <- grokExpression fe cond | ||
715 | let g = foldr applyComputation cnt gs -- body of loop | ||
716 | cnt = mkcomp $ hsvar " continue" | ||
717 | -- k = uniqIdentifier "go" (compFree g `Map.union` compIntro g) | ||
718 | loopcall = foldl (App ()) (hsvar "loop") $ map hsvar vs | ||
719 | -- c' = fmap (\cnd -> App () (App () (hsvar "when") cnd) (Paren () loopcall)) c | ||
720 | c' = fmap (\cnd -> If () cnd (Paren () loopcall) (hsvar "fin")) c | ||
721 | x = foldr applyComputation c' ss -- continue function | ||
722 | vs = [] -- Map.keys $ compIntro g | ||
723 | return $ fmap (FormalLambda "fin") $ fmap (factorOutFunction "continue" vs (comp x) " continue") g | ||
701 | grokStatement fe _ = Nothing | 724 | grokStatement fe _ = Nothing |
702 | 725 | ||
703 | isFunctionDecl :: CExternalDeclaration a -> Bool | 726 | isFunctionDecl :: CExternalDeclaration a -> Bool |