hermit 0.1.2.0 → 0.1.4.0

raw patch · 68 files changed

+2241/−1917 lines, 68 filesdep +directorydep ~kurePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: directory

Dependency ranges changed: kure

API changes (from Hackage documentation)

Files

• driver/Main.hs +59/−22
• examples/WWSplitTactic.hss +18/−0
• examples/concatVanishes/ConcatVanishes.hss +1/−1
• examples/concatVanishes/Makefile +0/−10
• examples/contents.txt +0/−181
• examples/evaluation/Eval.hs +33/−0
• examples/evaluation/Eval.hss +19/−0
• examples/factorial/Fac.hs +28/−0
• examples/factorial/Fac.hss +20/−0
• examples/fib-stream/Fib.hss +5/−7
• examples/fib-stream/Makefile +0/−10
• examples/fib-stream/WWSplitTactic.hss +0/−18
• examples/fib-tuple/Fib.hss +7/−5
• examples/fib-tuple/Makefile +0/−19
• examples/fib-tuple/WWSplitTactic.hss +0/−51
• examples/fib-tuple/blog.txt +0/−195
• examples/flatten/Flatten.hs +25/−0
• examples/flatten/Flatten.hss +37/−0
• examples/flatten/HList.hs +39/−0
• examples/hanoi/Hanoi.hss +2/−2
• examples/hanoi/Makefile +0/−13
• examples/last/Last.hs +21/−0
• examples/last/Last.hss +20/−0
• examples/map/Makefile +0/−10
• examples/map/Map.hs +0/−53
• examples/map/Map.hss +0/−47
• examples/mean/Mean.hs +20/−0
• examples/mean/Mean.hss +24/−0
• examples/qsort/HList.hs +39/−0
• examples/qsort/QSort.hs +28/−0
• examples/qsort/QSort.hss +36/−0
• examples/reverse/Makefile +0/−14
• examples/reverse/ReverseWW.hss +29/−0
• hermit.cabal +28/−23
• src/Language/HERMIT/Context.hs +74/−74
• src/Language/HERMIT/Core.hs +115/−0
• src/Language/HERMIT/CoreExtra.hs +0/−48
• src/Language/HERMIT/Dictionary.hs +16/−6
• src/Language/HERMIT/Expr.hs +2/−2
• src/Language/HERMIT/External.hs +1/−1
• src/Language/HERMIT/GHC.hs +24/−15
• src/Language/HERMIT/Interp.hs +8/−4
• src/Language/HERMIT/Kernel.hs +29/−29
• src/Language/HERMIT/Kernel/Scoped.hs +19/−17
• src/Language/HERMIT/Kure.hs +230/−177
• src/Language/HERMIT/Monad.hs +44/−30
• src/Language/HERMIT/Plugin.hs +22/−4
• src/Language/HERMIT/PrettyPrinter.hs +6/−2
• src/Language/HERMIT/PrettyPrinter/AST.hs +6/−4
• src/Language/HERMIT/PrettyPrinter/Clean.hs +53/−33
• src/Language/HERMIT/PrettyPrinter/GHC.hs +4/−3
• src/Language/HERMIT/PrettyPrinter/JSON.hs +6/−4
• src/Language/HERMIT/Primitive/AlphaConversion.hs +146/−115
• src/Language/HERMIT/Primitive/Common.hs +103/−62
• src/Language/HERMIT/Primitive/Debug.hs +1/−0
• src/Language/HERMIT/Primitive/FixPoint.hs +214/−0
• src/Language/HERMIT/Primitive/Fold.hs +9/−5
• src/Language/HERMIT/Primitive/GHC.hs +204/−144
• src/Language/HERMIT/Primitive/Inline.hs +30/−10
• src/Language/HERMIT/Primitive/Kure.hs +3/−0
• src/Language/HERMIT/Primitive/Local.hs +121/−52
• src/Language/HERMIT/Primitive/Local/Case.hs +31/−41
• src/Language/HERMIT/Primitive/Local/Let.hs +68/−36
• src/Language/HERMIT/Primitive/Navigation.hs +21/−9
• src/Language/HERMIT/Primitive/New.hs +42/−224
• src/Language/HERMIT/Primitive/Unfold.hs +2/−2
• src/Language/HERMIT/Primitive/Utils.hs +0/−12
• src/Language/HERMIT/Shell/Command.hs +49/−71

@@ -9,44 +9,81 @@ import Paths_hermit as P import Data.Version +import Data.List (isPrefixOf)+import System.Directory (doesFileExist)+ hermit_version :: String hermit_version = "HERMIT v" ++ showVersion P.version +usage :: IO ()+usage = putStrLn $ unlines+        [hermit_version+        ,""+        ,"usage: hermit File.hs SCRIPTNAME"+        ,"       - OR -"+        ,"       hermit File.hs [HERMIT_ARGS] [+module_name [MOD_ARGS]]* [-- [ghc-args]]"+        ,""+        ,"examples: hermit Foo.hs Foo.hss"+        ,"          hermit Foo.hs -p6 +main:Main Foo.hss"+        ,"          hermit Foo.hs +main:Main Foo.hss resume"+        ,"          hermit Foo.hs +main:Main Foo.hss +other:Other Bar.hss"+        ,"          hermit Foo.hs -- -ddump-simpl -ddump-to-file"+        ,""+        ,"If a module name is not supplied, the module main:Main is assumed."+        ,""+        ,"HERMIT_ARGS"+        ,"  -pN        : where 0 <= N < 18 is the position in the pipeline in which HERMIT should run, 0 being at the beginning"+        ,""+        ,"MOD_ARGS"+        ,"  SCRIPTNAME : name of script file to run for this module"+        ,"  resume     : skip interactive mode and resume compilation after any scripts"+        ]+ main :: IO () main = do    args <- getArgs-   main2 args+   main1 args -main2 :: [String] -> IO ()-main2 [] = putStrLn $ unlines-        [hermit_version-        ,""-        ,"usage: hermit <ModuleName>.hs [args] [-- [ghc-args]]"-        ]-main2 (mod_nm:args) = case span (/= "--") args of-        (hermit_args,"--":ghc_args) -> main3 mod_nm hermit_args ghc_args-        (hermit_args,[])            -> main3 mod_nm hermit_args []+main1 :: [String] -> IO ()+main1 [] = usage+main1 [file_nm,script_nm] = do+    e <- doesFileExist script_nm+    if e then main4 file_nm [] [("main:Main", [script_nm])] [] else usage+main1 other = main2 other++main2 (file_nm:rest) = case span (/= "--") rest of+        (args,"--":ghc_args) -> main3 file_nm args ghc_args+        (args,[])            -> main3 file_nm args []         _ -> error "hermit internal error" -main3 mod_nm hermit_args ghc_args = do-        putStrLn $ "[starting " ++ hermit_version ++ " on " ++ mod_nm ++ "]"+main3 file_nm args ghc_args = main4 file_nm hermit_args (sepMods margs) ghc_args+    where (hermit_args, margs) = span (not . isPrefixOf "+") args++          sepMods :: [String] -> [(String, [String])]+          sepMods [] = []+          sepMods (('+':mod_nm):rest) = (mod_nm, mod_opts) : sepMods next+            where (mod_opts, next) = span (not . isPrefixOf "+") rest++main4 file_nm hermit_args []          ghc_args = main4 file_nm hermit_args [("main:Main", [])] ghc_args+main4 file_nm hermit_args module_args ghc_args = do+        putStrLn $ "[starting " ++ hermit_version ++ " on " ++ file_nm ++ "]"         let cmds =-                 [ mod_nm+                  [ file_nm                   , "-fforce-recomp"                   , "-O2"                   , "-dcore-lint"                   , "-fsimple-list-literals" --                  , "-v0"-	          , "-fplugin=HERMIT"-                  ] ++ [ "-fplugin-opt=HERMIT:main:Main:" ++ opt-                       | opt <- "" : hermit_args-                       ] ++ ghc_args+                  , "-fplugin=HERMIT"+                  ] +++                  [ "-fplugin-opt=HERMIT:" ++ opt+                  | opt <- hermit_args+                  ] +++                  [ "-fplugin-opt=HERMIT:" ++ m_nm ++ ":" ++ opt+                  | (m_nm, m_opts) <- module_args+                  , opt <- "" : m_opts+                  ] ++ ghc_args         putStrLn $ "% ghc " ++ unwords cmds         (_,_,_,r) <- createProcess $ proc "ghc" cmds         ex <- waitForProcess r         exitWith ex-----

@@ -0,0 +1,18 @@+{+fix-intro+consider lam+let-intro 'f+up+let-float-arg+1+apply-rule ww+simplify+{ 1; let-intro 'w }+let-float-arg+{ rhs-of 'w+  unfold 'fix ; alpha-let 'work+  simplify+}+let-subst+let-float-arg+}

@@ -1,3 +1,4 @@+flatten-module consider let { consider def ; fix-intro } safe-let-subst@@ -12,4 +13,3 @@ bash any-call (unfold 'absH) try unshadow-

@@ -1,10 +0,0 @@-HERMIT = hermit--rev:-	$(HERMIT) Rev.hs Rev.hss--flatten:-	$(HERMIT) Flatten.hs Flatten.hss--qsort:-	$(HERMIT) QSort.hs QSort.hss

@@ -1,181 +0,0 @@-Concatenate Vanishes-====================--* A common script for all our Concatenate Vanishes examples.--* Completed.--* Interesting rewrites: push, innermost, unfold-rule--* It works for all three examples, but I doubt it would work for *any* concat vanishes example.--* Notes: unsafe uses of RULES with pre-conditions.---Evaluation-==========--* Evaluation of Hutton's Razor with exceptions.--* Convert to CPS to avoid repeated pattern matching.--* Completed.--* Interesting rewrites: abstract, fold---Fibonacci (Tupling)-===================--* Example of Tupling transformation.--* Completed and published--* Interesting rewrites: ww-split tactic, case-split(-inline), fold, remember (and fold/unfold remembered defns), let-tuple---Fibonacci (Stream Memoisation)-===================--* Example of Memoisation.--* Completed.--* Interesting rewrites: ww-split tactic---Flatten-=======--* Another concatenate-vanishes example, based on the Reverse example.--* Completed.--* Main rewrites: any-call---Hanoi-=====--* Another tupling transformation--* Completed.--* Interesting rewrites: ww-split tactic, case-split(-inline), fold, remember (and fold/unfold remembered defns), let-tuple--Map-===--* List unrolling.--* Completed.--* Main rewrites: simplify, any-call, unfold, case-split(-inline), remember.---Haskell 2012 Paper-==================--Fibonacci (Unrolling)------------------------* We unfold fib once to show how things operate overall.--* Main rewrites: any-bu, inline---Reverse----------* Our larger, low-level reverse example.--* Main rewrites: any-bu, unfold---Append---------* A demonstration of GHC RULES (no use of HERMIT).---IFL 2012 Paper-==================--Fibonacci (Tupling)----------------------* Example of Tupling transformation.--* Interesting rewrites: ww-split tactic, case-split(-inline), fold, remember (fold/unfold remembered defns), let-tuple---Last-====--* A classic simple example.--* Completed.---Mean-====--* Problem (and pen-and-paper calculation) provided by Jason Reich.--* A non-WW tupling example (maybe it can be cast as WW, I'm not sure).--* Completed.--* Interesting rewrites: abstract, remember, fold, let-intro, let-float, let-tuple----Nub-===--* A new (that is, unpublished) worker/wrapper example.--* There was a bug in Andy's original pen-and-paper derivation.--* A corrected version is in the files named "Revised".--* There has been no attempt to mechanise this revised derivation as yet.----Quicksort-=========--* Another concatenate-vanishes example.--* Completed.--* Main rewrites: any-call---Reverse-=======--* Higher-level script than in the Haskell 2012 paper.--* Completed.  Lower-level version has been published.--* Main rewrites: any-call---Talks-=====--* This directory is for the code that Neil intends to demo at Nottingham, IFL and Haskell.--* Don't mess with it without telling him!---To Do-=====--* Life - Can we translate to a stronger type?--* Kansas Lava example?--

@@ -0,0 +1,33 @@+module Main where++import Data.Function(fix)++data Expr = Val Int | Add Expr Expr | Throw | Catch Expr Expr++type Mint = Maybe Int++eval :: Expr -> Mint+eval (Val n)     = Just n+eval Throw       = Nothing+eval (Catch x y) = case eval x of+                       Nothing -> eval y+                       Just n  -> Just n+eval (Add x y)   = case eval x of+                       Nothing -> Nothing+                       Just m  -> case eval y of+                                    Nothing -> Nothing+                                    Just n  -> Just (m + n)++unwrap :: (Expr -> Mint) -> Expr -> (Int -> Mint) -> Mint -> Mint+unwrap g e s f = case g e of+                   Nothing -> f+                   Just n  -> s n++wrap :: (Expr -> (Int -> Mint) -> Mint -> Mint) -> Expr -> Mint+wrap h e = h e Just Nothing++{-# RULES "ww"     forall f. fix f = wrap (fix (unwrap . f . wrap)) #-}+{-# RULES "fusion" forall w. unwrap (wrap w) = w                    #-} -- has precondition++main :: IO ()+main = print (eval $ Val 5)

@@ -0,0 +1,19 @@+flatten-module+consider 'eval+load "../WWSplitTactic.hss"+{rhs-of 'work+   eta-expand 'e ; 0+   eta-expand 's ; 0+   eta-expand 'f ; 0+   unfold 'unwrap+   one-td (unfold 'f)+   bash+   {+     consider case ; 2 ; 0 ; abstract 'm+     consider case ; 2 ; 0 ; abstract 'n+   }+   any-bu (fold 'unwrap)+   any-bu (unfold-rule "fusion")+}+simplify+any-call (unfold 'wrap)

@@ -0,0 +1,28 @@+{-# LANGUAGE MagicHash #-}++import Prelude hiding ((*),(-))+import GHC.Exts+import Data.Function(fix)++fac :: Int -> Int+fac 0 = 1+fac n = n * fac (n -1)++unwrap :: (Int -> Int) -> Int# -> Int#+unwrap h x = case h (I# x) of+               I# y -> y++wrap :: (Int# -> Int#) -> Int -> Int+wrap h (I# x) = I# (h x)++{-# RULES "ww"     forall f. fix f = wrap (fix (unwrap . f . wrap)) #-}++main :: IO ()+main = print (fac 10)+++(*) :: Int -> Int -> Int+(I# x) * (I# y) = I# (x *# y)++(-) :: Int -> Int -> Int+(I# x) - (I# y) = I# (x -# y)

@@ -0,0 +1,20 @@+flatten-module+consider 'fac+load "../WWSplitTactic.hss"+{rhs-of 'work+  eta-expand 'x+  one-td (unfold 'unwrap)+  one-td (unfold 'f)+  one-td (unfold 'wrap)+  simplify+  {+    consider alt ; 0 ; case-float-arg+    consider alt ; 0 ; case-float-arg+  }+  one-td (unfold '-)+  one-td (unfold '*)+  simplify+  innermost case-float-case+}+simplify+{ consider let ; 1 ; eta-expand 'n ; any-call (unfold 'wrap) }

@@ -1,14 +1,12 @@ flatten-module consider 'fib {-load "WWSplitTactic.hss"-{ 0 ; 1-  { 0-    any-call (unfold 'unwrap)+  load "../WWSplitTactic.hss"+  {rhs-of 'work+    unfold 'unwrap     any-call (unfold 'f)     { consider lam ; alpha-lam 'm }   }-}-innermost dead-code-elimination-any-call (unfold 'wrap)+  simplify+  any-call (unfold 'wrap) }

@@ -1,10 +0,0 @@-HERMIT = perl ../../scripts/hermit.pl--fib:-	- $(HERMIT) Fib.hs Fib.hss resume--interactive:-	- $(HERMIT) Fib.hs Fib.hss--start:-	- $(HERMIT) Fib.hs

@@ -1,18 +0,0 @@-{-fix-intro-consider lam-let-intro 'f-up-let-float-arg-1-apply-rule ww-simplify-{ 1; let-intro 'w }-let-float-arg-{ rhs-of 'w-  unfold 'fix ; alpha-let 'work-  simplify-}-let-subst-let-float-arg-}

@@ -3,7 +3,7 @@  { -load "WWSplitTactic.hss"+load "../WWSplitTactic.hss" consider 'work ; remember origwork  -- work = unwrap (f (wrap work))@@ -22,13 +22,13 @@ -- work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+2))  { 1 ; any-call (unfold 'f) }-{ 2 ; 0 ; 1 ; any-bu (unfold 'f) }+{ 2 ; 0 ; 1 ; any-call (unfold 'f) } simplify  -- work 0     = (0, 1) -- work (n+1) = (f (wrap work) (n+1), wrap work (n+1) + wrap work n) -2 ; 0 ; { 1 ; any-bu (unfold origwork) }+2 ; 0 ; { 1 ; any-call (unfold origwork) }  -- work 0     = (0, 1) -- work (n+1) = (f (wrap work) (n+1), wrap (unwrap (f (wrap work))) (n+1) + wrap (unwrap (f (wrap work))) n)@@ -59,5 +59,7 @@  } -innermost dead-code-elimination-{ 0 ; 1 ; any-call (unfold 'wrap) ; simplify }+innermost dead-let-elimination+any-call (unfold 'wrap)+simplify+

@@ -1,19 +0,0 @@-HERMIT = perl ../../scripts/hermit.pl--fib:-	- $(HERMIT) Fib.hs Fib.hss resume--interactive:-	- $(HERMIT) Fib.hs Fib.hss--start:-	- $(HERMIT) Fib.hs--test:-	- rm *.o *.hi Fib-	- ghc --make -O2 -o Fib -fforce-recomp Fib.hs-	- ./Fib > timing.txt-	- echo "===========================================" >> timing.txt-	- $(HERMIT) Fib.hs Fib.hss resume-	- ./Fib >> timing.txt-	- cat timing.txt

@@ -1,51 +0,0 @@--- this is a (pretty general) ww tactic--- it transforms:------ rec g = body                                 (where body mentions g)------ into:------ g = let f = \g -> body                       (f is not recursive)---         rec work = unwrap (f (wrap work))---     in wrap work------ Note: inlining f (and bashing) would result in the same code---       achieved in the reverse example by applying the "ww" rule.------ The original function g is now a non-recursive wrapping of the worker.--- The worker makes use of the original body, and is recursive.------ So what have we gained doing it this way? Mainly, the noise of the--- original body is all tidily hidden in f, and we can focus on manipulating--- the wrap and unwrap functions, which is what we want to do.------ I've tested this on reverse, and it also works, so I think the--- next step is to formulate it as an actual rewrite, or otherwise--- bundle it up as a one-liner.------ TODO: this relies on a RULES pragmas:------  {-# RULES "ww" forall work . fix work = wrap (fix (unwrap . work . wrap)) #-}------ We either need to provide this somehow, or implement it as a rewrite.------ BEGIN: ww tactic-{-fix-intro-consider lam-let-intro 'f-up-let-float-arg-1-apply-rule ww-simplify-{ 1; let-intro 'w }-let-float-arg-{ rhs-of 'w-  unfold 'fix ; alpha-let 'work-  simplify-}-let-subst-let-float-arg-}--- END: ww tactic

@@ -1,195 +0,0 @@-Using this file to keep track of progress/improvements coming out of this example.-Format: steps from Neil's worker/wrapper derivation with interspersed commentary.-Entire derivation is:---- Normal fib definition-fib :: Nat -> Nat-fib = body---- After WWSplit tactic-fib = wrap work--f :: (Nat -> Nat) -> Nat -> Nat-f = \fib -> body--wrap :: (Nat -> (Nat, Nat)) -> (Nat -> Nat)-unwrap :: (Nat -> Nat) -> (Nat -> (Nat, Nat))-work :: Nat -> (Nat, Nat)---- Derivation-work = unwrap (f (wrap work))- {- extensionality -}-work n = unwrap (f (wrap work)) n- {- unfold 'unwrap -}-work n = (f (wrap work) n, f (wrap work) (n+1))- {- case 'n -}-work 0     = (f (wrap work) 0, f (wrap work) 1)-work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+2))- {- unfold 'f -}-work 0     = (0, 1)-work (n+1) = (f (wrap work) (n+1), wrap work (n+1) + wrap work n)- {- unfold 'work -}-work 0     = (0, 1)-work (n+1) = (f (wrap work) (n+1), wrap (unwrap (f (wrap work))) (n+1) + wrap (unwrap (f (wrap work))) n)- {- wrap . unwrap = id (precondition) -}-work 0     = (0, 1)-work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+1) + f (wrap work) n)- {- let-intro x2, let-float-tuple -}-work 0     = (0, 1)-work (n+1) = let (x,y) = (f (wrap work) n, f (wrap work) (n+1)) in (y,x+y)- {- fold 'unwrap -}-work 0     = (0, 1)-work (n+1) = let (x,y) = unwrap (f (wrap work)) n in (y,x+y)- {- fold 'work -}-work 0     = (0, 1)-work (n+1) = let (x,y) = work n in (y,x+y)- {- QED -}--Discussion:--###############################################################################--work = unwrap (f (wrap work))--To get to this point required creation of the WWSplit tactic. This-is slightly more complicated than how we did the split in the reverse-example in the paper, because we want to keep f abstract for most-of this derivation (we selectively unfold it once). I was able to-create a tactic which I believe is entirely general, allowing one-to rewrite:--  letrec g = body--to:--  let g = (let f = \g -> body-           in (letrec work = unwrap (f (wrap work))-               in wrap work))--There are a couple todo's regarding this split. It relies on-two GHC RULES pragmas (ww, and inline-fix). These should probably-be written as rewrites. Doing so would probably allow the whole-tactic to be expressed as a rewrite, rather than a hermit script.--###############################################################################-- {- extensionality -}-work n = unwrap (f (wrap work)) n--This was done with "eta-expand 'n". Allowing core lint to run revealed-that eta-expand was not handling types correctly. This is fixed in commit-b49fcd2be2ff0592ab51a2e9b8a291dff48bbf4b by using splitFunTy_maybe, which-looks to be a really handy function. Must remember to exit Hermit with-resume, instead of abort, so core-lint runs.--###############################################################################-- {- unfold 'unwrap -}-work n = (f (wrap work) n, f (wrap work) (n+1))--At the moment we have to be careful to call unfold at the right place. Otherwise-we end up with extra redexes that must be dealt with.--###############################################################################-- {- case 'n -}-work 0     = (f (wrap work) 0, f (wrap work) 1)-work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+2))--This step required two new capabilites:--  * A case-split rewrite that accepts the name of a free variable of an-    expression, finds all the data constructors belonging to the type,-    and builds a case statement, cloning the expression for each case alt.-    Getting the correct types of the pattern binders was tricky (or simple-    once I found the correct GHC functions to instantiate the constructor-    argument types).--  * Modify the Hermit context to store two possible values for variables-    that are case wildcard binders. These can refer to either the scrutinee-    (previous behavior), or the constructor application of the pattern. This-    is what allows the 'n above to be replaced by 0 and 1 when case splitting.-    It is important to store the AltCon and binders in the context, and only-    convert to a CoreExpr upon inlining, so that we can apply the constructor-    at the correct types.--There is a case-split-inline rewrite that combines these steps. This step-also required rewriting fib to work over:--  data Nat = Zero | Succ Nat--rather than Int, as the only Int constructor is the one which boxes Int#. We-probably need an case-literal rewrite, which accepts a literal and adds a-LitCon pattern. We could then go back to working on Int, and "case-literal 0"-rather than "case-split-inline 'n".--###############################################################################-- {- unfold 'f -}-work 0     = (0, 1)-work (n+1) = (f (wrap work) (n+1), wrap work (n+1) + wrap work n)--This step is done by calling unfold and repeatedly applying case-reduce on-three of the four tupled expressions. Should we add case-reduce to the-unfold cleanup step? Is there a more general cleanup rewrite we can build-that isn't as invasive as bash, but handles this stuff for us? I can imagine-some rewrites (like case-reduce) that we simply always want to run, as they-are effectively dead code elimination.--###############################################################################-- {- unfold 'work -}-work 0     = (0, 1)-work (n+1) = (f (wrap work) (n+1), wrap (unwrap (f (wrap work))) (n+1) + wrap (unwrap (f (wrap work))) n)--Our first run-in with equational reasoning issues. The problem is that we-want to unfold the definition of work we started with, not the one we currently-have. We are experimenting with two approaches to this:--    1. Create a GHC rule on the fly, stash it in the ModGuts, and then-       use unfold-rule. There are (currently) a few problems with this:--        * Only top-level bindings consistently work as rules. This can probably-          be solved by tracking down the occasional kernel panic. See my email-          on July 12th about the issue.--        * The add-rule rewrite works on ModGuts (by necessity), so you must be-          at the top level to use it. This is problematic when inside scoping-          braces, which prevent you from going up by design.--    2. Stash the definition in the HermitMonad (currently) or alongside the-       AST in the kernel. This is the method I'm currently using in the-       derivation. It appears to work quite well, and gives us control-       over how its unfolded. We can reject unfoldings that would result-       in variables that are not defined (because a binding is no longer-       present), for instance. TODO: prevent unintended capture!--The two rewrites added for #2 are:--  stashDef :: String -> TranslateH CoreDef () -- stashes the RHS of binding, with a name-  -- stash-defn-  stashApply :: String -> RewriteH CoreExpr   -- like inline, but looks up a stashed name-  -- stash-apply--###############################################################################-- {- wrap . unwrap = id (precondition) -}-work 0     = (0, 1)-work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+1) + f (wrap work) n)--I'm currently using a GHC rule for this:--    {-# RULES precondition forall w . wrap (unwrap w) = w #-}--###############################################################################-- {- let-intro x2, let-float -}-work 0     = (0, 1)-work (n+1) = let (x,y) = (f (wrap work) n, f (wrap work) (n+1)) in (y,x+y)- {- fold 'unwrap -}-work 0     = (0, 1)-work (n+1) = let (x,y) = unwrap (f (wrap work)) n in (y,x+y)- {- fold 'work -}-work 0     = (0, 1)-work (n+1) = let (x,y) = work n in (y,x+y)- {- QED -}

@@ -0,0 +1,25 @@+module Main where++import HList+import Data.Function (fix)++data Tree a = Node (Tree a) (Tree a) | Leaf a++{-# INLINE unwrap #-}+unwrap :: (Tree a -> [a]) -> (Tree a -> H a)+unwrap f = repH . f++{-# INLINE wrap #-}+wrap :: (Tree a -> H a) -> (Tree a -> [a])+wrap g = absH . g++{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}+{-# RULES "inline-fix" forall f . fix f = let w = f w in w #-}++-- flatten :: Tree a -> [a]+flatten (Leaf a)   = [a]+flatten (Node l r) = flatten l ++ flatten r++main :: IO ()+main = print (flatten (Node (Leaf 'h') (Leaf 'i')))+

@@ -0,0 +1,37 @@+flatten-module+consider 'flatten+{+  consider 'flatten+  fix-intro+  0+  unfold-rule "ww"+  any-call (unfold '.)+  any-call (unfold 'wrap)+  any-call (unfold 'unwrap)+  any-call (unfold '.)+  bash+  unshadow+  any-bu case-float-arg+  {+    consider case+    any-bu (apply-rule "repH ++")+    bash+    any-bu (unfold-rule "rep-abs-fusion")+    {+      2+      0+      unfold-rule "repH (:)"+      one-td (unfold-rule "repH []")+      unfold-rule "(.) id"+    }+  }+  {+    consider app+    unfold 'fix+    alpha-let 'work+  }+}+bash+try unshadow+one-td (unfold 'absH)+

@@ -0,0 +1,39 @@+module HList+       ( H+       , repH+       , absH+       ) where++type H a = [a] -> [a]++{-# INLINE repH #-}+repH :: [a] -> H a+repH xs = (xs ++)++{-# INLINE absH #-}+absH :: H a -> [a]+absH f = f []++-- These two we may get for free via INLINE+{-# RULES "repH" forall xs	 . repH xs = (xs ++) #-}+{-# RULES "absH" forall f 	 . absH f = f []     #-}++-- The "Algebra" for repH+{-# RULES "repH ++" forall xs ys   . repH (xs ++ ys) = repH xs . repH ys #-}+{-# RULES "repH []" 	             repH [] = id  	       	         #-}+{-# RULES "repH (:)" forall x xs   . repH (x:xs) = ((:) x) . repH xs     #-}++-- Should be in the "List" module+{-# RULES "(:) ++" forall x xs ys . (x:xs) ++ ys = x : (xs ++ ys) #-}+{-# RULES "[] ++"  forall xs      . [] ++ xs     = xs #-}++-- Should be somewhere else+{-# RULES "(.) id" forall f .    f . id = f #-}++-- has preconditon+{-# RULES "rep-abs-fusion" forall h . repH (absH h) = h #-}+++++

@@ -2,7 +2,7 @@  -- do the w/w split consider 'hanoi-{ load "../fib-tuple/WWSplitTactic.hss" }+{ load "../WWSplitTactic.hss" }  { consider 'work   remember origwork@@ -56,4 +56,4 @@     }   } }-innermost dead-code-elimination+innermost dead-let-elimination

@@ -1,13 +0,0 @@-hanoi:-	- hermit Hanoi.hs Hanoi.hss resume--interactive:-	- hermit Hanoi.hs Hanoi.hss--test:-	- rm Hanoi *.o *.hi-	- ghc --make Hanoi.hs -O2 -o Hanoi-	- ./Hanoi-	- rm Hanoi *.o *.hi-	- hermit Hanoi.hs Hanoi.hss resume-	- ./Hanoi

@@ -0,0 +1,21 @@+module Main where++import Data.Function(fix)+import Prelude hiding (last)++unwrap         :: ([a] -> a) -> a -> [a] -> a+unwrap f a as  = f (a:as)++wrap           :: (a -> [a] -> a) -> [a] -> a+wrap f []      = error "wrap _ []"+wrap f (a:as)  = f a as++{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}++-- last :: [a] -> a+last []        = error "last []"+last [a]       = a+last (_:a:as)  = last (a:as)++main :: IO ()+main = print (last "hello")

@@ -0,0 +1,20 @@+flatten-module+consider 'last+{consider 'last+  load "../WWSplitTactic.hss"+  {rhs-of 'work+     eta-expand 'b+     0+     eta-expand 'bs+     0+     unfold 'unwrap+     unfold 'f+     case-reduce+     consider app+     unfold 'wrap+     case-reduce+  }+}+simplify+any-call (unfold 'wrap)+

@@ -1,10 +0,0 @@-HERMIT = perl ../../scripts/hermit.pl--last:-	- $(HERMIT) Map.hs Map.hss resume--interactive:-	- $(HERMIT) Map.hs Map.hss--start:-	- $(HERMIT) Map.hs

@@ -1,53 +0,0 @@-module Main where--import Data.Function(fix)-import Prelude hiding (abs, map)--data List2 a = Cons2 a a (List2 a)-             | Singleton a-             | Nil--rep :: [a] -> List2 a-rep []       = Nil-rep [x]      = Singleton x-rep (x:y:xs) = Cons2 x y (rep xs)--abs :: List2 a -> [a]-abs Nil            = []-abs (Singleton x)  = [x]-abs (Cons2 x y xs) = x : y : abs xs--unwrap :: ([a] -> [b]) -> (List2 a -> List2 b)-unwrap f = rep . f . abs--wrap :: (List2 a -> List2 b) -> ([a] -> [b])-wrap f = abs . f . rep---- needed for WWSplitTactic.hss-{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}-{-# RULES "inline-fix" forall f . fix f = let work = f work in work #-}-{-# RULES "precondition1" forall xs . abs (rep xs) = xs #-}-{-# RULES "precondition2" forall xs . rep (abs xs) = xs #-}---- can apply "ww" rule to this-mapPlus1Int :: [Int] -> [Int]-mapPlus1Int []     = []-mapPlus1Int (x:xs) = (x+1) : mapPlus1Int xs--{- can't apply "ww" rule to either of these... is it because of the forall type?-unwrap :: ((a -> b) -> [a] -> [b]) -> ((a -> b) -> [a] -> List2 b)-unwrap g f = rep . g f--wrap :: ((a -> b) -> [a] -> List2 b) -> ((a -> b) -> [a] -> [b])-wrap g f = abs . g f--}-mapPlus1 :: Num a => [a] -> [a]-mapPlus1 []     = []-mapPlus1 (x:xs) = (x+1) : mapPlus1 xs--map :: (a -> b) -> [a] -> [b]-map _ []     = []-map f (x:xs) = f x : map f xs--main :: IO ()-main = print (map (+1) [1..10::Int])

@@ -1,47 +0,0 @@-flatten-module-consider 'mapPlus1Int-{load "../fib-tuple/WWSplitTactic.hss"-  consider 'work--  remember origwork-  0-  one-td (unfold 'unwrap)-  any-call (unfold '.)-  innermost (beta-reduce <+ safe-let-subst)-  0-  case-split-inline 'x-  { 3 -- Nil case-    any-call (unfold 'abs)-    any-call (unfold 'f)-    any-call (unfold 'rep)-    simplify-  }-  { 2 -- Singleton case-    any-call (unfold 'abs)-    any-call (unfold 'f)-    any-call (unfold 'wrap)-    any-call (unfold 'rep)-    -- here we make use of the already solved Nil case-    any-call (unfold 'work)-    simplify-    any-call (unfold 'abs)-    simplify-  }-  { 1 -- Cons2 case-    any-call (unfold 'abs)-    any-call (unfold 'f)-    any-call (unfold 'wrap)-    simplify-    any-bu (unfold origwork)-    any-call (unfold 'unwrap)-    simplify-    innermost (unfold-rule precondition1)-    any-call (unfold 'f)-    innermost case-reduce-    any-call (unfold 'rep)-    innermost case-reduce-    any-call (unfold 'wrap)-    simplify-    innermost (unfold-rule precondition2)-  }-}

@@ -0,0 +1,20 @@+import Prelude hiding (sum, length)++-- so we can let-tuple+import Data.Tuple+import GHC.Tuple++{-# NOINLINE mean #-}+mean :: [Int] -> Int+mean xs = sum xs `div` length xs++sum :: [Int] -> Int+sum []     = 0+sum (x:xs) = x + sum xs++length :: [Int] -> Int+length []     = 0+length (x:xs) = 1 + length xs++main :: IO ()+main = print $ mean [1..10]

@@ -0,0 +1,24 @@+{rhs-of 'mean ; 0+  { 1 ; let-intro 'l }+  { 0 ; 1 ; let-intro 's }+  innermost let-float+  let-tuple 'sl+  { 0 ; abstract 'xs ; 0 ; let-intro 'sumlength }+}+innermost let-float+consider 'sumlength+nonrec-to-rec           -- since we intend sumlength to be a recursive function+0+remember sumlen+{ 0 ; 0+  case-split-inline 'xs+  any-call (unfold 'sum)+  any-call (unfold 'length)+  simplify+  2 ; 0+  { 1 ; 1 ; let-intro 'l }+  { 0 ; 1 ; 1 ; let-intro 's }+  innermost let-float+  let-tuple 'sl+  { 0 ; fold sumlen }+}

@@ -0,0 +1,39 @@+module HList+       ( H+       , repH+       , absH+       ) where++type H a = [a] -> [a]++{-# INLINE repH #-}+repH :: [a] -> H a+repH xs = (xs ++)++{-# INLINE absH #-}+absH :: H a -> [a]+absH f = f []++-- These two we may get for free via INLINE+{-# RULES "repH" forall xs	 . repH xs = (xs ++) #-}+{-# RULES "absH" forall f 	 . absH f = f []     #-}++-- The "Algebra" for repH+{-# RULES "repH ++" forall xs ys   . repH (xs ++ ys) = repH xs . repH ys #-}+{-# RULES "repH []" 	             repH [] = id  	       	         #-}+{-# RULES "repH (:)" forall x xs   . repH (x:xs) = ((:) x) . repH xs     #-}++-- Should be in the "List" module+{-# RULES "(:) ++" forall x xs ys . (x:xs) ++ ys = x : (xs ++ ys) #-}+{-# RULES "[] ++"  forall xs      . [] ++ xs     = xs #-}++-- Should be somewhere else+{-# RULES "(.) id" forall f .    f . id = f #-}++-- has preconditon+{-# RULES "rep-abs-fusion" forall h . repH (absH h) = h #-}+++++

@@ -0,0 +1,28 @@+module Main where++import HList+import Data.Function (fix)+import Data.List++data Tree a = Node (Tree a) (Tree a) | Leaf a++{-# INLINE unwrap #-}+unwrap :: ([a] -> [a]) -> ([a] -> H a)+unwrap f = repH . f++{-# INLINE wrap #-}+wrap :: ([a] -> H a) -> ([a] -> [a])+wrap g = absH . g++{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}+{-# RULES "inline-fix" forall f . fix f = let w = f w in w #-}++-- qsort :: Ord a => [a] -> [a]+qsort []     = []+qsort (a:as) = qsort bs ++ [a] ++ qsort cs+               where+                  (bs , cs) = partition (< a) as++main :: IO ()+main = print (qsort [8,3,5,7,2,9,4,6,3,2])+

@@ -0,0 +1,36 @@+flatten-module+consider 'qsort+{+  consider 'qsort+  fix-intro+  0+  unfold-rule "ww"+  any-call (unfold '.)+  any-call (unfold 'wrap)+  any-call (unfold 'unwrap)+  any-call (unfold '.)+  bash+  any-td case-float-arg+  bash+  {+    consider case+    any-td (unfold-rule "repH ++")+    any-td (unfold-rule "rep-abs-fusion")+    any-td (unfold-rule "repH (:)")+    any-td (unfold-rule "repH []")+    any-call (unfold '.)+    bash+    { consider let+      repeat let-subst -- maybe if we folded the (.) then safe-let-subst would fire and this would be unneccassary+    }+    any-td (unfold-rule "(.) id")+  }+}+{+  consider app+  unfold 'fix+  alpha-let 'work+}+bash+one-td (unfold 'absH)+

@@ -1,14 +0,0 @@-HERMIT = perl ../../scripts/hermit.pl-MODULE=Reverse--test-example:-	- $(HERMIT) $(MODULE).hs resume-	./$(MODULE)--	- $(HERMIT) $(MODULE).hs $(MODULE).hss resume-	./$(MODULE)--interactive-example:-	- $(HERMIT) Reverse.hs--

@@ -0,0 +1,29 @@+flatten-module+consider 'rev+{consider 'rev+  load "../WWSplitTactic.hss"+  {rhs-of 'work+     any-call (unfold 'wrap)+     any-call (unfold 'f)+     any-call (unfold 'unwrap)+     any-call (unfold '.)+     simplify+     alpha-lam 'ys+     {0+       eta-expand 'acc+       innermost case-float+       one-td (unfold-rule "repH []")+       one-td (unfold 'id)+       one-td (unfold-rule "repH ++")+       one-td (unfold-rule "rep-abs-fusion")+       one-td (unfold 'repH)+       any-call (unfold '.)+       any-call (unfold-rule "(:) ++")+       any-call (unfold-rule "[] ++")+     }+  }+}+any-call (unfold 'wrap)+any-call (unfold '.)+any-call (unfold 'absH)+simplify

@@ -1,5 +1,5 @@ Name:                hermit-Version:             0.1.2.0+Version:             0.1.4.0 Synopsis:            Haskell Equational Reasoning Model-to-Implementation Tunnel Description:   HERMIT uses Haskell to express semi-formal models,@@ -17,7 +17,7 @@   .     * log command prints linearly, even if command history is a tree.   .-    * The fold rewrite can only fold syntactically equivalent (up to+    * The fold rewrite can only fold syntactically alpha-equivalent (up to       parameters of the function you are folding) expressions.   .     * RULES have issues with forall types.@@ -38,12 +38,12 @@   .   @    $ hermit Reverse.hs Reverse.hss resume-   [starting HERMIT v0.1.2.0 on Reverse.hs]+   [starting HERMIT v0.1.4.0 on Reverse.hs]    % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:main:Main: -fplugin-opt=HERMIT:main:Main:resume    [1 of 2] Compiling HList            ( HList.hs, HList.o )    Loading package ghc-prim ... linking ... done.    ...-   Loading package hermit-0.1.2.0 ... linking ... done.+   Loading package hermit-0.1.4.0 ... linking ... done.    [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )    Linking Reverse ...    $ ./Reverse@@ -54,12 +54,12 @@   .   @    $ hermit Reverse.hs-   [starting HERMIT v0.1.2.0 on Reverse.hs]+   [starting HERMIT v0.1.4.0 on Reverse.hs]    % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:main:Main:    [1 of 2] Compiling HList            ( HList.hs, HList.o )    Loading package ghc-prim ... linking ... done.    ...-   Loading package hermit-0.1.2.0 ... linking ... done.+   Loading package hermit-0.1.4.0 ... linking ... done.    [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )    module main:Main where    \ \ rev ∷ ∀ a . [] a -> [] a@@ -87,40 +87,44 @@ Maintainer:          Andy Gill <andygill@ku.edu> Stability:           pre-alpha build-type:          Simple-Cabal-Version:       >= 1.10+Cabal-Version:       >= 1.14  extra-source-files:+    examples/WWSplitTactic.hss     examples/concatVanishes/ConcatVanishes.hss     examples/concatVanishes/Flatten.hs     examples/concatVanishes/Flatten.hss     examples/concatVanishes/HList.hs-    examples/concatVanishes/Makefile     examples/concatVanishes/QSort.hs     examples/concatVanishes/QSort.hss     examples/concatVanishes/Rev.hs     examples/concatVanishes/Rev.hss-    examples/contents.txt+    examples/evaluation/Eval.hs+    examples/evaluation/Eval.hss+    examples/factorial/Fac.hs+    examples/factorial/Fac.hss     examples/fib-stream/Fib.hs     examples/fib-stream/Fib.hss-    examples/fib-stream/Makefile     examples/fib-stream/Nat.hs     examples/fib-stream/Stream.hs-    examples/fib-stream/WWSplitTactic.hss     examples/fib-tuple/Fib.hs     examples/fib-tuple/Fib.hss-    examples/fib-tuple/Makefile-    examples/fib-tuple/WWSplitTactic.hss-    examples/fib-tuple/blog.txt+    examples/flatten/HList.hs+    examples/flatten/Flatten.hs+    examples/flatten/Flatten.hss     examples/hanoi/Hanoi.hs     examples/hanoi/Hanoi.hss-    examples/hanoi/Makefile-    examples/map/Map.hs-    examples/map/Map.hss-    examples/map/Makefile+    examples/last/Last.hs+    examples/last/Last.hss+    examples/mean/Mean.hs+    examples/mean/Mean.hss+    examples/qsort/HList.hs+    examples/qsort/QSort.hs+    examples/qsort/QSort.hss     examples/reverse/HList.hs-    examples/reverse/Makefile     examples/reverse/Reverse.hs     examples/reverse/Reverse.hss+    examples/reverse/ReverseWW.hss  Library   ghc-options: -Wall -fno-warn-orphans@@ -131,7 +135,7 @@                  data-default >= 0.5.0,                  ghc == 7.6.*,                  haskeline >= 0.7.0.3,-                 kure >= 2.4.2,+                 kure >= 2.4.10,                  marked-pretty >= 0.1,                  mtl >= 2.1.2,                  stm >= 2.4,@@ -144,7 +148,7 @@        HERMIT         Language.HERMIT.Context-       Language.HERMIT.CoreExtra+       Language.HERMIT.Core        Language.HERMIT.Dictionary        Language.HERMIT.Expr        Language.HERMIT.External@@ -156,7 +160,9 @@         Language.HERMIT.Plugin +       Language.HERMIT.Primitive.AlphaConversion        Language.HERMIT.Primitive.Debug+       Language.HERMIT.Primitive.FixPoint        Language.HERMIT.Primitive.Fold        Language.HERMIT.Primitive.GHC        Language.HERMIT.Primitive.Inline@@ -166,9 +172,7 @@        Language.HERMIT.Primitive.Local.Case        Language.HERMIT.Primitive.Navigation        Language.HERMIT.Primitive.New-       Language.HERMIT.Primitive.AlphaConversion        Language.HERMIT.Primitive.Unfold-       Language.HERMIT.Primitive.Utils         Language.HERMIT.PrettyPrinter        Language.HERMIT.PrettyPrinter.AST@@ -187,6 +191,7 @@  Executable hermit     Build-Depends: base >= 4 && < 5,+                   directory >= 1.2.0.0,                    process      default-language: Haskell2010

@@ -1,31 +1,36 @@ {-# LANGUAGE InstanceSigs #-}  module Language.HERMIT.Context-       (-         -- * HERMIT Bindings-         HermitBinding(..)-       , hermitBindingDepth-         -- * The HERMIT Context-       , Context-       , initContext+       ( -- * The HERMIT Context+         HermitC+       , initHermitC+         -- ** Adding to the Context        , (@@)        , addAltBindings        , addBinding        , addCaseBinding        , addLambdaBinding+         -- ** Reading from the Context        , hermitBindings        , hermitDepth        , hermitPath        , hermitModGuts        , lookupHermitBinding-       , listBindings+       , boundVars        , boundIn+       , findBoundVars+         -- ** Bindings+       , HermitBinding(..)+       , hermitBindingDepth ) where  import Prelude hiding (lookup) import GhcPlugins hiding (empty)-import Data.Map hiding (map, foldr)+import Data.Map hiding (map, foldr, filter)+import qualified Language.Haskell.TH as TH +import Language.HERMIT.GHC+ import Language.KURE  ------------------------------------------------------------------------@@ -35,8 +40,8 @@         = BIND Int Bool CoreExpr  -- ^ Binding depth, whether it is recursive, and the bound value                                   --   (which cannot be inlined without checking for scoping issues).         | LAM Int                 -- ^ For a lambda binding you only know the depth.-        | CASE Int CoreExpr (AltCon,[Id]) -- ^ For case wildcard binders. First expr points to scrutinee,-                                          --   second to AltCon (which can be converted to Constructor or Literal).+        | CASE Int CoreExpr (AltCon,[Id]) -- ^ For case wildcard binders. We store both the scrutinised expression,+                                          --   and the case alternative 'AltCon' (which can be converted to Constructor or Literal) and identifiers.  -- | Get the depth of a binding. hermitBindingDepth :: HermitBinding -> Int@@ -49,8 +54,8 @@ -- | The HERMIT context, containing all bindings in scope and the current location in the AST. --   The bindings here are lazy by choice, so that we can avoid the cost --   of building the context if we never use it.-data Context = Context-        { hermitBindings :: Map Id HermitBinding    -- ^ All (important) bindings in scope.+data HermitC = HermitC+        { hermitBindings :: Map Var HermitBinding   -- ^ All (important) bindings in scope.         , hermitDepth    :: Int                     -- ^ The depth of the bindings.         , hermitPath     :: AbsolutePath            -- ^ The 'AbsolutePath' to the current node from the root.         , hermitModGuts  :: ModGuts                 -- ^ The 'ModGuts' of the current module.@@ -59,80 +64,75 @@ ------------------------------------------------------------------------  -- | The HERMIT context stores an 'AbsolutePath' to the current node in the tree.-instance PathContext Context where-  contextPath :: Context -> AbsolutePath+instance PathContext HermitC where+  contextPath :: HermitC -> AbsolutePath   contextPath = hermitPath --- | Create the initial HERMIT 'Context' by providing a 'ModGuts'.-initContext :: ModGuts -> Context-initContext modGuts = Context empty 0 rootAbsPath modGuts+-- | Create the initial HERMIT 'HermitC' by providing a 'ModGuts'.+initHermitC :: ModGuts -> HermitC+initHermitC modGuts = HermitC empty 0 rootAbsPath modGuts  -- | Update the context by extending the stored 'AbsolutePath' to a child.-(@@) :: Context -> Int -> Context-(@@) env n = env { hermitPath = extendAbsPath n (hermitPath env) }+(@@) :: HermitC -> Int -> HermitC+(@@) c v = c { hermitPath = extendAbsPath v (hermitPath c) } --- | Add all bindings in a binding group to the 'Context'.-addBinding :: CoreBind -> Context -> Context-addBinding (NonRec n e) env-        = env { hermitBindings = insert n (BIND next_depth False e) (hermitBindings env)-              , hermitDepth    = next_depth-              }-  where-        next_depth = succ (hermitDepth env)-addBinding (Rec bds) env-        = env { hermitBindings = bds_env `union` hermitBindings env-              , hermitDepth    = next_depth-              }-  where-        next_depth = succ (hermitDepth env)-        -- notice how all recursive binding in a binding group are at the same depth.-        bds_env    = fromList-                   [ (b,BIND next_depth True e)-                   | (b,e) <- bds-                   ]+------------------------------------------------------------------------ +-- | Add all bindings in a binding group to a context.+addBinding :: CoreBind -> HermitC -> HermitC+addBinding corebind c = let nextDepth = succ (hermitDepth c)+                            hbds      = hermitBindings c+                            newBds    = case corebind of+                                          NonRec v e  -> insert v (BIND nextDepth False e) hbds+                                          Rec bds     -> hbds `union` fromList [ (b, BIND nextDepth True e) | (b,e) <- bds ]+                                                         -- Notice how all recursive binding in a binding group are at the same depth.+                        in c { hermitBindings = newBds+                             , hermitDepth    = nextDepth+                             }+ -- | Add the bindings for a specific case alternative.-addCaseBinding :: (Id,CoreExpr,CoreAlt) -> Context -> Context-addCaseBinding (n,e,(ac,is,_)) env-        = env { hermitBindings = insert n (CASE next_depth e (ac,is)) (hermitBindings env)-              , hermitDepth    = next_depth-              }-  where-        next_depth = succ (hermitDepth env)+addCaseBinding :: (Id,CoreExpr,CoreAlt) -> HermitC -> HermitC+addCaseBinding (v,e,(con,vs,_)) c = let nextDepth = succ (hermitDepth c)+                                     in c { hermitBindings = insert v (CASE nextDepth e (con,vs)) (hermitBindings c)+                                          , hermitDepth    = nextDepth+                                          } --- | Add a binding that you know nothing about, except that it may shadow something.--- If so, do not worry about it here, just remember the binding and the depth.--- When we want to inline a value from the environment,--- we then check to see what is free in the inlinee, and see--- if any of the frees will stop the validity of the inlining.-addLambdaBinding :: Id -> Context -> Context-addLambdaBinding n env-        = env { hermitBindings = insert n (LAM next_depth) (hermitBindings env)-              , hermitDepth    = next_depth-              }-  where-        next_depth = succ (hermitDepth env)+-- | Add a lambda bound variable to a context.+--   All that is known is the variable, which may shadow something.+--   If so, we don't worry about that here, it is instead checked during inlining.+addLambdaBinding :: Var -> HermitC -> HermitC+addLambdaBinding v c = let nextDepth = succ (hermitDepth c)+                        in c { hermitBindings = insert v (LAM nextDepth) (hermitBindings c)+                             , hermitDepth    = nextDepth+                             } --- | Add the Ids bound by a DataCon in a case. Like lambda bindings,+-- | Add the identifiers bound by a 'DataCon' in a case. Like lambda bindings, -- in that we know nothing about them, but all bound at the same depth,--- so we cannot just fold addLambdaBinding over the list.-addAltBindings :: [Id] -> Context -> Context-addAltBindings ns env-        = env { hermitBindings = foldr (\n bds -> insert n (LAM next_depth) bds) (hermitBindings env) ns-              , hermitDepth    = next_depth-              }-  where next_depth = succ (hermitDepth env)+-- so we cannot just fold 'addLambdaBinding' over the list.+addAltBindings :: [Id] -> HermitC -> HermitC+addAltBindings vs c = let nextDepth = succ (hermitDepth c)+                       in c { hermitBindings = foldr (\ v bds -> insert v (LAM nextDepth) bds) (hermitBindings c) vs+                            , hermitDepth    = nextDepth+                            } --- | Lookup the binding for an identifier in a 'Context'.-lookupHermitBinding :: Id -> Context -> Maybe HermitBinding+------------------------------------------------------------------------++-- | Lookup the binding for a variable in a context.+lookupHermitBinding :: Var -> HermitC -> Maybe HermitBinding lookupHermitBinding n env = lookup n (hermitBindings env) --- | List all the identifiers bound in the 'Context'.-listBindings :: Context -> [Id]-listBindings = keys . hermitBindings+-- | List all the variables bound in a context.+boundVars :: HermitC -> [Var]+boundVars = keys . hermitBindings --- | Determine if an identifier is bound in the 'Context'.-boundIn :: Id -> Context -> Bool-boundIn i c = i `elem` listBindings c+-- | Determine if a variable is bound in a context.+boundIn :: Var -> HermitC -> Bool+boundIn i c = i `elem` boundVars c++------------------------------------------------------------------------++-- | List all variables bound in the context that match the given name.+findBoundVars :: TH.Name -> HermitC -> [Var]+findBoundVars nm = filter (cmpTHName2Var nm) . boundVars  ------------------------------------------------------------------------

@@ -0,0 +1,115 @@+module Language.HERMIT.Core+          (+            -- * Generic Data Type+            -- $typenote+            Core(..)+          , CoreProg(..)+          , CoreDef(..)+          , CoreTickish+            -- * Conversions to/from 'Core'+          , defsToRecBind+          , defToIdExpr+          , progToBinds+          , bindsToProg+          , bindToIdExprs+            -- * Utilities+          , isType+          , typeExprToType+          , exprTypeOrKind+          , appCount+) where++import Data.Maybe(isJust)++import GhcPlugins++---------------------------------------------------------------------++-- $typenote+--   NOTE: 'Type' is not included in the generic datatype.+--   However, we could have included it and provided the facility for descending into types.+--   We have not done so because+--     (a) we do not need that functionality, and+--     (b) the types are complicated and we're not sure that we understand them.++-- | Core is the sum type of all nodes in the AST that we wish to be able to traverse.+--   All 'Node' instances in HERMIT define their 'Generic' type to be 'Core'.+data Core = ModGutsCore  ModGuts            -- ^ The module.+          | ProgCore     CoreProg           -- ^ A program (a telescope of top-level binding groups).+          | BindCore     CoreBind           -- ^ A binding group.+          | DefCore      CoreDef            -- ^ A recursive definition.+          | ExprCore     CoreExpr           -- ^ An expression.+          | AltCore      CoreAlt            -- ^ A case alternative.++---------------------------------------------------------------------++-- | A program is a telescope of nested binding groups.+--   That is, each binding scopes over the remainder of the program.+--   In GHC Core, programs are encoded as ['CoreBind'].+--   This data type is isomorphic.+data CoreProg = ProgNil                     -- ^ An empty program.+              | ProgCons CoreBind CoreProg  -- ^ A binding group and the program it scopes over.++infixr 5 `ProgCons`++-- | Get the list of bindings in a program.+progToBinds :: CoreProg -> [CoreBind]+progToBinds ProgNil         = []+progToBinds (ProgCons bd p) = bd : progToBinds p++-- | Build a program from a list of bindings.+--   Note that bindings earlier in the list are considered scope over bindings later in the list.+bindsToProg :: [CoreBind] -> CoreProg+bindsToProg = foldr ProgCons ProgNil++-- | Extract the list of identifier/expression pairs from a binding group.+bindToIdExprs :: CoreBind -> [(Id,CoreExpr)]+bindToIdExprs (NonRec v e) = [(v,e)]+bindToIdExprs (Rec bds)    = bds++-- | A (potentially recursive) definition is an identifier and an expression.+--   In GHC Core, recursive definitions are encoded as ('Id', 'CoreExpr') pairs.+--   This data type is isomorphic.+data CoreDef = Def Id CoreExpr++-- | Convert a definition to an identifier/expression pair.+defToIdExpr :: CoreDef -> (Id,CoreExpr)+defToIdExpr (Def v e) = (v,e)++-- | Convert a list of recursive definitions into an (isomorphic) recursive binding group.+defsToRecBind :: [CoreDef] -> CoreBind+defsToRecBind = Rec . map defToIdExpr++-----------------------------------------------------------------------++-- | Unlike everything else, there is no synonym for 'Tickish' 'Id' provided by GHC, so we define one.+type CoreTickish = Tickish Id++-----------------------------------------------------------------------++-- TODO: I don't know what to do about Coercions here, because I don't understand them.++-- | Succeeds if the expression is either a 'Type' or type 'Var'.+isType :: CoreExpr -> Bool+isType = isJust . typeExprToType++-- | Convert a 'CoreExpr' expression that \is\ a 'Type' into a 'Type'.+typeExprToType :: CoreExpr -> Maybe Type+typeExprToType (Type t)            = Just t+typeExprToType (Var v) | isTKVar v = Just (mkTyVarTy v)+typeExprToType _                   = Nothing++-- | GHC's 'exprType' function throws an error if applied to a 'Type' (but, inconsistently, return a 'Kind' if applied to a type variable).+--   This function returns the 'Kind' of a 'Type', but otherwise behaves as 'exprType'.+exprTypeOrKind :: CoreExpr -> Type+exprTypeOrKind (Type t) = typeKind t+exprTypeOrKind e        = exprType e++-----------------------------------------------------------------------++-- | Count the number of nested applications.+appCount :: CoreExpr -> Int+appCount (App e1 _) = appCount e1 + 1+appCount _          = 0++-----------------------------------------------------------------------

@@ -1,48 +0,0 @@-module Language.HERMIT.CoreExtra-          (-            -- * Generic Data Type-            -- $typenote-            Core(..)-          , CoreDef(..)-            -- * GHC Core Extras-          , CoreTickish-          , defToRecBind-) where--import GhcPlugins--------------------------------------------------------------------------- $typenote---   NOTE: 'Type' is not included in the generic datatype.---   However, we could have included it and provided the facility for descending into types.---   We have not done so because---     (a) we do not need that functionality, and---     (b) the types are complicated and we're not sure that we understand them.---- | Core is the sum type of all nodes in the AST that we wish to be able to traverse.---   All 'Node' instances in HERMIT define their 'Generic' type to be 'Core'.-data Core = ModGutsCore  ModGuts            -- ^ The module.-          | ProgramCore  CoreProgram        -- ^ A program (list of top-level bindings).-          | BindCore     CoreBind           -- ^ A binding group.-          | DefCore      CoreDef            -- ^ A recursive definition.-          | ExprCore     CoreExpr           -- ^ An expression.-          | AltCore      CoreAlt            -- ^ A case alternative.--------------------------------------------------------------------------- | A (potentially recursive) definition is an identifier and an expression.---   In GHC Core, recursive definitions are encoded as ('Id', 'CoreExpr') pairs.---   This data type is isomorphic.-data CoreDef = Def Id CoreExpr----------------------------------------------------------------------------- | Unlike everything else, there is no synonym for 'Tickish' 'Id' provided by GHC, so we provide one.-type CoreTickish = Tickish Id---- | Convert a list of recursive definitions into an (isomorphic) recursive binding group.-defToRecBind :: [CoreDef] -> CoreBind-defToRecBind = Rec . map (\ (Def v e) -> (v,e))-------------------------------------------------------------------------

@@ -3,20 +3,21 @@ module Language.HERMIT.Dictionary        ( -- * The HERMIT Dictionary          -- | This is the main namespace. Things tend to be untyped, because the API is accessed via (untyped) names.-         all_externals+         Dictionary+       , all_externals        , dictionary        , pp_dictionary )  where -import Data.Default (def)+-- import Data.Default (def) import Data.Dynamic import Data.List import Data.Map (Map, fromList, toList) +import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.External ---import qualified Language.HERMIT.Primitive.Command as Command import qualified Language.HERMIT.Primitive.Kure as Kure import qualified Language.HERMIT.Primitive.Navigation as Navigation import qualified Language.HERMIT.Primitive.Inline as Inline@@ -24,6 +25,7 @@ import qualified Language.HERMIT.Primitive.New as New import qualified Language.HERMIT.Primitive.Debug as Debug import qualified Language.HERMIT.Primitive.GHC as GHC+import qualified Language.HERMIT.Primitive.FixPoint as FixPoint import qualified Language.HERMIT.Primitive.Fold as Fold import qualified Language.HERMIT.Primitive.Unfold as Unfold import qualified Language.HERMIT.Primitive.AlphaConversion as Alpha@@ -36,6 +38,10 @@  -------------------------------------------------------------------------- +-- | A 'Dictionary' is a collection of 'Dynamic's.+--   Looking up a 'Dynamic' (via a 'String' key) returns a list, as there can be multiple 'Dynamic's with the same name.+type Dictionary = Map String [Dynamic]+ prim_externals :: [External] prim_externals                =    Kure.externals@@ -44,6 +50,7 @@                  ++ Local.externals                  ++ Debug.externals                  ++ New.externals+                 ++ FixPoint.externals                  ++ Fold.externals                  ++ Unfold.externals                  ++ Alpha.externals@@ -53,8 +60,8 @@ all_externals :: [External] -> [External] all_externals my_externals = prim_externals ++ my_externals ++ GHC.externals --- | Create the dictionary.-dictionary :: [External] -> Map String [Dynamic]+-- | Create a dictionary from a list of 'External's.+dictionary :: [External] -> Dictionary dictionary externs = toDictionary externs'   where         msg = layoutTxt 60 (map (show . fst) dictionaryOfTags)@@ -88,6 +95,7 @@         , ("ghc",    GHCPP.corePrettyH)         ] +{- -- (This isn't used anywhere currently.) -- | Each pretty printer can suggest some options pp_opt_dictionary :: Map String PrettyOptions@@ -96,7 +104,7 @@         , ("ast",  def)         , ("ghc",  def)         ]-+-}  -------------------------------------------------------------------------- @@ -150,3 +158,5 @@                          , tagMatch p e                          -- necessary so we don't list things that don't type correctly                          , Just (_ :: RewriteH Core) <- [fmap unbox $ fromDynamic $ externFun e] ])++------------------------------------

@@ -135,7 +135,7 @@ parseExprH0 inp =         [ (Box (CmdName str),inp1)         | (str,inp1) <- parseToken inp-        , isAlphaNum (head str) || head str == ':'    -- commands can start with :+        , isAlphaNum (head str) || head str == ':'    -- commands can start with : -- This can probably be removed now, as we no longer start commands with :         , all isId (tail str)         ] ++         [ (InfixableExpr (CmdName str),inp1)@@ -210,7 +210,7 @@ isId c = isAlphaNum c || c `elem` "_-'"  isInfixId :: Char -> Bool-isInfixId c = c `elem` "+._-:<>"+isInfixId c = c `elem` "+*/._-:<>"   ---------------------------------------------

@@ -42,6 +42,7 @@  import qualified Language.Haskell.TH as TH +import Language.HERMIT.Core import Language.HERMIT.Kure  -----------------------------------------------------------------@@ -58,7 +59,6 @@ --   (or the help function will not find it). --   These should be /user facing/, because they give the user --   a way of sub-dividing our confusing array of commands.- data CmdTag = Shell          -- ^ Shell command.             | Eval           -- ^ The arrow of evaluation (reduces a term).             | KURE           -- ^ 'Language.KURE' command.

@@ -1,14 +1,16 @@ module Language.HERMIT.GHC-        (+        ( -- * GHC Imports         -- | Things that have been copied from GHC, or imported directly, for various reasons.           ppIdInfo         , var2String         , thRdrNameGuesses         , name2THName-        , id2THName+        , var2THName         , cmpTHName2Name-        , cmpTHName2Id-        , unqualifiedIdName+        , cmpString2Name+        , cmpTHName2Var+        , cmpString2Var+        , unqualifiedVarName         , findNameFromTH         , alphaTyVars         , Type(..)@@ -31,7 +33,6 @@  -------------------------------------------------------------------------- --- idName :: Id -> Name -- varName :: Var -> Name -- nameOccName :: Name -> OccName -- occNameString :: OccName -> String@@ -44,27 +45,35 @@  -- | Convert a variable to a neat string for printing. var2String :: Var -> String-var2String = occNameString . nameOccName . varName+var2String = occNameString . nameOccName . varName -- TODO: would getOccString be okay here?  -- | Converts a GHC 'Name' to a Template Haskell 'TH.Name', going via a 'String'. name2THName :: Name -> TH.Name name2THName = TH.mkName . getOccString --- | Converts an 'Id' to a Template Haskell 'TH.Name', going via a 'String'.-id2THName :: Id -> TH.Name-id2THName = name2THName . idName+-- | Converts an 'Var' to a Template Haskell 'TH.Name', going via a 'String'.+var2THName :: Var -> TH.Name+var2THName = name2THName . varName --- | Get the unqualified name from an Id/Var.-unqualifiedIdName :: Id -> String-unqualifiedIdName = TH.nameBase . id2THName+-- | Get the unqualified name from an Var.+unqualifiedVarName :: Var -> String+unqualifiedVarName = TH.nameBase . var2THName  -- | Hacks until we can find the correct way of doing these. cmpTHName2Name :: TH.Name -> Name -> Bool-cmpTHName2Name th_nm ghc_nm = TH.nameBase th_nm == getOccString ghc_nm -- occNameString (nameOccName ghc_nm)+cmpTHName2Name th_nm = cmpString2Name (TH.nameBase th_nm)  -- | Hacks until we can find the correct way of doing these.-cmpTHName2Id :: TH.Name -> Id -> Bool-cmpTHName2Id nm = cmpTHName2Name nm . idName+cmpString2Name :: String -> Name -> Bool+cmpString2Name str nm = str == getOccString nm -- occNameString (nameOccName ghc_nm)++-- | Hacks until we can find the correct way of doing these.+cmpTHName2Var :: TH.Name -> Var -> Bool+cmpTHName2Var nm = cmpTHName2Name nm . varName++-- | Hacks until we can find the correct way of doing these.+cmpString2Var :: String -> Var -> Bool+cmpString2Var str = cmpString2Name str . varName  -- | This is hopeless O(n), because the we could not generate the 'OccName's that match, -- for use of the GHC 'OccEnv'.

@@ -1,4 +1,4 @@-{-# LANGUAGE KindSignatures, GADTs #-}+{-# LANGUAGE KindSignatures, GADTs, InstanceSigs #-}  module Language.HERMIT.Interp         ( -- * The HERMIT Interpreter@@ -40,7 +40,8 @@ interp = Interp  instance Functor Interp where-   fmap f (Interp g) = Interp (f . g)+  fmap :: (a -> b) -> Interp a -> Interp b+  fmap f (Interp g) = Interp (f . g)   interpExpr :: M.Map String [Dynamic] -> ExprH -> Either String [Dynamic]@@ -49,7 +50,11 @@ interpExpr' :: Bool -> M.Map String [Dynamic] -> ExprH -> Either String [Dynamic] interpExpr' _   _   (SrcName str) = return [ toDyn $ NameBox $ TH.mkName str ] interpExpr' rhs env (CmdName str)-  | all isDigit str                     = return [ toDyn $ IntBox $ read str ]+                                        -- An Int is either a Path, or will be interpreted specially later.+  | all isDigit str                     = let i = read str in+                                          return [ toDyn $ IntBox i+                                                 , toDyn $ TranslateCorePathBox (return [i])+                                                 ]   | Just dyn <- M.lookup str env        = return $ if rhs                                                      then toDyn (StringBox str) : dyn                                                      else dyn@@ -64,4 +69,3 @@    where            dynApply' :: [Dynamic] -> [Dynamic] -> [Dynamic]            dynApply' fs xs = [ r | f <- fs, x <- xs, Just r <- return (dynApply f x)]-

@@ -25,23 +25,23 @@ import Data.Map import Control.Concurrent --- | A 'Kernel' is a repository for Core syntax trees.+-- | A 'Kernel' is a repository for complete Core syntax trees ('ModGuts'). --   For now, operations on a 'Kernel' are sequential, but later --   it will be possible to have two 'applyK's running in parallel. data Kernel = Kernel-  { resumeK ::            AST                                      -> IO ()                -- ^ Halt the 'Kernel' and return control to GHC, which compiles the specified 'AST'.-  , abortK  ::                                                        IO ()                -- ^ Halt the 'Kernel' and abort GHC without compiling.-  , applyK  ::            AST -> RewriteH Core     -> HermitMEnv   -> IO (KureMonad AST)   -- ^ Apply a 'Rewrite' to the specified 'AST' and return a handle to the resulting 'AST'.-  , queryK  :: forall a . AST -> TranslateH Core a -> HermitMEnv   -> IO (KureMonad a)     -- ^ Apply a 'TranslateH' to the 'AST' and return the resulting value.-  , deleteK ::            AST                                      -> IO ()                -- ^ Delete the internal record of the specified 'AST'.-  , listK   ::                                                        IO [AST]             -- ^ List all the 'AST's tracked by the 'Kernel'.+  { resumeK ::            AST                                        -> IO ()           -- ^ Halt the 'Kernel' and return control to GHC, which compiles the specified 'AST'.+  , abortK  ::                                                          IO ()           -- ^ Halt the 'Kernel' and abort GHC without compiling.+  , applyK  ::            AST -> RewriteH ModGuts     -> HermitMEnv  -> IO (KureM AST)  -- ^ Apply a 'Rewrite' to the specified 'AST' and return a handle to the resulting 'AST'.+  , queryK  :: forall a . AST -> TranslateH ModGuts a -> HermitMEnv  -> IO (KureM a)    -- ^ Apply a 'TranslateH' to the 'AST' and return the resulting value.+  , deleteK ::            AST                                        -> IO ()           -- ^ Delete the internal record of the specified 'AST'.+  , listK   ::                                                          IO [AST]        -- ^ List all the 'AST's tracked by the 'Kernel'.   }  -- | A /handle/ for a specific version of the 'ModGuts'. newtype AST = AST Int -- ^ Currently 'AST's are identified by an 'Int' label.               deriving (Eq, Ord, Show) -data Msg s r = forall a . Req (s -> CoreM (KureMonad (a,s))) (MVar (KureMonad a))+data Msg s r = forall a . Req (s -> CoreM (KureM (a,s))) (MVar (KureM a))              | Done (s -> CoreM r)  type KernelState = Map AST (DefStash, ModGuts)@@ -54,25 +54,25 @@          msgMV :: MVar (Msg KernelState ModGuts) <- liftIO newEmptyMVar -        syntax_names :: MVar AST <- liftIO newEmptyMVar+        nextASTname :: MVar AST <- liftIO newEmptyMVar -        _ <- liftIO $ forkIO $ let loop n = do putMVar syntax_names (AST n)+        _ <- liftIO $ forkIO $ let loop n = do putMVar nextASTname (AST n)                                                loop (succ n)                                 in loop 0          let sendDone :: (KernelState -> CoreM ModGuts) -> IO ()             sendDone = putMVar msgMV . Done -        let sendReq :: (KernelState -> CoreM (KureMonad (a, KernelState))) -> IO (KureMonad a)+        let sendReq :: (KernelState -> CoreM (KureM (a, KernelState))) -> IO (KureM a)             sendReq fn = do rep  <- newEmptyMVar                             putMVar msgMV (Req fn rep)                             takeMVar rep -        let sendReqRead :: (KernelState -> CoreM (KureMonad a)) -> IO (KureMonad a)+        let sendReqRead :: (KernelState -> CoreM (KureM a)) -> IO (KureM a)             sendReqRead fn = sendReq (\ st -> (fmap.fmap) (,st) $ fn st)          let sendReqWrite :: (KernelState -> CoreM KernelState) -> IO ()-            sendReqWrite fn = sendReq (fmap ( return . ((),) ) . fn) >>= runKureMonad return fail+            sendReqWrite fn = sendReq (fmap ( return . ((),) ) . fn) >>= runKureM return fail          let kernel :: Kernel             kernel = Kernel@@ -80,38 +80,38 @@                  , abortK  = sendDone $ \ _ -> throwGhcException (ProgramError "Exiting HERMIT and aborting GHC compilation.") -                , applyK = \ name r hm_env -> sendReq $ \ st -> findWithErrMsg name st fail $ \ (defs, core) -> runHM hm_env+                , applyK = \ name r hm_env -> sendReq $ \ st -> findWithErrMsg name st fail $ \ (defs, guts) -> runHM hm_env                                                                                                                defs-                                                                                                               (\ defs' core' -> do syn' <- liftIO $ takeMVar syntax_names-                                                                                                                                    return $ return (syn', insert syn' (defs',core') st))+                                                                                                               (\ defs' guts' -> do ast <- liftIO $ takeMVar nextASTname+                                                                                                                                    return $ return (ast, insert ast (defs',guts') st))                                                                                                                (return . fail)-                                                                                                               (apply (extractR r) (initContext core) core)+                                                                                                               (apply r (initHermitC guts) guts) -                , queryK = \ name q hm_env -> sendReqRead $ \ st -> findWithErrMsg name st fail $ \ (defs, core) -> runHM hm_env-                                                                                                                   defs-                                                                                                                   (\ _ -> return.return)-                                                                                                                   (return . fail)-                                                                                                                   (apply (extractT q) (initContext core) core)+                , queryK = \ name t hm_env -> sendReqRead $ \ st -> findWithErrMsg name st fail $ \ (defs, core) -> runHM hm_env+                                                                                                                      defs+                                                                                                                      (\ _ -> return.return)+                                                                                                                      (return . fail)+                                                                                                                      (apply t (initHermitC core) core)                  , deleteK = \ name -> sendReqWrite (return . delete name) -                , listK = sendReqRead (return . return . keys) >>= runKureMonad return fail+                , listK = sendReqRead (return . return . keys) >>= runKureM return fail                 } -        -- We always start with syntax blob 0-        syn <- liftIO $ takeMVar syntax_names+        -- We always start with AST 0+        ast0 <- liftIO $ takeMVar nextASTname          let loop :: KernelState -> CoreM ModGuts             loop st = do                 m <- liftIO $ takeMVar msgMV                 case m of-                  Req fn rep -> fn st >>= runKureMonad (\ (a,st') -> liftIO (putMVar rep $ return a) >> loop st')-                                                       (\ msg     -> liftIO (putMVar rep $ fail msg) >> loop st)+                  Req fn rep -> fn st >>= runKureM (\ (a,st') -> liftIO (putMVar rep $ return a) >> loop st')+                                                   (\ msg     -> liftIO (putMVar rep $ fail msg) >> loop st)                   Done fn -> fn st -        _pid <- liftIO $ forkIO $ callback kernel syn+        _pid <- liftIO $ forkIO $ callback kernel ast0 -        loop (singleton syn (empty, modGuts))+        loop (singleton ast0 (empty, modGuts))          -- (Kill the pid'd thread? do we need to?) 

@@ -10,6 +10,7 @@        , scopedKernel ) where +import Control.Arrow import Control.Concurrent.STM import Control.Exception.Base (bracketOnError) @@ -17,9 +18,10 @@  import GhcPlugins hiding (Direction,L) +import Language.HERMIT.Core import Language.HERMIT.Kure-import Language.HERMIT.Kernel import Language.HERMIT.Monad+import Language.HERMIT.Kernel  ---------------------------------------------------------------------------- @@ -65,8 +67,8 @@ extendLocalPath :: Path -> LocalPath -> LocalPath extendLocalPath p (LocalPath lp) = LocalPath (reverse p ++ lp) -pathStackToLens :: [LocalPath] -> LocalPath -> LensH Core Core-pathStackToLens ps p = pathL $ concat $ localPaths2Paths (p:ps)+pathStackToLens :: [LocalPath] -> LocalPath -> LensH ModGuts Core+pathStackToLens ps p = injectL >>> pathL (concat $ localPaths2Paths (p:ps))  ---------------------------------------------------------------------------- @@ -74,12 +76,12 @@ data ScopedKernel = ScopedKernel         { resumeS     ::            SAST                                              -> IO ()         , abortS      ::                                                                 IO ()-        , applyS      ::            SAST -> RewriteH Core             -> HermitMEnv   -> IO (KureMonad SAST)-        , queryS      :: forall a . SAST -> TranslateH Core a         -> HermitMEnv   -> IO (KureMonad a)+        , applyS      ::            SAST -> RewriteH Core             -> HermitMEnv   -> IO (KureM SAST)+        , queryS      :: forall a . SAST -> TranslateH Core a         -> HermitMEnv   -> IO (KureM a)         , deleteS     ::            SAST                                              -> IO ()         , listS       ::                                                                 IO [SAST]         , pathS       ::            SAST                                              -> IO [Path]-        , modPathS    ::            SAST -> (LocalPath -> LocalPath)  -> HermitMEnv   -> IO (KureMonad SAST)+        , modPathS    ::            SAST -> (LocalPath -> LocalPath)  -> HermitMEnv   -> IO (KureM SAST)         , beginScopeS ::            SAST                                              -> IO SAST         , endScopeS   ::            SAST                                              -> IO SAST         }@@ -103,7 +105,7 @@     store <- newTMVarIO $ I.fromList [(0,(initAST, [], emptyLocalPath))]     key <- newTMVarIO (1::Int) -    let failCleanup :: SASTStore -> String -> IO (KureMonad a)+    let failCleanup :: SASTStore -> String -> IO (KureM a)         failCleanup m msg = atomically $ do putTMVar store m                                             return $ fail msg @@ -121,9 +123,9 @@             , applyS      = \ (SAST sAst) rr env -> safeTakeTMVar store $ \ m -> do                                 (ast, base, rel) <- get sAst m                                 applyK kernel ast (focusR (pathStackToLens base rel) rr) env-                                  >>= runKureMonad (\ ast' -> atomically $ do k <- newKey-                                                                              putTMVar store $ I.insert k (ast', base, rel) m-                                                                              return $ return $ SAST k)+                                  >>= runKureM (\ ast' -> atomically $ do k <- newKey+                                                                          putTMVar store $ I.insert k (ast', base, rel) m+                                                                          return $ return $ SAST k)                                                    (failCleanup m)             , queryS      = \ (SAST sAst) t env -> do                                 m <- atomically $ readTMVar store@@ -142,13 +144,13 @@                                 (ast, base, rel) <- get sAst m                                 let rel' = f rel                                 queryK kernel ast (testLensT (pathStackToLens base rel')) env-                                  >>= runKureMonad (\ b -> if rel == rel'-                                                            then failCleanup m "Path is unchanged, nothing to do."-                                                            else if b-                                                                  then atomically $ do k <- newKey-                                                                                       putTMVar store $ I.insert k (ast, base, rel') m-                                                                                       return (return $ SAST k)-                                                                  else failCleanup m "Invalid path created.")+                                  >>= runKureM (\ b -> if rel == rel'+                                                        then failCleanup m "Path is unchanged, nothing to do."+                                                        else if b+                                                              then atomically $ do k <- newKey+                                                                                   putTMVar store $ I.insert k (ast, base, rel') m+                                                                                   return (return $ SAST k)+                                                              else failCleanup m "Invalid path created.")                                                    (failCleanup m)             , beginScopeS = \ (SAST sAst) -> atomically $ do                                 m <- takeTMVar store

@@ -1,5 +1,7 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances, FlexibleContexts, TupleSections #-}+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances, FlexibleContexts, TupleSections, LambdaCase, InstanceSigs #-} +-- Note: InstanceSigs don't expand type families (annoyingly), as of GHC 7.6.1.  Check if this has been fixed in the next version.+ module Language.HERMIT.Kure        (        -- * KURE Modules@@ -7,22 +9,19 @@        -- | All the required functionality of KURE is exported here, so other modules do not need to import KURE directly.          module Language.KURE        , module Language.KURE.Injection-       , KureMonad, runKureMonad, fromKureMonad+       , KureM, runKureM, fromKureM        -- * Synonyms        -- | In HERMIT, 'Translate', 'Rewrite' and 'Lens' always operate on the same context and monad.        , TranslateH        , RewriteH        , LensH        , idR-       -- * Generic Data Type-       , Core(..)-       , CoreDef(..)        -- * Congruence combinators        -- ** Modguts        , modGutsT, modGutsR        -- ** Program-       , nilT-       , consBindT, consBindAllR, consBindAnyR, consBindOneR+       , progNilT+       , progConsT, progConsAllR, progConsAnyR, progConsOneR        -- ** Binding Groups        , nonRecT, nonRecR        , recT, recAllR, recAnyR, recOneR@@ -53,14 +52,14 @@        -- * Promotion Combinators        -- ** Rewrite Promotions        , promoteModGutsR-       , promoteProgramR+       , promoteProgR        , promoteBindR        , promoteDefR        , promoteExprR        , promoteAltR        -- ** Translate Promotions        , promoteModGutsT-       , promoteProgramT+       , promoteProgT        , promoteBindT        , promoteDefT        , promoteExprT@@ -74,7 +73,7 @@ import Language.KURE.Injection import Language.KURE.Utilities -import Language.HERMIT.CoreExtra+import Language.HERMIT.Core import Language.HERMIT.Context import Language.HERMIT.Monad @@ -85,9 +84,9 @@  --------------------------------------------------------------------- -type TranslateH a b = Translate Context HermitM a b-type RewriteH a = Rewrite Context HermitM a-type LensH a b = Lens Context HermitM a b+type TranslateH a b = Translate HermitC HermitM a b+type RewriteH a = Rewrite HermitC HermitM a+type LensH a b = Lens HermitC HermitM a b  -- | A synonym for the identity rewrite.  Convienient to avoid importing Control.Category. idR :: RewriteH a@@ -98,8 +97,9 @@ instance Node Core where   type Generic Core = Core +  numChildren :: Core -> Int   numChildren (ModGutsCore x) = numChildren x-  numChildren (ProgramCore x) = numChildren x+  numChildren (ProgCore x)    = numChildren x   numChildren (BindCore x)    = numChildren x   numChildren (DefCore x)     = numChildren x   numChildren (ExprCore x)    = numChildren x@@ -108,50 +108,57 @@ -- Defining Walker instances for the Generic type 'Core' is almost entirely automated by KURE. -- Unfortunately, you still need to pattern match on the 'Core' data type. -instance Walker Context HermitM Core where-  childL n = lens $ translate $ \ c core -> case core of+instance Walker HermitC HermitM Core where++  childL :: Int -> LensH Core (Generic Core)+  childL n = lens $ translate $ \ c -> \case           ModGutsCore x -> childLgeneric n c x-          ProgramCore x -> childLgeneric n c x+          ProgCore x    -> childLgeneric n c x           BindCore x    -> childLgeneric n c x           DefCore x     -> childLgeneric n c x           ExprCore x    -> childLgeneric n c x           AltCore x     -> childLgeneric n c x -  allT t = translate $ \ c core -> case core of+  allT :: Monoid b => TranslateH (Generic Core) b -> TranslateH Core b+  allT t = translate $ \ c -> \case           ModGutsCore x -> allTgeneric t c x-          ProgramCore x -> allTgeneric t c x+          ProgCore x    -> allTgeneric t c x           BindCore x    -> allTgeneric t c x           DefCore x     -> allTgeneric t c x           ExprCore x    -> allTgeneric t c x           AltCore x     -> allTgeneric t c x -  oneT t = translate $ \ c core -> case core of+  oneT :: TranslateH (Generic Core) b -> TranslateH Core b+  oneT t = translate $ \ c -> \case           ModGutsCore x -> oneTgeneric t c x-          ProgramCore x -> oneTgeneric t c x+          ProgCore x    -> oneTgeneric t c x           BindCore x    -> oneTgeneric t c x           DefCore x     -> oneTgeneric t c x           ExprCore x    -> oneTgeneric t c x           AltCore x     -> oneTgeneric t c x -  allR r = rewrite $ \ c core -> case core of+  allR :: RewriteH (Generic Core) -> RewriteH Core+  allR r = rewrite $ \ c -> \case           ModGutsCore x -> allRgeneric r c x-          ProgramCore x -> allRgeneric r c x+          ProgCore x    -> allRgeneric r c x           BindCore x    -> allRgeneric r c x           DefCore x     -> allRgeneric r c x           ExprCore x    -> allRgeneric r c x           AltCore x     -> allRgeneric r c x -  anyR r = rewrite $ \ c core -> case core of+  anyR :: RewriteH (Generic Core) -> RewriteH Core+  anyR r = rewrite $ \ c -> \case           ModGutsCore x -> anyRgeneric r c x-          ProgramCore x -> anyRgeneric r c x+          ProgCore x    -> anyRgeneric r c x           BindCore x    -> anyRgeneric r c x           DefCore x     -> anyRgeneric r c x           ExprCore x    -> anyRgeneric r c x           AltCore x     -> anyRgeneric r c x -  oneR r = rewrite $ \ c core -> case core of+  oneR :: RewriteH (Generic Core) -> RewriteH Core+  oneR r = rewrite $ \ c -> \case           ModGutsCore x -> oneRgeneric r c x-          ProgramCore x -> oneRgeneric r c x+          ProgCore x    -> oneRgeneric r c x           BindCore x    -> oneRgeneric r c x           DefCore x     -> oneRgeneric r c x           ExprCore x    -> oneRgeneric r c x@@ -160,87 +167,109 @@ ---------------------------------------------------------------------  instance Injection ModGuts Core where-  inject                     = ModGutsCore++  inject :: ModGuts -> Core+  inject = ModGutsCore++  retract :: Core -> Maybe ModGuts   retract (ModGutsCore guts) = Just guts   retract _                  = Nothing  instance Node ModGuts where   type Generic ModGuts = Core +  numChildren :: ModGuts -> Int   numChildren _ = 1 -instance Walker Context HermitM ModGuts where-  childL 0 = lens $ modGutsT exposeT (childL1of2 $ \ modguts bds -> modguts {mg_binds = bds})+instance Walker HermitC HermitM ModGuts where++  childL :: Int -> LensH ModGuts (Generic ModGuts)+  childL 0 = lens $ modGutsT exposeT (childL1of2 $ \ modguts p -> modguts {mg_binds = progToBinds p})   childL n = failT (missingChild n)  -- | Translate a module. --   Slightly different to the other congruence combinators: it passes in *all* of the original to the reconstruction function.-modGutsT :: TranslateH CoreProgram a -> (ModGuts -> a -> b) -> TranslateH ModGuts b-modGutsT t f = translate $ \ c modGuts -> f modGuts <$> apply t (c @@ 0) (mg_binds modGuts)+modGutsT :: TranslateH CoreProg a -> (ModGuts -> a -> b) -> TranslateH ModGuts b+modGutsT t f = translate $ \ c modGuts -> f modGuts <$> apply t (c @@ 0) (bindsToProg (mg_binds modGuts)) --- | Rewrite the 'CoreProgram' child of a module.-modGutsR :: RewriteH CoreProgram -> RewriteH ModGuts-modGutsR r = modGutsT r (\ modguts bds -> modguts {mg_binds = bds})+-- | Rewrite the 'CoreProg' child of a module.+modGutsR :: RewriteH CoreProg -> RewriteH ModGuts+modGutsR r = modGutsT r (\ modguts p -> modguts {mg_binds = progToBinds p})  --------------------------------------------------------------------- -instance Injection CoreProgram Core where-  inject                    = ProgramCore-  retract (ProgramCore bds) = Just bds-  retract _                 = Nothing+instance Injection CoreProg Core where -instance Node CoreProgram where-  type Generic CoreProgram = Core+  inject :: CoreProg -> Core+  inject = ProgCore -  -- we consider only the head and tail to be interesting children-  numChildren bds = min 2 (length bds)+  retract :: Core -> Maybe CoreProg+  retract (ProgCore bds) = Just bds+  retract _              = Nothing -instance Walker Context HermitM CoreProgram where-  childL 0 = lens $ consBindT exposeT idR (childL0of2 (:))-  childL 1 = lens $ consBindT idR exposeT (childL1of2 (:))+instance Node CoreProg where+  type Generic CoreProg = Core++  -- A program is either empty (zero children) or a binding group and the remaining program it scopes over (two children).+  numChildren :: CoreProg -> Int+  numChildren ProgNil        = 0+  numChildren (ProgCons _ _) = 2++instance Walker HermitC HermitM CoreProg where++  childL :: Int -> LensH CoreProg (Generic CoreProg)+  childL 0 = lens $ progConsT exposeT idR (childL0of2 ProgCons)+  childL 1 = lens $ progConsT idR exposeT (childL1of2 ProgCons)   childL n = failT (missingChild n)  -- | Translate an empty list.-nilT :: b -> TranslateH [a] b-nilT b = contextfreeT $ \ e -> case e of-                           [] -> pure b-                           _  -> fail "no match for []"+progNilT :: b -> TranslateH CoreProg b+progNilT b = contextfreeT $ \case+                               ProgNil       -> pure b+                               ProgCons _ _  -> fail "not an empty program node." -consBindT' :: TranslateH CoreBind a1 -> TranslateH CoreProgram a2 -> (HermitM a1 -> HermitM a2 -> HermitM b) -> TranslateH CoreProgram b-consBindT' t1 t2 f = translate $ \ c e -> case e of-        bd:bds -> f (apply t1 (c @@ 0) bd) (apply t2 (addBinding bd c @@ 1) bds)-        _      -> fail "no match for consBind"+progConsT' :: TranslateH CoreBind a1 -> TranslateH CoreProg a2 -> (HermitM a1 -> HermitM a2 -> HermitM b) -> TranslateH CoreProg b+progConsT' t1 t2 f = translate $ \ c -> \case+                                           ProgCons bd p -> f (apply t1 (c @@ 0) bd) (apply t2 (addBinding bd c @@ 1) p)+                                           _             -> fail "not a non-empty program node." --- | Translate a program of the form: ('CoreBind' @:@ 'CoreProgram')-consBindT :: TranslateH CoreBind a1 -> TranslateH CoreProgram a2 -> (a1 -> a2 -> b) -> TranslateH CoreProgram b-consBindT t1 t2 f = consBindT' t1 t2 (liftA2 f)+-- | Translate a program of the form: ('CoreBind' @:@ 'CoreProg')+progConsT :: TranslateH CoreBind a1 -> TranslateH CoreProg a2 -> (a1 -> a2 -> b) -> TranslateH CoreProg b+progConsT t1 t2 f = progConsT' t1 t2 (liftA2 f) --- | Rewrite all children of a program of the form: ('CoreBind' @:@ 'CoreProgram')-consBindAllR :: RewriteH CoreBind -> RewriteH CoreProgram -> RewriteH CoreProgram-consBindAllR r1 r2 = consBindT r1 r2 (:)+-- | Rewrite all children of a program of the form: ('CoreBind' @:@ 'CoreProg')+progConsAllR :: RewriteH CoreBind -> RewriteH CoreProg -> RewriteH CoreProg+progConsAllR r1 r2 = progConsT r1 r2 ProgCons --- | Rewrite any children of a program of the form: ('CoreBind' @:@ 'CoreProgram')-consBindAnyR :: RewriteH CoreBind -> RewriteH CoreProgram -> RewriteH CoreProgram-consBindAnyR r1 r2 = consBindT' (attemptR r1) (attemptR r2) (attemptAny2 (:))+-- | Rewrite any children of a program of the form: ('CoreBind' @:@ 'CoreProg')+progConsAnyR :: RewriteH CoreBind -> RewriteH CoreProg -> RewriteH CoreProg+progConsAnyR r1 r2 = progConsT' (attemptR r1) (attemptR r2) (attemptAny2 ProgCons) --- | Rewrite one child of a program of the form: ('CoreBind' @:@ 'CoreProgram')-consBindOneR :: RewriteH CoreBind -> RewriteH CoreProgram -> RewriteH CoreProgram-consBindOneR r1 r2 = consBindT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 (:))+-- | Rewrite one child of a program of the form: ('CoreBind' @:@ 'CoreProg')+progConsOneR :: RewriteH CoreBind -> RewriteH CoreProg -> RewriteH CoreProg+progConsOneR r1 r2 = progConsT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 ProgCons)  ---------------------------------------------------------------------  instance Injection CoreBind Core where-  inject                  = BindCore++  inject :: CoreBind -> Core+  inject = BindCore++  retract :: Core -> Maybe CoreBind   retract (BindCore bnd)  = Just bnd   retract _               = Nothing  instance Node CoreBind where   type Generic CoreBind = Core +  numChildren :: CoreBind -> Int   numChildren (NonRec _ _) = 1   numChildren (Rec defs)   = length defs -instance Walker Context HermitM CoreBind where+instance Walker HermitC HermitM CoreBind where++  childL :: Int -> LensH CoreBind (Generic CoreBind)   childL n = lens $ setFailMsg (missingChild n) $                case n of                  0 -> nonrec <+ rec@@ -249,41 +278,46 @@     where       nonrec = nonRecT exposeT (childL1of2 NonRec)       rec    = whenM (hasChildT n) $-                  recT (const exposeT) (childLMofN n defToRecBind)+                  recT (const exposeT) (childLMofN n defsToRecBind) +  allT :: Monoid b => TranslateH (Generic CoreBind) b -> TranslateH CoreBind b   allT t = nonRecT (extractT t) (\ _ -> id)         <+ recT (\ _ -> extractT t) mconcat +  oneT :: TranslateH (Generic CoreBind) b -> TranslateH CoreBind b   oneT t = nonRecT (extractT t) (\ _ -> id)         <+ recT' (\ _ -> extractT t) catchesM +  allR :: RewriteH (Generic CoreBind) -> RewriteH CoreBind   allR r = nonRecR (extractR r)         <+ recAllR (\ _ -> extractR r) +  anyR :: RewriteH (Generic CoreBind) -> RewriteH CoreBind   anyR r = nonRecR (extractR r)         <+ recAnyR (\ _ -> extractR r) +  oneR :: RewriteH (Generic CoreBind) -> RewriteH CoreBind   oneR r = nonRecR (extractR r)         <+ recOneR (\ _ -> extractR r) --- | Translate a binding group of the form: @NonRec@ 'Id' 'CoreExpr'-nonRecT :: TranslateH CoreExpr a -> (Id -> a -> b) -> TranslateH CoreBind b-nonRecT t f = translate $ \ c e -> case e of-                                     NonRec v e' -> f v <$> apply t (c @@ 0) e'-                                     _           -> fail "not NonRec constructor"+-- | Translate a binding group of the form: @NonRec@ 'Var' 'CoreExpr'+nonRecT :: TranslateH CoreExpr a -> (Var -> a -> b) -> TranslateH CoreBind b+nonRecT t f = translate $ \ c -> \case+                                    NonRec v e -> f v <$> apply t (c @@ 0) e+                                    _          -> fail "not a non-recursive binding-group node." --- | Rewrite the 'CoreExpr' child of a binding group of the form: @NonRec@ 'Id' 'CoreExpr'+-- | Rewrite the 'CoreExpr' child of a binding group of the form: @NonRec@ 'Var' 'CoreExpr' nonRecR :: RewriteH CoreExpr -> RewriteH CoreBind nonRecR r = nonRecT r NonRec  recT' :: (Int -> TranslateH CoreDef a) -> ([HermitM a] -> HermitM b) -> TranslateH CoreBind b-recT' t f = translate $ \ c e -> case e of-         Rec bds -> -- Notice how we add the scoping bindings here *before* decending into each individual definition.+recT' t f = translate $ \ c -> \case+         Rec bds -> -- Notice how we add the scoping bindings here *before* descending into each individual definition.                     let c' = addBinding (Rec bds) c-                     in f [ apply (t n) (c' @@ n) (Def v e') -- here we convert from (Id,CoreExpr) to CoreDef-                          | ((v,e'),n) <- zip bds [0..]+                     in f [ apply (t n) (c' @@ n) (Def v e) -- here we convert from (Id,CoreExpr) to CoreDef+                          | ((v,e),n) <- zip bds [0..]                           ]-         _       -> fail "not Rec constructor"+         _       -> fail "not a recursive binding-group node."  -- | Translate a binding group of the form: @Rec@ ['CoreDef'] recT :: (Int -> TranslateH CoreDef a) -> ([a] -> b) -> TranslateH CoreBind b@@ -291,29 +325,36 @@  -- | Rewrite all children of a binding group of the form: @Rec@ ['CoreDef'] recAllR :: (Int -> RewriteH CoreDef) -> RewriteH CoreBind-recAllR rs = recT rs defToRecBind+recAllR rs = recT rs defsToRecBind  -- | Rewrite any children of a binding group of the form: @Rec@ ['CoreDef'] recAnyR :: (Int -> RewriteH CoreDef) -> RewriteH CoreBind-recAnyR rs = recT' (attemptR . rs) (attemptAnyN defToRecBind)+recAnyR rs = recT' (attemptR . rs) (attemptAnyN defsToRecBind)  -- | Rewrite one child of a binding group of the form: @Rec@ ['CoreDef'] recOneR :: (Int -> RewriteH CoreDef) -> RewriteH CoreBind-recOneR rs = recT' (withArgumentT . rs) (attemptOneN defToRecBind)+recOneR rs = recT' (withArgumentT . rs) (attemptOneN defsToRecBind)  ---------------------------------------------------------------------  instance Injection CoreDef Core where-  inject                = DefCore++  inject :: CoreDef -> Core+  inject = DefCore++  retract :: Core -> Maybe CoreDef   retract (DefCore def) = Just def   retract _             = Nothing  instance Node CoreDef where   type Generic CoreDef = Core +  numChildren :: CoreDef -> Int   numChildren _ = 1 -instance Walker Context HermitM CoreDef where+instance Walker HermitC HermitM CoreDef where++  childL :: Int -> LensH CoreDef (Generic CoreDef)   childL 0 = lens $ defT exposeT (childL1of2 Def)   childL n = failT (missingChild n) @@ -328,16 +369,23 @@ ---------------------------------------------------------------------  instance Injection CoreAlt Core where-  inject                 = AltCore++  inject :: CoreAlt -> Core+  inject = AltCore++  retract :: Core -> Maybe CoreAlt   retract (AltCore expr) = Just expr   retract _              = Nothing  instance Node CoreAlt where   type Generic CoreAlt = Core +  numChildren :: CoreAlt -> Int   numChildren _ = 1 -instance Walker Context HermitM CoreAlt where+instance Walker HermitC HermitM CoreAlt where++  childL :: Int -> LensH CoreAlt (Generic CoreAlt)   childL 0 = lens $ altT exposeT (childL2of3 (,,))   childL n = failT (missingChild n) @@ -352,13 +400,18 @@ ---------------------------------------------------------------------  instance Injection CoreExpr Core where-  inject                  = ExprCore++  inject :: CoreExpr -> Core+  inject = ExprCore++  retract :: Core -> Maybe CoreExpr   retract (ExprCore expr) = Just expr   retract _               = Nothing  instance Node CoreExpr where   type Generic CoreExpr = Core +  numChildren :: CoreExpr -> Int   numChildren (Var _)         = 0   numChildren (Lit _)         = 0   numChildren (App _ _)       = 2@@ -370,8 +423,9 @@   numChildren (Type _)        = 0   numChildren (Coercion _)    = 0 -instance Walker Context HermitM CoreExpr where+instance Walker HermitC HermitM CoreExpr where +  childL :: Int -> LensH CoreExpr (Generic CoreExpr)   childL n = lens $ setFailMsg (missingChild n) $                case n of                  0  ->    appT  exposeT idR         (childL0of2 App)@@ -391,6 +445,7 @@        caseChooseL = whenM (hasChildT n) $                            caseT idR (const exposeT) (\ e v t -> childLMofN (n-1) (Case e v t)) +  allT :: Monoid b => TranslateH (Generic CoreExpr) b -> TranslateH CoreExpr b   allT t = varT (\ _ -> mempty)         <+ litT (\ _ -> mempty)         <+ appT (extractT t) (extractT t) mappend@@ -402,6 +457,7 @@         <+ typeT (\ _ -> mempty)         <+ coercionT (\ _ -> mempty) +  oneT :: TranslateH (Generic CoreExpr) b -> TranslateH CoreExpr b   oneT t = appT' (extractT t) (extractT t) (<<+)         <+ lamT (extractT t) (\ _ -> id)         <+ letT' (extractT t) (extractT t) (<<+)@@ -409,6 +465,7 @@         <+ castT (extractT t) const         <+ tickT (extractT t) (\ _ -> id) +  allR :: RewriteH (Generic CoreExpr) -> RewriteH CoreExpr   allR r = varT Var         <+ litT Lit         <+ appAllR (extractR r) (extractR r)@@ -420,6 +477,7 @@         <+ typeT Type         <+ coercionT Coercion +  anyR :: RewriteH (Generic CoreExpr) -> RewriteH CoreExpr   anyR r = appAnyR (extractR r) (extractR r)         <+ lamR (extractR r)         <+ letAnyR (extractR r) (extractR r)@@ -428,6 +486,7 @@         <+ tickR (extractR r)         <+ fail "anyR failed" +  oneR :: RewriteH (Generic CoreExpr) -> RewriteH CoreExpr   oneR r = appOneR (extractR r) (extractR r)         <+ lamR (extractR r)         <+ letOneR (extractR r) (extractR r)@@ -438,23 +497,23 @@  --------------------------------------------------------------------- --- | Translate an expression of the form: @Var@ 'Id'-varT :: (Id -> b) -> TranslateH CoreExpr b-varT f = contextfreeT $ \ e -> case e of-        Var v -> pure (f v)-        _     -> fail "no match for Var"+-- | Translate an expression of the form: @Var@ 'Var'+varT :: (Var -> b) -> TranslateH CoreExpr b+varT f = contextfreeT $ \case+                           Var v -> pure (f v)+                           _     -> fail "not a variable node."  -- | Translate an expression of the form: @Lit@ 'Literal' litT :: (Literal -> b) -> TranslateH CoreExpr b-litT f = contextfreeT $ \ e -> case e of-        Lit x -> pure (f x)-        _     -> fail "no match for Lit"+litT f = contextfreeT $ \case+                           Lit x -> pure (f x)+                           _     -> fail "not a literal node."   appT' :: TranslateH CoreExpr a1 -> TranslateH CoreExpr a2 -> (HermitM a1 -> HermitM a2 -> HermitM b) -> TranslateH CoreExpr b-appT' t1 t2 f = translate $ \ c e -> case e of-         App e1 e2 -> f (apply t1 (c @@ 0) e1) (apply t2 (c @@ 1) e2)-         _         -> fail "no match for App"+appT' t1 t2 f = translate $ \ c -> \case+                                      App e1 e2 -> f (apply t1 (c @@ 0) e1) (apply t2 (c @@ 1) e2)+                                      _         -> fail "not an application node."  -- | Translate an expression of the form: @App@ 'CoreExpr' 'CoreExpr' appT :: TranslateH CoreExpr a1 -> TranslateH CoreExpr a2 -> (a1 -> a2 -> b) -> TranslateH CoreExpr b@@ -472,23 +531,23 @@ appOneR :: RewriteH CoreExpr -> RewriteH CoreExpr -> RewriteH CoreExpr appOneR r1 r2 = appT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 App) --- | Translate an expression of the form: @Lam@ 'Id' 'CoreExpr'-lamT :: TranslateH CoreExpr a -> (Id -> a -> b) -> TranslateH CoreExpr b-lamT t f = translate $ \ c e -> case e of-        Lam b e1 -> f b <$> apply t (addLambdaBinding b c @@ 0) e1-        _        -> fail "no match for Lam"+-- | Translate an expression of the form: @Lam@ 'Var' 'CoreExpr'+lamT :: TranslateH CoreExpr a -> (Var -> a -> b) -> TranslateH CoreExpr b+lamT t f = translate $ \ c -> \case+                                 Lam b e -> f b <$> apply t (addLambdaBinding b c @@ 0) e+                                 _       -> fail "not a lambda node." --- | Rewrite the 'CoreExpr' child of an expression of the form: @Lam@ 'Id' 'CoreExpr'+-- | Rewrite the 'CoreExpr' child of an expression of the form: @Lam@ 'Var' 'CoreExpr' lamR :: RewriteH CoreExpr -> RewriteH CoreExpr lamR r = lamT r Lam   letT' :: TranslateH CoreBind a1 -> TranslateH CoreExpr a2 -> (HermitM a1 -> HermitM a2 -> HermitM b) -> TranslateH CoreExpr b-letT' t1 t2 f = translate $ \ c e -> case e of-        Let bds e1 -> f (apply t1 (c @@ 0) bds) (apply t2 (addBinding bds c @@ 1) e1)+letT' t1 t2 f = translate $ \ c -> \case+        Let bds e -> f (apply t1 (c @@ 0) bds) (apply t2 (addBinding bds c @@ 1) e)                 -- use *original* env, because the bindings are self-binding,                 -- if they are recursive. See recT'.-        _         -> fail "no match for Let"+        _         -> fail "not a let node."  -- | Translate an expression of the form: @Let@ 'CoreBind' 'CoreExpr' letT :: TranslateH CoreBind a1 -> TranslateH CoreExpr a2 -> (a1 -> a2 -> b) -> TranslateH CoreExpr b@@ -507,21 +566,15 @@ letOneR r1 r2 = letT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 Let)  -caseT' :: TranslateH CoreExpr a1-      -> (Int -> TranslateH CoreAlt a2)-      -> (Id -> Type -> HermitM a1 -> [HermitM a2] -> HermitM b)-      -> TranslateH CoreExpr b-caseT' t ts f = translate $ \ c e -> case e of-         Case e1 b ty alts -> f b ty (apply t (c @@ 0) e1) $ [ apply (ts n) (addCaseBinding (b,e1,alt) c @@ (n+1)) alt-                                                             | (alt,n) <- zip alts [0..]-                                                             ]-         _ -> fail "no match for Case"+caseT' :: TranslateH CoreExpr a1 -> (Int -> TranslateH CoreAlt a2) -> (Id -> Type -> HermitM a1 -> [HermitM a2] -> HermitM b) -> TranslateH CoreExpr b+caseT' t ts f = translate $ \ c -> \case+         Case e b ty alts -> f b ty (apply t (c @@ 0) e) $ [ apply (ts n) (addCaseBinding (b,e,alt) c @@ (n+1)) alt+                                                           | (alt,n) <- zip alts [0..]+                                                           ]+         _                -> fail "not a case node."  -- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']-caseT :: TranslateH CoreExpr a1-      -> (Int -> TranslateH CoreAlt a2)-      -> (a1 -> Id -> Type -> [a2] -> b)-      -> TranslateH CoreExpr b+caseT :: TranslateH CoreExpr a1 -> (Int -> TranslateH CoreAlt a2) -> (a1 -> Id -> Type -> [a2] -> b) -> TranslateH CoreExpr b caseT t ts f = caseT' t ts (\ b ty me malts -> f <$> me <*> pure b <*> pure ty <*> sequence malts)  -- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']@@ -538,9 +591,9 @@  -- | Translate an expression of the form: @Cast@ 'CoreExpr' 'Coercion' castT :: TranslateH CoreExpr a -> (a -> Coercion -> b) -> TranslateH CoreExpr b-castT t f = translate $ \ c e -> case e of-                                   Cast e1 cast -> f <$> apply t (c @@ 0) e1 <*> pure cast-                                   _            -> fail "no match for Cast"+castT t f = translate $ \ c -> \case+                                  Cast e cast -> f <$> apply t (c @@ 0) e <*> pure cast+                                  _           -> fail "not a cast node."  -- | Rewrite the 'CoreExpr' child of an expression of the form: @Cast@ 'CoreExpr' 'Coercion' castR :: RewriteH CoreExpr -> RewriteH CoreExpr@@ -548,9 +601,9 @@  -- | Translate an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr' tickT :: TranslateH CoreExpr a -> (CoreTickish -> a -> b) -> TranslateH CoreExpr b-tickT t f = translate $ \ c e -> case e of-        Tick tk e1 -> f tk <$> apply t (c @@ 0) e1-        _          -> fail "no match for Tick"+tickT t f = translate $ \ c -> \case+        Tick tk e -> f tk <$> apply t (c @@ 0) e+        _         -> fail "not a tick node."  -- | Rewrite the 'CoreExpr' child of an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr' tickR :: RewriteH CoreExpr -> RewriteH CoreExpr@@ -558,15 +611,15 @@  -- | Translate an expression of the form: @Type@ 'Type' typeT :: (Type -> b) -> TranslateH CoreExpr b-typeT f = contextfreeT $ \ e -> case e of-                                  Type t -> pure (f t)-                                  _      -> fail "no match for Type"+typeT f = contextfreeT $ \case+                            Type t -> pure (f t)+                            _      -> fail "not a type node."  -- | Translate an expression of the form: @Coercion@ 'Coercion' coercionT :: (Coercion -> b) -> TranslateH CoreExpr b-coercionT f = contextfreeT $ \ e -> case e of-                                      Coercion co -> pure (f co)-                                      _           -> fail "no match for Coercion"+coercionT f = contextfreeT $ \case+                                Coercion co -> pure (f co)+                                _           -> fail "not a coercion node."  --------------------------------------------------------------------- @@ -589,70 +642,70 @@ recDefOneR rs = recOneR (\ n -> defR (rs n))  --- | Translate a program of the form: (@NonRec@ 'Id' 'CoreExpr') @:@ 'CoreProgram'-consNonRecT :: TranslateH CoreExpr a1 -> TranslateH CoreProgram a2 -> (Id -> a1 -> a2 -> b) -> TranslateH CoreProgram b-consNonRecT t1 t2 f = consBindT (nonRecT t1 (,)) t2 (uncurry f)+-- | Translate a program of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'+consNonRecT :: TranslateH CoreExpr a1 -> TranslateH CoreProg a2 -> (Var -> a1 -> a2 -> b) -> TranslateH CoreProg b+consNonRecT t1 t2 f = progConsT (nonRecT t1 (,)) t2 (uncurry f) --- | Rewrite all children of an expression of the form: (@NonRec@ 'Id' 'CoreExpr') @:@ 'CoreProgram'-consNonRecAllR :: RewriteH CoreExpr -> RewriteH CoreProgram -> RewriteH CoreProgram-consNonRecAllR r1 r2 = consBindAllR (nonRecR r1) r2+-- | Rewrite all children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'+consNonRecAllR :: RewriteH CoreExpr -> RewriteH CoreProg -> RewriteH CoreProg+consNonRecAllR r1 r2 = progConsAllR (nonRecR r1) r2 --- | Rewrite any children of an expression of the form: (@NonRec@ 'Id' 'CoreExpr') @:@ 'CoreProgram'-consNonRecAnyR :: RewriteH CoreExpr -> RewriteH CoreProgram -> RewriteH CoreProgram-consNonRecAnyR r1 r2 = consBindAnyR (nonRecR r1) r2+-- | Rewrite any children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'+consNonRecAnyR :: RewriteH CoreExpr -> RewriteH CoreProg -> RewriteH CoreProg+consNonRecAnyR r1 r2 = progConsAnyR (nonRecR r1) r2 --- | Rewrite one child of an expression of the form: (@NonRec@ 'Id' 'CoreExpr') @:@ 'CoreProgram'-consNonRecOneR :: RewriteH CoreExpr -> RewriteH CoreProgram -> RewriteH CoreProgram-consNonRecOneR r1 r2 = consBindOneR (nonRecR r1) r2+-- | Rewrite one child of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'+consNonRecOneR :: RewriteH CoreExpr -> RewriteH CoreProg -> RewriteH CoreProg+consNonRecOneR r1 r2 = progConsOneR (nonRecR r1) r2  --- | Translate an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProgram'-consRecT :: (Int -> TranslateH CoreDef a1) -> TranslateH CoreProgram a2 -> ([a1] -> a2 -> b) -> TranslateH CoreProgram b-consRecT ts t = consBindT (recT ts id) t+-- | Translate an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'+consRecT :: (Int -> TranslateH CoreDef a1) -> TranslateH CoreProg a2 -> ([a1] -> a2 -> b) -> TranslateH CoreProg b+consRecT ts t = progConsT (recT ts id) t --- | Rewrite all children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProgram'-consRecAllR :: (Int -> RewriteH CoreDef) -> RewriteH CoreProgram -> RewriteH CoreProgram-consRecAllR rs r = consBindAllR (recAllR rs) r+-- | Rewrite all children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'+consRecAllR :: (Int -> RewriteH CoreDef) -> RewriteH CoreProg -> RewriteH CoreProg+consRecAllR rs r = progConsAllR (recAllR rs) r --- | Rewrite any children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProgram'-consRecAnyR :: (Int -> RewriteH CoreDef) -> RewriteH CoreProgram -> RewriteH CoreProgram-consRecAnyR rs r = consBindAnyR (recAnyR rs) r+-- | Rewrite any children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'+consRecAnyR :: (Int -> RewriteH CoreDef) -> RewriteH CoreProg -> RewriteH CoreProg+consRecAnyR rs r = progConsAnyR (recAnyR rs) r --- | Rewrite one child of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProgram'-consRecOneR :: (Int -> RewriteH CoreDef) -> RewriteH CoreProgram -> RewriteH CoreProgram-consRecOneR rs r = consBindOneR (recOneR rs) r+-- | Rewrite one child of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'+consRecOneR :: (Int -> RewriteH CoreDef) -> RewriteH CoreProg -> RewriteH CoreProg+consRecOneR rs r = progConsOneR (recOneR rs) r  --- | Translate an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProgram'-consRecDefT :: (Int -> TranslateH CoreExpr a1) -> TranslateH CoreProgram a2 -> ([(Id,a1)] -> a2 -> b) -> TranslateH CoreProgram b+-- | Translate an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'+consRecDefT :: (Int -> TranslateH CoreExpr a1) -> TranslateH CoreProg a2 -> ([(Id,a1)] -> a2 -> b) -> TranslateH CoreProg b consRecDefT ts t = consRecT (\ n -> defT (ts n) (,)) t --- | Rewrite all children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProgram'-consRecDefAllR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreProgram -> RewriteH CoreProgram+-- | Rewrite all children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'+consRecDefAllR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreProg -> RewriteH CoreProg consRecDefAllR rs r = consRecAllR (\ n -> defR (rs n)) r --- | Rewrite any children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProgram'-consRecDefAnyR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreProgram -> RewriteH CoreProgram+-- | Rewrite any children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'+consRecDefAnyR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreProg -> RewriteH CoreProg consRecDefAnyR rs r = consRecAnyR (\ n -> defR (rs n)) r --- | Rewrite one child of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProgram'-consRecDefOneR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreProgram -> RewriteH CoreProgram+-- | Rewrite one child of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'+consRecDefOneR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreProg -> RewriteH CoreProg consRecDefOneR rs r = consRecOneR (\ n -> defR (rs n)) r  --- | Translate an expression of the form: @Let@ (@NonRec@ 'Id' 'CoreExpr') 'CoreExpr'-letNonRecT :: TranslateH CoreExpr a1 -> TranslateH CoreExpr a2 -> (Id -> a1 -> a2 -> b) -> TranslateH CoreExpr b+-- | Translate an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'+letNonRecT :: TranslateH CoreExpr a1 -> TranslateH CoreExpr a2 -> (Var -> a1 -> a2 -> b) -> TranslateH CoreExpr b letNonRecT t1 t2 f = letT (nonRecT t1 (,)) t2 (uncurry f) --- | Rewrite all children of an expression of the form: @Let@ (@NonRec@ 'Id' 'CoreExpr') 'CoreExpr'+-- | Rewrite all children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' letNonRecAllR :: RewriteH CoreExpr -> RewriteH CoreExpr -> RewriteH CoreExpr letNonRecAllR r1 r2 = letAllR (nonRecR r1) r2 --- | Rewrite any children of an expression of the form: @Let@ (@NonRec@ 'Id' 'CoreExpr') 'CoreExpr'+-- | Rewrite any children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' letNonRecAnyR :: RewriteH CoreExpr -> RewriteH CoreExpr -> RewriteH CoreExpr letNonRecAnyR r1 r2 = letAnyR (nonRecR r1) r2 --- | Rewrite one child of an expression of the form: @Let@ (@NonRec@ 'Id' 'CoreExpr') 'CoreExpr'+-- | Rewrite one child of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' letNonRecOneR :: RewriteH CoreExpr -> RewriteH CoreExpr -> RewriteH CoreExpr letNonRecOneR r1 r2 = letOneR (nonRecR r1) r2 @@ -713,9 +766,9 @@ promoteModGutsR :: RewriteH ModGuts -> RewriteH Core promoteModGutsR = promoteWithFailMsgR "This rewrite can only succeed at the module level." --- | Promote a rewrite on 'CoreProgram' to a rewrite on 'Core'.-promoteProgramR :: RewriteH CoreProgram -> RewriteH Core-promoteProgramR = promoteWithFailMsgR "This rewrite can only succeed at program nodes (the top-level)."+-- | Promote a rewrite on 'CoreProg' to a rewrite on 'Core'.+promoteProgR :: RewriteH CoreProg -> RewriteH Core+promoteProgR = promoteWithFailMsgR "This rewrite can only succeed at program nodes (the top-level)."  -- | Promote a rewrite on 'CoreBind' to a rewrite on 'Core'. promoteBindR :: RewriteH CoreBind -> RewriteH Core@@ -739,9 +792,9 @@ promoteModGutsT :: TranslateH ModGuts b -> TranslateH Core b promoteModGutsT = promoteWithFailMsgT "This translate can only succeed at the module level." --- | Promote a translate on 'CoreProgram' to a translate on 'Core'.-promoteProgramT :: TranslateH CoreProgram b -> TranslateH Core b-promoteProgramT = promoteWithFailMsgT "This translate can only succeed at program nodes (the top-level)."+-- | Promote a translate on 'CoreProg' to a translate on 'Core'.+promoteProgT :: TranslateH CoreProg b -> TranslateH Core b+promoteProgT = promoteWithFailMsgT "This translate can only succeed at program nodes (the top-level)."  -- | Promote a translate on 'CoreBind' to a translate on 'Core'. promoteBindT :: TranslateH CoreBind b -> TranslateH Core b

@@ -6,15 +6,18 @@             HermitM           , runHM           , liftCoreM-          , newVarH-          , newTypeVarH-          , cloneIdH+          , newIdH+          , newTyVarH+    --      , newVarExprH+    --      , newVarH+          , cloneVarH             -- * Saving Definitions           , Label           , DefStash           , saveDef           , lookupDef           , getStash+            -- * Messages           , HermitMEnv(..)           , DebugMessage(..)           , mkHermitMEnv@@ -34,7 +37,7 @@ import Language.KURE.Combinators import Language.KURE.Utilities -import Language.HERMIT.CoreExtra+import Language.HERMIT.Core import Language.HERMIT.Context  ----------------------------------------------------------------------------@@ -49,14 +52,16 @@ newtype HermitMEnv = HermitMEnv { hs_debugChan :: DebugMessage -> HermitM () }  -- | The HERMIT monad is kept abstract.-newtype HermitM a = HermitM (HermitMEnv -> DefStash -> CoreM (KureMonad (DefStash, a)))+newtype HermitM a = HermitM (HermitMEnv -> DefStash -> CoreM (KureM (DefStash, a))) -runHermitM :: HermitM a -> HermitMEnv -> DefStash -> CoreM (KureMonad (DefStash, a))+runHermitM :: HermitM a -> HermitMEnv -> DefStash -> CoreM (KureM (DefStash, a)) runHermitM (HermitM f) = f +-- | Get the stash of saved definitions. getStash :: HermitM DefStash getStash = HermitM (\ _ s -> return $ return (s, s)) +-- | Replace the stash of saved definitions. putStash :: DefStash -> HermitM () putStash s = HermitM (\ _ _ -> return $ return (s, ())) @@ -75,7 +80,7 @@  -- | Eliminator for 'HermitM'. runHM :: HermitMEnv -> DefStash -> (DefStash -> a -> CoreM b) -> (String -> CoreM b) -> HermitM a -> CoreM b-runHM env s success failure ma = runHermitM ma env s >>= runKureMonad (\ (a,b) -> success a b) failure+runHM env s success failure ma = runHermitM ma env s >>= runKureM (\ (a,b) -> success a b) failure  ---------------------------------------------------------------------------- @@ -85,7 +90,7 @@  instance Applicative HermitM where   pure :: a -> HermitM a-  pure  = return+  pure = return    (<*>) :: HermitM (a -> b) -> HermitM a -> HermitM b   (<*>) = ap@@ -95,14 +100,14 @@   return a = HermitM $ \ _ s -> return (return (s,a))    (>>=) :: HermitM a -> (a -> HermitM b) -> HermitM b-  (HermitM gcm) >>= f = HermitM $ \ env -> gcm env >=> runKureMonad (\ (s', a) -> runHermitM (f a) env s') (return . fail)+  (HermitM gcm) >>= f = HermitM $ \ env -> gcm env >=> runKureM (\ (s', a) -> runHermitM (f a) env s') (return . fail)    fail :: String -> HermitM a   fail msg = HermitM $ \ _ _ -> return (fail msg)  instance MonadCatch HermitM where   catchM :: HermitM a -> (String -> HermitM a) -> HermitM a-  (HermitM gcm) `catchM` f = HermitM $ \ env s -> gcm env s >>= runKureMonad (return.return) (\ msg -> runHermitM (f msg) env s)+  (HermitM gcm) `catchM` f = HermitM $ \ env s -> gcm env s >>= runKureM (return.return) (\ msg -> runHermitM (f msg) env s)  ---------------------------------------------------------------------------- @@ -130,39 +135,48 @@ ----------------------------------------------------------------------------  newName :: String -> HermitM Name-newName name = do-        uq <- getUniqueM-        return $ mkSystemVarName uq $ mkFastString $ name+newName name = do uq <- getUniqueM+                  return $ mkSystemVarName uq $ mkFastString name  -- | Make a unique identifier for a specified type based on a provided name.-newVarH :: String -> Type -> HermitM Id-newVarH name ty = do-        name' <- newName name-        return $ mkLocalId name' ty+newIdH :: String -> Type -> HermitM Id+newIdH name ty = do name' <- newName name+                    return $ mkLocalId name' ty  -- | Make a unique type variable for a specified kind based on a provided name.-newTypeVarH :: String -> Kind -> HermitM TyVar-newTypeVarH name kind = do-        name' <- newName name-        return $ mkTyVar name' kind+newTyVarH :: String -> Kind -> HermitM TyVar+newTyVarH name kind = do name' <- newName name+                         return $ mkTyVar name' kind +-- Not sure whether this would be useful or not.+--  Make either a new identifier of a given type, or type variable of a given kind.+--   Note that as 'Id' and 'TyVar' are synonyms of 'Var', and 'Kind' is a synonym of 'Type',+--   the choice is determined entirely by the 'Either' constructor.+-- newVarH :: String -> Either Type Kind -> HermitM Var+-- newVarH name = either (newIdH name) (newTypeVarH name) --- This gives an new version of an Id, with the same info, and a new textual name.-cloneIdH :: (String -> String) -> Id -> HermitM Id-cloneIdH nameMod b =-        let name = nameMod $ getOccString b-            ty   = idType b+--   Make either a new identifier of a given type, or type variable of a given kind,+--   and wrap it in a 'Var' or 'Type' constructor, respectively.+-- newVarExprH :: String -> Either Type Kind -> HermitM CoreExpr+-- newVarExprH str (Left ty) = Var <$> newIdH str ty+-- newVarExprH str (Right k) = (Type . mkTyVarTy) <$> newTypeVarH str k++-- | This gives an new version of a 'Var', with the same info, and a new textual name.+cloneVarH :: (String -> String) -> Var -> HermitM Var+cloneVarH nameMod v =+        let name = nameMod (getOccString v)+            ty   = varType v         in-          if isTyVar b-           then newTypeVarH name ty-           else newVarH name ty+          if isTyVar v+           then newTyVarH name ty+           else newIdH name ty  ----------------------------------------------------------------------------  -- | A message packet. data DebugMessage :: * where         DebugTick    :: String                    -> DebugMessage-        DebugCore    :: String -> Context -> Core -> DebugMessage       -- A postcard+        DebugCore    :: String -> HermitC -> Core -> DebugMessage       -- A postcard  mkHermitMEnv :: (DebugMessage -> HermitM ()) -> HermitMEnv mkHermitMEnv debugger = HermitMEnv

@@ -8,9 +8,22 @@ import Data.List import System.IO +import Data.Char (isDigit)+import Data.Default+ -- | Given a list of 'CommandLineOption's, produce the 'ModGuts' to 'ModGuts' function required to build a plugin. type HermitPass = [CommandLineOption] -> ModGuts -> CoreM ModGuts +data Options = Options { pass :: Int }++instance Default Options where+    def = Options { pass = 0 }++parse :: [String] -> Options -> Options+parse (('-':'p':n):rest) o | all isDigit n = parse rest $ o { pass = read n }+parse (_:rest) o = parse rest o -- unknown option+parse [] o       = o+ -- | Build a hermit plugin. This mainly handles the per-module options. hermitPlugin :: HermitPass -> Plugin hermitPlugin hp = defaultPlugin { installCoreToDos = install }@@ -24,17 +37,18 @@              dynFlags <- getDynFlags -            let-                myPass = CoreDoPluginPass "HERMIT" $ modFilter dynFlags hp opts+            let (m_opts, h_opts) = partition (isInfixOf ":") opts+                hermit_opts = parse h_opts def+                myPass = CoreDoPluginPass "HERMIT" $ modFilter dynFlags hp m_opts                 -- at front, for now-                allPasses = myPass : todos+                allPasses = insertAt (pass hermit_opts) myPass todos              return allPasses  -- | Determine whether to act on this module, choose plugin pass. modFilter :: DynFlags -> HermitPass -> HermitPass modFilter dynFlags hp opts guts | null modOpts && not (null opts) = return guts -- don't process this module-                       | otherwise    = hp modOpts guts+                                | otherwise                       = hp modOpts guts     where modOpts = filterOpts dynFlags opts guts  -- | Filter options to those pertaining to this module, stripping module prefix.@@ -42,3 +56,7 @@ filterOpts dynFlags opts guts = [ drop len nm | nm <- opts, modName `isPrefixOf` nm ]     where modName = showPpr dynFlags $ mg_module guts           len = length modName + 1 -- for the colon++insertAt :: Int -> a -> [a] -> [a]+insertAt n x xs = pre ++ (x : suf)+    where (pre,suf) = splitAt n xs

@@ -6,6 +6,7 @@  import Text.PrettyPrint.MarkedHughesPJ as PP import Language.HERMIT.Kure+import Language.HERMIT.Core import Control.Arrow import Data.Monoid hiding ((<>)) import Data.Default@@ -232,7 +233,7 @@ ghcCorePrettyH :: PrettyH Core ghcCorePrettyH =            promoteT (ppModule :: PrettyH ModGuts)-        <+ promoteT (ppH      :: PrettyH CoreProgram)+        <+ promoteT (ppProg   :: PrettyH CoreProg)         <+ promoteT (ppH      :: PrettyH CoreBind)         <+ promoteT (ppDef    :: PrettyH CoreDef)         <+ promoteT (ppH      :: PrettyH CoreExpr)@@ -247,8 +248,11 @@         ppModule :: PrettyH ModGuts         ppModule = mg_module ^>> ppH +        ppProg :: PrettyH CoreProg+        ppProg = progToBinds ^>> ppH+         ppDef :: PrettyH CoreDef-        ppDef = (\ (Def v e) -> (v,e)) ^>> ppH+        ppDef = defToIdExpr ^>> ppH  --        arr (PP.text . ppr . mg_module) 

@@ -8,6 +8,7 @@  import qualified GhcPlugins as GHC import Language.HERMIT.Kure+import Language.HERMIT.Core import Language.HERMIT.PrettyPrinter  import Text.PrettyPrint.MarkedHughesPJ as PP@@ -37,9 +38,10 @@         ppModGuts :: PrettyH GHC.ModGuts         ppModGuts = arr (ppSDoc . GHC.mg_module) -        -- DocH is not a monoid, so we can't use listT here-        ppProgram :: PrettyH GHC.CoreProgram -- CoreProgram = [CoreBind]-        ppProgram = translate $ \ c -> fmap vlist . sequenceA . map (apply ppCoreBind c)+        -- DocH is not a monoid.+        -- GHC uses a list, which we print here. The CoreProg type is our doing.+        ppCoreProg :: PrettyH CoreProg+        ppCoreProg = translate $ \ c -> fmap vlist . sequenceA . map (apply ppCoreBind c) . progToBinds          ppCoreExpr :: PrettyH GHC.CoreExpr         ppCoreExpr = varT (\i -> text "Var" <+> varColor (ppSDoc i))@@ -71,7 +73,7 @@         ppCoreDef = defT ppCoreExpr $ \ i e -> parens $ varColor (ppSDoc i) <> text "," <> e      promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)-     <+ promoteT (ppProgram  :: PrettyH GHC.CoreProgram)+     <+ promoteT (ppCoreProg :: PrettyH CoreProg)      <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)      <+ promoteT (ppCoreDef  :: PrettyH CoreDef)      <+ promoteT (ppModGuts  :: PrettyH GHC.ModGuts)

@@ -8,9 +8,12 @@  import qualified GhcPlugins as GHC import Language.HERMIT.Kure+import Language.HERMIT.Core import Language.HERMIT.PrettyPrinter import Language.HERMIT.GHC +import TypeRep (TyLit(..))+ import Text.PrettyPrint.MarkedHughesPJ as PP  listify :: (MDoc a -> MDoc a -> MDoc a) -> [MDoc a] -> MDoc a@@ -52,7 +55,7 @@  normalExpr :: RetExpr -> DocH normalExpr (RetLam vs e0) = hang (specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e0-normalExpr (RetLet vs e0) = sep [ keywordColor (text "let") <+> vcat vs, keywordColor (text "in") <+> e0 ]+normalExpr (RetLet vs e0) = sep [ keyword "let" <+> vcat vs, keyword "in" <+> e0 ] normalExpr (RetApp fn xs) = sep [ hsep (fn : map atomExpr (takeWhile isAtom xs))                                 , nest 2 (sep (map atomExpr (dropWhile isAtom xs))) ] normalExpr (RetExpr e0)    = e0@@ -71,26 +74,41 @@      let hideNotes = True +        optional :: Maybe DocH -> (DocH -> DocH) -> DocH+        optional Nothing  _ = empty+        optional (Just d) k = k d+         ppVar :: GHC.Var -> DocH         ppVar = ppName . GHC.varName          ppName :: GHC.Name -> DocH-        ppName nm-                | isInfix name = ppParens $ varColor $ text name-                | otherwise    = varColor $ text name+        ppName = ppName' True++        ppVar' :: Bool -> GHC.Var -> DocH+        ppVar' useVarColor = ppName' useVarColor . GHC.varName++        ppName' :: Bool -> GHC.Name -> DocH+        ppName' useVarColor nm+                | isInfix name = ppParens $ markColor color $ text name+                | otherwise    = markColor color $ text name           where name = GHC.occNameString $ GHC.nameOccName $ nm                 isInfix = all (\ n -> n `elem` "!@#$%^&*-._+=:?/\\<>'")+                color = if useVarColor then VarColor else TypeColor +        ppLitTy :: Bool -> TyLit -> DocH+        ppLitTy useVarColor tylit = markColor color $ text $ case tylit of+                                                                NumTyLit i -> show i+                                                                StrTyLit fs -> show fs+            where color = if useVarColor then VarColor else TypeColor +         -- binders are vars that is bound by lambda or case, etc.         ppBinder :: GHC.Var -> Maybe DocH-        ppBinder var = case po_exprTypes opts of-                        Abstract | GHC.isTyVar var -> Just $ typeBindSymbol-                        Omit     | GHC.isTyVar var -> Nothing-                        _                          -> Just $ ppVar var--        ppIdBinder :: GHC.Id -> DocH-        ppIdBinder var = ppVar var+        ppBinder var | GHC.isTyVar var = case po_exprTypes opts of+                                            Abstract -> Just $ typeBindSymbol+                                            Omit     -> Nothing+                                            _        -> Just $ ppVar' False var+                     | otherwise = Just $ ppVar var          -- Use for any GHC structure, the 'showSDoc' prefix is to remind us         -- that we are eliding infomation here.@@ -101,16 +119,17 @@          ppModGuts :: PrettyH GHC.ModGuts         ppModGuts =   arr $ \ m -> hang (keyword "module" <+> ppSDoc (GHC.mg_module m) <+> keyword "where") 2-                                   (vcat [ (ppIdBinder v <+> specialSymbol TypeOfSymbol <+> ppCoreType (GHC.idType v))+                                   (vcat [ (optional (ppBinder v) (\b -> b <+> specialSymbol TypeOfSymbol <+> ppCoreType True (GHC.idType v)))                                          | bnd <- GHC.mg_binds m                                          , v <- case bnd of                                                   GHC.NonRec f _ -> [f]                                                   GHC.Rec bnds -> map fst bnds                                        ]) -        -- DocH is not a monoid, so we can't use listT here-        ppProgram :: PrettyH GHC.CoreProgram -- CoreProgram = [CoreBind]-        ppProgram = translate $ \ c -> fmap vcat . sequenceA . map (apply ppCoreBind c)+        -- DocH is not a monoid.+        -- GHC uses a list, which we print here. The CoreProg type is our doing.+        ppCoreProg :: PrettyH CoreProg+        ppCoreProg = translate $ \ c -> fmap vcat . sequenceA . map (apply ppCoreBind c) . progToBinds          ppCoreExpr :: PrettyH GHC.CoreExpr         ppCoreExpr = ppCoreExprR >>^ normalExpr@@ -167,27 +186,30 @@                    <+ varT (\ i p -> RetAtom (attrP p $ ppVar i))                    <+ litT (\ i p -> RetAtom (attrP p $ ppSDoc i))                    <+ typeT (\ t p -> case po_exprTypes opts of-                                      Show     -> RetAtom (attrP p $ ppCoreType t)+                                      Show     -> RetAtom (attrP p $ ppCoreType False t)                                       Abstract -> RetAtom (attrP p $ typeSymbol)                                       Omit     -> RetEmpty)                    <+ (ppCoreExpr0 >>^ \ e p -> RetExpr (attrP p e)) -        ppCoreType :: GHC.Type -> DocH-        ppCoreType = normalExpr . go-            where go (TyVarTy v)   = RetAtom $ ppVar v-                  go (AppTy t1 t2) = RetExpr $ ppCoreType t1 <+> ppCoreType t2+        ppCoreType :: Bool -> GHC.Type -> DocH+        ppCoreType isTySig = normalExpr . go+            where go (TyVarTy v)   = RetAtom $ ppVar' isTySig v+                  go (LitTy tylit) = RetAtom $ ppLitTy isTySig tylit+                  go (AppTy t1 t2) = RetExpr $ ppCoreType isTySig t1 <+> ppCoreType isTySig t2                   go (TyConApp tyCon tys)                     | GHC.isFunTyCon tyCon, [ty1,ty2] <- tys = go (FunTy ty1 ty2)-                    | GHC.isTupleTyCon tyCon = case map ppCoreType tys of-                                                [] -> RetAtom $ text "()"-                                                ds -> RetExpr $ text "(" <> (foldr1 (\d r -> d <> text "," <+> r) ds) <> text ")"-                    | otherwise = RetAtom $ ppName (GHC.getName tyCon) <+> sep (map ppCoreType tys) -- has spaces, but we never want parens-                  go (FunTy ty1 ty2) = RetExpr $ atomExpr (go ty1) <+> text "->" <+> ppCoreType ty2-                  go (ForAllTy v ty) = RetExpr $ specialSymbol ForallSymbol <+> ppVar v <+> symbol '.' <+> ppCoreType ty+                    | GHC.isTupleTyCon tyCon = case map (ppCoreType isTySig) tys of+                                                [] -> RetAtom $ tyText "()"+                                                ds -> RetExpr $ tyText "(" <> (foldr1 (\d r -> d <> tyText "," <+> r) ds) <> tyText ")"+                    | otherwise = RetAtom $ ppName' isTySig (GHC.getName tyCon) <+> sep (map (ppCoreType isTySig) tys) -- has spaces, but we never want parens+                  go (FunTy ty1 ty2) = RetExpr $ atomExpr (go ty1) <+> text "->" <+> ppCoreType isTySig ty2+                  go (ForAllTy v ty) = RetExpr $ specialSymbol ForallSymbol <+> ppVar' isTySig v <+> symbol '.' <+> ppCoreType isTySig ty +                  tyText = if isTySig then text else markColor TypeColor . text+         ppCoreExpr0 :: PrettyH GHC.CoreExpr         ppCoreExpr0 = caseT ppCoreExpr (const ppCoreAlt) (\ s b _ty alts ->-                            (keywordColor (text "case") <+> s <+> keywordColor (text "of") <+> ppIdBinder b) $$+                            (keyword "case" <+> s <+> keyword "of" <+> optional (ppBinder b) id) $$                               nest 2 (vcat alts))                   <+ castT ppCoreExpr (\e co -> text "Cast" $$ nest 2 ((parens e) <+> ppSDoc co))                   <+ tickT ppCoreExpr (\i e  -> text "Tick" $$ nest 2 (ppSDoc i <+> parens e))@@ -196,7 +218,7 @@          ppCoreBind :: PrettyH GHC.CoreBind         ppCoreBind = nonRecT ppCoreExprR ppDefFun-                  <+ recT (const ppCoreDef) (\ bnds -> keywordColor (text "rec") <+> vcat bnds)+                  <+ recT (const ppCoreDef) (\ bnds -> keyword "rec" <+> vcat bnds)          ppCoreAlt :: PrettyH GHC.CoreAlt         ppCoreAlt = altT ppCoreExpr $ \ con ids e -> case con of@@ -205,7 +227,7 @@                       GHC.DEFAULT      -> symbol '_' <+> ppIds ids <+> e               where                      ppIds ids | null ids  = specialSymbol RightArrowSymbol-                               | otherwise = hsep (map ppIdBinder ids) <+> specialSymbol RightArrowSymbol+                               | otherwise = hsep (map (flip optional id . ppBinder) ids) <+> specialSymbol RightArrowSymbol          -- GHC uses a tuple, which we print here. The CoreDef type is our doing.         ppCoreDef :: PrettyH CoreDef@@ -216,12 +238,10 @@                         RetLam vs e0 -> hang (pre <+> specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e0                         _ -> hang pre 2 (normalExpr e)             where-                pre = case ppBinder i of-                        Nothing -> empty-                        Just p  -> p <+> symbol '='+                pre = optional (ppBinder i) (<+> symbol '=')      promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)-     <+ promoteT (ppProgram  :: PrettyH GHC.CoreProgram)+     <+ promoteT (ppCoreProg :: PrettyH CoreProg)      <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)      <+ promoteT (ppCoreDef  :: PrettyH CoreDef)      <+ promoteT (ppModGuts  :: PrettyH GHC.ModGuts)

@@ -7,6 +7,7 @@  import qualified GhcPlugins as GHC import Language.HERMIT.Kure+import Language.HERMIT.Core import Language.HERMIT.PrettyPrinter  import Text.PrettyPrint.MarkedHughesPJ as PP@@ -36,8 +37,8 @@         ppModGuts :: PrettyH GHC.ModGuts         ppModGuts = arr (ppSDoc . GHC.mg_binds) -        ppProgram :: PrettyH GHC.CoreProgram-        ppProgram = arr ppSDoc+        ppCoreProg :: PrettyH CoreProg+        ppCoreProg = arr (ppSDoc . progToBinds)          ppCoreExpr :: PrettyH GHC.CoreExpr         ppCoreExpr = arr ppSDoc@@ -52,7 +53,7 @@         ppCoreDef = defT ppCoreExpr $ \ i e -> ppSDoc i <> text "=" <> e      promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)-     <+ promoteT (ppProgram  :: PrettyH GHC.CoreProgram)+     <+ promoteT (ppCoreProg :: PrettyH CoreProg)      <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)      <+ promoteT (ppCoreDef  :: PrettyH CoreDef)      <+ promoteT (ppModGuts  :: PrettyH GHC.ModGuts)

@@ -10,6 +10,7 @@  import qualified GhcPlugins as GHC import Language.HERMIT.Kure+import Language.HERMIT.Core import Language.HERMIT.PrettyPrinter  corePrettyH :: PrettyOptions -> TranslateH Core Value@@ -27,9 +28,10 @@         ppModGuts :: TranslateH GHC.ModGuts Value         ppModGuts = arr (ppSDoc . GHC.mg_module) -        -- DocH is not a monoid, so we can't use listT here-        ppProgram :: TranslateH GHC.CoreProgram Value -- CoreProgram = [CoreBind]-        ppProgram = translate $ \ c -> fmap toJSON . mapM (apply ppCoreBind c)+        -- DocH is not a monoid.+        -- GHC uses a list, which we print here. The CoreProg type is our doing.+        ppCoreProg :: TranslateH CoreProg Value+        ppCoreProg = translate $ \ c -> fmap toJSON . mapM (apply ppCoreBind c) . progToBinds          ppCoreExpr :: TranslateH GHC.CoreExpr Value         ppCoreExpr = varT (\i -> object [mkCon "Var", "value" .= ppSDoc i])@@ -62,7 +64,7 @@         ppCoreDef = defT ppCoreExpr $ \ i e -> object [mkCon "CoreDef", "var" .= ppSDoc i, "exp" .= e]      promoteT ppCoreExpr-     <+ promoteT ppProgram+     <+ promoteT ppCoreProg      <+ promoteT ppCoreBind      <+ promoteT ppCoreDef      <+ promoteT ppModGuts

@@ -1,24 +1,52 @@ {-# LANGUAGE TypeFamilies, FlexibleContexts #-}-module Language.HERMIT.Primitive.AlphaConversion where+module Language.HERMIT.Primitive.AlphaConversion+       ( -- * Alpha-Renaming and Shadowing+         externals+         -- ** Alpha-Renaming+       , alpha+       , alphaLam+       , alphaCaseBinder+       , alphaAltIds+       , alphaAlt+       , alphaCase+       , alphaLetVars+       , alphaLetRecIds+       , alphaLetOne+       , alphaLet+       , alphaConsOne+       , alphaCons+         -- ** Shadow Detection and Unshadowing+       , unshadow+       , visibleVarsT+       , freshNameGenT+       , freshNameGenAvoiding+       , replaceVarR+       )+where  import GhcPlugins hiding (empty) +import Control.Applicative import Control.Arrow import Data.Char (isDigit)-import Data.List (intersect, (\\), nub)+import Data.List (nub)+import Data.Monoid -import Language.HERMIT.Context+import Language.HERMIT.Core import Language.HERMIT.Monad import Language.HERMIT.Kure import Language.HERMIT.External-import Language.HERMIT.Primitive.GHC(freeVarsT, substR) +import Language.HERMIT.Primitive.GHC hiding (externals) import Language.HERMIT.Primitive.Common  import qualified Language.Haskell.TH as TH  import Prelude hiding (exp) +-----------------------------------------------------------------------++-- | Externals for alpha-renaming. externals :: [External] externals = map (.+ Deep)          [  external "alpha" alpha@@ -39,26 +67,19 @@                [ "renames the bound variable in a Let expression with one binder to the given name."]          ,  external "alpha-let" (promoteExprR alphaLet)                [ "renames the bound variables in a Let expression."]-         ,  external "alpha-top" (promoteProgramR . alphaConsOne . Just)+         ,  external "alpha-top" (promoteProgR . alphaConsOne . Just)                [ "renames the bound variable in a top-level binding with one binder to the given name."]-         ,  external "alpha-top" (promoteProgramR alphaCons)+         ,  external "alpha-top" (promoteProgR alphaCons)                [ "renames the bound variables in a top-level binding."]--         , external "shadow-query" (promoteExprT shadowedNamesQuery)-                [ "List variable names shadowed by bindings in this expression." ] .+ Query-         , external "if-shadow" (promoteExprR ifShadowingR)-                [ "succeeds ONLY-IF bindings in this expression shadow free variable name(s)." ]-          , external "unshadow" unshadow-                [ "Rename local variable with manifestly unique names (x, x0, x1, ...)"]-+                [ "Rename local variables with manifestly unique names (x, x0, x1, ...)."]          ]  ----------------------------------------------------------------------- ----- freshNameGen is a function used in conjunction with cloneIdH, which clones an existing Id.+-- freshNameGen is a function used in conjunction with cloneVarH, which clones an existing 'Var'. -- But, what name should the new Id have?--- cloneIdH generates a new Unique -- so we are positive that the new Id will be new,+-- cloneVarH generates a new Unique -- so we are positive that the new Var will be new, -- but freshNameGen tries to assign a Name that will be meaningful to the user, and -- not shadow other names in scope. -- So,  we start with the name of the original Id, and add an integer suffix@@ -67,66 +88,71 @@ -- 1.  Any free variable name in the active Expr; or -- 2.  Any bound variables in context. -visibleIds :: TranslateH CoreExpr [Id]-visibleIds = do ctx <- contextT-                frees <- freeVarsT-                return $ frees ++ (listBindings ctx)+-- | List all visible identifiers (in the expression or the context).+visibleVarsT :: TranslateH CoreExpr [Var]+visibleVarsT = boundVarsT `mappend` freeVarsT -freshNameGen :: (Maybe TH.Name) -> [Id] -> (String -> String)-freshNameGen newName idsToAvoid =-        case newName of-          Just name -> const (show name)-          Nothing   -> inventNames idsToAvoid+-- | If a name is provided replace the string with that,+--   otherwise modify the string making sure to /not/ clash with any visible variables.+freshNameGenT :: Maybe TH.Name -> TranslateH CoreExpr (String -> String)+freshNameGenT mn = freshNameGenAvoiding mn <$> visibleVarsT -freshNameGenT :: (Maybe TH.Name) -> TranslateH CoreExpr (String -> String)-freshNameGenT newName =-        case newName of-          Just name -> return $ const (show name)-          Nothing -> do idsToAvoid <- visibleIds-                        return $ freshNameGen Nothing idsToAvoid+-- | A generalisation of 'freshNameGen' that operates on any node, but only avoids name clashes with the results of the argument translation.+freshNameGenAvoiding :: Maybe TH.Name -> [Var] -> (String -> String)+freshNameGenAvoiding mn vs str = maybe (inventNames vs str) TH.nameBase mn -inventNames :: [Id] -> String -> String+-- | Invent a new String based on the old one, but avoiding clashing with the given list of identifiers.+inventNames :: [Var] -> String -> String inventNames curr old = head                      [ nm                      | nm <- old : [ base ++ show uq | uq <- [start ..] :: [Int] ]                      , nm `notElem` names                      ]    where-           names = map getOccString curr+           names = nub (map getOccString curr)            nums = reverse $ takeWhile isDigit (reverse old)            baseLeng = length $ drop (length nums) old            base = take baseLeng old            start = case reads nums of-                     [(v,_)] -> (v + 1)-                     _ -> 0+                     [(v,_)] -> v + 1+                     _       -> 0 -shadowedNamesT :: TranslateH CoreExpr [String]-shadowedNamesT = do ctx         <- contextT-                    frees       <- freeVarsT-                    bindingIds  <- extractT bindingVarsT-                    let shadows = intersect (map getOccString bindingIds)-                                            (map getOccString (frees ++ (listBindings ctx)))-                    return        shadows --- | Output a list of all variables that shadowed by bindings in the is expression.-shadowedNamesQuery :: TranslateH CoreExpr String-shadowedNamesQuery = shadowedNamesT >>^ (("Names shadowed by bindings in the current expression: " ++) . show)+-- | Remove all variables from the first list that shadow a variable in the second list.+shadowedBy :: [Var] -> [Var] -> [Var]+shadowedBy vs fvs = filter (\ v -> getOccString v `elem` map getOccString fvs) vs -ifShadowingR :: RewriteH CoreExpr-ifShadowingR = do shadows <- shadowedNamesT-                  case shadows of-                    [] -> fail "Bindings at this node do not shadow."-                    _  -> idR+-- | Lifted version of 'shadowedBy'.+--   Additionally, it fails if no shadows are found.+shadowedByT :: TranslateH a [Var] -> TranslateH a [Var] -> TranslateH a [Var]+shadowedByT t1 t2 = (shadowedBy <$> t1 <*> t2) >>> acceptR (not . null) "No shadowing detected." --- | Arguments are the original identifier and the replacement identifier, respectively.-renameIdR :: (Injection a Core, Generic a ~ Core) => Id -> Id -> RewriteH a-renameIdR v v' = extractR $ tryR $ substR v (Var v')+-- | Rename local variables with manifestly unique names (x, x0, x1, ...).+--   Does not rename top-level definitions (though this may change in the future).+unshadow :: RewriteH Core+unshadow = setFailMsg "No shadows to eliminate." $+           anytdR (promoteExprR unshadowExpr <+ promoteAltR unshadowAlt) --- | Given an identifier to replace, and a replacement, produce an 'Id' @->@ 'Id' function that---   acts as in identity for all 'Id's except the one to replace, for which it returns the replacment.+  where+    unshadowExpr :: RewriteH CoreExpr+    unshadowExpr = do vs <- shadowedByT (boundVarsT `mappend` freeVarsT) (letVarsT <+ fmap return (caseWildVarT <+ lamVarT))+                      alphaLam Nothing <+ alphaLetRecIds vs <+ alphaLetNonRec Nothing <+ alphaCaseBinder Nothing++    unshadowAlt :: RewriteH CoreAlt+    unshadowAlt = shadowedByT altVarsT (boundVarsT `mappend` altFreeVarsT) >>= alphaAltIds++-----------------------------------------------------------------------++-- | Replace all occurrences of a specified variable.+--   Arguments are the variable to replace and the replacement variable, respectively.+replaceVarR :: (Injection a Core, Generic a ~ Core) => Var -> Var -> RewriteH a+replaceVarR v v' = extractR $ tryR $ substR v (Var v')++-- | Given a variable to replace, and a replacement, produce a 'Var' @->@ 'Var' function that+--   acts as in identity for all 'Var's except the one to replace, for which it returns the replacment. --   Don't export this, it'll likely just cause confusion.-replaceId :: Id -> Id -> (Id -> Id)-replaceId v v' i = if v == i then v' else i+replaceVar :: Var -> Var -> (Var -> Var)+replaceVar v v' i = if v == i then v' else i  ----------------------------------------------------------------------- @@ -134,8 +160,8 @@ alphaLam :: Maybe TH.Name -> RewriteH CoreExpr alphaLam mn = setFailMsg (wrongFormForAlpha "Lam v e") $               do (v, nameModifier) <- lamT (freshNameGenT mn) (,)-                 v' <- constT (cloneIdH nameModifier v)-                 lamT (renameIdR v v') (\ _ -> Lam v')+                 v' <- constT (cloneVarH nameModifier v)+                 lamT (replaceVarR v v') (\ _ -> Lam v')  ----------------------------------------------------------------------- @@ -144,22 +170,24 @@ alphaCaseBinder mn = setFailMsg (wrongFormForAlpha "Case e v ty alts") $                      do Case _ v _ _ <- idR                         nameModifier <- freshNameGenT mn-                        v' <- constT (cloneIdH nameModifier v)-                        caseT idR (\ _ -> renameIdR v v') (\ e _ t alts -> Case e v' t alts)+                        v' <- constT (cloneVarH nameModifier v)+                        caseT idR (\ _ -> replaceVarR v v') (\ e _ t alts -> Case e v' t alts)  -----------------------------------------------------------------------  -- | Rename the specified identifier in a case alternative.  Optionally takes a suggested new name. alphaAltId :: Maybe TH.Name -> Id -> RewriteH CoreAlt alphaAltId mn v = do nameModifier <- altT (freshNameGenT mn) (\ _ _ nameGen -> nameGen)-                     v' <- constT (cloneIdH nameModifier v)-                     altT (renameIdR v v') (\ con vs e -> (con, map (replaceId v v') vs, e))+                     v' <- constT (cloneVarH nameModifier v)+                     altT (replaceVarR v v') (\ con vs e -> (con, map (replaceVar v v') vs, e)) +-- | Rename the specified identifiers in a case alternative.+alphaAltIds :: [Id] -> RewriteH CoreAlt+alphaAltIds = andR . map (alphaAltId Nothing)+ -- | Rename all identifiers bound in a case alternative. alphaAlt :: RewriteH CoreAlt-alphaAlt = setFailMsg (wrongFormForAlpha "(con,vs,e)") $-           do (_, vs, _) <- idR-              andR $ map (alphaAltId Nothing) vs+alphaAlt = altVarsT >>= alphaAltIds  ----------------------------------------------------------------------- @@ -173,30 +201,36 @@ alphaLetNonRec :: Maybe TH.Name -> RewriteH CoreExpr alphaLetNonRec mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $                     do (v, nameModifier) <- letNonRecT idR (freshNameGenT mn) (\ v _ nameMod -> (v, nameMod))-                       v' <- constT (cloneIdH nameModifier v)-                       letNonRecT idR (renameIdR v v') (\ _ e1 e2 -> Let (NonRec v' e1) e2)+                       v' <- constT (cloneVarH nameModifier v)+                       letNonRecT idR (replaceVarR v v') (\ _ e1 e2 -> Let (NonRec v' e1) e2) +-- | Alpha rename a non-recursive let binder if the variable appears in the argument list.  Optionally takes a suggested new name.+alphaLetNonRecVars :: Maybe TH.Name -> [Var] -> RewriteH CoreExpr+alphaLetNonRecVars mn vs = whenM ((`elem` vs) <$> letNonRecVarT) (alphaLetNonRec mn)+ -- | Rename the specified identifier bound in a recursive let.  Optionally takes a suggested new name. alphaLetRecId :: Maybe TH.Name -> Id -> RewriteH CoreExpr alphaLetRecId mn v = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $-                     do Let (Rec {}) _ <- idR-                        ctx <- contextT-                         -- Cannot use freshNameGen directly, because we want to include-                         -- free variables from every bound expression, in the name generation function-                         -- as a result we must replicate the essence of freshNameGen in the next few lines-                        frees <- letRecDefT (\ _ -> freeVarsT) freeVarsT (\ bindFrees exprFrees -> (concat (map snd bindFrees)) ++ exprFrees)-                        let nameGen = case mn of-                                        Just name -> const (show name)-                                        Nothing -> inventNames (frees ++ (listBindings ctx))-                        v' <- constT (cloneIdH nameGen v)+                     do usedVars <- boundVarsT `mappend`+                                    letVarsT  `mappend`+                                    letRecDefT (\ _ -> freeVarsT) freeVarsT (\ bndfvs vs -> concatMap snd bndfvs ++ vs)+                        v' <- constT (cloneVarH (freshNameGenAvoiding mn usedVars) v)+                        letRecDefT (\ _ -> replaceVarR v v')+                                   (replaceVarR v v')+                                   (\ bs e -> Let (Rec $ (map.first) (replaceVar v v') bs) e) -                        letRecDefT (\ _ -> renameIdR v v') (renameIdR v v') (\ bs e -> Let (Rec $ (map.first) (replaceId v v') bs) e)+-- | Rename the specified identifiers bound in a recursive let.+alphaLetRecIds :: [Id] -> RewriteH CoreExpr+alphaLetRecIds = andR . map (alphaLetRecId Nothing) +-- | Rename the specified variables bound in a let.+alphaLetVars :: [Var] -> RewriteH CoreExpr+alphaLetVars vs = alphaLetNonRecVars Nothing vs <+ alphaLetRecIds vs+ -- | Rename all identifiers bound in a recursive let. alphaLetRec :: RewriteH CoreExpr alphaLetRec = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $-              do Let (Rec bs) _ <- idR-                 andR $ map (alphaLetRecId Nothing . fst) bs+              letRecVarsT >>= alphaLetRecIds  -- | Rename the identifier bound in a recursive let with a single recursively bound identifier.  Optionally takes a suggested new name. alphaLetRecOne :: Maybe TH.Name -> RewriteH CoreExpr@@ -215,47 +249,45 @@ -----------------------------------------------------------------------  -- | Alpha rename a non-recursive top-level binder.  Optionally takes a suggested new name.-alphaConsNonRec :: Maybe TH.Name -> RewriteH CoreProgram-alphaConsNonRec mn = setFailMsg (wrongFormForAlpha "NonRec v e : prog") $-                     do NonRec v _ : _ <- idR+alphaConsNonRec :: Maybe TH.Name -> RewriteH CoreProg+alphaConsNonRec mn = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $+                     do ProgCons (NonRec v _) _ <- idR                         nameModifier <- consNonRecT (freshNameGenT mn) idR (\ _ nameGen _ -> nameGen)-                        v' <- constT (cloneIdH nameModifier v)-                        consNonRecT idR (renameIdR v v') (\ _ e1 e2 -> NonRec v' e1 : e2)+                        v' <- constT (cloneVarH nameModifier v)+                        consNonRecT idR (replaceVarR v v') (\ _ e1 e2 -> ProgCons (NonRec v' e1) e2)  -- | Rename the specified identifier bound in a recursive top-level binder.  Optionally takes a suggested new name.-alphaConsRecId :: Maybe TH.Name -> Id -> RewriteH CoreProgram-alphaConsRecId mn v = setFailMsg (wrongFormForAlpha "Rec bs : prog") $-                      do rbs@(Rec _) : _ <- idR-                         -- Cannot use freshNameGen directly, because we want to include-                         -- free variables from every bound expression, in the name generation function-                         -- as a result we must replicate the essence of freshNameGen in the next few lines-                         ctx <- contextT-                         frees <- consRecDefT (\ _ -> freeVarsT) idR (\ frees _ -> concat (map snd frees))-                         let idsToAvoid = ((nub frees) \\ (bindings rbs)) ++ (listBindings ctx)-                             nameGen = case mn of-                                         Just name -> const (show name)-                                         Nothing -> inventNames idsToAvoid-                         v' <- constT (cloneIdH nameGen v)-                         consRecDefT (\ _ -> renameIdR v v') (renameIdR v v') (\ bs e -> Rec ((map.first) (replaceId v v') bs) : e)+alphaConsRecId :: Maybe TH.Name -> Id -> RewriteH CoreProg+alphaConsRecId mn v = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $+                      do usedVars <- boundVarsT `mappend`+                                     progConsT recVarsT (return ()) (\ vs () -> vs) `mappend`+                                     consRecDefT (\ _ -> freeVarsT) idR (\ bndfvs _ -> concatMap snd bndfvs)+                         v' <- constT (cloneVarH (freshNameGenAvoiding mn usedVars) v)+                         consRecDefT (\ _ -> replaceVarR v v')+                                     (replaceVarR v v')+                                     (\ bs e -> ProgCons (Rec $ (map.first) (replaceVar v v') bs) e) +-- | Rename the specified identifiers bound in a program node containing a recursive binding group.+alphaConsRecIds :: [Id] -> RewriteH CoreProg+alphaConsRecIds = andR . map (alphaConsRecId Nothing)+ -- | Rename all identifiers bound in a recursive top-level binder.-alphaConsRec :: RewriteH CoreProgram-alphaConsRec = setFailMsg (wrongFormForAlpha "Rec bs : prog") $-               do Rec bs : _ <- idR-                  andR $ map (alphaConsRecId Nothing . fst) bs+alphaConsRec :: RewriteH CoreProg+alphaConsRec = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $+               progConsT recVarsT mempty (\ vs () -> vs) >>= alphaConsRecIds  -- | Rename the identifier bound in a recursive top-level binder with a single recursively bound identifier.  Optionally takes a suggested new name.-alphaConsRecOne :: Maybe TH.Name -> RewriteH CoreProgram-alphaConsRecOne mn = setFailMsg (wrongFormForAlpha "Rec [(v,e)] : prog") $-                     do Rec [(v, _)] : _ <- idR+alphaConsRecOne :: Maybe TH.Name -> RewriteH CoreProg+alphaConsRecOne mn = setFailMsg (wrongFormForAlpha "ProgCons (Rec [Def v e]) p") $+                     do ProgCons (Rec [(v, _)]) _ <- idR                         alphaConsRecId mn v  -- | Rename the identifier bound in a top-level binder with a single bound identifier.  Optionally takes a suggested new name.-alphaConsOne :: Maybe TH.Name -> RewriteH CoreProgram+alphaConsOne :: Maybe TH.Name -> RewriteH CoreProg alphaConsOne mn = alphaConsNonRec mn <+ alphaConsRecOne mn  -- | Rename all identifiers bound in a Let.-alphaCons :: RewriteH CoreProgram+alphaCons :: RewriteH CoreProg alphaCons = alphaConsRec <+ alphaConsNonRec Nothing  -----------------------------------------------------------------------@@ -264,13 +296,12 @@ alpha :: RewriteH Core alpha = setFailMsg "Cannot alpha-rename here." $            promoteExprR (alphaLam Nothing <+ alphaCaseBinder Nothing <+ alphaLet)-        <+ promoteProgramR alphaCons--unshadow :: RewriteH Core-unshadow = setFailMsg "No shadows to eliminate." $-           anytdR (promoteExprR (ifShadowingR >>> (alphaLam Nothing <+ alphaCase <+ alphaLet)))+        <+ promoteProgR alphaCons+        <+ promoteAltR alphaAlt  -----------------------------------------------------------------------  wrongFormForAlpha :: String -> String-wrongFormForAlpha s = "Cannot alpha-rename: " ++ wrongExprForm s+wrongFormForAlpha s = "Cannot alpha-rename, " ++ wrongExprForm s++-----------------------------------------------------------------------

@@ -1,94 +1,135 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances, FlexibleContexts, TupleSections #-}- -- | Note: this module should NOT export externals. It is for common --   transformations needed by the other primitive modules. module Language.HERMIT.Primitive.Common-    ( altFreeVarsT-    , bindings-    , bindingVarsT-    , caseAltVarsT-    , caseBinderVarT+    ( -- * Utility Transformations+      -- ** Collecting variables bound at a Node+      progVarsT+    , bindVarsT+    , nonRecVarT+    , recVarsT+    , defVarT+    , lamVarT     , letVarsT+    , letRecVarsT+    , letNonRecVarT+    , caseVarsT+    , caseWildVarT+    , caseAltVarsT+    , altVarsT+      -- ** Finding variables bound in the Context+    , boundVarsT+    , findBoundVarT+    , findIdT+      -- ** Error Message Generators     , wrongExprForm-    ) where+    ) -import GhcPlugins+where -import Control.Arrow+import GhcPlugins  import Data.List import Data.Monoid  import Language.HERMIT.Kure--import Language.HERMIT.Primitive.GHC+import Language.HERMIT.Core+import Language.HERMIT.Context+import Language.HERMIT.GHC +import qualified Language.Haskell.TH as TH -class BindEnv a where-    bindings :: a -> [Id]+------------------------------------------------------------------------------ --- | All the identifiers bound in this binding group.-instance BindEnv  CoreBind where-    bindings (NonRec b _) = [b]-    bindings (Rec bs)     = map fst bs+-- | List all identifiers bound at the top-level in a program.+progVarsT :: TranslateH CoreProg [Id]+progVarsT = progNilT [] <+ progConsT bindVarsT progVarsT (++) -instance BindEnv CoreAlt where-    bindings (_,vs,_) = vs+-- | List all identifiers bound in a binding group.+bindVarsT :: TranslateH CoreBind [Var]+bindVarsT = fmap return nonRecVarT <+ recVarsT -instance BindEnv CoreExpr where-    bindings (Lam b _)          = [b]-    bindings (Let bs _)         = bindings bs-    bindings (Case _ sc _ alts) = sc : (nub (concat (map bindings alts)))-    bindings _                  = []+-- | Return the variable bound by a non-recursive let expression.+nonRecVarT :: TranslateH CoreBind Var+nonRecVarT = nonRecT mempty (\ v () -> v) -instance BindEnv CoreProgram where-    bindings prog = nub (concat (map bindings prog))+-- | List all identifiers bound in a recursive binding group.+recVarsT :: TranslateH CoreBind [Id]+recVarsT = recT (\ _ -> defVarT) id -instance BindEnv CoreDef  where-    bindings (Def b _) = [b]+-- | Return the identifier bound by a recursive definition.+defVarT :: TranslateH CoreDef Id+defVarT = defT mempty (\ v () -> v) -bindingVarsT :: TranslateH Core [Var]-bindingVarsT = translate $ \ c core -> case core of-          ModGutsCore _ -> fail "Cannot get binding vars at topmost level"-          ProgramCore x -> apply (promoteT ((arr bindings) :: TranslateH CoreProgram [Var])) c x-          BindCore x    -> apply (promoteT ((arr bindings) :: TranslateH CoreBind [Var])) c x-          DefCore x     -> apply (promoteT ((arr bindings) :: TranslateH CoreDef [Var])) c x-          ExprCore x    -> apply (promoteT ((arr bindings) :: TranslateH CoreExpr [Var])) c x-          AltCore x     -> apply (promoteT ((arr bindings) :: TranslateH CoreAlt [Var])) c x+-- | Return the variable bound by a lambda expression.+lamVarT :: TranslateH CoreExpr Var+lamVarT = lamT mempty (\ v () -> v) --- TODO.  Isn't there a better way to handle this ?--- Although the work of this Translate is handled by bindingVarsT--- This implementation fails for any expression that is not a Let.--- This specific argument matching is required where it is used in Local/Let.hs and Local/Case.hs+-- | List the variables bound by a let expression. letVarsT :: TranslateH CoreExpr [Var]-letVarsT = setFailMsg "Not a Let expression." $-           do Let bs _ <- idR-              return (bindings bs)+letVarsT = letT bindVarsT mempty (\ vs () -> vs) --- | List of the list of Ids bound by each case alternative-caseAltVarsT :: TranslateH CoreExpr [[Id]]-caseAltVarsT = caseT mempty (const (extractT bindingVarsT)) $ \ () _ _ vs -> vs+-- | List the variables bound by a recursive let expression.+letRecVarsT :: TranslateH CoreExpr [Var]+letRecVarsT = letT recVarsT mempty (\ vs () -> vs) --- | List of the list of Ids bound by each case alternative, including the Case binder in each list-caseAltVarsWithBinderT :: TranslateH CoreExpr [[Id]]-caseAltVarsWithBinderT = caseT mempty (const (extractT bindingVarsT)) $ \ () v _ vs -> map (v:) vs+-- | Return the variable bound by a non-recursive let expression.+letNonRecVarT :: TranslateH CoreExpr Var+letNonRecVarT = letT nonRecVarT mempty (\ v () -> v) --- | list containing the single Id of the case binder-caseBinderVarT :: TranslateH CoreExpr [Id]-caseBinderVarT = setFailMsg "Not a Case expression." $-                 do Case _ b _ _ <- idR-                    return [b]+-- | List all variables bound by a case expression (in the alternatives and the wildcard binder).+caseVarsT :: TranslateH CoreExpr [Var]+caseVarsT = caseT mempty (\ _ -> altVarsT) (\ () v _ vss -> v : nub (concat vss)) --- | Free variables for a CoreAlt, returns a function, which accepts---   the coreBndr name, before giving a result.---   This is so we can use this with congruence combinators:------   caseT id (const altFreeVarsT) $ \ _ bndr _ fs -> [ f bndr | f <- fs ]-altFreeVarsT :: TranslateH CoreAlt (Id -> [Var])-altFreeVarsT = altT freeVarsT $ \ _con ids frees coreBndr -> nub frees \\ nub (coreBndr : ids)+-- | Return the case wildcard binder.+caseWildVarT :: TranslateH CoreExpr Var+caseWildVarT = caseT mempty (\ _ -> return ()) (\ () v _ _ -> v) +-- | List the variables bound by all alternatives in a case expression.+caseAltVarsT :: TranslateH CoreExpr [[Var]]+caseAltVarsT = caseT mempty (\ _ -> altVarsT) (\ () _ _ vss -> vss)++-- | List the variables bound by a case alternative.+altVarsT :: TranslateH CoreAlt [Var]+altVarsT = altT mempty (\ _ vs () -> vs)+ ------------------------------------------------------------------------------ +-- Need a better error type so that we can factor out the repetition.++-- | Lifted version of 'boundVars'.+boundVarsT :: TranslateH a [Var]+boundVarsT = contextonlyT (return . boundVars)++-- | Find the unique variable bound in the context that matches the given name, failing if it is not unique.+findBoundVarT :: TH.Name -> TranslateH a Var+findBoundVarT nm = prefixFailMsg ("Cannot resolve name " ++ TH.nameBase nm ++ ", ") $+                        do c <- contextT+                           case findBoundVars nm c of+                             []         -> fail "no matching variables in scope."+                             [v]        -> return v+                             _ : _ : _  -> fail "multiple matching variables in scope."++-- | Lookup the name in the 'HermitC' first, then, failing that, in GHC's global reader environment.+findIdT :: TH.Name -> TranslateH a Id+findIdT nm = prefixFailMsg ("Cannot resolve name " ++ TH.nameBase nm ++ ", ") $+             do c <- contextT+                case findBoundVars nm c of+                  []         -> findIdMG nm+                  [v]        -> return v+                  _ : _ : _  -> fail "multiple matching variables in scope."++findIdMG :: TH.Name -> TranslateH a Id+findIdMG nm = contextonlyT $ \ c ->+    case filter isValName $ findNameFromTH (mg_rdr_env $ hermitModGuts c) nm of+      []  -> fail $ "variable not in scope."+      [n] -> lookupId n+      ns  -> do dynFlags <- getDynFlags+                fail $ "multiple matches found:\n" ++ intercalate ", " (map (showPpr dynFlags) ns)++------------------------------------------------------------------------------++-- | Constructs a common error message.+--   Argument 'String' should be the desired form of the expression. wrongExprForm :: String -> String wrongExprForm form = "Expression does not have the form: " ++ form 

@@ -8,6 +8,7 @@        ) where +import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.External import Language.HERMIT.Monad

@@ -0,0 +1,214 @@+module Language.HERMIT.Primitive.FixPoint where++import GhcPlugins as GHC hiding (varName)++import Control.Arrow++import Language.HERMIT.Core+import Language.HERMIT.Monad+import Language.HERMIT.Kure+import Language.HERMIT.External+import Language.HERMIT.GHC+import Language.HERMIT.Primitive.GHC+import Language.HERMIT.Primitive.Common+import Language.HERMIT.Primitive.Local+import Language.HERMIT.Primitive.AlphaConversion+import Language.HERMIT.Primitive.New -- TODO: Sort out heirarchy++import qualified Language.Haskell.TH as TH+++externals ::  [External]+externals = map ((.+ Experiment) . (.+ TODO))+         [ external "fix-intro" (promoteDefR fixIntro :: RewriteH Core)+                [ "rewrite a recursive binding into a non-recursive binding using fix" ]+         , external "fix-spec" (promoteExprR fixSpecialization :: RewriteH Core)+                [ "specialize a fix with a given argument"] .+ Shallow+         , external "ww-fac-test" ((\ wrap unwrap -> promoteExprR $ workerWrapperFacTest wrap unwrap) :: TH.Name -> TH.Name -> RewriteH Core)+                [ "Under construction "+                ] .+ Introduce .+ Context .+ Experiment .+ PreCondition+         , external "ww-split-test" ((\ wrap unwrap -> promoteDefR $ workerWrapperSplitTest wrap unwrap) :: TH.Name -> TH.Name -> RewriteH Core)+                [ "Under construction "+                ] .+ Introduce .+ Context .+ Experiment .+ PreCondition+         ]++fixLocation :: String+fixLocation = "Data.Function.fix"++findFixId :: TranslateH a Id+findFixId = findIdT (TH.mkName fixLocation)++guardIsFixId :: Id -> TranslateH a ()+guardIsFixId v = do fixId <- findFixId+                    guardMsg (v == fixId) (var2String v ++ " does not match " ++ fixLocation)+++-- |  f = e   ==>   f = fix (\ f -> e)+fixIntro :: RewriteH CoreDef+fixIntro = prefixFailMsg "Fix introduction failed: " $+           do Def f e <- idR+              fixId   <- findFixId+              constT $ do f' <- cloneVarH id f+                          let coreFix  = App (App (Var fixId) (Type (idType f)))+                              emptySub = mkEmptySubst (mkInScopeSet (exprFreeVars e))+                              sub      = extendSubst emptySub f (Var f')+                          return $ Def f (coreFix (Lam f' (substExpr (text "fixIntro") sub e)))++-- ironically, this is an instance of worker/wrapper itself.++fixSpecialization :: RewriteH CoreExpr+fixSpecialization = do++        -- fix (t::*) (f :: t -> t) (a :: t) :: t+        App (App (App (Var fixId) (Type _)) _) _ <- idR -- TODO: couldn't that Type be a Var?  Might be better to use my "isType" fucntion.++        guardIsFixId fixId -- guardMsg (fx == fixId) "fixSpecialization only works on fix"++        let rr :: RewriteH CoreExpr+            rr = multiEtaExpand [TH.mkName "f",TH.mkName "a"]++            sub :: RewriteH Core+            sub = pathR [0,1] (promoteR rr)+        -- be careful this does not loop (it should not)+        extractR sub >>> fixSpecialization'+++fixSpecialization' :: RewriteH CoreExpr+fixSpecialization' =+     do+        -- In normal form now+        App (App (App (Var fx) fixTyE)+                 (Lam _ (Lam v2 (App (App e _) _a2)))+            )+            a <- idR++        t  <- case typeExprToType fixTyE of+                Nothing -> fail "first argument to fix is not a type, this shouldn't have happened."+                Just ty -> return ty++        t' <- case typeExprToType a of+                Just t2           -> return (applyTy t t2)+                Nothing           -> fail "Not a type variable." -- TODO:  I think this entire functions needs revisiting and cleaning up.  What's going on with all the dead-code (which I've commented out now).+--                   Var  a2  -> mkAppTy t (exprType t2)+--                   mkAppTy t t'+++        -- TODO: t2' isn't used anywhere -- which means that a2 is never used ???+--        let t2' = case a2 of+--                   Type t2  -> applyTy t t2+--                   Var  a2  -> mkAppTy t (exprType t2)+--                   mkAppTy t t'+++        v3 <- constT $ newIdH "f" t' -- (funArgTy t')+        v4 <- constT $ newTyVarH "a" (tyVarKind v2)++         -- f' :: \/ a -> T [a] -> (\/ b . T [b])+        let f' = Lam v4  (Cast (Var v3)+                               (mkUnsafeCo t' (applyTy t (mkTyVarTy v4))))+        let e' = Lam v3 (App (App e f') a)++        return $ App (App (Var fx) (Type t')) e'+++-- introSpecialisedPolyFun :: TH.Name -> TH.Name -> RewriteH CoreExpr+-- introSpecialisedPolyFun funNm ty = do funId <- lookupMatchingVarT funNm+--                                       tyVar <- lookupMatchingVarT ty++++workerWrapperFacTest :: TH.Name -> TH.Name -> RewriteH CoreExpr+workerWrapperFacTest wrapNm unwrapNm = do wrapId   <- findBoundVarT wrapNm+                                          unwrapId <- findBoundVarT unwrapNm+                                          monomorphicWorkerWrapperFac (Var wrapId) (Var unwrapId)++workerWrapperSplitTest :: TH.Name -> TH.Name -> RewriteH CoreDef+workerWrapperSplitTest wrapNm unwrapNm = do wrapId   <- findBoundVarT wrapNm+                                            unwrapId <- findBoundVarT unwrapNm+                                            monomorphicWorkerWrapperSplit (Var wrapId) (Var unwrapId)+++-- monomorphicWorkerWrapperFac :: Id -> Id -> RewriteH CoreExpr+-- monomorphicWorkerWrapperFac wrapId unwrapId = -- let wrapTy   = idType wrapId+--                                               --     unwrapTy = idType unwrapId+--                                               --     (wrapForallTyVars, wrapMainTy)     = splitForAllTys wrapTy+--                                               --     (unwrapForallTyVars, unwrapMainTy) = splitForAllTys unwrapTy++--                                               -- in  -- In progress: above are not used yet.+--                                                   workerWrapperFac (Var wrapId) (Var unwrapId)+--                                                 -- workerWrapperFac (mkTyApps (Var wrapId)   wrapForallTys)+--                                                 --                  (mkTyApps (Var unwrapId) unwrapForallTys)++-- workerWrapperFac (Var wrapId) (Var unwrapId)+-- splitForAllTys :: Type -> ([TyVar], Type)++-- monomorphicWorkerWrapperSplit :: Id -> Id -> RewriteH CoreDef+-- monomorphicWorkerWrapperSplit wrapId unwrapId = workerWrapperSplit (Var wrapId) (Var unwrapId)++-- substTyWith :: [TyVar] -> [Type] -> Type -> Type+-- mkTyApps  :: Expr b -> [Type]   -> Expr b++-- I assume there are GHC functions to do this, but I can't find them.+-- in progress+-- unifyTyVars :: [TyVar] -- | forall quantified type variables+--             -> Type    -- | type containing forall quantified type variables+--             -> Type    -- | type to unify with+--             -> Maybe [Type]  -- | types that the variables have been unified with+-- unifyTyVars vs tyGen tySpec = let unifyTyVarsAux tyGen tySpec vs+--                                in undefined+--   unifyTyVarsAux :: Type -> Type -> [(TyVar,[Type])] -> Maybe [(TyVar,[Type])]+--   unifyTyVarsAux (TyVarTy v)   t             = match v t+--   unifyTyVarsAux (AppTy s1 s2) (AppTy t1 t2) = match s1 t1 . match s2 t2+++-- f      :: a -> a+-- wrap   :: forall x,y..z. b -> a+-- unwrap :: forall p,q..r. a -> b+-- fix tyA f ==> wrap (fix tyB (\ x -> unwrap (f (wrap (Var x)))))+-- Assumes the arguments are monomorphic functions (all type variables have alread been applied)+monomorphicWorkerWrapperFac :: CoreExpr -> CoreExpr -> RewriteH CoreExpr+monomorphicWorkerWrapperFac wrapE unwrapE =+  prefixFailMsg "Worker/wrapper Factorisation failed: " $+  withPatFailMsg (wrongExprForm "fix type fun") $+  do App (App (Var fixId) fixTyE) f <- idR  -- fix :: forall a. (a -> a) -> a+     guardIsFixId fixId+     case typeExprToType fixTyE of+       Nothing  -> fail "first argument to fix is not a type, this shouldn't have happened."+       Just tyA -> case splitFunTy_maybe (exprType wrapE) of+           Nothing            -> fail "type of wrapper is not a function."+           Just (tyB,wrapTyA) -> case splitFunTy_maybe (exprType unwrapE) of+             Nothing                    -> fail "type of unwrapper is not a function."+             Just (unwrapTyA,unwrapTyB) -> do guardMsg (eqType wrapTyA unwrapTyA) ("argument type of unwrapper does not match result type of wrapper.")+                                              guardMsg (eqType unwrapTyB tyB) ("argument type of wrapper does not match result type of unwrapper.")+                                              guardMsg (eqType wrapTyA tyA) ("wrapper/unwrapper types do not match expression type.")+                                              x <- constT (newIdH "x" tyB)+                                              return $ App wrapE+                                                           (App (App (Var fixId) (Type tyB))+                                                                (Lam x (App unwrapE+                                                                            (App f+                                                                                 (App wrapE+                                                                                      (Var x)+                                                                                 )+                                                                            )+                                                                       )+                                                                )+                                                           )+++monomorphicWorkerWrapperSplit :: CoreExpr -> CoreExpr -> RewriteH CoreDef+monomorphicWorkerWrapperSplit wrap unwrap =+  let f    = TH.mkName "f"+      w    = TH.mkName "w"+      work = TH.mkName "work"+      fx   = TH.mkName "fix"+   in+      fixIntro >>> defR ( appAllR idR (letIntro f)+                            >>> letFloatArg+                            >>> letAllR idR ( monomorphicWorkerWrapperFac wrap unwrap+                                                >>> appAllR idR (letIntro w)+                                                >>> letFloatArg+                                                >>> letNonRecAllR (unfold fx >>> alphaLetOne (Just work) >>> extractR simplifyR) idR+                                                >>> letSubstR+                                                >>> letFloatArg+                                            )+                        )

@@ -1,9 +1,12 @@ module Language.HERMIT.Primitive.Fold-    ( externals+    ( -- * Fold/Unfold Transformation+      externals     , foldR     , stashFoldR-    ) where+    ) +where+ import GhcPlugins hiding (empty)  import Control.Applicative@@ -12,10 +15,11 @@ import Data.List (intercalate) import qualified Data.Map as Map -import Language.HERMIT.Monad+import Language.HERMIT.Core import Language.HERMIT.Context-import Language.HERMIT.External+import Language.HERMIT.Monad import Language.HERMIT.Kure+import Language.HERMIT.External import Language.HERMIT.GHC  import Language.HERMIT.Primitive.GHC hiding (externals)@@ -60,7 +64,7 @@ foldR :: TH.Name -> RewriteH CoreExpr foldR nm =  prefixFailMsg "Fold failed: " $     translate $ \ c e -> do-        i <- case filter (cmpTHName2Id nm) $ Map.keys (hermitBindings c) of+        i <- case filter (cmpTHName2Var nm) $ Map.keys (hermitBindings c) of                 []  -> fail "cannot find name."                 [i] -> return i                 is  -> fail $ "multiple names match: " ++ intercalate ", " (map var2String is)

@@ -1,128 +1,146 @@-{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, TupleSections #-}-module Language.HERMIT.Primitive.GHC where+module Language.HERMIT.Primitive.GHC+       ( -- * GHC-based Transformations+         -- | This module contains transformations that are reflections of GHC functions, or derived from GHC functions.+         externals+         -- ** Free Variables+       , coreExprFreeIds+       , coreExprFreeVars+       , freeIdsT+       , freeVarsT+       , altFreeVarsT+       , altFreeVarsExclWildT+         -- ** Substitution+       , substR+       , letSubstR+       , safeLetSubstR+       , safeLetSubstPlusR+         -- ** Utilities+       , inScope+       , exprEqual+       , showVars+       , rules+       )+where -import GhcPlugins hiding (empty)+import GhcPlugins import qualified OccurAnal+ import Control.Arrow import Control.Monad-import qualified Data.Map as Map-import Data.List (nub, mapAccumL)---- import Language.HERMIT.Primitive.Debug-import Language.HERMIT.Primitive.Navigation+import Data.List (intercalate,mapAccumL,(\\)) -import Language.HERMIT.CoreExtra-import Language.HERMIT.Kure+import Language.HERMIT.Core+import Language.HERMIT.Context import Language.HERMIT.Monad+import Language.HERMIT.Kure import Language.HERMIT.External-import Language.HERMIT.Context-import qualified Language.HERMIT.GHC as GHC+import Language.HERMIT.GHC -import qualified Language.Haskell.TH as TH--- import Debug.Trace+import Language.HERMIT.Primitive.Navigation hiding (externals) -import Prelude hiding (exp)+import qualified Language.Haskell.TH as TH  ------------------------------------------------------------------------ +-- | Externals that reflect GHC functions, or are derived from GHC functions. externals :: [External] externals =-         [ external "let-subst" (promoteExprR letSubstR :: RewriteH Core)-                [ "Let substitution [via GHC]"-                , "let x = E1 in E2 ==> E2[E1/x], fails otherwise"-                , "only matches non-recursive lets" ]                           .+ Deep+         [ external "info" (info :: TranslateH Core String)+                [ "display information about the current node." ]+         , external "let-subst" (promoteExprR letSubstR :: RewriteH Core)+                [ "Let substitution"+                , "(let x = e1 in e2) ==> (e2[e1/x])"+                , "x must not be free in e1." ]                           .+ Deep          , external "safe-let-subst" (promoteExprR safeLetSubstR :: RewriteH Core)-                [ "Safe let substitution [via GHC]"-                , "let x = E1 in E2, safe to inline without duplicating work ==> E2[E1/x],"-                , "fails otherwise"-                , "only matches non-recursive lets" ]                           .+ Deep .+ Eval .+ Bash+                [ "Safe let substitution"+                , "let x = e1 in e2, safe to inline without duplicating work ==> e2[e1/x],"+                , "x must not be free in e1." ]                           .+ Deep .+ Eval .+ Bash          , external "safe-let-subst-plus" (promoteExprR safeLetSubstPlusR :: RewriteH Core)-                [ "Safe let substitution [via GHC]"-                , "let { x = E1, ... } in E2, "-                , "  where safe to inline without duplicating work ==> E2[E1/x,...],"-                , "fails otherwise"+                [ "Safe let substitution"+                , "let { x = e1, ... } in e2, "+                , "  where safe to inline without duplicating work ==> e2[e1/x,...],"                 , "only matches non-recursive lets" ]  .+ Deep .+ Eval          , external "free-ids" (promoteExprT freeIdsQuery :: TranslateH Core String)-                [ "List the free identifiers in this expression [via GHC]" ] .+ Query .+ Deep-         , external "deshadow-binds" (promoteProgramR deShadowBindsR :: RewriteH Core)-                [ "Deshadow a program " ] .+ Deep+                [ "List the free identifiers in this expression." ] .+ Query .+ Deep+         , external "deshadow-prog" (promoteProgR deShadowProgR :: RewriteH Core)+                [ "Deshadow a program." ] .+ Deep          , external "apply-rule" (promoteExprR . rules :: String -> RewriteH Core)                 [ "apply a named GHC rule" ] .+ Shallow          , external "apply-rule" (rules_help :: TranslateH Core String)                 [ "list rules that can be used" ] .+ Query          , external "compare-values" compareValues-                ["compare's the rhs of two values"] .+ Query .+ Predicate+                ["compare the rhs of two values."] .+ Query .+ Predicate          , external "add-rule" (\ rule_name id_name -> promoteModGutsR (addCoreBindAsRule rule_name id_name))                 ["add-rule \"rule-name\" <id> -- adds a new rule that freezes the right hand side of the <id>"]                                         .+ Introduce          , external "cast-elim" (promoteExprR castElimination)                 ["cast-elim removes casts"]-                                        .+ Shallow .+ TODO+                                        .+ Shallow .+ Experiment .+ TODO          , external "add-rule" (\ rule_name id_name -> promoteModGutsR (addCoreBindAsRule rule_name id_name))                 ["add-rule \"rule-name\" <id> -- adds a new rule that freezes the right hand side of the <id>"]-         , external "flatten-module" (promoteModGutsR flattenModule :: RewriteH Core)-                ["Flatten all the top-level binding groups into a single recursive binding group.",-                 "This can be useful if you intend to appply GHC RULES."]-          , external "occur-analysis" (promoteExprR occurAnalyseExprR :: RewriteH Core)                 ["Performs dependency anlaysis on a CoreExpr.",                  "This can be useful to simplify a recursive let to a non-recursive let."] .+ Deep          ]  -------------------------------------------------------------------------substR :: Id -> CoreExpr -> RewriteH Core-substR b e = setFailMsg "Can only perform substitution on Expr or CoreProgram forms." $-             promoteExprR (substExprR b e) <+  promoteProgramR (substTopBindR b e) -substExprR :: Id -> CoreExpr -> RewriteH CoreExpr-substExprR b e =  contextfreeT $ \ exp ->+-- | Substitute all occurrences of a variable with an expression, in either a program or an expression.+substR :: Var -> CoreExpr -> RewriteH Core+substR v e = setFailMsg "Can only perform substitution on expressions or programs." $+             promoteExprR (substExprR v e) <+ promoteProgR (substTopBindR v e)++-- | Substitute all occurrences of a variable with an expression, in an expression.+substExprR :: Var -> CoreExpr -> RewriteH CoreExpr+substExprR v e =  contextfreeT $ \ expr ->           -- The InScopeSet needs to include any free variables appearing in the           -- expression to be substituted.  Constructing a NonRec Let expression           -- to pass on to exprFeeVars takes care of this, but ...           -- TODO Is there a better way to do this ???-          let emptySub = mkEmptySubst (mkInScopeSet (exprFreeVars (Let (NonRec b e) exp)))-              sub = if (isTyVar b)-                    then case e of-                           (Type bty) -> Just $ extendTvSubst emptySub b bty-                           (Var x)    -> Just $ extendTvSubst emptySub b (mkTyVarTy x)-                           _ ->  Nothing-                    else Just $ extendSubst emptySub b e-          in-            case sub of-              Just sub' -> return $ substExpr (text "substR") sub' exp-              Nothing -> fail "substExprR:  Id argument is a TyVar, but the expression is not a Type."+       let emptySub = mkEmptySubst (mkInScopeSet (exprFreeVars (Let (NonRec v e) expr)))+        in do+              sub <- if isTyVar v+                       then case e of+                              Type vty -> return $ extendTvSubst emptySub v vty+                              Var x    -> return $ extendTvSubst emptySub v (mkTyVarTy x)+                              _        -> fail "substExprR:  Var argument is a TyVar, but the expression is not a Type."+                       else return $ extendSubst emptySub v e+              return $ substExpr (text "substR") sub expr +-- | Substitute all occurrences of a variable with an expression, in a program.+substTopBindR :: Var -> CoreExpr -> RewriteH CoreProg+substTopBindR v e =  contextfreeT $ \ p ->+          -- TODO.  Do we need to initialize the emptySubst with bindFreeVars?+       let emptySub =  emptySubst -- mkEmptySubst (mkInScopeSet (exprFreeVars exp))+        in do+              sub <- if isTyVar v+                      then case e of+                             Type vty -> return $ extendTvSubst emptySub v vty+                             Var x    -> return $ extendTvSubst emptySub v (mkTyVarTy x)+                             _        -> fail "substTopBindR:  Var argument is a TyVar, but the expression is not a Type."+                      else return $ extendSubst emptySub v e+              return $ bindsToProg $ snd (mapAccumL substBind sub (progToBinds p)) -substTopBindR :: Id -> CoreExpr -> RewriteH CoreProgram-substTopBindR b e =  contextfreeT $ \  binds  ->-          -- TODO.  Do we ned to initialize the emptySubst with bindFreeVars ?-          let emptySub =  emptySubst -- mkEmptySubst (mkInScopeSet (exprFreeVars exp))-              sub = if (isTyVar b)-                    then case e of-                           (Type bty) -> Just $ extendTvSubst emptySub b bty-                           (Var x)    -> Just $ extendTvSubst emptySub b (mkTyVarTy x)-                           _ ->  Nothing-                    else Just $ extendSubst emptySub b e-          in-            case sub of-              Just sub' -> return $ snd (mapAccumL substBind sub' binds)-              Nothing -> fail "substTopBindR:  Id argument is a TyVar, but the expression is not a Type." +-- | (let x = e1 in e2) ==> (e2[e1/x]),+--   x must not be free in e1. letSubstR :: RewriteH CoreExpr letSubstR =  prefixFailMsg "Let substition failed: " $-             rewrite $ \ ctx exp -> case occurAnalyseExpr exp of-                                     Let (NonRec b be) e -> apply (substExprR b be) ctx e+             rewrite $ \ c expr -> case occurAnalyseExpr expr of+                                     Let (NonRec b be) e -> apply (substExprR b be) c e                                      _ -> fail "expression is not a non-recursive Let." --- remove N lets, please-letSubstNR :: Int -> RewriteH Core-letSubstNR 0 = idR-letSubstNR n = childR 1 (letSubstNR (n - 1)) >>> promoteExprR letSubstR --- This is quite expensive (O(n) for the size of the sub-tree)+-- Neil: Commented this out as it's not (currently) used.+--  Perform let-substitution the specified number of times.+-- letSubstNR :: Int -> RewriteH Core+-- letSubstNR 0 = idR+-- letSubstNR n = childR 1 (letSubstNR (n - 1)) >>> promoteExprR letSubstR++-- | This is quite expensive (O(n) for the size of the sub-tree). safeLetSubstR :: RewriteH CoreExpr safeLetSubstR =  prefixFailMsg "Safe let-substition failed: " $-                 translate $ \ env exp ->+                 translate $ \ env expr ->     let   -- Lit?           safeBind (Var {})   = True           safeBind (Lam {})   = True@@ -137,13 +155,13 @@           safeSubst IAmDead   = True    -- DCE           safeSubst (OneOcc inLam oneBr _) = not inLam && oneBr -- do not inline inside a lambda or if in multiple case branches           safeSubst _ = False   -- strange case, like a loop breaker-   in case occurAnalyseExpr exp of+   in case occurAnalyseExpr expr of       -- By (our) definition, types are a trivial bind       Let (NonRec b _) _-         | isTyVar b -> apply letSubstR env exp+         | isTyVar b -> apply letSubstR env expr       Let (NonRec b be) _          | isId b && (safeBind be || safeSubst (occInfo (idInfo b)))-                     -> apply letSubstR env exp+                     -> apply letSubstR env expr          | otherwise -> fail "safety critera not met."       _ -> fail "expression is not a non-recursive Let." @@ -154,35 +172,98 @@  ------------------------------------------------------------------------ +info :: TranslateH Core String+info = translate $ \ c core -> do+         dynFlags <- getDynFlags+         let pa       = "Path: " ++ show (contextPath c)+             node     = "Node: " ++ coreNode core+             con      = "Constructor: " ++ coreConstructor core+             bds      = "Bindings in Scope: " ++ show (map unqualifiedVarName $ boundVars c)+             expExtra = case core of+                          ExprCore e -> ["Type or Kind: " ++ showExprTypeOrKind dynFlags e] +++                                        ["Free Variables: " ++ showVars (coreExprFreeVars e)]+                                           --  +++                                           -- case e of+                                           --   Var v -> ["Identifier Info: " ++ showIdInfo dynFlags v] -- TODO: what if this is a TyVar?+                                           --   _     -> []+                          _          -> []++         return (intercalate "\n" $ [pa,node,con,bds] ++ expExtra)++showExprTypeOrKind :: DynFlags -> CoreExpr -> String+showExprTypeOrKind dynFlags = showPpr dynFlags . exprTypeOrKind++-- showIdInfo :: DynFlags -> Id -> String+-- showIdInfo dynFlags v = showSDoc dynFlags $ ppIdInfo v $ idInfo v++coreNode :: Core -> String+coreNode (ModGutsCore _) = "Module"+coreNode (ProgCore _)    = "Program"+coreNode (BindCore _)    = "Binding Group"+coreNode (DefCore _)     = "Recursive Definition"+coreNode (ExprCore _)    = "Expression"+coreNode (AltCore _)     = "Case Alternative"++coreConstructor :: Core -> String+coreConstructor (ModGutsCore _)    = "ModGuts"+coreConstructor (ProgCore prog)    = case prog of+                                       ProgNil      -> "ProgNil"+                                       ProgCons _ _ -> "ProgCons"+coreConstructor (BindCore bnd)     = case bnd of+                                       Rec _      -> "Rec"+                                       NonRec _ _ -> "NonRec"+coreConstructor (DefCore _)        = "Def"+coreConstructor (AltCore _)        = "(,,)"+coreConstructor (ExprCore expr)    = case expr of+                                       Var _        -> "Var"+                                       Type _       -> "Type"+                                       Lit _        -> "Lit"+                                       App _ _      -> "App"+                                       Lam _ _      -> "Lam"+                                       Let _ _      -> "Let"+                                       Case _ _ _ _ -> "Case"+                                       Cast _ _     -> "Cast"+                                       Tick _ _     -> "Tick"+                                       Coercion _   -> "Coercion"++------------------------------------------------------------------------+ -- | Output a list of all free variables in an expression. freeIdsQuery :: TranslateH CoreExpr String-freeIdsQuery = do-    dynFlags <- constT getDynFlags-    frees <- freeIdsT-    return $ "Free identifiers are: " ++ showVars dynFlags frees---- | Show a human-readable version of a 'Var'.-showVar :: DynFlags -> Var -> String-showVar dynFlags = show . showPpr dynFlags+freeIdsQuery = do frees <- freeIdsT+                  return $ "Free identifiers are: " ++ showVars frees  -- | Show a human-readable version of a list of 'Var's.-showVars :: DynFlags -> [Var] -> String-showVars dynFlags = show . map (showPpr dynFlags) -- map GHC.var2String+showVars :: [Var] -> String+showVars = show . map var2String +-- | Lifted version of 'coreExprFreeIds'. freeIdsT :: TranslateH CoreExpr [Id] freeIdsT = arr coreExprFreeIds +-- | Lifted version of 'coreExprFreeVars'. freeVarsT :: TranslateH CoreExpr [Var] freeVarsT = arr coreExprFreeVars --- note: coreExprFreeVars get *all* free variables, including types+-- | List all free variables (including types) in the expression. coreExprFreeVars :: CoreExpr -> [Var] coreExprFreeVars  = uniqSetToList . exprFreeVars --- note: coreExprFreeIds is only value-level free variables+-- | List all free identifiers (value-level free variables) in the expression. coreExprFreeIds :: CoreExpr -> [Id] coreExprFreeIds  = uniqSetToList . exprFreeIds +-- | The free variables in a case alternative, which excludes any identifiers bound in the alternative.+altFreeVarsT :: TranslateH CoreAlt [Var]+altFreeVarsT = altT freeVarsT (\ _ vs fvs -> fvs \\ vs)++-- | A variant of 'altFreeVarsT' that returns a function that accepts the case wild-card binder before giving a result.+--   This is so we can use this with congruence combinators, for example:+--+--   caseT id (const altFreeVarsT) $ \ _ wild _ fvs -> [ f wild | f <- fvs ]+altFreeVarsExclWildT :: TranslateH CoreAlt (Id -> [Var])+altFreeVarsExclWildT = altT freeVarsT (\ _ vs fvs wild -> fvs \\ (wild : vs))+ ------------------------------------------------------------------------  -- | [from GHC documentation] De-shadowing the program is sometimes a useful pre-pass.@@ -191,8 +272,8 @@ -- -- (Actually, within a single /type/ there might still be shadowing, because -- 'substTy' is a no-op for the empty substitution, but that's probably OK.)-deShadowBindsR :: RewriteH CoreProgram-deShadowBindsR = arr deShadowBinds+deShadowProgR :: RewriteH CoreProg+deShadowProgR = arr (bindsToProg . deShadowBinds . progToBinds)  ------------------------------------------------------------------------ {-@@ -203,11 +284,12 @@ 	    -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -} -rulesToEnv :: [CoreRule] -> Map.Map String (RewriteH CoreExpr)-rulesToEnv rs = Map.fromList-        [ ( unpackFS (ruleName r), rulesToRewriteH [r] )-        | r <- rs-        ]+-- Neil: Commented this out as its not (currently) used.+-- rulesToEnv :: [CoreRule] -> Map.Map String (RewriteH CoreExpr)+-- rulesToEnv rs = Map.fromList+--         [ ( unpackFS (ruleName r), rulesToRewriteH [r] )+--         | r <- rs+--         ]  rulesToRewriteH :: [CoreRule] -> RewriteH CoreExpr rulesToRewriteH rs = translate $ \ c e -> do@@ -223,21 +305,21 @@     -- trace (showSDoc (ppr fn GhcPlugins.<+> ppr args $$ ppr rs)) $     case lookupRule (const True) (const NoUnfolding) in_scope fn args rs of         Nothing         -> fail "rule not matched"-        Just (rule, exp)  -> do-            let e' = mkApps exp (drop (ruleArity rule) args)+        Just (rule, expr)  -> do+            let e' = mkApps expr (drop (ruleArity rule) args)             ifM (liftM (and . map (inScope c)) $ apply freeVarsT c e')                 (return e')                 (fail $ unlines ["Resulting expression after rule application contains variables that are not in scope."                                 ,"This can probably be solved by running the flatten-module command at the top level."]) --- | See whether an identifier is in scope.-inScope :: Context -> Id -> Bool-inScope c i = maybe (case unfoldingInfo (idInfo i) of-                        CoreUnfolding {} -> True -- defined elsewhere-                        _ -> False)-                    (const True) -- defined in this module-                    (lookupHermitBinding i c)+-- | Determine whether an identifier is in scope.+inScope :: HermitC -> Id -> Bool+inScope c v = (v `boundIn` c) ||                 -- defined in this module+              case unfoldingInfo (idInfo v) of+                CoreUnfolding {} -> True         -- defined elsewhere+                _                -> False +-- | Lookup a rule and attempt to construct a corresponding rewrite. rules ::  String -> RewriteH CoreExpr rules r = do         theRules <- getHermitRules@@ -245,8 +327,8 @@                Nothing -> fail $ "failed to find rule: " ++ show r                Just rr -> rulesToRewriteH rr -getHermitRules :: (Generic a ~ Core) => TranslateH a [(String, [CoreRule])]-getHermitRules = translate $ \ env _e -> do+getHermitRules :: TranslateH a [(String, [CoreRule])]+getHermitRules = translate $ \ env _ -> do     rb <- liftCoreM getRuleBase     let other_rules = [ rule                         | top_bnds <- mg_binds (hermitModGuts env)@@ -283,9 +365,9 @@              , (v,e) <- case top_bnds of                             Rec bnds -> bnds                             NonRec b e -> [(b,e)]-             ,  nm `GHC.cmpTHName2Id` v+             ,  nm `cmpTHName2Var` v              ] of-         [] -> fail $ "can not find binding " ++ show nm+         [] -> fail $ "cannot find binding " ++ show nm          [(v,e)] -> return $ modGuts { mg_rules = mg_rules modGuts                                               ++ [makeRule rule_name v e]                                      }@@ -293,29 +375,14 @@  ---------------------------------------------------------------------- -flattenModule :: RewriteH ModGuts-flattenModule = modGutsR mergeBinds--mergeBinds :: RewriteH CoreProgram-mergeBinds = contextfreeT $ \  binds ->-             let allbinds = foldr listOfBinds [] binds-                 nodups = nub $ map fst allbinds-             in-               if (length allbinds == length nodups)-               then return $ [Rec allbinds]-               else fail "Module top level bindings contain multiple occurances of a name"- where listOfBinds cb others = case cb of-                                 (NonRec b e) -> (b, e) : others-                                 (Rec bds) -> bds ++ others-------------------------------------------------------------------------+-- | Performs dependency anlaysis on an expression.+--   This can be useful to simplify a non-recursive recursive binding group to a non-recursive binding group. occurAnalyseExpr :: CoreExpr -> CoreExpr occurAnalyseExpr = OccurAnal.occurAnalyseExpr -+-- | Lifted version of 'occurAnalyseExpr' occurAnalyseExprR :: RewriteH CoreExpr-occurAnalyseExprR = contextfreeT $ \ exp -> return (occurAnalyseExpr exp)+occurAnalyseExprR = arr occurAnalyseExpr   @@ -330,12 +397,6 @@  -} -{--joinT :: TranslateH a (TranslateH b c) -> (a -> TranslateH b c)-joinT f e0 = translate $ \ c e1 -> do-                t <- apply f c e0-                apply t c e1--}  exprEqual :: CoreExpr -> CoreExpr -> Bool exprEqual e1 e2 = eqExpr (mkInScopeSet $ exprsFreeVars [e1, e2]) e1 e2@@ -361,25 +422,24 @@ coreEqual :: Core -> Core -> Maybe Bool coreEqual (ExprCore e1) (ExprCore e2) = Just $ e1 `exprEqual` e2 coreEqual (BindCore b1) (BindCore b2) = b1 `bindEqual` b2-coreEqual (DefCore dc1) (DefCore dc2) = defToRecBind [dc1] `bindEqual` defToRecBind [dc2]+coreEqual (DefCore dc1) (DefCore dc2) = defsToRecBind [dc1] `bindEqual` defsToRecBind [dc2] coreEqual _             _             = Nothing  compareValues :: TH.Name -> TH.Name -> TranslateH Core () compareValues n1 n2 = do         p1 <- onePathToT (namedBinding n1)         p2 <- onePathToT (namedBinding n2)-        e1 :: Core <- pathT p1 idR-        e2 :: Core <- pathT p2 idR+        e1 <- pathT p1 idR+        e2 <- pathT p2 idR         case e1 `coreEqual` e2 of-          Nothing    -> fail $ show n1 ++ " and " ++ show n2 ++ " are incomparable"-          Just False -> fail $ show n1 ++ " and " ++ show n2 ++ " are not equal"+          Nothing    -> fail $ show n1 ++ " and " ++ show n2 ++ " are incomparable."+          Just False -> fail $ show n1 ++ " and " ++ show n2 ++ " are not equal."           Just True  -> return ()  -------------------------------------------------------- ---- try figure out the arity of an Id-arityOf:: Context -> Id -> Int+-- | Try to figure out the arity of an identifier.+arityOf :: HermitC -> Id -> Int arityOf env nm =      case lookupHermitBinding nm env of         Nothing       -> idArity nm@@ -387,8 +447,8 @@         -- Note: the exprArity will call idArity if         -- it hits an id; perhaps we should do the counting         -- The advantage of idArity is it will terminate, though.-        Just (BIND _ _ e) -> GHC.exprArity e-        Just (CASE _ e _) -> GHC.exprArity e+        Just (BIND _ _ e) -> exprArity e+        Just (CASE _ e _) -> exprArity e  ------------------------------------------- 

@@ -1,20 +1,34 @@-module Language.HERMIT.Primitive.Inline where+module Language.HERMIT.Primitive.Inline+         ( -- * Inlining+           externals+         , inline+         , inlineName+         , inlineScrutinee+         , inlineCaseBinder+         , inlineTargets+         ) +where+ import GhcPlugins  import Control.Arrow -import Language.HERMIT.GHC-import Language.HERMIT.Primitive.Common--- import Language.HERMIT.Primitive.Debug (traceR)-import Language.HERMIT.Primitive.GHC-import Language.HERMIT.Primitive.Unfold+import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.Context+import Language.HERMIT.GHC import Language.HERMIT.External +import Language.HERMIT.Primitive.Common+import Language.HERMIT.Primitive.GHC hiding (externals)+import Language.HERMIT.Primitive.Unfold hiding (externals)+ import qualified Language.Haskell.TH as TH +------------------------------------------------------------------------++-- | 'External's for inlining variables. externals :: [External] externals =             [ external "inline" (promoteExprR inline :: RewriteH Core)@@ -29,20 +43,26 @@                 [ "Inline if this variable is a case binder." ].+ Eval .+ Deep .+ Bash .+ TODO             ] +------------------------------------------------------------------------++-- | If the current variable matches the given name, then inline it. inlineName :: TH.Name -> RewriteH CoreExpr inlineName nm = let name = TH.nameBase nm in                 prefixFailMsg ("inline '" ++ name ++ " failed: ") $                 withPatFailMsg (wrongExprForm "Var v") $    do Var v <- idR-      guardMsg (cmpTHName2Id nm v) $ name ++ " does not match " ++ var2String v ++ "."+      guardMsg (cmpTHName2Var nm v) $ " does not match " ++ var2String v ++ "."       inline +-- | Inline the current variable. inline :: RewriteH CoreExpr inline = configurableInline False False +-- | Inline the current variable, using the scrutinee rather than the case alternative if it is a case wild-card binder. inlineScrutinee :: RewriteH CoreExpr inlineScrutinee = configurableInline True False +-- | If the current variable is a case wild-card binder, then inline it. inlineCaseBinder :: RewriteH CoreExpr inlineCaseBinder = configurableInline False True @@ -74,6 +94,6 @@  -- | Get list of possible inline targets. Used by shell for completion. inlineTargets :: TranslateH Core [String]-inlineTargets = collectT $ promoteT $ ifM (testM inline)-                                          (varT unqualifiedIdName)-                                          (fail "cannot be inlined.")+inlineTargets = collectT $ promoteT $ whenM (testM inline) (varT unqualifiedVarName)++------------------------------------------------------------------------

@@ -7,6 +7,7 @@  import Control.Arrow +import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.External @@ -65,6 +66,8 @@    , external "not"        (notM :: TranslateH Core () -> TranslateH Core ())        [ "cause a failing check to succeed, a succeeding check to fail" ] .+ Predicate    ]++------------------------------------------------------------------------------------  hfocusR :: TranslateH Core Path -> RewriteH Core -> RewriteH Core hfocusR tp r = do p <- tp

@@ -1,56 +1,100 @@--- Andre Santos' Local Transformations (Ch 3 in his dissertation)-module Language.HERMIT.Primitive.Local where+module Language.HERMIT.Primitive.Local+       ( -- * Local Structural Manipulations+         Language.HERMIT.Primitive.Local.externals+         -- ** Let Expressions+       , module Language.HERMIT.Primitive.Local.Let+         -- ** Case Expressions+       , module Language.HERMIT.Primitive.Local.Case+         -- ** Miscellaneous+       , abstract+       , nonrecToRec+       , betaReduce+       , betaReducePlus+       , betaExpand+       , etaReduce+       , etaExpand+       , multiEtaExpand+       , flattenModule+       , flattenProgramR+       , flattenProgramT+       )+where  import GhcPlugins +import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.Monad import Language.HERMIT.External import Language.HERMIT.GHC  import Language.HERMIT.Primitive.GHC--- import Language.HERMIT.Primitive.Debug- import Language.HERMIT.Primitive.Common-import qualified Language.HERMIT.Primitive.Local.Case as Case-import qualified Language.HERMIT.Primitive.Local.Let as Let+import Language.HERMIT.Primitive.Local.Case+import Language.HERMIT.Primitive.Local.Let  import qualified Language.Haskell.TH as TH +import Data.List(nub)+ import Control.Arrow  ------------------------------------------------------------------------------ +-- | Externals for local structural manipulations.+--   (Many taken from Chapter 3 of Andre Santos' dissertation.) externals :: [External] externals =-         [ external "beta-reduce" (promoteExprR betaReduce :: RewriteH Core)-                     [ "((\\ v -> E1) E2) ==> let v = E2 in E1, fails otherwise"-                     , "this form of beta reduction is safe if E2 is an arbitrary"+         [ external "nonrec-to-rec" (promoteBindR nonrecToRec :: RewriteH Core)+                     [ "convert a non-recursive binding into a recursive binding group with a single definition."+                     , "NonRec v e ==> Rec [Def v e]" ]+         , external "beta-reduce" (promoteExprR betaReduce :: RewriteH Core)+                     [ "((\\ v -> E1) E2) ==> let v = E2 in E1"+                     , "this form of beta-reduction is safe if E2 is an arbitrary"                      , "expression (won't duplicate work)" ]                                 .+ Eval .+ Shallow          , external "beta-reduce-plus" (promoteExprR betaReducePlus :: RewriteH Core)-                     [ "perform one or more beta-reductions"]                                .+ Eval .+ Shallow .+ Bash+                     [ "perform one or more beta-reductions."]                               .+ Eval .+ Shallow .+ Bash          , external "beta-expand" (promoteExprR betaExpand :: RewriteH Core)-                     [ "(let v = E1 in E2) ==> (\\ v -> E2) E1, fails otherwise" ]           .+ Shallow-         , external "dead-code-elimination" (promoteExprR dce :: RewriteH Core)-                     [ "dead code elimination removes a let."-                     , "(let v = E1 in E2) ==> E2, if v is not free in E2, fails otherwise"-                     , "condition: let is not-recursive" ]                                   .+ Eval .+ Shallow .+ Bash+                     [ "(let v = e1 in e2) ==> (\\ v -> e2) e1" ]                            .+ Shallow          , external "eta-reduce" (promoteExprR etaReduce :: RewriteH Core)-                     [ "(\\ v -> E1 v) ==> E1, fails otherwise" ]                            .+ Eval .+ Shallow .+ Bash+                     [ "(\\ v -> e1 v) ==> e1" ]                                             .+ Eval .+ Shallow .+ Bash          , external "eta-expand" (promoteExprR . etaExpand :: TH.Name -> RewriteH Core)-                     [ "'eta-expand v' performs E1 ==> (\\ v -> E1 v), fails otherwise" ]    .+ Shallow .+ Introduce+                     [ "\"eta-expand 'v\" performs e1 ==> (\\ v -> e1 v)" ]                     .+ Shallow .+ Introduce+         , external "flatten-module" (promoteModGutsR flattenModule :: RewriteH Core)+                ["Flatten all the top-level binding groups in the module to a single recursive binding group.",+                 "This can be useful if you intend to appply GHC RULES."]+         , external "flatten-program" (promoteProgR flattenProgramR :: RewriteH Core)+                ["Flatten all the top-level binding groups in a program (list of binding groups) to a single recursive binding group.",+                 "This can be useful if you intend to appply GHC RULES."]+         , external "abstract" (promoteExprR . abstract :: TH.Name -> RewriteH Core)+                [ "Abstract over a variable using a lambda.",+                  "e  ==>  (\\ x -> e) x"+                ] .+ Shallow .+ Introduce .+ Context          ]-         ++ Let.externals-         ++ Case.externals+         ++ letExternals+         ++ caseExternals  ------------------------------------------------------------------------------ +-- | NonRec v e ==> Rec [Def v e]+nonrecToRec :: RewriteH CoreBind+nonrecToRec = prefixFailMsg "Converting non-recursive binding to recursive binding failed: " $+              setFailMsg (wrongExprForm "NonRec v e") $+  do NonRec v e <- idR+     guardMsg (isId v) "type variables cannot be defined recursively."+     return $ Rec [(v,e)]++------------------------------------------------------------------------------++-- | ((\\ v -> e1) e2) ==> (let v = e2 in e1)+--   This form of beta-reduction is safe if e2 is an arbitrary+--   expression (won't duplicate work). betaReduce :: RewriteH CoreExpr-betaReduce = prefixFailMsg "Beta reduction failed: " $-             setFailMsg (wrongExprForm "App (Lam v e1) e2") $+betaReduce = setFailMsg ("Beta-reduction failed: " ++ wrongExprForm "App (Lam v e1) e2") $     do App (Lam v e1) e2 <- idR        return $ Let (NonRec v e2) e1 + multiBetaReduce :: (Int -> Bool) -> RewriteH CoreExpr multiBetaReduce p = prefixFailMsg "Multi-Beta-Reduce failed: " $     do@@ -69,6 +113,8 @@            $ mkLams vs2 e0  -- TODO: inline this everywhere+-- Neil: Are we sure we want to inline this?+-- | Perform one or more beta-reductions. betaReducePlus :: RewriteH CoreExpr betaReducePlus = multiBetaReduce (> 0) @@ -91,50 +137,73 @@                    ) -} +-- | (let v = e1 in e2) ==> (\\ v -> e2) e1 betaExpand :: RewriteH CoreExpr-betaExpand = setFailMsg ("Beta expansion failed: " ++ wrongExprForm "Let (NonRec v e1) e2") $-    do Let (NonRec v e2) e1 <- idR-       return $ App (Lam v e1) e2+betaExpand = setFailMsg ("Beta-expansion failed: " ++ wrongExprForm "Let (NonRec v e1) e2") $+    do Let (NonRec v e1) e2 <- idR+       return $ App (Lam v e2) e1  ------------------------------------------------------------------------------ +-- | (\\ v -> e1 v) ==> e1 etaReduce :: RewriteH CoreExpr-etaReduce = prefixFailMsg "Eta reduction failed: " $-            withPatFailMsg (wrongExprForm "Lam v1 (App f (Var v2))") $-       (do Lam v1 (App f (Var v2)) <- idR-           guardMsg (v1 == v2) "the expression has the right form, but the variables are not equal."-           guardMsg (v1 `notElem` coreExprFreeIds f) $ var2String v1 ++ " is free in the function being applied."-           return f) <+-       (do Lam v1 (App f (Type ty)) <- idR-           Just v2 <- return (getTyVar_maybe ty)-           guardMsg (v1 == v2) "type variables are not equal."-           guardMsg (v1 `notElem` coreExprFreeVars f) $ var2String v1 ++ " is free in the function being applied."-           return f)+etaReduce = prefixFailMsg "Eta-reduction failed: " $+            withPatFailMsg (wrongExprForm "Lam v1 (App f e)") $+            do Lam v1 (App f e) <- idR+               case e of+                  Var v2  -> guardMsg (v1 == v2) "the expression has the right form, but the variables are not equal."+                  Type ty -> case getTyVar_maybe ty of+                               Nothing -> fail "the argument expression is not a type variable."+                               Just v2 -> guardMsg (v1 == v2) "type variables are not equal."+                  _       -> fail "the argument expression is not a variable."+               guardMsg (v1 `notElem` coreExprFreeIds f) $ var2String v1 ++ " is free in the function being applied."+               return f +-- | e1 ==> (\\ v -> e1 v) etaExpand :: TH.Name -> RewriteH CoreExpr-etaExpand nm = prefixFailMsg "Eta expansion failed: " $-               contextfreeT $ \ e ->-        case splitFunTy_maybe (exprType e) of-          Just (arg_ty, _) -> do v1 <- newVarH (show nm) arg_ty-                                 return $ Lam v1 (App e (Var v1))-          _ -> case splitForAllTy_maybe (exprType e) of-                  Just (v,_) -> do v1 <- newTypeVarH (show nm) (tyVarKind v)-                                   return $ Lam v1 (App e (Type (mkTyVarTy v1)))-                  Nothing -> fail "TODO: Add useful error message here."+etaExpand nm = prefixFailMsg "Eta-expansion failed: " $+               contextfreeT $ \ e -> let ty = exprType e in+        case splitFunTy_maybe ty of+          Just (argTy, _) -> do v <- newIdH (show nm) argTy+                                return $ Lam v (App e (Var v))+          Nothing         -> case splitForAllTy_maybe ty of+                               Just (tv,_) -> do v <- newTyVarH (show nm) (tyVarKind tv)+                                                 return $ Lam v (App e (Type (mkTyVarTy v)))+                               Nothing -> fail "type of expression is not a function or a forall." +-- | Perform multiple eta-expansions. multiEtaExpand :: [TH.Name] -> RewriteH CoreExpr multiEtaExpand []       = idR multiEtaExpand (nm:nms) = etaExpand nm >>> lamR (multiEtaExpand nms)  ------------------------------------------------------------------------------ --- dead code elimination removes a let.--- (let v = E1 in E2) => E2, if v is not free in E2-dce :: RewriteH CoreExpr-dce = prefixFailMsg "Dead code elimination failed: " $-      withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $-      do Let (NonRec v _) e <- idR-         guardMsg (v `notElem` coreExprFreeVars e) "Dead code elimination failed.  No dead code to eliminate."-         return e+-- | Flatten all the top-level binding groups in the module to a single recursive binding group.+flattenModule :: RewriteH ModGuts+flattenModule = modGutsR flattenProgramR++-- | Flatten all the top-level binding groups in a program to a program containing a single recursive binding group.+flattenProgramR :: RewriteH CoreProg+flattenProgramR = do bnd <- flattenProgramT+                     return (bindsToProg [bnd])++-- | Flatten all the top-level binding groups in a program to a single recursive binding group.+flattenProgramT :: TranslateH CoreProg CoreBind+flattenProgramT = do bds <- arr (concatMap bindToIdExprs . progToBinds)+                     guardMsg (nodups $ map fst bds) "Top-level bindings contain multiple occurrences of a name."+                     return (Rec bds)++nodups :: Eq a => [a] -> Bool+nodups as = length as == length (nub as)++------------------------------------------------------------------------------++-- | Abstract over a variable using a lambda.+--   e  ==>  (\ x. e) x+abstract :: TH.Name -> RewriteH CoreExpr+abstract nm = prefixFailMsg "abstraction failed: " $+   do e <- idR+      v <- findBoundVarT nm+      return (App (Lam v e) (Var v))  ------------------------------------------------------------------------------

@@ -1,8 +1,6 @@--- Andre Santos' Local Transformations (Ch 3 in his dissertation) module Language.HERMIT.Primitive.Local.Case        ( -- * Rewrites on Case Expressions-         externals-       , letFloatCase+         caseExternals        , caseFloatApp        , caseFloatArg        , caseFloatCase@@ -19,17 +17,17 @@  import Data.List import Control.Arrow-import Control.Applicative -import Language.HERMIT.GHC+import Language.HERMIT.Core+import Language.HERMIT.Monad import Language.HERMIT.Kure+import Language.HERMIT.GHC import Language.HERMIT.External-import Language.HERMIT.Monad  import Language.HERMIT.Primitive.Common-import Language.HERMIT.Primitive.GHC hiding (externals)-import Language.HERMIT.Primitive.Inline hiding (externals)-import Language.HERMIT.Primitive.AlphaConversion hiding (externals)+import Language.HERMIT.Primitive.GHC+import Language.HERMIT.Primitive.Inline+import Language.HERMIT.Primitive.AlphaConversion  import qualified Language.Haskell.TH as TH @@ -37,8 +35,8 @@ ------------------------------------------------------------------------------  -- | Externals relating to Case expressions.-externals :: [External]-externals =+caseExternals :: [External]+caseExternals =          [ -- I'm not sure this is possible. In core, v2 can only be a Constructor, Lit, or DEFAULT            -- In the last case, v1 is already inlined in e. So we can't construct v2 as a Var.          --   external "case-elimination" (promoteR $ not_defined "case-elimination" :: RewriteH Core)@@ -49,9 +47,7 @@          --   -- Again, don't think the lhs of this rule is possible to construct in core.          -- , external "case-merging" (promoteR $ not_defined "case-merging" :: RewriteH Core)          --             [ "case v of ...; d -> case v of alt -> e ==> case v of ...; alt -> e[v/d]" ] .+ Unimplemented .+ Eval-           external "let-float-case" (promoteExprR letFloatCase :: RewriteH Core)-                     [ "case (let v = ev in e) of ... ==> let v = ev in case e of ..." ]  .+ Commute .+ Shallow .+ Eval .+ Bash-         , external "case-float-app" (promoteExprR caseFloatApp :: RewriteH Core)+           external "case-float-app" (promoteExprR caseFloatApp :: RewriteH Core)                      [ "(case ec of alt -> e) v ==> case ec of alt -> e v" ]              .+ Commute .+ Shallow .+ Bash          , external "case-float-arg" (promoteExprR caseFloatArg :: RewriteH Core)                      [ "f (case s of alt -> e) ==> case s of alt -> f e" ]                .+ Commute .+ Shallow .+ PreCondition@@ -72,26 +68,15 @@                 , "applications for all occurances of the named variable." ]          ] --- not_defined :: String -> RewriteH CoreExpr--- not_defined nm = fail $ nm ++ " not implemented!"---- | case (let v = e1 in e2) of alts ==> let v = e1 in case e2 of alts-letFloatCase :: RewriteH CoreExpr-letFloatCase = prefixFailMsg "Let floating from Case failed: " $-  do-     captures <- caseT letVarsT (const (pure ())) $ \ vs _ _ _ -> vs-     cFrees   <- freeVarsT -- so we get type variables too-     caseT (if null (cFrees `intersect` captures) then idR else alphaLet)-           (const idR)-           (\ (Let bnds e) b ty alts -> Let bnds (Case e b ty alts))+------------------------------------------------------------------------------  -- | (case s of alt1 -> e1; alt2 -> e2) v ==> case s of alt1 -> e1 v; alt2 -> e2 v caseFloatApp :: RewriteH CoreExpr caseFloatApp = prefixFailMsg "Case floating from App function failed: " $   do-    captures      <- appT caseAltVarsT freeVarsT (flip (map . intersect))-    binderCapture <- appT caseBinderVarT freeVarsT intersect-    appT ((if null binderCapture then idR else alphaCaseBinder Nothing)+    captures    <- appT caseAltVarsT freeVarsT (flip (map . intersect))+    wildCapture <- appT caseWildVarT freeVarsT elem+    appT ((if not wildCapture then idR else alphaCaseBinder Nothing)           >>> caseAllR idR (\i -> if null (captures !! i) then idR else alphaAlt)          )           idR@@ -104,10 +89,10 @@ caseFloatArg :: RewriteH CoreExpr caseFloatArg = prefixFailMsg "Case floating from App argument failed: " $   do-    captures      <- appT freeVarsT caseAltVarsT (map . intersect)-    binderCapture <- appT freeVarsT caseBinderVarT intersect+    captures    <- appT freeVarsT caseAltVarsT (map . intersect)+    wildCapture <- appT freeVarsT caseWildVarT (flip elem)     appT idR-         ((if null binderCapture then idR else alphaCaseBinder Nothing)+         ((if not wildCapture then idR else alphaCaseBinder Nothing)           >>> caseAllR idR (\i -> if null (captures !! i) then idR else alphaAlt)          )          (\f (Case s b _ty alts) -> let newTy = exprType (App f (case head alts of (_,_,e) -> e))@@ -122,15 +107,15 @@ caseFloatCase :: RewriteH CoreExpr caseFloatCase = prefixFailMsg "Case floating from Case failed: " $   do-    captures <- caseT caseAltVarsT (const altFreeVarsT) $ \ vss bndr _ fs -> map (intersect (concatMap ($ bndr) fs)) vss+    captures <- caseT caseAltVarsT (const altFreeVarsExclWildT) (\ vss bndr _ fs -> map (intersect (concatMap ($ bndr) fs)) vss)     -- does the binder of the inner case, shadow a free variable in any of the outer case alts?     -- notice, caseBinderVarT returns a singleton list-    binderCapture <- caseT caseBinderVarT (const altFreeVarsT) $ \ innerBindr bndr _ fs -> intersect (concatMap ($ bndr) fs) innerBindr-    caseT ((if null binderCapture then idR else alphaCaseBinder Nothing)+    wildCapture <- caseT caseWildVarT (const altFreeVarsExclWildT) (\ innerBndr bndr _ fvs -> innerBndr `elem` concatMap ($ bndr) fvs)+    caseT ((if not wildCapture then idR else alphaCaseBinder Nothing)            >>> caseAllR idR (\i -> if null (captures !! i) then idR else alphaAlt)           )           (const idR)-          (\ (Case s1 b1 ty1 alts1) b2 ty2 alts2 -> Case s1 b1 ty1 [ (c1, ids1, Case e1 b2 ty2 alts2) | (c1, ids1, e1) <- alts1 ])+          (\ (Case s1 b1 _ alts1) b2 ty alts2 -> Case s1 b1 ty [ (c1, ids1, Case e1 b2 ty alts2) | (c1, ids1, e1) <- alts1 ])  -- | let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e caseFloatLet :: RewriteH CoreExpr@@ -153,9 +138,13 @@                          do Case s binder _ alts <- idR                             case isDataCon s of                               Nothing -> fail "head of scrutinee is not a data constructor."-                              Just (dc, args) -> case [ (bs, rhs) | (DataAlt dc', bs, rhs) <- alts, dc == dc' ] of-                                    [(bs,e')] -> let valArgs = filter isValArg args -- discard any type arguments-                                                  in return $ nestedLets e' $ (binder, s) : zip bs valArgs+                              Just (dc, args) ->+                                case [ (bs, rhs) | (DataAlt dc', bs, rhs) <- alts, dc == dc' ] of+                                    [(bs,e')] -> let (tyArgs, valArgs) = span isTypeArg args+                                                     tyBndrs = takeWhile isTyVar bs -- it is possible the pattern constructor binds a type+                                                                                    -- if the constructor is existentially quantified+                                                     existentials = reverse $ take (length tyBndrs) $ reverse tyArgs+                                                  in return $ nestedLets e' $ (binder, s) : zip bs (existentials ++ valArgs)                                     []   -> fail "no matching alternative."                                     _    -> fail "more than one matching alternative." @@ -182,14 +171,14 @@ caseSplit nm = do     frees <- freeIdsT     contextfreeT $ \ e ->-        case [ i | i <- frees, cmpTHName2Id nm i ] of+        case [ i | i <- frees, cmpTHName2Var nm i ] of             []    -> fail "caseSplit: provided name is not free"             (i:_) -> do                 let (tycon, tys) = splitTyConApp (idType i)                     dcs = tyConDataCons tycon                     aNms = map (:[]) $ cycle ['a'..'z']                 dcsAndVars <- mapM (\dc -> do-                                        as <- sequence [ newVarH a ty | (a,ty) <- zip aNms $ dataConInstArgTys dc tys ]+                                        as <- sequence [ newIdH a ty | (a,ty) <- zip aNms $ dataConInstArgTys dc tys ]                                         return (dc,as)) dcs                 return $ Case (Var i) i (exprType e) [ (DataAlt dc, as, e) | (dc,as) <- dcsAndVars ] @@ -200,3 +189,4 @@ caseSplitInline :: TH.Name -> RewriteH Core caseSplitInline nm = promoteR (caseSplit nm) >>> anybuR (promoteExprR $ inlineName nm) +------------------------------------------------------------------------------

@@ -1,11 +1,13 @@--- Andre Santos' Local Transformations (Ch 3 in his dissertation) module Language.HERMIT.Primitive.Local.Let        ( -- * Rewrites on Let Expressions-         externals+         letExternals        , letIntro+       , letElim        , letFloatApp        , letFloatArg        , letFloatLet+       , letFloatLam+       , letFloatCase        , letFloatExpr        , letFloatLetTop        , letToCase@@ -19,24 +21,31 @@ import Data.List import Data.Monoid -import Language.HERMIT.Kure+import Language.HERMIT.Core import Language.HERMIT.Monad+import Language.HERMIT.Kure import Language.HERMIT.External import Language.HERMIT.GHC  import Language.HERMIT.Primitive.Common-import Language.HERMIT.Primitive.GHC hiding (externals)-import Language.HERMIT.Primitive.AlphaConversion hiding (externals)+import Language.HERMIT.Primitive.GHC+import Language.HERMIT.Primitive.AlphaConversion  import qualified Language.Haskell.TH as TH  ------------------------------------------------------------------------------  -- | Externals relating to Let expressions.-externals :: [External]-externals =+letExternals :: [External]+letExternals =          [ external "let-intro" (promoteExprR . letIntro :: TH.Name -> RewriteH Core)                 [ "e => (let v = e in v), name of v is provided" ]                      .+ Shallow .+ Introduce+         , external "dead-let-elimination" (promoteExprR letElim :: RewriteH Core)+                     [ "dead-let-elimination removes an unused let binding."+                     , "(let v = e1 in e2) ==> e2, if v is not free in e2."+                     , "condition: let is not-recursive" ]                                   .+ Eval .+ Shallow .+ Bash+         , external "dead-code-elimination" (promoteExprR letElim :: RewriteH Core)+                     [ "Synonym for dead-let-elimination [deprecated]" ]  .+ Eval .+ Shallow -- TODO: delete this at some point          -- , external "let-constructor-reuse" (promoteR $ not_defined "constructor-reuse" :: RewriteH Core)          --             [ "let v = C v1..vn in ... C v1..vn ... ==> let v = C v1..vn in ... v ..., fails otherwise" ] .+ Unimplemented .+ Eval          , external "let-float-app" (promoteExprR letFloatApp :: RewriteH Core)@@ -44,31 +53,53 @@          , external "let-float-arg" (promoteExprR letFloatArg :: RewriteH Core)                      [ "f (let v = ev in e) ==> let v = ev in f e" ]                    .+ Commute .+ Shallow .+ Bash          , external "let-float-lam" (promoteExprR letFloatLam :: RewriteH Core)-                     [ "(\\ v1 -> let v2 = e1 in e2)  ==>  let v2 = e1 in (\\ v1 -> e2)",-                       "Fails if v1 occurs in e1.",+                     [ "(\\ v1 -> let v2 = e1 in e2)  ==>  let v2 = e1 in (\\ v1 -> e2), if v1 is not free in e2.",                        "If v1 = v2 then v1 will be alpha-renamed."                      ]                                                                  .+ Commute .+ Shallow .+ Bash          , external "let-float-let" (promoteExprR letFloatLet :: RewriteH Core)                      [ "let v = (let w = ew in ev) in e ==> let w = ew in let v = ev in e" ] .+ Commute .+ Shallow .+ Bash-         , external "let-float-top" (promoteProgramR letFloatLetTop :: RewriteH Core)+         , external "let-float-case" (promoteExprR letFloatCase :: RewriteH Core)+                     [ "case (let v = ev in e) of ... ==> let v = ev in case e of ..." ]  .+ Commute .+ Shallow .+ Eval .+ Bash+         , external "let-float-top" (promoteProgR letFloatLetTop :: RewriteH Core)                      [ "v = (let w = ew in ev) : bds ==> w = ew : v = ev : bds" ] .+ Commute .+ Shallow .+ Bash-         , external "let-float" (promoteProgramR letFloatLetTop <+ promoteExprR letFloatExpr :: RewriteH Core)+         , external "let-float" (promoteProgR letFloatLetTop <+ promoteExprR letFloatExpr :: RewriteH Core)                      [ "Float a Let whatever the context." ] .+ Commute .+ Shallow .+ Bash          , external "let-to-case" (promoteExprR letToCase :: RewriteH Core)                      [ "let v = ev in e ==> case ev of v -> e" ] .+ Commute .+ Shallow .+ PreCondition          -- , external "let-to-case-unbox" (promoteR $ not_defined "let-to-case-unbox" :: RewriteH Core)          --             [ "let v = ev in e ==> case ev of C v1..vn -> let v = C v1..vn in e" ] .+ Unimplemented-         , external "nonrec-to-rec" (promoteBindR nonrecToRec :: RewriteH Core)-                     [ "convert a nonrec binding into a recursive binding group with a single binding"-                     , "NonRec v ev ==> Rec [(v,ev)]" ]          ] +-------------------------------------------------------------------------------------------+ -- | e => (let v = e in v), name of v is provided letIntro ::  TH.Name -> RewriteH CoreExpr-letIntro nm = prefixFailMsg "Let introduction failed: " $-              contextfreeT $ \ e -> do letvar <- newVarH (show nm) (exprType e)-                                       return $ Let (NonRec letvar e) (Var letvar)+letIntro nm = prefixFailMsg "Let-introduction failed: " $+              contextfreeT $ \ e -> do guardMsg (not $ isType e) "let expressions may not return a type."+                                       v <- newIdH (show nm) (exprTypeOrKind e)+                                       return $ Let (NonRec v e) (Var v) +-- | Remove an unused let binding.+--   (let v = E1 in E2) => E2, if v is not free in E2+letElim :: RewriteH CoreExpr+letElim = prefixFailMsg "Dead-let-elimination failed: " $+          withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $+      do Let (NonRec v _) e <- idR+         guardMsg (v `notElem` coreExprFreeVars e) "let-bound variable appears in the expression."+         return e++-- | let v = ev in e ==> case ev of v -> e+letToCase :: RewriteH CoreExpr+letToCase = prefixFailMsg "Converting Let to Case failed: " $+            withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $+  do Let (NonRec v ev) _ <- idR+     guardMsg (not $ isType ev) "cannot case on a type."+     nameModifier <- freshNameGenT Nothing+     caseBndr <- constT (cloneVarH nameModifier v)+     letT mempty (replaceVarR v caseBndr) $ \ () e' -> Case ev caseBndr (varType v) [(DEFAULT, [], e')]++-------------------------------------------------------------------------------------------+ -- | (let v = ev in e) x ==> let v = ev in e x letFloatApp :: RewriteH CoreExpr letFloatApp = prefixFailMsg "Let floating from App function failed: " $@@ -102,27 +133,28 @@       then alphaLam Nothing >>> letFloatLam       else return (Let (NonRec v2 e1) (Lam v1 e2)) +-- | @case (let bnds in e) of wild alts ==> let bnds in (case e of wild alts)@+--   Fails if any variables bound in @bnds@ occurs in @alts@.+letFloatCase :: RewriteH CoreExpr+letFloatCase = prefixFailMsg "Let floating from Case failed: " $+  do captures <- caseT letVarsT+                       (\ _ -> altFreeVarsExclWildT)+                       (\ vs wild _ fs -> vs `intersect` concatMap ($ wild) fs)+     caseT (if null captures then idR else alphaLetVars captures)+           (const idR)+           (\ (Let bnds e) wild ty alts -> Let bnds (Case e wild ty alts))+ -- | Float a Let through an expression, whatever the context. letFloatExpr :: RewriteH CoreExpr letFloatExpr = setFailMsg "Unsuitable expression for Let floating." $-               letFloatApp <+ letFloatArg <+ letFloatLet <+ letFloatLam---- | NonRec v (Let (NonRec w ew) ev) : bds ==> NonRec w ew : NonRec v ev : bds-letFloatLetTop :: RewriteH CoreProgram-letFloatLetTop = setFailMsg ("Let floating to top level failed: " ++ wrongExprForm "NonRec v (Let (NonRec w ew) ev) : bds") $-  do NonRec v (Let (NonRec w ew) ev) : bds <- idR-     return (NonRec w ew : NonRec v ev : bds)+               letFloatApp <+ letFloatArg <+ letFloatLet <+ letFloatLam <+ letFloatCase --- | let v = ev in e ==> case ev of v -> e-letToCase :: RewriteH CoreExpr-letToCase = prefixFailMsg "Converting Let to Case failed: " $-            withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $-  do Let (NonRec v ev) _ <- idR-     nameModifier <- freshNameGenT Nothing-     caseBndr <- constT (cloneIdH nameModifier v)-     letT mempty (renameIdR v caseBndr) $ \ () e' -> Case ev caseBndr (varType v) [(DEFAULT, [], e')]+-- | NonRec v (Let (NonRec w ew) ev) `ProgCons` p ==> NonRec w ew `ProgCons` NonRec v ev `ProgCons` p+letFloatLetTop :: RewriteH CoreProg+letFloatLetTop = prefixFailMsg "Let floating to top level failed: " $+                 withPatFailMsg (wrongExprForm "NonRec v (Let (NonRec w ew) ev) `ProgCons` p") $+  do NonRec v (Let (NonRec w ew) ev) `ProgCons` p <- idR+     guardMsg (not $ isType ew) "type bindings are not allowed at the top level."+     return (NonRec w ew `ProgCons` NonRec v ev `ProgCons` p) -nonrecToRec :: RewriteH CoreBind-nonrecToRec = do-    NonRec v ev <- idR-    return $ Rec [(v,ev)]+-------------------------------------------------------------------------------------------

@@ -13,16 +13,17 @@  import GhcPlugins as GHC +import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.External import Language.HERMIT.GHC  import Control.Arrow -import Data.Monoid- import qualified Language.Haskell.TH as TH +---------------------------------------------------------------------------------------+ -- | 'External's involving navigating to named entities. externals :: [External] externals = map (.+ Navigation)@@ -38,6 +39,8 @@                 [ "binding-group-of '<v> focuses on the binding group that binds the variable <v>" ]             ] +---------------------------------------------------------------------------------------+ -- | Find the path to the RHS of the binding group of the given name. bindingGroupOf :: TH.Name -> TranslateH Core Path bindingGroupOf = oneNonEmptyPathToT . bindGroup@@ -52,23 +55,30 @@  -- | Verify that this is a binding group defining the given name. bindGroup :: TH.Name -> Core -> Bool-bindGroup nm (BindCore (NonRec v _))  =  nm `cmpTHName2Id` v-bindGroup nm (BindCore (Rec bds))     =  any (cmpTHName2Id nm . fst) bds+bindGroup nm (BindCore (NonRec v _))  =  nm `cmpTHName2Var` v+bindGroup nm (BindCore (Rec bds))     =  any (cmpTHName2Var nm . fst) bds bindGroup _  _                        =  False  -- | Verify that this is the definition of the given name. namedBinding :: TH.Name -> Core -> Bool-namedBinding nm (BindCore (NonRec v _))  =  nm `cmpTHName2Id` v-namedBinding nm (DefCore (Def v _))      =  nm `cmpTHName2Id` v+namedBinding nm (BindCore (NonRec v _))  =  nm `cmpTHName2Var` v+namedBinding nm (DefCore (Def v _))      =  nm `cmpTHName2Var` v namedBinding _  _                        =  False  -- | Find all the possible targets of \"consider\". considerTargets :: TranslateH Core [String]-considerTargets = allT (collectT (promoteT $ nonRec <+ rec)) >>> arr concat-    where nonRec = nonRecT mempty (\ v () -> [unqualifiedIdName v])-          rec    = recT (const (arr (\ (Def v _) -> unqualifiedIdName v))) id+considerTargets = allT $ collectT (promoteBindT nonRec <+ promoteDefT def)+    where+      nonRec :: TranslateH CoreBind String+      nonRec = nonRecT (return ()) constUnq +      def :: TranslateH CoreDef String+      def = defT (return ()) constUnq +      constUnq :: Var -> () -> String+      constUnq v () = unqualifiedVarName v++ data Considerable = Binding | Definition | CaseAlt | Variable | Literal | Application | Lambda | LetIn | CaseOf | Casty | Ticky | TypeVar | Coerce  recognizedConsiderables :: String@@ -115,3 +125,5 @@ underConsideration TypeVar     (ExprCore (Type _))        = True underConsideration Coerce      (ExprCore (Coercion _))    = True underConsideration _           _                          = False++---------------------------------------------------------------------------------------

@@ -1,5 +1,3 @@-{-# LANGUAGE TypeFamilies, FlexibleInstances #-}- -- Placeholder for new prims module Language.HERMIT.Primitive.New where @@ -7,41 +5,28 @@  import Control.Applicative import Control.Arrow-import Control.Monad -import Data.List(intercalate,intersect)+import Data.List(intersect) -import Language.HERMIT.Context+import Language.HERMIT.Core import Language.HERMIT.Monad import Language.HERMIT.Kure import Language.HERMIT.External import Language.HERMIT.GHC++import Language.HERMIT.Primitive.Common import Language.HERMIT.Primitive.GHC-import Language.HERMIT.Primitive.Utils import Language.HERMIT.Primitive.Local-import Language.HERMIT.Primitive.Local.Case-import Language.HERMIT.Primitive.Local.Let import Language.HERMIT.Primitive.Inline -- import Language.HERMIT.Primitive.Debug  import qualified Language.Haskell.TH as TH --- import Debug.Trace-import MonadUtils (MonadIO) -- GHC's MonadIO - externals ::  [External] externals = map ((.+ Experiment) . (.+ TODO))-         [ external "info" (info :: TranslateH Core String)-                [ "tell me what you know about this expression or binding" ] .+ Unimplemented-         , external "expr-type" (promoteExprT exprTypeT :: TranslateH Core String)-                [ "display the type of this expression"]-         , external "test" (testQuery :: RewriteH Core -> TranslateH Core String)+         [ external "test" (testQuery :: RewriteH Core -> TranslateH Core String)                 [ "determines if a rewrite could be successfully applied" ]-         , external "fix-intro" (promoteDefR fixIntro :: RewriteH Core)-                [ "rewrite a recursive binding into a non-recursive binding using fix" ]-         , external "fix-spec" (promoteExprR fixSpecialization :: RewriteH Core)-                [ "specialize a fix with a given argument"] .+ Shallow          , external "cleanup-unfold" (promoteExprR cleanupUnfold :: RewriteH Core)                 [ "clean up immeduate nested fully-applied lambdas, from the bottom up"]          , external "unfold" (promoteExprR . unfold :: TH.Name -> RewriteH Core)@@ -56,148 +41,62 @@                  [ "var '<v> returns successfully for variable v, and fails otherwise.",                    "Useful in combination with \"when\", as in: when (var v) r" ] .+ Predicate          , external "simplify" (simplifyR :: RewriteH Core)-                [ "innermost (unfold '. <+ beta-reduce-plus <+ safe-let-subst <+ case-reduce <+ dead-code-elimination)" ]+                [ "innermost (unfold '. <+ beta-reduce-plus <+ safe-let-subst <+ case-reduce <+ dead-let-elimination)" ]          , external "let-tuple" (promoteExprR . letTupleR :: TH.Name -> RewriteH Core)                 [ "let x = e1 in (let y = e2 in e) ==> let t = (e1,e2) in (let x = fst t in (let y = snd t in e))" ]          , external "any-call" (withUnfold :: RewriteH Core -> RewriteH Core)                 [ "any-call (.. unfold command ..) applies an unfold commands to all applications"                 , "preference is given to applications with more arguments"                 ] .+ Deep-         , external "abstract" (promoteExprR . abstract :: TH.Name -> RewriteH Core)-                [ "Abstract over a variable using a lambda.",-                  "e  ==>  (\\ x -> e) x"-                ] .+ Shallow .+ Introduce .+ Context          ] +------------------------------------------------------------------------------------------------------ +-- TODO: what about Type constructors around TyVars? isVar :: TH.Name -> TranslateH CoreExpr ()-isVar nm = varT (cmpTHName2Id nm) >>= guardM+isVar nm = varT (cmpTHName2Var nm) >>= guardM +------------------------------------------------------------------------------------------------------+ simplifyR :: RewriteH Core-simplifyR = innermostR (promoteExprR (unfold (TH.mkName ".") <+ betaReducePlus <+ safeLetSubstR <+ caseReduce <+ dce))+simplifyR = setFailMsg "Simplify failed: nothing to simplify." $+            innermostR (promoteExprR (unfold (TH.mkName ".") <+ betaReducePlus <+ safeLetSubstR <+ caseReduce <+ letElim)) --- This left for Neil's IFL presentation. letTupleR is the more general version.-letPairR :: TH.Name -> RewriteH CoreExpr-letPairR nm = do-    Let (NonRec x e1) (Let (NonRec y e2) e) <- idR-    ifM (letT (nonRecT (pure ()) const)-              (letT (nonRecT freeVarsT (flip const)) (pure ()) const)-              elem)-        (fail "'x' is used in 'e2'")-        (translate $ \ c _ -> do-              tupleConId <- findId c "(,)"-              fstId <- findId c "Data.Tuple.fst"-              sndId <- findId c "Data.Tuple.snd"-              let e1TyE = Type (exprType e1)-                  e2TyE = Type (exprType e2)-                  rhs = mkCoreApps (Var tupleConId) [e1TyE, e2TyE, e1, e2]-              letId <- newVarH (show nm) (exprType rhs)-              let fstE = mkCoreApps (Var fstId) [e1TyE, e2TyE, Var letId]-                  sndE = mkCoreApps (Var sndId) [e1TyE, e2TyE, Var letId]-              return $ Let (NonRec letId rhs)-                      $ Let (NonRec x fstE)-                       $ Let (NonRec y sndE) e) -letTupleR :: TH.Name -> RewriteH CoreExpr-letTupleR nm = translate $ \ c e -> do-    let collectLets :: CoreExpr -> ([(Id, CoreExpr)],CoreExpr)-        collectLets (Let (NonRec x e1) e2) = let (bs,expr) = collectLets e2-                                             in ((x,e1):bs, expr)-        collectLets expr = ([],expr)--        (bnds, body) = collectLets e--    guardMsg (length bnds > 1) "cannot tuple: need at least two nonrec lets"--    -- until we no longer need letPairR-    if length bnds == 2-      then apply (letPairR nm) c e-      else do-        -- check if tupling the bindings would cause unbound variables-        let (ids, rhss) = unzip bnds--        frees <- mapM (apply freeVarsT c) (drop 1 rhss)+collectLets :: CoreExpr -> ([(Var, CoreExpr)],CoreExpr)+collectLets (Let (NonRec x e1) e2) = let (bs,expr) = collectLets e2 in ((x,e1):bs, expr)+collectLets expr                   = ([],expr) -        let used = concat $ zipWith intersect (map (flip take ids) [1..]) frees+-- | Combine nested non-recursive lets into case of a tuple.+letTupleR :: TH.Name -> RewriteH CoreExpr+letTupleR nm = prefixFailMsg "Let-tuple failed: " $+  do (bnds, body) <- arr collectLets+     let numBnds = length bnds+     guardMsg (numBnds > 1) "at least two non-recursive let bindings required." -        if null used-          then do-            tupleConId <- findId c $ "(" ++ replicate (length bnds - 1) ',' ++ ")"+     let (vs, rhss)  = unzip bnds+     guardMsg (all isId vs) "cannot tuple type variables." -- TODO: it'd be better if collectLets stopped on reaching a TyVar -            let rhs = mkCoreApps (Var tupleConId) $ map (Type . exprType) rhss ++ rhss-                varList = concat $ iterate (zipWith (flip (++)) $ repeat "0") $ map (:[]) ['a'..'z']-            dc <- maybe (fail "cannot find tuple datacon") return $ isDataConId_maybe tupleConId-            vs <- zipWithM newVarH varList $ dataConInstOrigArgTys dc $ map exprType rhss+     -- check if tupling the bindings would cause unbound variables+     let+         rhsTypes = map exprType rhss+         frees    = map coreExprFreeVars (drop 1 rhss)+         used     = concat $ zipWith intersect (map (`take` vs) [1..]) frees+     if null used+       then do tupleConId <- findIdT $ TH.mkName $ "(" ++ replicate (numBnds - 1) ',' ++ ")"+               case isDataConId_maybe tupleConId of+                 Nothing -> fail "cannot find tuple data constructor."+                 Just dc -> let rhs = mkCoreApps (Var tupleConId) $ map Type rhsTypes ++ rhss+                             in constT $ do wild <- newIdH (show nm) (exprType rhs)+                                            return $ Case rhs wild (exprType body) [(DataAlt dc, vs, body)] -            letId <- newVarH (show nm) (exprType rhs)-            return $ Let (NonRec letId rhs)-                     $ foldr (\ (i,(v,oe)) b -> Let (NonRec v (Case (Var letId) letId (exprType oe) [(DataAlt dc, vs, Var $ vs !! i)])) b)-                             body $ zip [0..] bnds-          else fail "cannot tuple: some bindings are used in the rhs of others"+       else fail $ "the following bound variables are used in subsequent bindings: " ++ showVars used  -- Others -- let v = E1 in E2 E3 <=> (let v = E1 in E2) E3 -- let v = E1 in E2 E3 <=> E2 (let v = E1 in E3) --- A few Queries.--info :: TranslateH Core String-info = translate $ \ c core -> do-         dynFlags <- getDynFlags-         let pa       = "Path: " ++ show (contextPath c)-             node     = "Node: " ++ coreNode core-             con      = "Constructor: " ++ coreConstructor core-             bds      = "Bindings in Scope: " ++ (show $ map unqualifiedIdName $ listBindings c)-             expExtra = case core of-                          ExprCore e -> ["Type: " ++ showExprType dynFlags e] ++-                                        ["Free Variables: " ++ showVars dynFlags (coreExprFreeVars e)] ++-                                           case e of-                                             Var v -> ["Identifier Info: " ++ showIdInfo dynFlags v]-                                             _     -> []-                          _          -> []--         return (intercalate "\n" $ [pa,node,con,bds] ++ expExtra)--exprTypeT :: TranslateH CoreExpr String-exprTypeT = contextfreeT $ \ e -> do-    dynFlags <- getDynFlags-    return $ showExprType dynFlags e--showExprType :: DynFlags -> CoreExpr -> String-showExprType dynFlags = showPpr dynFlags . exprType--showIdInfo :: DynFlags -> Id -> String-showIdInfo dynFlags v = showSDoc dynFlags $ ppIdInfo v $ idInfo v--coreNode :: Core -> String-coreNode (ModGutsCore _) = "Module"-coreNode (ProgramCore _) = "Program"-coreNode (BindCore _)    = "Binding Group"-coreNode (DefCore _)     = "Recursive Definition"-coreNode (ExprCore _)    = "Expression"-coreNode (AltCore _)     = "Case Alternative"--coreConstructor :: Core -> String-coreConstructor (ModGutsCore _)    = "ModGuts"-coreConstructor (ProgramCore prog) = case prog of-                                       []    -> "[]"-                                       (_:_) -> "(:)"-coreConstructor (BindCore bnd)     = case bnd of-                                       Rec _      -> "Rec"-                                       NonRec _ _ -> "NonRec"-coreConstructor (DefCore _)        = "Def"-coreConstructor (AltCore _)        = "(,,)"-coreConstructor (ExprCore expr)    = case expr of-                                       Var _        -> "Var"-                                       Type _       -> "Type"-                                       Lit _        -> "Lit"-                                       App _ _      -> "App"-                                       Lam _ _      -> "Lam"-                                       Let _ _      -> "Let"-                                       Case _ _ _ _ -> "Case"-                                       Cast _ _     -> "Cast"-                                       Tick _ _     -> "Tick"-                                       Coercion _   -> "Coercion"+------------------------------------------------------------------------------------------------------  testQuery :: RewriteH Core -> TranslateH Core String testQuery r = f <$> testM r@@ -205,80 +104,7 @@     f True  = "Rewrite would succeed."     f False = "Rewrite would fail." -findId :: (MonadUnique m, MonadIO m, MonadThings m, HasDynFlags m) => Context -> String -> m Id-findId c = findIdMG (hermitModGuts c)--findIdMG :: (MonadUnique m, MonadIO m, MonadThings m, HasDynFlags m) => ModGuts -> String -> m Id-findIdMG modguts nm =-    case filter isValName $ findNameFromTH (mg_rdr_env modguts) $ TH.mkName nm of-        []  -> fail $ "cannot find " ++ nm-        [n] -> lookupId n-        ns  -> do dynFlags <- getDynFlags-                  fail $ "too many " ++ nm ++ " found:\n" ++ intercalate ", " (map (showPpr dynFlags) ns)---- |  f = e   ==>   f = fix (\ f -> e)-fixIntro :: RewriteH CoreDef-fixIntro = prefixFailMsg "Fix introduction failed: " $-           do (c, Def f e) <- exposeT-              constT $ do fixId <- findId c "Data.Function.fix"-                          f' <- cloneIdH id f-                          let coreFix = App (App (Var fixId) (Type (idType f)))-                              emptySub = mkEmptySubst (mkInScopeSet (exprFreeVars e))-                              sub      = extendSubst emptySub f (Var f')-                          return $ Def f (coreFix (Lam f' (substExpr (text "fixIntro") sub e)))---- ironically, this is an instance of worker/wrapper itself.--fixSpecialization :: RewriteH CoreExpr-fixSpecialization = do-        fixId <- translate $ \ c _ -> findId c "Data.Function.fix"--        -- fix (t::*) (f :: t -> t) (a :: t) :: t-        App (App (App (Var fx) (Type _)) _) _ <- idR--        guardMsg (fx == fixId) "fixSpecialization only works on fix"--        let rr :: RewriteH CoreExpr-            rr = multiEtaExpand [TH.mkName "f",TH.mkName "a"]--            sub :: RewriteH Core-            sub = pathR [0,1] (promoteR rr)-        -- be careful this does not loop (it should not)-        extractR sub >>> fixSpecialization'---fixSpecialization' :: RewriteH CoreExpr-fixSpecialization' = do-        -- In normal form now-        App (App (App (Var fx) (Type t))-                 (Lam _ (Lam v2 (App (App e _) _a2)))-            )-            a <- idR--        let t' = case a of-                   Type t2  -> applyTy t t2-                   (Var x) | isTyVar x -> applyTy t (mkTyVarTy x)---                   Var  a2  -> mkAppTy t (exprType t2)---                   mkAppTy t t'---        -- TODO: t2' isn't used anywhere -- which means that a2 is never used ???---        let t2' = case a2 of---                   Type t2  -> applyTy t t2---                   Var  a2  -> mkAppTy t (exprType t2)---                   mkAppTy t t'---        v3 <- constT $ newVarH "f" t' -- (funArgTy t')-        v4 <- constT $ newTypeVarH "a" (tyVarKind v2)--         -- f' :: \/ a -> T [a] -> (\/ b . T [b])-        let f' = Lam v4  (Cast (Var v3)-                               (mkUnsafeCo t' (applyTy t (mkTyVarTy v4))))-        let e' = Lam v3 (App (App e f') a)--        return $ App (App (Var fx) (Type t')) e'-+------------------------------------------------------------------------------------------------------  -- | cleanupUnfold cleans a unfold operation --  (for example, an inline or rule application)@@ -313,6 +139,7 @@         rec :: RewriteH Core         rec = withUnfold rr +------------------------------------------------------------------------------------------------------  -- | Push a function through a Case or Let expression. --   Unsafe if the function is not strict.@@ -321,7 +148,7 @@      do e <- idR         case collectArgs e of           (Var v,args) -> do-                  guardMsg (nm `cmpTHName2Id` v) $ "could not find name " ++ show nm+                  guardMsg (nm `cmpTHName2Var` v) $ "cannot find name " ++ show nm                   guardMsg (not $ null args) $ "no argument for " ++ show nm                   guardMsg (all isTypeArg $ init args) $ "initial arguments are not type arguments for " ++ show nm                   case last args of@@ -330,13 +157,4 @@                      _       -> fail "argument is not a Case or Let."           _ -> fail "no function to match." --- | Abstract over a variable using a lambda.---   e  ==>  (\ x. e) x-abstract :: TH.Name -> RewriteH CoreExpr-abstract nm = prefixFailMsg "abstraction failed: " $-    do (c,e) <- exposeT-       let name = TH.nameBase nm-       case filter (cmpTHName2Id nm) (listBindings c) of-         []         -> fail $ name ++ " is not in scope."-         [v]        -> return (App (Lam v e) (Var v)) -- There might be issues if "v" is a type variable, I'm not sure.-         _ : _ : _  -> fail $ "multiple variables named " ++ name ++ " in scope."+------------------------------------------------------------------------------------------------------

@@ -13,7 +13,7 @@ import Language.HERMIT.Primitive.GHC hiding (externals) import Language.HERMIT.Primitive.Common -import Language.HERMIT.CoreExtra+import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.Monad import Language.HERMIT.External@@ -70,7 +70,7 @@ getUnfolding :: Monad m              => Bool -- ^ Get the scrutinee instead of the patten match (for case binders).              -> Bool -- ^ Only succeed if this variable is a case binder.-             -> Id -> Context -> m (CoreExpr, Int)+             -> Id -> HermitC -> m (CoreExpr, Int) getUnfolding scrutinee caseBinderOnly i c =     case lookupHermitBinding i c of         Nothing -> case unfoldingInfo (idInfo i) of

@@ -1,12 +0,0 @@---- Utils for primitives, not the primitives themselves--module Language.HERMIT.Primitive.Utils where--import GhcPlugins as GHC---- appCount counts the number of applications / arguments are present-appCount :: CoreExpr -> Int-appCount (App e1 _) = appCount e1 + 1-appCount _          = 0-

@@ -23,14 +23,16 @@ import qualified Data.Map as M import Data.Maybe +import Language.HERMIT.Core+import Language.HERMIT.Monad+import Language.HERMIT.Kure import Language.HERMIT.Dictionary import Language.HERMIT.Expr import Language.HERMIT.External import Language.HERMIT.Interp import Language.HERMIT.Kernel.Scoped-import Language.HERMIT.Kure-import Language.HERMIT.Monad import Language.HERMIT.PrettyPrinter+ import Language.HERMIT.Primitive.Navigation import Language.HERMIT.Primitive.Inline @@ -43,13 +45,12 @@  import System.Console.Haskeline hiding (catch) --- There are 3 types of commands, AST effect-ful, Shell effect-ful, and Queries.+-- There are 4 types of commands, AST effect-ful, Shell effect-ful, Queries, and Meta-commands. -data ShellCommand :: * where-   AstEffect     :: AstEffect                -> ShellCommand-   ShellEffect   :: ShellEffect              -> ShellCommand-   QueryFun      :: QueryFun                 -> ShellCommand-   MetaCommand   :: MetaCommand              -> ShellCommand+data ShellCommand =  AstEffect   AstEffect+                  |  ShellEffect ShellEffect+                  |  QueryFun    QueryFun+                  |  MetaCommand MetaCommand  -- | AstEffects are things that are recorded in our log and saved files. @@ -60,8 +61,8 @@    | Pathfinder (TranslateH Core Path)    -- | This changes the currect location using directions    | Direction  Direction-   -- | This changes the current location using a give path-   | PushFocus Path+   --  | This changes the current location using a give path+--   | PushFocus Path     | BeginScope    | EndScope@@ -71,9 +72,9 @@    deriving Typeable  instance Extern AstEffect where-    type Box AstEffect = AstEffect-    box i = i-    unbox i = i+   type Box AstEffect = AstEffect+   box i = i+   unbox i = i  data ShellEffect :: * where    SessionStateEffect    :: (CommandLineState -> SessionState -> IO SessionState) -> ShellEffect@@ -89,9 +90,9 @@    deriving Typeable  instance Extern QueryFun where-    type Box QueryFun = QueryFun-    box i = i-    unbox i = i+   type Box QueryFun = QueryFun+   box i = i+   unbox i = i  data MetaCommand    = Resume@@ -129,7 +130,6 @@ interpShellCommand :: [Interp ShellCommand] interpShellCommand =                 [ interp $ \ (ShellCommandBox cmd)       -> cmd-                , interp $ \ (IntBox i)                  -> AstEffect (PushFocus [i])                 , interp $ \ (RewriteCoreBox rr)         -> AstEffect (Apply rr)                 , interp $ \ (TranslateCorePathBox tt)   -> AstEffect (Pathfinder tt)                 , interp $ \ (StringBox str)             -> QueryFun (Message str)@@ -222,7 +222,7 @@ changeRenderer :: String -> ShellEffect changeRenderer renderer = SessionStateEffect $ \ _ st ->         case lookup renderer finalRenders of-          Nothing -> return st          -- should fail with message+          Nothing -> return st          -- TODO: should fail with message           Just r  -> return $ st { cl_render = r }  ----------------------------------------------------------------------------------@@ -251,20 +251,20 @@ type CLM m a = ErrorT String (StateT CommandLineState m) a  -- TODO: Come up with names for these, and/or better characterise these abstractions.-iokm2clm' :: MonadIO m => String -> (a -> CLM m b) -> IO (KureMonad a) -> CLM m b-iokm2clm' msg ret m = liftIO m >>= runKureMonad ret (throwError . (msg ++))+iokm2clm' :: MonadIO m => String -> (a -> CLM m b) -> IO (KureM a) -> CLM m b+iokm2clm' msg ret m = liftIO m >>= runKureM ret (throwError . (msg ++)) -iokm2clm :: MonadIO m => String -> IO (KureMonad a) -> CLM m a+iokm2clm :: MonadIO m => String -> IO (KureM a) -> CLM m a iokm2clm msg = iokm2clm' msg return  data CommandLineState = CommandLineState         { cl_graph       :: [(SAST,ExprH,SAST)]         , cl_tags        :: [(String,SAST)]         -- these two should be in a reader-        , cl_dict        :: M.Map String [Dynamic]-        , cl_kernel       :: ScopedKernel+        , cl_dict        :: Dictionary+        , cl_kernel      :: ScopedKernel         -- and the session state (perhaps in a seperate state?)-        , cl_session      :: SessionState+        , cl_session     :: SessionState         }  newSAST :: ExprH -> SAST -> CommandLineState -> CommandLineState@@ -274,14 +274,14 @@  -- Session-local issues; things that are never saved. data SessionState = SessionState-        { cl_cursor      :: SAST              -- ^ the current AST-        , cl_pretty      :: String           -- ^ which pretty printer to use-        , cl_pretty_opts :: PrettyOptions -- ^ The options for the pretty printer+        { cl_cursor      :: SAST                                       -- ^ the current AST+        , cl_pretty      :: String                                     -- ^ which pretty printer to use+        , cl_pretty_opts :: PrettyOptions                              -- ^ The options for the pretty printer         , cl_render      :: Handle -> PrettyOptions -> DocH -> IO ()   -- ^ the way of outputing to the screen-        , cl_width       :: Int                 -- ^ how wide is the screen?-        , cl_nav         :: Bool        -- ^ keyboard input the the nav panel-        , cl_loading     :: Bool        -- ^ if loading a file-        , cl_tick        :: TVar (M.Map String Int)     -- ^ The list of ticked messages+        , cl_width       :: Int                                        -- ^ how wide is the screen?+        , cl_nav         :: Bool                                       -- ^ keyboard input the the nav panel+        , cl_loading     :: Bool                                       -- ^ if loading a file+        , cl_tick        :: TVar (M.Map String Int)                    -- ^ The list of ticked messages         }  -------------------------------------------------------------------------------@@ -292,7 +292,7 @@                     | AmbiguousC [CompletionType]  -- completionType function needs to be more specific     deriving (Show) --- todo: reverse rPrev and parse it, to better figure out what possiblities are in context?+-- TODO: reverse rPrev and parse it, to better figure out what possiblities are in context? --       for instance, completing "any-bu (inline " should be different than completing just "inline " --       this would also allow typed completion? completionType :: String -> CompletionType@@ -324,7 +324,7 @@     --     $ queryS (cl_kernel st) (cl_cursor (cl_session st)) targetQuery     -- TODO: I expect you want to build a silent version of the kernal_env for this query     mcls <- queryS (cl_kernel st) (cl_cursor (cl_session st)) targetQuery (cl_kernel_env (cl_session st))-    cl <- runKureMonad return fail mcls -- TO DO: probably shouldn't use fail here.+    cl <- runKureM return fail mcls -- TO DO: probably shouldn't use fail here.     return $ (map simpleCompletion . nub . filter (so_far `isPrefixOf`)) cl  -- | The first argument is a list of files to load.@@ -383,7 +383,7 @@                          `ourCatch` (liftIO . putStrLn)                            >> loop' -ourCatch :: (MonadIO n) => CLM IO () -> (String -> CLM n ()) -> CLM n ()+ourCatch :: MonadIO m => CLM IO () -> (String -> CLM m ()) -> CLM m () ourCatch m failure = do                 st <- get                 (res,st') <- liftIO $ runStateT (runErrorT m) st@@ -394,7 +394,7 @@   -evalStmts :: (MonadIO m) => [StmtH ExprH] -> CLM m ()+evalStmts :: MonadIO m => [StmtH ExprH] -> CLM m () evalStmts = mapM_ evalExpr . scopes     where scopes :: [StmtH ExprH] -> [ExprH]           scopes [] = []@@ -402,7 +402,7 @@           scopes (ScopeH s:ss) = (CmdName "{" : scopes s) ++ [CmdName "}"] ++ scopes ss  -evalExpr :: (MonadIO m) => ExprH -> CLM m ()+evalExpr :: MonadIO m => ExprH -> CLM m () evalExpr expr = do     dict <- gets cl_dict     case interpExprH dict interpShellCommand expr of@@ -437,20 +437,11 @@  performAstEffect (Direction dir) expr = do     st <- get-    -- This seems unnecassary.  But if you restore it, note that it needs editing so that it doesn't print if we're loading a file.-    -- child_count <- iokm2clm "Could not compute number of children:" $ queryS (cl_kernel st) (cl_cursor (cl_session st)) numChildrenT (cl_kernel_env (cl_session st))-    -- liftIO $ print (child_count, dir)     ast <- iokm2clm "Invalid move: " $ modPathS (cl_kernel st) (cl_cursor $ cl_session st) (moveLocally dir) (cl_kernel_env $ cl_session st)     put $ newSAST expr ast st     -- something changed, to print     showFocus -performAstEffect (PushFocus p) expr = do-    st <- get-    ast <- iokm2clm "Invalid push: " $ modPathS (cl_kernel st) (cl_cursor $ cl_session st) (extendLocalPath p) (cl_kernel_env $ cl_session st)-    put $ newSAST expr ast st-    showFocus- performAstEffect BeginScope expr = do         st <- get         ast <- liftIO $ beginScopeS (cl_kernel st) (cl_cursor (cl_session st))@@ -471,14 +462,8 @@         st <- get         -- TODO: Again, we may want a quiet version of the kernel_env         liftIO (queryS (cl_kernel st) (cl_cursor $ cl_session st) q (cl_kernel_env $ cl_session st))-          >>= runKureMonad (\ () -> putStrToConsole $ unparseExprH expr ++ " [correct]")-                           (\ err -> fail $ unparseExprH expr ++ " [exception: " ++ err ++ "]")-        -- correctness <- liftIO (try $ queryS (cl_kernel st) (cl_cursor (cl_session st)) q)-        -- case correctness of-        --   Right ()  -> do putStrToConsole $ unparseExprH expr ++ " [correct]"-        --   Left (err :: IOException)-        --            -> fail $ unparseExprH expr ++ " [exception: " ++ show err ++ "]"-+          >>= runKureM (\ () -> putStrToConsole $ unparseExprH expr ++ " [correct]")+                       (\ err -> fail $ unparseExprH expr ++ " [exception: " ++ err ++ "]")  ------------------------------------------------------------------------------- @@ -508,13 +493,6 @@ -- These two need to use Inquiry performQuery (Message msg) = liftIO (putStrLn msg) performQuery Display = showFocus-  -- do-  --   st <- get-  --   liftIO $ do-  --       ps <- pathS (cl_kernel st) (cl_cursor (cl_session st))-  --       putStrLn $ "Paths: " ++ show ps-  --       print ("Graph",cl_graph st)-  --       print ("This",cl_cursor (cl_session st))  ------------------------------------------------------------------------------- @@ -525,12 +503,12 @@ performMetaCommand (Dump fileName _pp renderer width) = do     st <- get     case (M.lookup (cl_pretty (cl_session st)) pp_dictionary,lookup renderer finalRenders) of-        (Just pp, Just r) -> do doc <- iokm2clm "Bad pretty-printer or renderer option: " $-                                           queryS (cl_kernel st) (cl_cursor $ cl_session st) (pp (cl_pretty_opts $ cl_session st)) (cl_kernel_env $ cl_session st)-                                liftIO $ do h <- openFile fileName WriteMode-                                            r h ((cl_pretty_opts $ cl_session st) { po_width = width }) doc-                                            hClose h-        _ -> throwError "dump: bad pretty-printer or renderer option"+      (Just pp, Just r) -> do doc <- iokm2clm "Bad pretty-printer or renderer option: " $+                                         queryS (cl_kernel st) (cl_cursor $ cl_session st) (pp (cl_pretty_opts $ cl_session st)) (cl_kernel_env $ cl_session st)+                              liftIO $ do h <- openFile fileName WriteMode+                                          r h ((cl_pretty_opts $ cl_session st) { po_width = width }) doc+                                          hClose h+      _ -> throwError "dump: bad pretty-printer or renderer option" performMetaCommand (LoadFile fileName) = do         putStrToConsole $ "[loading " ++ fileName ++ "]"         res <- liftIO $ try (readFile fileName)@@ -619,14 +597,14 @@            all_nds <- listS (cl_kernel st)            if SAST n `elem` all_nds               then return $ sess_st { cl_cursor = SAST n }-              else fail $ "Can not find AST #" ++ show n+              else fail $ "Cannot find AST #" ++ show n ++ "."       GotoTag tag -> case lookup tag (cl_tags st) of                        Just sast -> return $ sess_st { cl_cursor = sast }-                       Nothing   -> fail $ "Can not find tag " ++ show tag+                       Nothing   -> fail $ "Cannot find tag " ++ show tag ++ "."       Step -> do            let ns = [ edge | edge@(s,_,_) <- cl_graph st, s == cl_cursor (cl_session st) ]            case ns of-             [] -> fail "Cannot step forward (no more steps)"+             [] -> fail "Cannot step forward (no more steps)."              [(_,cmd,d) ] -> do                            putStrLn $ "step : " ++ unparseExprH cmd                            return $ sess_st { cl_cursor = d }@@ -634,11 +612,11 @@       Back -> do            let ns = [ edge | edge@(_,_,d) <- cl_graph st, d == cl_cursor (cl_session st) ]            case ns of-             []         -> fail "Cannot step backwards (no more steps)"+             []         -> fail "Cannot step backwards (no more steps)."              [(s,cmd,_) ] -> do                            putStrLn $ "back, unstepping : " ++ unparseExprH cmd                            return $ sess_st { cl_cursor = s }-             _          -> fail "Cannot step backwards (multiple choices, impossible!)"+             _          -> fail "Cannot step backwards (multiple choices, impossible!)."  --------------------------------------------------------