hermit 0.0 → 0.1.1.0

raw patch · 67 files changed

+7372/−15 lines, 67 filesdep +aesondep +ansi-terminaldep +containersdep ~basenew-component:exe:hermitnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, ansi-terminal, containers, data-default, ghc, haskeline, kure, marked-pretty, mtl, process, stm, template-haskell, text

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Language/HERMIT.hs +0/−3
• driver/Main.hs +52/−0
• examples/concatVanishes/ConcatVanishes.hss +15/−0
• examples/concatVanishes/Flatten.hs +25/−0
• examples/concatVanishes/Flatten.hss +3/−0
• examples/concatVanishes/HList.hs +33/−0
• examples/concatVanishes/Makefile +10/−0
• examples/concatVanishes/QSort.hs +28/−0
• examples/concatVanishes/QSort.hss +7/−0
• examples/concatVanishes/Rev.hs +22/−0
• examples/concatVanishes/Rev.hss +4/−0
• examples/contents.txt +156/−0
• examples/fib-stream/Fib.hs +23/−0
• examples/fib-stream/Fib.hss +14/−0
• examples/fib-stream/Makefile +10/−0
• examples/fib-stream/Nat.hs +17/−0
• examples/fib-stream/Stream.hs +16/−0
• examples/fib-stream/WWSplitTactic.hss +18/−0
• examples/fib-tuple/Fib.hs +53/−0
• examples/fib-tuple/Fib.hss +63/−0
• examples/fib-tuple/Makefile +19/−0
• examples/fib-tuple/WWSplitTactic.hss +51/−0
• examples/fib-tuple/blog.txt +195/−0
• examples/hanoi/Hanoi.hs +79/−0
• examples/hanoi/Hanoi.hss +59/−0
• examples/hanoi/Makefile +13/−0
• examples/map/Makefile +10/−0
• examples/map/Map.hs +53/−0
• examples/map/Map.hss +47/−0
• examples/reverse/HList.hs +36/−0
• examples/reverse/Makefile +14/−0
• examples/reverse/Reverse.hs +25/−0
• examples/reverse/Reverse.hss +30/−0
• hermit.cabal +184/−12
• src/HERMIT.hs +13/−0
• src/Language/HERMIT/Context.hs +135/−0
• src/Language/HERMIT/CoreExtra.hs +48/−0
• src/Language/HERMIT/Dictionary.hs +152/−0
• src/Language/HERMIT/Expr.hs +218/−0
• src/Language/HERMIT/External.hs +319/−0
• src/Language/HERMIT/GHC.hs +115/−0
• src/Language/HERMIT/Interp.hs +67/−0
• src/Language/HERMIT/Kernel.hs +122/−0
• src/Language/HERMIT/Kernel/Scoped.hs +169/−0
• src/Language/HERMIT/Kure.hs +762/−0
• src/Language/HERMIT/Monad.hs +163/−0
• src/Language/HERMIT/Plugin.hs +42/−0
• src/Language/HERMIT/PrettyPrinter.hs +391/−0
• src/Language/HERMIT/PrettyPrinter/AST.hs +76/−0
• src/Language/HERMIT/PrettyPrinter/Clean.hs +226/−0
• src/Language/HERMIT/PrettyPrinter/GHC.hs +59/−0
• src/Language/HERMIT/PrettyPrinter/JSON.hs +67/−0
• src/Language/HERMIT/Primitive/AlphaConversion.hs +276/−0
• src/Language/HERMIT/Primitive/Common.hs +94/−0
• src/Language/HERMIT/Primitive/Debug.hs +37/−0
• src/Language/HERMIT/Primitive/Fold.hs +133/−0
• src/Language/HERMIT/Primitive/GHC.hs +405/−0
• src/Language/HERMIT/Primitive/Inline.hs +74/−0
• src/Language/HERMIT/Primitive/Kure.hs +77/−0
• src/Language/HERMIT/Primitive/Local.hs +139/−0
• src/Language/HERMIT/Primitive/Local/Case.hs +202/−0
• src/Language/HERMIT/Primitive/Local/Let.hs +100/−0
• src/Language/HERMIT/Primitive/Navigation.hs +117/−0
• src/Language/HERMIT/Primitive/New.hs +326/−0
• src/Language/HERMIT/Primitive/Unfold.hs +100/−0
• src/Language/HERMIT/Primitive/Utils.hs +12/−0
• src/Language/HERMIT/Shell/Command.hs +752/−0

@@ -1,3 +0,0 @@-module Language.HERMIT where--version = "0.0"

@@ -0,0 +1,52 @@+-- Simple driver for hermit++module Main where++import System.Environment+import System.Process+import System.Exit++import Paths_hermit as P+import Data.Version++hermit_version :: String+hermit_version = "HERMIT v" ++ showVersion P.version++main :: IO ()+main = do+   args <- getArgs+   main2 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 []+        _ -> error "hermit internal error"++main3 mod_nm hermit_args ghc_args = do+        putStrLn $ "[starting " ++ hermit_version ++ " on " ++ mod_nm ++ "]"+        let cmds =+                 [ mod_nm+                  , "-fforce-recomp"+                  , "-O2"+                  , "-dcore-lint"+                  , "-fsimple-list-literals"+--                  , "-v0"+	          , "-fplugin=HERMIT"+                  ] ++ [ "-fplugin-opt=HERMIT:main:Main:" ++ opt+                       | opt <- "" : hermit_args+                       ] ++ ghc_args+        putStrLn $ "% ghc " ++ unwords cmds+        (_,_,_,r) <- createProcess $ proc "ghc" cmds+        ex <- waitForProcess r+        exitWith ex+++++

@@ -0,0 +1,15 @@+consider let+{ consider def ; fix-intro }+safe-let-subst+unfold-rule "ww"+any-call (unfold '.)+any-call (unfold 'wrap)+one-td (unfold 'unwrap)+any-call (unfold '.)+innermost (bash >+> push 'repH >+> unfold-rule "repH ++" >+> unfold-rule "repH (:)" >+> apply-rule ". id"  >+> apply-rule "id ." >+> unfold-rule "repH []" >+> unfold-rule "[] ++" >+> unfold-rule "[] ++" >+> unfold-rule "(:) ++")+any-td (unfold-rule "rep-abs-fusion")+{ consider app ; unfold 'fix ; alpha-let 'work }+bash+any-call (unfold 'absH)+try unshadow+

@@ -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,3 @@+flatten-module+consider 'flatten+{ load "ConcatVanishes.hss" }

@@ -0,0 +1,33 @@+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 []++-- 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                   #-}+{-# RULES "++ []"  forall xs .         xs ++ []     = xs                   #-}++-- Should be somewhere else+{-# RULES ". id" forall f .          f . id = f                          #-}+{-# RULES "id ." forall f .          id . f = f                          #-}+++-- has preconditon+{-# RULES "rep-abs-fusion" forall h .  repH (absH h) = h                   #-}

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

@@ -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,7 @@+flatten-module+consider 'qsort+{ load "ConcatVanishes.hss" }+one-td let-subst+bash++

@@ -0,0 +1,22 @@+module Main where++import HList+import Data.Function (fix)++{-# 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)) #-}++-- rev :: [a] -> [a]+rev []     = []+rev (y:ys) = rev ys ++ [y]++main :: IO ()+main = print $ length $ rev [1..15000]+

@@ -0,0 +1,4 @@+flatten-module+consider 'rev+{ load "ConcatVanishes.hss" }+

@@ -0,0 +1,156 @@+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.+++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.+++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,23 @@+module Main where++import Prelude hiding ((+),map,(!!))+import Nat+import Stream++import Data.Function(fix)++fib :: Nat -> Nat+fib Zero             = Zero+fib (Succ Zero)      = Succ Zero+fib (Succ (Succ n))  = fib (Succ n) + fib n++wrap :: Stream a -> (Nat -> a)+wrap s n = s !! n++unwrap :: (Nat -> a) -> Stream a+unwrap f = map f nats++{-# RULES "ww" forall f.  fix f = wrap (fix (unwrap . f . wrap)) #-}++main :: IO ()+main = print (fromNat $ fib $ toNat 30)

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

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

@@ -0,0 +1,17 @@+module Nat where++import Prelude hiding ((+))++data Nat = Zero | Succ Nat deriving (Eq,Show)++(+) :: Nat -> Nat -> Nat+Zero     + n = n+(Succ m) + n = Succ (m + n)++toNat :: Integer -> Nat+toNat 0 = Zero+toNat n = Succ (toNat (pred n))++fromNat :: Nat -> Integer+fromNat Zero = 0+fromNat (Succ n) = succ (fromNat n)

@@ -0,0 +1,16 @@+module Stream where++import Prelude hiding (map,(!!))+import Nat++data Stream a = Cons a (Stream a)++map :: (a -> b) -> Stream a -> Stream b+map f (Cons a s) = Cons (f a) (map f s)++(!!) :: Stream a -> Nat -> a+(Cons a _) !! Zero     = a+(Cons _ s) !! (Succ n) = s !! n++nats :: Stream Nat+nats = Zero `Cons` map Succ nats

@@ -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+}

@@ -0,0 +1,53 @@+{-# LANGUAGE TemplateHaskell #-}+-- for criterion+import Criterion.Main+import Control.DeepSeq.TH++-- so we can fix-intro+import Data.Function (fix)++-- so we can let-tuple+import GHC.Tuple++import Prelude hiding ((+))++data Nat = Z | S Nat++{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}+{-# RULES "precondition" forall w . wrap (unwrap w) = w #-}++(+) :: Nat -> Nat -> Nat+Z      + n = n+(S n') + n = S (n' + n)++fromInt :: Int -> Nat+fromInt 0 = Z+fromInt i | i < 0 = error "fromInt negative"+          | otherwise = S (fromInt (i-1))++-- original fib definition+fib :: Nat -> Nat+fib Z = Z+fib (S Z) = S Z+fib (S (S n)) = fib (S n) + fib n++-- goal:+-- fib' = fst work+--   where work Z = (Z, S Z)+--         work (S n) = let (x,y) = work n+--                         in (y,x+y)++wrap :: (Nat -> (Nat, Nat)) -> Nat -> Nat+wrap h = fst . h++unwrap :: (Nat -> Nat) -> Nat -> (Nat, Nat)+unwrap h n = (h n, h (S n))++-- for criterion+deriveNFData ''Nat++main :: IO ()+main = defaultMain+        [ bench "15" $ nf fib (fromInt 15)+        , bench "30" $ nf fib (fromInt 30)+        ]

@@ -0,0 +1,63 @@+flatten-module+consider 'fib++{++load "WWSplitTactic.hss"+consider 'work ; remember origwork++-- work = unwrap (f (wrap work))++down ; eta-expand 'n++-- work n = unwrap (f (wrap work)) n++any-call (unfold 'unwrap)++-- work n = (f (wrap work) n, f (wrap work) (n+1))++down ; case-split-inline 'n++-- work 0     = (f (wrap work) 0, f (wrap work) 1)+-- 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) }+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) }++-- 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)++any-bu (unfold-rule precondition)++-- work 0     = (0, 1)+-- work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+1) + f (wrap work) n)++{ 1 ; 1 ; let-intro 'x }+{ 0 ; 1 ; let-intro 'y }+innermost (let-float-arg <+ let-float-app)+one-td (fold 'y)+let-tuple 'xy++-- work 0     = (0, 1)+-- work (n+1) = let (x,y) = (f (wrap work) n, f (wrap work) (n+1)) in (y,x+y)++one-td (fold 'unwrap)++-- work 0     = (0, 1)+-- work (n+1) = let (x,y) = unwrap (f (wrap work)) n in (y,x+y)++one-td (fold origwork)++-- work 0     = (0, 1)+-- work (n+1) = let (x,y) = work n in (y,x+y)++}++innermost dead-code-elimination+{ 0 ; 1 ; any-call (unfold 'wrap) ; simplify }

@@ -0,0 +1,19 @@+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

@@ -0,0 +1,51 @@+-- 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

@@ -0,0 +1,195 @@+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,79 @@+module Main where++import Criterion.Main++import Control.Monad (forM_)++import Data.Function (fix)+import GHC.Tuple++data Nat = Z | S Nat++toInt :: Nat -> Int+toInt Z = 0+toInt (S m) = 1 + toInt m++fromInt :: Int -> Nat+fromInt 0 = Z+fromInt i = S (fromInt (i-1))++instance Show Nat where+    show = show . toInt++main :: IO ()+main = do+    forM_ [0..20] $ \i -> do+        let h = hanoi (fromInt i) A B C+            h' = hanoi' (fromInt i) A B C+            h'' = wrap (unwrap hanoi) (fromInt i) A B C+        if h == h'+        then do putStrLn $ show i ++ " good."+                if h == h''+                then do putStrLn $ show i ++ " wrap/unwrap good."+                else do print h+                        print h''+        else do print h+                print h'++--       defaultMain+--        [ bench "4" $ whnf hanoi 4+--        ]++{-# RULES "ww" forall work. fix work = wrap (fix (unwrap . work . wrap)) #-}+{-# RULES "pc" forall w. wrap (unwrap w) = w #-}+{-# RULES "++ []" forall l. l ++ [] = l #-}+{-# RULES "[] ++" forall l. [] ++ l = l #-}++data Peg = A | B | C deriving (Show, Eq)+type Moves = [(Peg,Peg)]++-- this is a candidate for tupling+hanoi :: Nat -> Peg -> Peg -> Peg -> Moves+hanoi Z     _ _ _ = []+hanoi (S n) d b c = hanoi n d c b ++ [(d,b)] ++ hanoi n c b d++-- this is the goal+hanoi' Z         _ _ _ = []+hanoi' (S Z)     d b _ = [(d,b)]+hanoi' (S (S n)) d b c = u ++ [(d,c)] ++ v ++ [(d,b)] ++ w ++ [(c,b)] ++ u+    where (u,v,w) = worker n d b c++          worker :: Nat -> Peg -> Peg -> Peg -> (Moves, Moves, Moves)+          worker Z         _ _ _ = ([],[],[])+          worker (S Z)     d b c = ([(d,b)], [(b,c)], [(c,d)])+          worker (S (S n)) d b c =+                let (u,v,w) = worker n d b c+                in (u ++ [(d,c)] ++ v ++ [(d,b)] ++ w ++ [(c,b)] ++ u+                   ,v ++ [(b,d)] ++ w ++ [(b,c)] ++ u ++ [(d,c)] ++ v+                   ,w ++ [(c,b)] ++ u ++ [(c,d)] ++ v ++ [(b,d)] ++ w)++unwrap :: (Nat -> Peg -> Peg -> Peg -> Moves)+       -> (Nat -> Peg -> Peg -> Peg -> (Moves, Moves, Moves))+unwrap f n d b c = (f n d b c, f n b c d, f n c d b)++wrap :: (Nat -> Peg -> Peg -> Peg -> (Moves, Moves, Moves))+     -> (Nat -> Peg -> Peg -> Peg -> Moves)+wrap _ Z         _ _ _ = []+wrap _ (S Z)     d b _ = [(d,b)]+wrap f (S (S n)) d b c = let (u,v,w) = f n d b c+                         in u ++ [(d,c)] ++ v ++ [(d,b)] ++ w ++ [(c,b)] ++ u

@@ -0,0 +1,59 @@+flatten-module++-- do the w/w split+consider 'hanoi+{ load "../fib-tuple/WWSplitTactic.hss" }++{ consider 'work+  remember origwork++  any-call (unfold 'unwrap)++  -- establish the zero base case+  down ; down ; down ; down ; down+  case-split-inline 'n+  { 1 ; any-call (unfold 'f) ; simplify }++  -- establish the one base case+  { 2 ; down ; case-split-inline 'a+    { 1 ; any-call (unfold 'f) ; simplify+      any-call (unfold origwork)+      any-call (unfold-rule pc)+      any-call (unfold 'f)+      simplify+      any-call (unfold-rule "[] ++")+      any-call (unfold-rule "++ []")+    }+    { 2 ; any-call (unfold 'f) ; simplify++      any-call (unfold origwork)+      any-call (unfold-rule pc)+      any-call (unfold 'f)+      simplify++      -- recursion decrements by two, so must do this again+      any-call (unfold origwork)+      any-call (unfold-rule pc)++      -- time to let intro+      -- need a "occurance 'work" like consider+      { down+        { 1+          { 0 ; 1+            { 0 ; 1 ; let-intro 'u }+            { 1 ; 1 ; let-intro 'v }+          }+          { 1 ; 1 ; 0 ; 1 ; let-intro 'w }+        }+        innermost let-float+        any-call (fold 'u)+        any-call (fold 'v)+        any-call (fold 'w)+        let-tuple 'uvw+        any-call (fold 'unwrap)+        any-call (fold origwork)+      }+    }+  }+}+innermost dead-code-elimination

@@ -0,0 +1,13 @@+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,10 @@+HERMIT = perl ../../scripts/hermit.pl++last:+	- $(HERMIT) Map.hs Map.hss resume++interactive:+	- $(HERMIT) Map.hs Map.hss++start:+	- $(HERMIT) Map.hs

@@ -0,0 +1,53 @@+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])

@@ -0,0 +1,47 @@+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,36 @@+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 #-}++-- has preconditon+{-# RULES "rep-abs-fusion" forall h . repH (absH h) = h #-}+++++

@@ -0,0 +1,14 @@+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,25 @@+module Main where++import Criterion.Main+import HList+import Data.Function (fix)++{-# 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 #-}++-- rev :: [a] -> [a]+rev []     = []+rev (x:xs) = rev xs ++ [x]++main = defaultMain+       [ bench (show n) $ whnf (\n -> sum $ rev [1..n]) n+       | n <- take 8 $ [50,100..]+       ]

@@ -0,0 +1,30 @@+-- set-renderer latex+-- set-renderer unicode-console+-- unicode-terminal++flatten-module++-- This is the outer rev, with the big lambda+consider 'rev+   consider 'rev+   fix-intro+   any-call (unfold-rule "ww")+   any-call (unfold '.)+   any-call (unfold 'wrap)+   any-call (unfold 'unwrap)+   any-call (unfold '.)+   unshadow ; bash+   any-bu case-float-arg+   any-bu (apply-rule "repH ++") ; bash+   any-bu (apply-rule "repH []") ; bash+   any-bu (unfold-rule "rep-abs-fusion")++   -- This is just a setup to all completion+   { consider case ; eta-expand 'ys ; any-bu case-float-app }+   any-call (unfold 'repH)+   any-call (unfold '.)+   any-call (unfold-rule "(:) ++")+   any-call (unfold-rule "[] ++")+   any-call (unfold 'fix) ; bash+   unshadow+

@@ -1,23 +1,195 @@ Name:                hermit-Version:             0.0+Version:             0.1.1.0 Synopsis:            Haskell Equational Reasoning Model-to-Implementation Tunnel-Description:	     HERMIT uses Haskell to express semi-formal models,-		     efficient implementations, and provide a bridging DSL-		     to describe via stepwise refinement the connection between-		     these models and implementations. The key transformation-		     in the bridging DSL is the worker/wrapper transformation.+Description:+  HERMIT uses Haskell to express semi-formal models,+  efficient implementations, and provide a bridging DSL+  to describe via stepwise refinement the connection between+  these models and implementations. The key transformation+  in the bridging DSL is the worker/wrapper transformation.+  .+  This is a pre-alpha `please give feedback' release.+  Shortcomings/gotchas include:+  .+    * Command line completion is ad hoc at the moment.+  .+    * Parser needs to be reimplemented with a parsing library.+  .+    * log command prints linearly, even if command history is a tree.+  .+    * The fold rewrite can only fold syntactically equivalent (up to+      parameters of the function you are folding) expressions.+  .+    * RULES have issues with forall types.+  .+    * Different core comes out depending on whether you ascribe explicit+      type signatures.+  .+    * A number of rewrites don't enforce preconditions. ex: cast elimination+      always works, even if the cast is necessary+  .+  Examples can be found in the examples sub-directory.+  .+  @+   $ cd examples/reverse+  @+  .+  Example of running a script.+  .+  @+   $ hermit Reverse.hs Reverse.hss resume+   [starting HERMIT v0.1.1.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.1.0 ... linking ... done.+   [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )+   Linking Reverse ...+   $ ./Reverse+   ....+  @+  .+  Example of interactive use.+  .+  @+   $ hermit Reverse.hs+   [starting HERMIT v0.1.1.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.1.0 ... linking ... done.+   [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )+   module main:Main where+   \ \ rev ∷ ∀ a . [] a -> [] a+   \ \ unwrap ∷ ∀ a . ([] a -> [] a) -> [] a -> H a+   \ \ wrap ∷ ∀ a . ([] a -> H a) -> [] a -> [] a+   \ \ main ∷ IO ()+   \ \ main ∷ IO ()+   hermit\<0\>+   ...+  @+  .+  To resume compile, use resume.+  .+  @+   ...+   hermit\<0\> resume+   hermit\<0\> Linking Reverse ...+   $+  @  Category:            Language, Formal Methods, Optimization, Transformation, Refactoring, Reflection License:             BSD3 License-file:        LICENSE-Author:              Andy Gill+Author:              Andrew Farmer, Andy Gill, Ed Komp, Neil Sculthorpe Maintainer:          Andy Gill <andygill@ku.edu>-Stability:	     vaporware-build-type: 	     Simple-Cabal-Version:       >= 1.6+Stability:           pre-alpha+build-type:          Simple+Cabal-Version:       >= 1.10 +extra-source-files:+    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/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/hanoi/Hanoi.hs+    examples/hanoi/Hanoi.hss+    examples/hanoi/Makefile+    examples/map/Map.hs+    examples/map/Map.hss+    examples/map/Makefile+    examples/reverse/HList.hs+    examples/reverse/Makefile+    examples/reverse/Reverse.hs+    examples/reverse/Reverse.hss+ Library-       Build-Depends: base >= 4 && < 5+  ghc-options: -Wall -fno-warn-orphans+  Build-Depends: base >= 4 && < 5,+                 aeson >= 0.6.0.0,+                 ansi-terminal >= 0.5.5,+                 containers >= 0.4.2.1,+                 data-default >= 0.4,+                 ghc >= 7.4,+                 haskeline >= 0.6.4.7 && < 0.7,+                 kure >= 2.2.5,+                 marked-pretty >= 0.1,+                 mtl >= 2.0.1.0,+                 stm >= 2.2.0.1,+                 template-haskell >= 2.7.0.0,+                 text >= 0.11.1.13 +  default-language: Haskell2010+   Exposed-modules:-       Language.HERMIT+       HERMIT++       Language.HERMIT.Context+       Language.HERMIT.CoreExtra+       Language.HERMIT.Dictionary+       Language.HERMIT.Expr+       Language.HERMIT.External+       Language.HERMIT.Kernel+       Language.HERMIT.Kernel.Scoped+       Language.HERMIT.Kure+       Language.HERMIT.Interp+       Language.HERMIT.Monad++       Language.HERMIT.Plugin++       Language.HERMIT.Primitive.Debug+       Language.HERMIT.Primitive.Fold+       Language.HERMIT.Primitive.GHC+       Language.HERMIT.Primitive.Inline+       Language.HERMIT.Primitive.Kure+       Language.HERMIT.Primitive.Local+       Language.HERMIT.Primitive.Local.Let+       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+       Language.HERMIT.PrettyPrinter.Clean+       Language.HERMIT.PrettyPrinter.GHC+       Language.HERMIT.PrettyPrinter.JSON++       Language.HERMIT.Shell.Command++  Other-modules:+       Language.HERMIT.GHC++       Language.HERMIT.Primitive.Common++  Hs-Source-Dirs: src++Executable hermit+    Build-Depends: base >= 4 && < 5,+                   process++    default-language: Haskell2010+    Main-Is: Main.hs+    Hs-Source-Dirs: driver+    Ghc-Options:

@@ -0,0 +1,13 @@+module HERMIT (plugin) where++import GhcPlugins++import Language.HERMIT.Shell.Command as Dispatch+import Language.HERMIT.Plugin+import System.Console.Haskeline (defaultBehavior)++plugin :: Plugin+plugin = hermitPlugin interactive++interactive :: HermitPass+interactive opts modGuts = Dispatch.commandLine opts defaultBehavior modGuts

@@ -0,0 +1,135 @@+module Language.HERMIT.Context+       (+         -- * HERMIT Bindings+         HermitBinding(..)+       , hermitBindingDepth+         -- * The HERMIT Context+       , Context+       , initContext+       , (@@)+       , addAltBindings+       , addBinding+       , addCaseBinding+       , addLambdaBinding+       , hermitBindings+       , hermitDepth+       , hermitPath+       , hermitModGuts+       , lookupHermitBinding+       , listBindings+       , boundIn+) where++import Prelude hiding (lookup)+import GhcPlugins hiding (empty)+import Data.Map hiding (map, foldr)++import Language.KURE++------------------------------------------------------------------------++-- | HERMIT\'s representation of variable bindings.+data HermitBinding+        = 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).++-- | Get the depth of a binding.+hermitBindingDepth :: HermitBinding -> Int+hermitBindingDepth (LAM d)      = d+hermitBindingDepth (BIND d _ _) = d+hermitBindingDepth (CASE d _ _) = d++------------------------------------------------------------------------++-- | 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.+        , 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.+        }++------------------------------------------------------------------------++-- | The HERMIT context stores an 'AbsolutePath' to the current node in the tree.+instance PathContext Context where+  contextPath = hermitPath++-- | Create the initial HERMIT 'Context' by providing a 'ModGuts'.+initContext :: ModGuts -> Context+initContext modGuts = Context 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) }++-- | 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 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)++-- | 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 the Ids 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)++-- | Lookup the binding for an identifier in a 'Context'.+lookupHermitBinding :: Id -> Context -> Maybe HermitBinding+lookupHermitBinding n env = lookup n (hermitBindings env)++-- | List all the identifiers bound in the 'Context'.+listBindings :: Context -> [Id]+listBindings = keys . hermitBindings++-- | Determine if an identifier is bound in the 'Context'.+boundIn :: Id -> Context -> Bool+boundIn i c = i `elem` listBindings c++------------------------------------------------------------------------

@@ -0,0 +1,48 @@+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))++-----------------------------------------------------------------------

@@ -0,0 +1,152 @@+{-# LANGUAGE GADTs, ScopedTypeVariables #-}++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+       , pp_dictionary+)  where++import Data.Default (def)+import Data.Dynamic+import Data.List+import Data.Map (Map, fromList, toList)++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+import qualified Language.HERMIT.Primitive.Local as Local+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.Fold as Fold+import qualified Language.HERMIT.Primitive.Unfold as Unfold+import qualified Language.HERMIT.Primitive.AlphaConversion as Alpha+++import Language.HERMIT.PrettyPrinter+import qualified Language.HERMIT.PrettyPrinter.AST as AST+import qualified Language.HERMIT.PrettyPrinter.Clean as Clean+import qualified Language.HERMIT.PrettyPrinter.GHC as GHCPP++--------------------------------------------------------------------------++prim_externals :: [External]+prim_externals+               =    Kure.externals+                 ++ Navigation.externals+                 ++ Inline.externals+                 ++ Local.externals+                 ++ Debug.externals+                 ++ New.externals+                 ++ Fold.externals+                 ++ Unfold.externals+                 ++ Alpha.externals++-- The GHC.externals here is a bit of a hack. Not sure about this+-- | Augment a list of 'External's by adding all of HERMIT's primitive 'External's, plus any GHC RULES pragmas in the module.+all_externals :: [External] -> [External]+all_externals my_externals = prim_externals ++ my_externals ++ GHC.externals++-- | Create the dictionary.+dictionary :: [External] -> Map String [Dynamic]+dictionary externs = toDictionary externs'+  where+        msg = layoutTxt 60 (map (show . fst) dictionaryOfTags)+        externs' = externs +++                [ external "help" (help_command externs' "help")+                    [ "(this message)" ] .+ Query .+ Shell+                , external "help" (help_command externs')+                    ([ "help <command>|<category>|categories|all|<search-string>"+                     , "displays help about a command or category."+                     , "Multiple items may match."+                     , ""+                     , "categories: " ++ head msg+                     ] ++ map ("            " ++) (tail msg))  .+ Query .+ Shell+                -- Runs every command matching the tag predicate with innermostR (fix point anybuR),+                -- Only fails if all of them fail the first time.+                , let bashPredicate = Bash -- Shallow .& Eval .& (notT Loop)+                  in external "bash"+                              (metaCmd externs bashPredicate (setFailMsg "Nothing to do." . innermostR . orR))+                              (metaHelp externs bashPredicate+                                [ "Iteratively apply the following rewrites until nothing changes:" ])+                              .+ Eval .+ Deep .+ Loop+                ]++--------------------------------------------------------------------------++-- | The pretty-printing dictionaries.+pp_dictionary :: Map String (PrettyOptions -> PrettyH Core)+pp_dictionary = fromList+        [ ("clean",  Clean.corePrettyH)+        , ("ast",    AST.corePrettyH)+        , ("ghc",    GHCPP.corePrettyH)+        ]++-- (This isn't used anywhere currently.)+-- | Each pretty printer can suggest some options+pp_opt_dictionary :: Map String PrettyOptions+pp_opt_dictionary = fromList+        [ ("clean", def)+        , ("ast",  def)+        , ("ghc",  def)+        ]+++--------------------------------------------------------------------------++make_help :: [External] -> [String]+make_help = concatMap snd . toList . toHelp++help_command :: [External] -> String -> String+help_command externals m+        | [(ct :: CmdTag,"")] <- reads m+        = unlines $ make_help $ filter (tagMatch ct) externals+help_command externals "all"+        = unlines $ make_help externals+help_command _ "categories" = unlines $+                [ "categories" ] +++                [ "----------" ] +++                [ txt ++ " " ++ replicate (16 - length txt) '.' ++ " " ++ desc+                | (cmd,desc) <- dictionaryOfTags+                , let txt = show cmd+                ]++help_command externals m = unlines $ make_help $ pathPrefix m+    where pathPrefix p = filter (isInfixOf p . externName) externals++layoutTxt :: Int -> [String] -> [String]+layoutTxt n (w1:w2:ws) | length w1 + length w2 >= n = w1 : layoutTxt n (w2:ws)+                       | otherwise = layoutTxt n ((w1 ++ " " ++ w2) : ws)+layoutTxt _ other = other++--------------------------------------------------------------------------++-- TODO: We need to think harder about bash/metaCmd.++-- TODO: supply map of command-name -> arguments?+-- otherwise fromDynamic will fail for any rewrite that takes arguments.+metaCmd :: Tag a+        => [External]                         -- ^ universe of commands to search+        -> a                                  -- ^ tag matching predicate+        -> ([RewriteH Core] -> RewriteH Core) -- ^ means to combine the matched rewrites+        -> RewriteH Core+metaCmd externs p = ($ [ rw | e <- externs+                            , tagMatch p e+                            , Just rw <- [fmap unbox $ fromDynamic $ externFun e] ])++metaHelp :: Tag a+        => [External]                         -- ^ universe of commands to search+        -> a                                  -- ^ tag matching predicate+        -> [String]                           -- ^ help text preamble+        -> [String]+metaHelp externs p = (++ [ externName e+                         | e <- externs+                         , tagMatch p e+                         -- necessary so we don't list things that don't type correctly+                         , Just (_ :: RewriteH Core) <- [fmap unbox $ fromDynamic $ externFun e] ])

@@ -0,0 +1,218 @@+module Language.HERMIT.Expr+        ( -- * HERMIT Expressions++          -- | This is the /untyped/ command and control language for HERMIT.+          ExprH(..)+        , StmtH(..)+        , parseExprH+        , parseStmtsH+        , unparseExprH+        , unparseStmtH+        , unparseStmtsH+        , numStmtsH+        ) where++import Control.Applicative ((<$>))+import Data.Char+import Data.List++---------------------------------------------++-- | A simple expression language AST, for things parsed from 'String' or JSON structures.+data ExprH+        = SrcName String                -- ^ Variable names (refers to source code).+        | CmdName String                -- ^ Commands (to be looked up in 'Language.HERMIT.Dictionary').+        | AppH ExprH ExprH              -- ^ Application.+        deriving (Eq, Show)++-- | Nested lists to represent scoping structure.+data StmtH expr+        = ExprH expr+        | ScopeH [StmtH expr]+        deriving Show++data Box e = InfixableExpr e | Box e deriving Show++---------------------------------------------++-- TODO: This is a quick hack that's better than just saying "N"; I have no idea how accurate this is.++-- | Count the total number of statements.+numStmtH :: StmtH expr -> Int+numStmtH (ExprH _)   = 1+numStmtH (ScopeH ss) = numStmtsH ss++-- | Count the total number of statements.+numStmtsH :: [StmtH expr] -> Int+numStmtsH = sum . map numStmtH++---------------------------------------------++unparseExprH :: ExprH -> String+unparseExprH (SrcName nm) = "'" ++ nm+unparseExprH (CmdName nm)+        |  all isId nm = nm+        | otherwise    = show nm     -- with quotes+unparseExprH (AppH (AppH (CmdName nm) e1) e2)+        | all isInfixId nm+        = unparseAtom e1 ++ " " ++ nm ++ " " ++ unparseAtom e2+unparseExprH (AppH e1 e2) = unparseExprH e1 ++ " " ++ unparseAtom e2++unparseAtom :: ExprH -> String+unparseAtom e@(AppH {}) = "(" ++ unparseExprH e ++ ")"+unparseAtom e           = unparseExprH e+++unparseStmtH :: StmtH ExprH -> String+unparseStmtH (ExprH expr)   = unparseExprH expr+unparseStmtH (ScopeH stmts) = "{ " ++ unparseStmtsH stmts ++ "}"++unparseStmtsH :: [StmtH ExprH] -> String+unparseStmtsH stmts = intercalate " ; " (map unparseStmtH stmts)++---------------------------------------------++-- Cheap and cheerful parser. Pretty hacky for now++parse :: ReadS a -> String -> Either String a+parse p str = case p str of+                (a,rest) : _  | all isSpace rest -> Right a+                _                                -> Left $ "User error, cannot parse: " ++ str++many :: ReadS a -> ReadS [a]+many p inp =+     some p inp +++     [ ([], inp) ]++some :: ReadS a -> ReadS [a]+some p inp =+     [ (x:xs,inp2)+     | (x,inp1)  <- p inp+     , (xs,inp2) <- many p inp1+     ]++bind :: ReadS a -> (a -> ReadS b) -> ReadS b+bind m k inp =+        [ (b,inp2)+        | (a,inp1) <- m inp+        , (b,inp2) <- k a inp1+        ]++---------------------------------------------+++-- | Parse an expression.+parseExprH :: String -> Either String ExprH+parseExprH = parse parseExprH1++-- | Parse a list of statements, seperated by semicolons.+parseStmtsH :: String -> Either String [StmtH ExprH]+parseStmtsH = parse parseExprsH'++---------------------------------------------++parseExprsH' :: ReadS [StmtH ExprH]+parseExprsH' inp =+        (many (item ";")                 `bind` \ _ -> -- another hack+        (parseTopExprH1                  `bind` (\ a ->+        (many (item ";")                 `bind` \ _ -> -- complete hack, needed fixed with real parser+        (parseExprsH'                    `bind` (\ as ->+        (\ inp' -> [(a:as,inp')]))))))) inp ++  [ ([], inp) ]++++parseTopExprH1 :: ReadS (StmtH ExprH)+parseTopExprH1 inp =+        (parseExprH1 `bind` \ es inp1 -> [(ExprH es,inp1)]) inp +++        [ (ScopeH es,inp3)+        | ("{",inp1) <- parseToken inp+        , (es,inp2)   <- parseExprsH' inp1+        , ("}",inp3) <- parseToken inp2+        ]+++parseExprH0 :: ReadS (Box ExprH)+parseExprH0 inp =+        [ (Box (CmdName str),inp1)+        | (str,inp1) <- parseToken inp+        , isId (head str) || head str == ':'    -- commands can start with :+        , all isId (tail str)+        ] +++        [ (InfixableExpr (CmdName str),inp1)+        | (str,inp1) <- parseToken inp+        , all isInfixId str+        ] +++        [ (Box (SrcName str),inp2)+        | ("'",inp1) <- parseToken inp+        , (str,inp2) <- parseToken inp1+        ] +++        [ (Box (CmdName $ chomp '"' str),inp1)+        | (str@('"':_),inp1) <- lex inp+        ] +++        [ (Box e,inp3)+        | ("(",inp1) <- parseToken inp+        , (e,inp2)   <- parseExprH1 inp1+        , (")",inp3) <- parseToken inp2+        ]+    where chomp _  [] = []+          chomp ch s@(c:cs) | c == ch && last cs == ch = init cs+                            | otherwise = s++parseExprH1 :: ReadS ExprH+parseExprH1 = some parseExprH0 `bind` \ es inp ->+        case mkAppH es id [] of+          Nothing -> []+          Just r  -> [(r,inp)]++-- TODO: Assoc to the right, want assoc to the left.+mkAppH :: [Box ExprH] -> (ExprH -> ExprH) -> [ExprH] -> Maybe ExprH+mkAppH (Box e:es)             ops        rs = mkAppH es ops (rs ++ [e])+mkAppH (InfixableExpr e:es)   ops        rs = maybe Nothing (\ lhs ->+                                                mkAppH es (ops . AppH (AppH e lhs)) []+                                                ) (mkAppH' rs)+mkAppH []                     ops rs        = ops <$> mkAppH' rs++mkAppH' :: [ExprH] -> Maybe ExprH+mkAppH' (r:rs) = Just $ foldl AppH r rs+mkAppH' []     = Nothing++--mkAppH (e:es)             = foldl AppH (f e) (map f es)+--  where f (InfixableExpr e) = e+--        f (Box e) = e+++item :: String -> ReadS ()+item str inp =+        [ ((),rest)+        | (tok,rest) <- parseToken inp+        , tok == str+        ]++parseToken :: ReadS String+parseToken []        = []+parseToken ('\n':cs) = [(";",cs)]               -- yes, really+parseToken ('(' :cs) = [("(",cs)]+parseToken (')' :cs) = [(")",cs)]+parseToken ('{' :cs) = [("{",cs)]+parseToken ('}' :cs) = [("}",cs)]+parseToken (';' :cs) = [(";",cs)]+parseToken ('\'':cs) = [("'",cs)]+parseToken ('\"':cs) = [("\"",cs)]+parseToken (c   :cs) | isSpace c = parseToken cs+                     | c == ':'       = [let (a,b) = span isId cs in (c:a,b) ]+                     | isAlphaNum c   = [span isId (c:cs)]+                     | isInfixId c    = [span isInfixId (c:cs)]+parseToken _         = []++---------------------------------------------++isId :: Char -> Bool+isId c = isAlphaNum c || c `elem` "_-"++isInfixId :: Char -> Bool+isInfixId c = c `elem` "+._-:<>"+++---------------------------------------------++

@@ -0,0 +1,319 @@+{-# LANGUAGE TypeFamilies, DeriveDataTypeable, FlexibleContexts,+             GADTs, TypeSynonymInstances, FlexibleInstances #-}++module Language.HERMIT.External+       (+       -- * Externals+         External+       , ExternalName+       , ExternalHelp+       , externName+       , externFun+       , externHelp+       , toDictionary+       , toHelp+       , external+       , Extern(..)+       -- * Tags+       , CmdTag(..)+       , TagE+       , Tag((.+),remTag,tagMatch)+       , (.&)+       , (.||)+       , notT+       , externTags+       , dictionaryOfTags+       -- * Boxes+       -- | Boxes are used by the 'Extern' class.+       , TagBox(..)+       , IntBox(..)+       , RewriteCoreBox(..)+       , TranslateCoreStringBox(..)+       , TranslateCoreCheckBox(..)+       , NameBox(..)+       , TranslateCorePathBox(..)+       , StringBox(..)++) where++import Data.Map hiding (map)+import Data.Dynamic+import Data.List++import qualified Language.Haskell.TH as TH++import Language.HERMIT.Kure++-----------------------------------------------------------------++-- | 'External' names are just strings.+type ExternalName = String++-- | Help information for 'External's is stored as a list of strings, designed for multi-line displaying.+type ExternalHelp = [String]++-- Tags --------------------------------------------------------++-- | Requirement: commands cannot have the same name as any 'CmdTag'+--   (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.+            | Loop           -- ^ Command may operate multiple times.+            | Deep           -- ^ O(n)+            | Shallow        -- ^ O(1)+            | Navigation     -- ^ Uses 'Path' or 'Lens' to focus onto something.+            | Query          -- ^ A question we ask.+            | Predicate      -- ^ Something that passes or fails.+            | Introduce      -- ^ Introduce something, like a new name.+            | Commute        -- ^ It's all about the commute.+            | PreCondition   -- ^ Operation has a precondition.+            | Debug          -- ^ Commands to help debugging.+            | VersionControl -- ^ Version control.+            | Bash           -- ^ Commands that are run by 'Language.HERMIT.Dicitonary.bash'.+            | Context        -- ^ a command that uses its context, like inline+++            | TODO           -- ^ TODO: check before the release.+            | Unimplemented  -- ^ Something is not finished yet, do not use.+            | Experiment     -- ^ Things we are trying out.+++-- Unsure about these+{-+            | Local         -- local thing, O(1)+            | CaseCmd       -- works on case statements+            | Context       -- something that uses the context+            | GHC           -- a tunnel into GHC+            | Lens          -- focuses into a specific node+            | LetCmd        -- works on let statements+            | Meta          -- combines other commands+            | Restful       -- RESTful API commands+            | Slow          -- this command is slow+-}+            -- Other String+            -- etc+    deriving (Eq, Show, Read, Bounded, Enum)++-- | Lists all the tags paired with a short description of what they're about.+dictionaryOfTags :: [(CmdTag,String)]+dictionaryOfTags = notes ++ [ (tag,"(unknown purpose)")+                            | tag <- [minBound..maxBound]+                            , tag `notElem` map fst notes+                            ]+  where notes =+          -- These should give the user a clue about what the sub-commands+          -- might do+          [ (Shell,        "Shell-specific commands")+          , (Eval,         "The arrow of evaluation (reduces a term)")+          , (KURE,         "Commands the directly reflect the KURE DSL")+          , (Loop,        "Command may operate multiple times")+          , (Deep,         "Command may make a deep change, can be O(n)")+          , (Shallow,      "Command operates on local nodes only, O(1)")+          , (Navigation,   "Navigate via focus, or directional command")+          , (Query,        "Questions we ask")+          , (Predicate,    "Something that passes or fails")+          , (Introduce,    "Introduce something, like a new name")+          , (Commute,      "Commute is when you swap nested terms")+          , (PreCondition, "Operation has a (perhaps undocumented) precondition")+          , (Debug,        "Commands specifically to help debugging")+          , (VersionControl,"Version Control for Core Syntax")+          , (Bash,         "Commands that run as part of the bash command.")+          , (Context,      "Commands that use their context, like inlining")++          , (TODO,         "TO BE assessed before a release")+          , (Unimplemented,"Something is not finished yet; do not used")+          , (Experiment,   "Things we are trying out")+          ]+++-- Unfortunately, record update syntax seems to associate to the right.+-- This guy saves us some parentheses.+infixl 3 .++infixr 4 .||+infixr 5 .&++-- | A data type of logical operations on tags.+data TagE :: * where+    Tag    :: Tag a => a -> TagE+    NotTag :: TagE -> TagE+    AndTag :: TagE -> TagE -> TagE+    OrTag  :: TagE -> TagE -> TagE++-- | Tags are meta-data that we add to 'External's to make them sortable and searchable.+class Tag a where+    toTagE :: a -> TagE++    -- | Add a 'Tag' to an 'External'.+    (.+) :: External -> a -> External++    -- | Remove a 'Tag' from an 'External'.+    remTag :: a -> External -> External++    -- | Check if an 'External' has the specified 'Tag'.+    tagMatch :: a -> External -> Bool++instance Tag TagE where+    toTagE = id++    e .+ (Tag t) = e .+ t+    e .+ (NotTag t) = remTag t e+    e .+ (AndTag t1 t2) = e .+ t1 .+ t2+    e .+ (OrTag t1 t2) = e .+ t1 .+ t2 -- not sure what else to do++    remTag (Tag t) e = remTag t e+    remTag (NotTag t) e = e .+ t+    remTag (AndTag t1 t2) e = remTag t1 (remTag t2 e)+    remTag (OrTag t1 t2) e = remTag t1 (remTag t2 e) -- again++    tagMatch (Tag t)        e = tagMatch t e+    tagMatch (NotTag t)     e = not (tagMatch t e)+    tagMatch (AndTag t1 t2) e = tagMatch t1 e && tagMatch t2 e+    tagMatch (OrTag  t1 t2) e = tagMatch t1 e || tagMatch t2 e++instance Tag CmdTag where+    toTagE = Tag+    ex@(External {externTags = ts}) .+ t = ex {externTags = t:ts}+    remTag t ex@(External {externTags = ts}) = ex { externTags = [ t' | t' <- ts, t' /= t ] }+    tagMatch t (External {externTags = ts}) = t `elem` ts++-- | An \"and\" on 'Tag's.+(.&) :: (Tag a, Tag b) => a -> b -> TagE+t1 .& t2 = AndTag (toTagE t1) (toTagE t2)++-- | An \"or\" on 'Tag's.+(.||) :: (Tag a, Tag b) => a -> b -> TagE+t1 .|| t2 = OrTag (toTagE t1) (toTagE t2)++-- how to make a unary operator?+-- | A \"not\" on 'Tag's.+notT :: Tag a => a -> TagE+notT = NotTag . toTagE++-----------------------------------------------------------------++-- | An 'External' is a 'Dynamic' value with some associated meta-data (name, help string and tags).+data External = External+        { externName :: ExternalName        -- ^ Get the name of an 'External'.+        , externFun  :: Dynamic             -- ^ Get the 'Dynamic' value stored in an 'External'.+        , externHelp :: ExternalHelp        -- ^ Get the list of help 'String's for an 'External'.+        , externTags :: [CmdTag]            -- ^ List all the 'CmdTag's associated with an 'External'+        }++-- | The primitive way to build an 'External'.+external :: Extern a => ExternalName -> a -> ExternalHelp -> External+external nm fn help = External+        { externName = nm+        , externFun  = toDyn (box fn)+        , externHelp = map ("  " ++) help+        , externTags = []+        }++-- | Build a 'Data.Map' from names to 'Dynamic' values.+toDictionary :: [External] -> Map ExternalName [Dynamic]+toDictionary+        -- TODO: check names are uniquely-prefixed+              = fromListWith (++) . map toD+  where+         toD :: External -> (ExternalName,[Dynamic])+         toD e = (externName e,[externFun e])++-- | Build a 'Data.Map' from names to help information.+toHelp :: [External] -> Map ExternalName ExternalHelp+toHelp = fromListWith (++) . map toH+  where+         toH :: External -> (ExternalName,ExternalHelp)+         toH e = (externName e, spaceout (externName e ++ " :: " ++ fixup (show (dynTypeRep (externFun e))))+                                         (show (externTags e)) : externHelp e)++         spaceout xs ys = xs ++ replicate (width - (length xs + length ys)) ' ' ++ ys++         width = 78++         fixup :: String -> String+         fixup xs | "Box" `isPrefixOf` xs = fixup (drop 3 xs)+         fixup (x:xs)                     = x : fixup xs+         fixup []                         = []+++-----------------------------------------------------------------++-- | The class of things that can be made into 'External's.+--   To be an 'Extern' there must exist an isomorphic 'Box' type that is an instance of 'Typeable'.+class Typeable (Box a) => Extern a where++    -- | An isomorphic wrapper.+    type Box a++    -- | Wrap a value in a 'Box'.+    box :: a -> Box a++    -- | Unwrap a value from a 'Box'.+    unbox :: Box a -> a++instance (Extern a, Extern b) => Extern (a -> b) where+    type Box (a -> b) = Box a -> Box b+    box f = box . f . unbox+    unbox f = unbox . f . box++data TagBox = TagBox TagE deriving Typeable++instance Extern TagE where+    type Box TagE = TagBox+    box = TagBox+    unbox (TagBox t) = t++data IntBox = IntBox Int deriving Typeable++instance Extern Int where+    type Box Int = IntBox+    box = IntBox+    unbox (IntBox i) = i++data RewriteCoreBox = RewriteCoreBox (RewriteH Core) deriving Typeable++instance Extern (RewriteH Core) where+    type Box (RewriteH Core) = RewriteCoreBox+    box = RewriteCoreBox+    unbox (RewriteCoreBox i) = i++data TranslateCoreStringBox = TranslateCoreStringBox (TranslateH Core String) deriving Typeable++instance Extern (TranslateH Core String) where+    type Box (TranslateH Core String) = TranslateCoreStringBox+    box = TranslateCoreStringBox+    unbox (TranslateCoreStringBox i) = i++data TranslateCoreCheckBox = TranslateCoreCheckBox (TranslateH Core ()) deriving Typeable++instance Extern (TranslateH Core ()) where+    type Box (TranslateH Core ()) = TranslateCoreCheckBox+    box = TranslateCoreCheckBox+    unbox (TranslateCoreCheckBox i) = i++data NameBox = NameBox (TH.Name) deriving Typeable++instance Extern TH.Name where+    type Box TH.Name = NameBox+    box = NameBox+    unbox (NameBox i) = i++data TranslateCorePathBox = TranslateCorePathBox (TranslateH Core Path) deriving Typeable++instance Extern (TranslateH Core Path) where+    type Box (TranslateH Core Path) = TranslateCorePathBox+    box = TranslateCorePathBox+    unbox (TranslateCorePathBox i) = i+++data StringBox = StringBox String deriving Typeable++instance Extern String where+    type Box String = StringBox+    box = StringBox+    unbox (StringBox i) = i++-----------------------------------------------------------------

@@ -0,0 +1,115 @@+module Language.HERMIT.GHC+        (+        -- | Things that have been copied from GHC, or imported directly, for various reasons.+          ppIdInfo+        , thRdrNameGuesses+        , name2THName+        , id2THName+        , cmpTHName2Name+        , cmpTHName2Id+        , unqualifiedIdName+        , findNameFromTH+        , alphaTyVars+        , Type(..)+        , GhcException(..)+        , throwGhcException+        , exprArity+) where++import GhcPlugins++-- hacky direct GHC imports+import Convert (thRdrNameGuesses)+import TysPrim (alphaTyVars)+import TypeRep (Type(..))+import Panic (GhcException(ProgramError), throwGhcException)+import CoreArity++import Data.Maybe (isJust)+import qualified Language.Haskell.TH as TH++--------------------------------------------------------------------------++-- idName :: Id -> Name+-- nameOccName :: Name -> OccName+-- occNameString :: OccName -> String+-- getOccName :: NamedThing a => a -> OccName+-- getName :: NamedThing a => a -> Name+-- getOccString :: NamedThing a => a -> String++-- TH.nameBase :: TH.Name -> String+-- TH.mkName :: String -> TH.Name++-- | 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++-- | Get the unqualified name from an Id/Var.+unqualifiedIdName :: Id -> String+unqualifiedIdName = TH.nameBase . id2THName++-- | 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)++-- | Hacks until we can find the correct way of doing these.+cmpTHName2Id :: TH.Name -> Id -> Bool+cmpTHName2Id nm = cmpTHName2Name nm . idName++-- | This is hopeless O(n), because the we could not generate the 'OccName's that match,+-- for use of the GHC 'OccEnv'.+findNameFromTH :: GlobalRdrEnv -> TH.Name -> [Name]+findNameFromTH rdrEnv nm =+        [ gre_name elt+        | elt <- concat $ occEnvElts rdrEnv+        , cmpTHName2Name nm (gre_name elt)+        ]++-- | Pretty-print an identifier.+ppIdInfo :: Id -> IdInfo -> SDoc+ppIdInfo v info+  = showAttributes+    [ (True, pp_scope <> ppr (idDetails v))+    , (has_arity,      ptext (sLit "Arity=") <> int arity)+    , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)+    , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)+    , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)+    , (not (null rules), ptext (sLit "RULES:") <+> vcat (map ppr rules))+    ]	-- Inline pragma, occ, demand, lbvar info+	-- printed out with all binders (when debug is on);+	-- see PprCore.pprIdBndr+  where+    pp_scope | isGlobalId v   = ptext (sLit "GblId")+    	     | isExportedId v = ptext (sLit "LclIdX")+    	     | otherwise      = ptext (sLit "LclId")++    arity = arityInfo info+    has_arity = arity /= 0++    caf_info = cafInfo info+    has_caf_info = not (mayHaveCafRefs caf_info)++    str_info = strictnessInfo info+    has_strictness = isJust str_info++    unf_info = unfoldingInfo info+    has_unf = hasSomeUnfolding unf_info++    rules = specInfoRules (specInfo info)++showAttributes :: [(Bool,SDoc)] -> SDoc+showAttributes stuff+  | null docs = empty+  | otherwise = brackets (sep (punctuate comma docs))+  where+    docs = [d | (True,d) <- stuff]++--------------------------------------------------------------------------++++

@@ -0,0 +1,67 @@+{-# LANGUAGE KindSignatures, GADTs #-}++module Language.HERMIT.Interp+        ( -- * The HERMIT Interpreter+          Interp+        , interp+        , interpExprH+        ) where++import Control.Monad (liftM2)++import Data.Char+import Data.Dynamic+import qualified Data.Map as M++import qualified Language.Haskell.TH as TH++import Language.HERMIT.External+import Language.HERMIT.Expr++-- | Interpret an 'ExprH' by looking up the appropriate 'Dynamic'(s) in the provided 'Data.Map', then interpreting the 'Dynamic'(s) with the provided 'Interp's, returning the first interpretation to succeed (or an error string if none succeed).+interpExprH :: M.Map String [Dynamic] -> [Interp a] -> ExprH -> Either String a+interpExprH env interps =+          either Left (\ dyns -> runInterp dyns (map (fmap Right) interps) (Left "User error, HERMIT command does not type-check."))+          . interpExpr env++runInterp :: [Dynamic] -> [Interp b] -> b -> b+runInterp dyns interps bad = head $+             [f a+             | Interp f <- interps+             , Just a <- map fromDynamic dyns+             ] ++ [ bad ]++-- | An 'Interp' @a@ is a /possible/ means of converting a 'Typeable' value to a value of type @a@.+data Interp :: * -> * where+   Interp :: Typeable a => (a -> b) -> Interp b++-- | The primitive way of building an 'Interp'.+interp :: Typeable a => (a -> b) -> Interp b+interp = Interp++instance Functor Interp where+   fmap f (Interp g) = Interp (f . g)+++interpExpr :: M.Map String [Dynamic] -> ExprH -> Either String [Dynamic]+interpExpr = interpExpr' False++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 ]+  | Just dyn <- M.lookup str env        = return $ if rhs+                                                     then toDyn (StringBox str) : dyn+                                                     else dyn+  -- not a command, try as a string arg... worst case: dynApply fails with "bad type of expression"+  -- best case: 'help ls' works instead of 'help "ls"'. this is likewise done in then clause above+  | rhs                                 = return [toDyn $ StringBox str]+  | otherwise                           = Left $ "User error, unrecognised HERMIT command: " ++ show str+interpExpr' _ env (AppH e1 e2)              = dynAppMsg (interpExpr' False env e1) (interpExpr' True env e2)++dynAppMsg :: Either String [Dynamic] -> Either String [Dynamic] -> Either String [Dynamic]+dynAppMsg = liftM2 dynApply'+   where+           dynApply' :: [Dynamic] -> [Dynamic] -> [Dynamic]+           dynApply' fs xs = [ r | f <- fs, x <- xs, Just r <- return (dynApply f x)]+

@@ -0,0 +1,122 @@+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, DeriveDataTypeable, TupleSections #-}++module Language.HERMIT.Kernel+        ( -- * The HERMIT Kernel+          AST+        , Kernel+        , hermitKernel+        , resumeK+        , abortK+        , applyK+        , queryK+        , deleteK+        , listK+) where++import Prelude hiding (lookup)++import GhcPlugins hiding (singleton, empty)++import Language.HERMIT.Context+import Language.HERMIT.Monad+import Language.HERMIT.Kure+import Language.HERMIT.GHC++import Data.Map+import Control.Concurrent++-- | A 'Kernel' is a repository for Core syntax trees.+--   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'.+  }++-- | 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))+             | Done (s -> CoreM r)++type KernelState = Map AST (DefStash, ModGuts)++-- | Start a HERMIT client by providing an IO function that takes the initial 'Kernel' and inital 'AST' handle.+--   The 'Modguts' to 'CoreM' Modguts' function required by GHC Plugins is returned.+--   The callback is only ever called once.+hermitKernel :: (Kernel -> AST -> IO ()) -> ModGuts -> CoreM ModGuts+hermitKernel callback modGuts = do++        msgMV :: MVar (Msg KernelState ModGuts) <- liftIO newEmptyMVar++        syntax_names :: MVar AST <- liftIO newEmptyMVar++        _ <- liftIO $ forkIO $ let loop n = do putMVar syntax_names (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)+            sendReq fn = do rep  <- newEmptyMVar+                            putMVar msgMV (Req fn rep)+                            takeMVar rep++        let sendReqRead :: (KernelState -> CoreM (KureMonad a)) -> IO (KureMonad 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++        let kernel :: Kernel+            kernel = Kernel+                { resumeK = \ name -> sendDone $ \ st -> findWithErrMsg name st (\ msg -> throwGhcException $ ProgramError $ msg ++ ", exiting HERMIT and aborting GHC compilation.") (return.snd)++                , 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+                                                                                                               defs+                                                                                                               (\ defs' core' -> do syn' <- liftIO $ takeMVar syntax_names+                                                                                                                                    return $ return (syn', insert syn' (defs',core') st))+                                                                                                               (return . fail)+                                                                                                               (apply (extractR r) (initContext core) core)++                , 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)++                , deleteK = \ name -> sendReqWrite (return . delete name)++                , listK = sendReqRead (return . return . keys) >>= runKureMonad return fail+                }++        -- We always start with syntax blob 0+        syn <- liftIO $ takeMVar syntax_names++        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)+                  Done fn -> fn st++        _pid <- liftIO $ forkIO $ callback kernel syn++        loop (singleton syn (empty, modGuts))++        -- (Kill the pid'd thread? do we need to?)++findWithErrMsg :: AST -> Map AST v -> (String -> b) -> (v -> b) -> b+findWithErrMsg ast m f = find ast m (f $ "Cannot find syntax tree: " ++ show ast)++find :: Ord k => k -> Map k v -> b -> (v -> b) -> b+find k m f s = maybe f s (lookup k m)

@@ -0,0 +1,169 @@+{-# LANGUAGE RankNTypes #-}+module Language.HERMIT.Kernel.Scoped+       (+         Direction(..)+       , LocalPath+       , moveLocally+       , extendLocalPath+       , ScopedKernel(..)+       , SAST(..)+       , scopedKernel+) where++import Control.Concurrent.STM+import Control.Exception.Base (bracketOnError)++import qualified Data.IntMap as I++import GhcPlugins hiding (Direction,L)++import Language.HERMIT.Kure+import Language.HERMIT.Kernel+import Language.HERMIT.Monad++----------------------------------------------------------------------------++-- | A primitive means of denoting navigation of a tree (within a local scope).+data Direction = L -- ^ Left+               | R -- ^ Right+               | U -- ^ Up+               | D -- ^ Down+               | T -- ^ Top+               deriving (Eq,Show)++-- | The path within the current local scope.+newtype LocalPath = LocalPath [Int] deriving Eq++instance Show LocalPath where+  show (LocalPath p) = show (reverse p)++-- | An empty 'LocalPath'.+emptyLocalPath :: LocalPath+emptyLocalPath = LocalPath []++-- | Convert between path representations.+localPath2Path :: LocalPath -> Path+localPath2Path (LocalPath p) = reverse p++-- Convert between path representations.+-- path2LocalPath :: Path -> LocalPath+-- path2LocalPath p = LocalPath (reverse p)++localPaths2Paths :: [LocalPath] -> [Path]+localPaths2Paths = reverse . map localPath2Path++-- | Movement confined within the local scope.+moveLocally :: Direction -> LocalPath -> LocalPath+moveLocally D (LocalPath ns)             = LocalPath (0:ns)+moveLocally U (LocalPath (_:ns))         = LocalPath ns+moveLocally L (LocalPath (n:ns)) | n > 0 = LocalPath ((n-1):ns)+moveLocally R (LocalPath (n:ns))         = LocalPath ((n+1):ns)+moveLocally T _                          = LocalPath []+moveLocally _ p                          = p++-- | Add a 'Path' to the end of a 'LocalPath'.+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)++----------------------------------------------------------------------------++-- | An alternative HERMIT kernel, that provides scoping.+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)+        , deleteS     ::            SAST                                              -> IO ()+        , listS       ::                                                                 IO [SAST]+        , pathS       ::            SAST                                              -> IO [Path]+        , modPathS    ::            SAST -> (LocalPath -> LocalPath)  -> HermitMEnv   -> IO (KureMonad SAST)+        , beginScopeS ::            SAST                                              -> IO SAST+        , endScopeS   ::            SAST                                              -> IO SAST+        }++-- | A /handle/ for an 'AST' combined with scoping information.+newtype SAST = SAST Int deriving (Eq, Ord, Show)++-- path stack, representing the base path, then the relative path+type SASTStore = I.IntMap (AST, [LocalPath], LocalPath)++get :: Monad m => Int -> SASTStore -> m (AST, [LocalPath], LocalPath)+get sAst m = maybe (fail "scopedKernel: invalid SAST") return (I.lookup sAst m)++safeTakeTMVar :: TMVar a -> (a -> IO b) -> IO b+safeTakeTMVar mvar = bracketOnError (atomically $ takeTMVar mvar) (atomically . putTMVar mvar)++-- | Start a HERMIT client by providing an IO function that takes the initial 'ScopedKernel' and inital 'SAST' handle.+--   The 'Modguts' to 'CoreM' Modguts' function required by GHC Plugins is returned.+scopedKernel :: (ScopedKernel -> SAST -> IO ()) -> ModGuts -> CoreM ModGuts+scopedKernel callback = hermitKernel $ \ kernel initAST -> do+    store <- newTMVarIO $ I.fromList [(0,(initAST, [], emptyLocalPath))]+    key <- newTMVarIO (1::Int)++    let failCleanup :: SASTStore -> String -> IO (KureMonad a)+        failCleanup m msg = atomically $ do putTMVar store m+                                            return $ fail msg++    let newKey = do+            k <- takeTMVar key+            putTMVar key (k+1)+            return k++        skernel = ScopedKernel+            { resumeS     = \ (SAST sAst) -> do+                                m <- atomically $ readTMVar store+                                (ast,_,_) <- get sAst m+                                resumeK kernel ast+            , abortS      = abortK kernel+            , 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)+                                                   (failCleanup m)+            , queryS      = \ (SAST sAst) t env -> do+                                m <- atomically $ readTMVar store+                                (ast, base, rel) <- get sAst m+                                queryK kernel ast (focusT (pathStackToLens base rel) t) env+            , deleteS     = \ (SAST sAst) -> atomically $ do+                                m <- takeTMVar store+                                putTMVar store $ I.delete sAst m+            , listS       = do m <- atomically $ readTMVar store+                               return [ SAST sAst | sAst <- I.keys m ]+            , pathS       = \ (SAST sAst) -> atomically $ do+                                m <- readTMVar store+                                (_, base, rel) <- get sAst m+                                return $ localPaths2Paths (rel : base)+            , modPathS    = \ (SAST sAst) f env -> safeTakeTMVar store $ \ m -> do+                                (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.")+                                                   (failCleanup m)+            , beginScopeS = \ (SAST sAst) -> atomically $ do+                                m <- takeTMVar store+                                (ast, base, rel) <- get sAst m+                                k <- newKey+                                putTMVar store $ I.insert k (ast, rel : base, emptyLocalPath) m+                                return $ SAST k+            , endScopeS   = \ (SAST sAst) -> atomically $ do+                                m <- takeTMVar store+                                (ast, base, _) <- get sAst m+                                case base of+                                    []          -> fail "Scoped Kernel: no scope to end."+                                    rel : base' -> do k <- newKey+                                                      putTMVar store $ I.insert k (ast, base', rel) m+                                                      return $ SAST k+            }++    callback skernel $ SAST 0

@@ -0,0 +1,762 @@+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances, FlexibleContexts, TupleSections #-}++module Language.HERMIT.Kure+       (+       -- * KURE Modules++       -- | 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+       -- * 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+       -- ** Binding Groups+       , nonRecT, nonRecR+       , recT, recAllR, recAnyR, recOneR+       -- ** Recursive Definitions+       , defT, defR+       -- ** Case Alternatives+       , altT, altR+       -- ** Expressions+       , varT+       , litT+       , appT, appAllR, appAnyR, appOneR+       , lamT, lamR+       , letT, letAllR, letAnyR, letOneR+       , caseT, caseAllR, caseAnyR, caseOneR+       , castT, castR+       , tickT, tickR+       , typeT+       , coercionT+       -- ** Composite Congruence Combinators+       , recDefT, recDefAllR, recDefAnyR, recDefOneR+       , letNonRecT, letNonRecAllR, letNonRecAnyR, letNonRecOneR+       , letRecT, letRecAllR, letRecAnyR, letRecOneR+       , letRecDefT, letRecDefAllR, letRecDefAnyR, letRecDefOneR+       , consNonRecT, consNonRecAllR, consNonRecAnyR, consNonRecOneR+       , consRecT, consRecAllR, consRecAnyR, consRecOneR+       , consRecDefT, consRecDefAllR, consRecDefAnyR, consRecDefOneR+       , caseAltT, caseAltAllR, caseAltAnyR, caseAltOneR+       -- * Promotion Combinators+       -- ** Rewrite Promotions+       , promoteModGutsR+       , promoteProgramR+       , promoteBindR+       , promoteDefR+       , promoteExprR+       , promoteAltR+       -- ** Translate Promotions+       , promoteModGutsT+       , promoteProgramT+       , promoteBindT+       , promoteDefT+       , promoteExprT+       , promoteAltT+       )+where++import GhcPlugins hiding (empty)++import Language.KURE+import Language.KURE.Injection+import Language.KURE.Utilities++import Language.HERMIT.CoreExtra+import Language.HERMIT.Context+import Language.HERMIT.Monad++import Control.Applicative+import qualified Control.Category++import Data.Monoid++---------------------------------------------------------------------++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++-- | A synonym for the identity rewrite.  Convienient to avoid importing Control.Category.+idR :: RewriteH a+idR = Control.Category.id++---------------------------------------------------------------------++instance Node Core where+  type Generic Core = Core++  numChildren (ModGutsCore x) = numChildren x+  numChildren (ProgramCore x) = numChildren x+  numChildren (BindCore x)    = numChildren x+  numChildren (DefCore x)     = numChildren x+  numChildren (ExprCore x)    = numChildren x+  numChildren (AltCore x)     = numChildren x++-- 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+          ModGutsCore x -> childLgeneric n c x+          ProgramCore 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+          ModGutsCore x -> allTgeneric t c x+          ProgramCore 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+          ModGutsCore x -> oneTgeneric t c x+          ProgramCore 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+          ModGutsCore x -> allRgeneric r c x+          ProgramCore 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+          ModGutsCore x -> anyRgeneric r c x+          ProgramCore 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+          ModGutsCore x -> oneRgeneric r c x+          ProgramCore x -> oneRgeneric r c x+          BindCore x    -> oneRgeneric r c x+          DefCore x     -> oneRgeneric r c x+          ExprCore x    -> oneRgeneric r c x+          AltCore x     -> oneRgeneric r c x++---------------------------------------------------------------------++instance Injection ModGuts Core where+  inject                     = ModGutsCore+  retract (ModGutsCore guts) = Just guts+  retract _                  = Nothing++instance Node ModGuts where+  type Generic ModGuts = Core++  numChildren _ = 1++instance Walker Context HermitM ModGuts where+  childL 0 = lens $ modGutsT exposeT (childL1of2 $ \ modguts bds -> modguts {mg_binds = bds})+  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)++-- | Rewrite the 'CoreProgram' child of a module.+modGutsR :: RewriteH CoreProgram -> RewriteH ModGuts+modGutsR r = modGutsT r (\ modguts bds -> modguts {mg_binds = bds})++---------------------------------------------------------------------++instance Injection CoreProgram Core where+  inject                    = ProgramCore+  retract (ProgramCore bds) = Just bds+  retract _                 = Nothing++instance Node CoreProgram where+  type Generic CoreProgram = Core++  -- we consider only the head and tail to be interesting children+  numChildren bds = min 2 (length bds)++instance Walker Context HermitM CoreProgram where+  childL 0 = lens $ consBindT exposeT idR (childL0of2 (:))+  childL 1 = lens $ consBindT idR exposeT (childL1of2 (:))+  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 []"++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"++-- | 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)++-- | 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 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 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 (:))++---------------------------------------------------------------------++instance Injection CoreBind Core where+  inject                  = BindCore+  retract (BindCore bnd)  = Just bnd+  retract _               = Nothing++instance Node CoreBind where+  type Generic CoreBind = Core++  numChildren (NonRec _ _) = 1+  numChildren (Rec defs)   = length defs++instance Walker Context HermitM CoreBind where+  childL n = lens $ setFailMsg (missingChild n) $+               case n of+                 0 -> nonrec <+ rec+                 _ -> rec++    where+      nonrec = nonRecT exposeT (childL1of2 NonRec)+      rec    = whenM (hasChildT n) $+                  recT (const exposeT) (childLMofN n defToRecBind)++  allT t = nonRecT (extractT t) (\ _ -> id)+        <+ recT (\ _ -> extractT t) mconcat++  oneT t = nonRecT (extractT t) (\ _ -> id)+        <+ recT' (\ _ -> extractT t) catchesM++  allR r = nonRecR (extractR r)+        <+ recAllR (\ _ -> extractR r)++  anyR r = nonRecR (extractR r)+        <+ recAnyR (\ _ -> extractR r)++  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"++-- | Rewrite the 'CoreExpr' child of a binding group of the form: @NonRec@ 'Id' '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.+                    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..]+                          ]+         _       -> fail "not Rec constructor"++-- | Translate a binding group of the form: @Rec@ ['CoreDef']+recT :: (Int -> TranslateH CoreDef a) -> ([a] -> b) -> TranslateH CoreBind b+recT ts f = recT' ts (fmap f . sequence)++-- | Rewrite all children of a binding group of the form: @Rec@ ['CoreDef']+recAllR :: (Int -> RewriteH CoreDef) -> RewriteH CoreBind+recAllR rs = recT rs defToRecBind++-- | 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)++-- | 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)++---------------------------------------------------------------------++instance Injection CoreDef Core where+  inject                = DefCore+  retract (DefCore def) = Just def+  retract _             = Nothing++instance Node CoreDef where+  type Generic CoreDef = Core++  numChildren _ = 1++instance Walker Context HermitM CoreDef where+  childL 0 = lens $ defT exposeT (childL1of2 Def)+  childL n = failT (missingChild n)++-- | Translate a recursive definition of the form: @Def@ 'Id' 'CoreExpr'+defT :: TranslateH CoreExpr a -> (Id -> a -> b) -> TranslateH CoreDef b+defT t f = translate $ \ c (Def v e) -> f v <$> apply t (c @@ 0) e++-- | Rewrite the 'CoreExpr' child of a recursive definition of the form: @Def@ 'Id' 'CoreExpr'+defR :: RewriteH CoreExpr -> RewriteH CoreDef+defR r = defT r Def++---------------------------------------------------------------------++instance Injection CoreAlt Core where+  inject                 = AltCore+  retract (AltCore expr) = Just expr+  retract _              = Nothing++instance Node CoreAlt where+  type Generic CoreAlt = Core++  numChildren _ = 1++instance Walker Context HermitM CoreAlt where+  childL 0 = lens $ altT exposeT (childL2of3 (,,))+  childL n = failT (missingChild n)++-- | Translate a case alternative of the form: ('AltCon', ['Id'], 'CoreExpr')+altT :: TranslateH CoreExpr a -> (AltCon -> [Id] -> a -> b) -> TranslateH CoreAlt b+altT t f = translate $ \ c (con,bs,e) -> f con bs <$> apply t (addAltBindings bs c @@ 0) e++-- | Rewrite the 'CoreExpr' child of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr')+altR :: RewriteH CoreExpr -> RewriteH CoreAlt+altR r = altT r (,,)++---------------------------------------------------------------------++instance Injection CoreExpr Core where+  inject                  = ExprCore+  retract (ExprCore expr) = Just expr+  retract _               = Nothing++instance Node CoreExpr where+  type Generic CoreExpr = Core++  numChildren (Var _)         = 0+  numChildren (Lit _)         = 0+  numChildren (App _ _)       = 2+  numChildren (Lam _ _)       = 1+  numChildren (Let _ _)       = 2+  numChildren (Case _ _ _ es) = 1 + length es+  numChildren (Cast _ _)      = 1+  numChildren (Tick _ _)      = 1+  numChildren (Type _)        = 0+  numChildren (Coercion _)    = 0++instance Walker Context HermitM CoreExpr where++  childL n = lens $ setFailMsg (missingChild n) $+               case n of+                 0  ->    appT  exposeT idR         (childL0of2 App)+                       <+ lamT  exposeT             (childL1of2 Lam)+                       <+ letT  exposeT idR         (childL0of2 Let)+                       <+ caseT exposeT (const idR) (childL0of4 Case)+                       <+ castT exposeT             (childL0of2 Cast)+                       <+ tickT exposeT             (childL1of2 Tick)++                 1  ->    appT idR exposeT (childL1of2 App)+                       <+ letT idR exposeT (childL1of2 Let)+                       <+ caseChooseL++                 _  ->    caseChooseL+     where+       -- Note we use index (n-1) because 0 refers to the expression being scrutinised.+       caseChooseL = whenM (hasChildT n) $+                           caseT idR (const exposeT) (\ e v t -> childLMofN (n-1) (Case e v t))++  allT t = varT (\ _ -> mempty)+        <+ litT (\ _ -> mempty)+        <+ appT (extractT t) (extractT t) mappend+        <+ lamT (extractT t) (\ _ -> id)+        <+ letT (extractT t) (extractT t) mappend+        <+ caseT (extractT t) (\ _ -> extractT t) (\ r _ _ rs -> mconcat (r:rs))+        <+ castT (extractT t) const+        <+ tickT (extractT t) (\ _ -> id)+        <+ typeT (\ _ -> mempty)+        <+ coercionT (\ _ -> mempty)++  oneT t = appT' (extractT t) (extractT t) (<<+)+        <+ lamT (extractT t) (\ _ -> id)+        <+ letT' (extractT t) (extractT t) (<<+)+        <+ caseT' (extractT t) (\ _ -> extractT t) (\ _ _ r rs -> catchesM (r:rs))+        <+ castT (extractT t) const+        <+ tickT (extractT t) (\ _ -> id)++  allR r = varT Var+        <+ litT Lit+        <+ appAllR (extractR r) (extractR r)+        <+ lamR (extractR r)+        <+ letAllR (extractR r) (extractR r)+        <+ caseAllR (extractR r) (\ _ -> extractR r)+        <+ castR (extractR r)+        <+ tickR (extractR r)+        <+ typeT Type+        <+ coercionT Coercion++  anyR r = appAnyR (extractR r) (extractR r)+        <+ lamR (extractR r)+        <+ letAnyR (extractR r) (extractR r)+        <+ caseAnyR (extractR r) (\ _ -> extractR r)+        <+ castR (extractR r)+        <+ tickR (extractR r)+        <+ fail "anyR failed"++  oneR r = appOneR (extractR r) (extractR r)+        <+ lamR (extractR r)+        <+ letOneR (extractR r) (extractR r)+        <+ caseOneR (extractR r) (\ _ -> extractR r)+        <+ castR (extractR r)+        <+ tickR (extractR r)+        <+ fail "oneR failed"++---------------------------------------------------------------------++-- | 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: @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"+++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"++-- | Translate an expression of the form: @App@ 'CoreExpr' 'CoreExpr'+appT :: TranslateH CoreExpr a1 -> TranslateH CoreExpr a2 -> (a1 -> a2 -> b) -> TranslateH CoreExpr b+appT t1 t2 = appT' t1 t2 . liftA2++-- | Rewrite all children of an expression of the form: @App@ 'CoreExpr' 'CoreExpr'+appAllR :: RewriteH CoreExpr -> RewriteH CoreExpr -> RewriteH CoreExpr+appAllR r1 r2 = appT r1 r2 App++-- | Rewrite any children of an expression of the form: @App@ 'CoreExpr' 'CoreExpr'+appAnyR :: RewriteH CoreExpr -> RewriteH CoreExpr -> RewriteH CoreExpr+appAnyR r1 r2 = appT' (attemptR r1) (attemptR r2) (attemptAny2 App)++-- | Rewrite one child of an expression of the form: @App@ 'CoreExpr' 'CoreExpr'+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"++-- | Rewrite the 'CoreExpr' child of an expression of the form: @Lam@ 'Id' '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)+                -- use *original* env, because the bindings are self-binding,+                -- if they are recursive. See recT'.+        _         -> fail "no match for Let"++-- | Translate an expression of the form: @Let@ 'CoreBind' 'CoreExpr'+letT :: TranslateH CoreBind a1 -> TranslateH CoreExpr a2 -> (a1 -> a2 -> b) -> TranslateH CoreExpr b+letT t1 t2 = letT' t1 t2 . liftA2++-- | Rewrite all children of an expression of the form: @Let@ 'CoreBind' 'CoreExpr'+letAllR :: RewriteH CoreBind -> RewriteH CoreExpr -> RewriteH CoreExpr+letAllR r1 r2 = letT r1 r2 Let++-- | Rewrite any children of an expression of the form: @Let@ 'CoreBind' 'CoreExpr'+letAnyR :: RewriteH CoreBind -> RewriteH CoreExpr -> RewriteH CoreExpr+letAnyR r1 r2 = letT' (attemptR r1) (attemptR r2) (attemptAny2 Let)++-- | Rewrite one child of an expression of the form: @Let@ 'CoreBind' 'CoreExpr'+letOneR :: RewriteH CoreBind -> RewriteH CoreExpr -> RewriteH CoreExpr+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"++-- | 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 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']+caseAllR :: RewriteH CoreExpr -> (Int -> RewriteH CoreAlt) -> RewriteH CoreExpr+caseAllR r rs = caseT r rs Case++-- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']+caseAnyR :: RewriteH CoreExpr -> (Int -> RewriteH CoreAlt) -> RewriteH CoreExpr+caseAnyR r rs = caseT' (attemptR r) (attemptR . rs) (\ b ty -> attemptAny1N (\ e -> Case e b ty))++-- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']+caseOneR :: RewriteH CoreExpr -> (Int -> RewriteH CoreAlt) -> RewriteH CoreExpr+caseOneR r rs = caseT' (withArgumentT r) (withArgumentT . rs) (\ b ty -> attemptOne1N (\ e -> Case e b ty))++-- | 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"++-- | Rewrite the 'CoreExpr' child of an expression of the form: @Cast@ 'CoreExpr' 'Coercion'+castR :: RewriteH CoreExpr -> RewriteH CoreExpr+castR r = castT r Cast++-- | 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"++-- | Rewrite the 'CoreExpr' child of an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr'+tickR :: RewriteH CoreExpr -> RewriteH CoreExpr+tickR r = tickT r Tick++-- | 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"++-- | 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"++---------------------------------------------------------------------++-- Some composite congruence combinators to export.++-- | Translate a binding group of the form: @Rec@ [('Id', 'CoreExpr')]+recDefT :: (Int -> TranslateH CoreExpr a1) -> ([(Id,a1)] -> b) -> TranslateH CoreBind b+recDefT ts = recT (\ n -> defT (ts n) (,))++-- | Rewrite all children of a binding group of the form: @Rec@ [('Id', 'CoreExpr')]+recDefAllR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreBind+recDefAllR rs = recAllR (\ n -> defR (rs n))++-- | Rewrite any children of a binding group of the form: @Rec@ [('Id', 'CoreExpr')]+recDefAnyR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreBind+recDefAnyR rs = recAnyR (\ n -> defR (rs n))++-- | Rewrite one child of a binding group of the form: @Rec@ [('Id', 'CoreExpr')]+recDefOneR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreBind+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)++-- | 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 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 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+++-- | 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++-- | 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 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 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+++-- | 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+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+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+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+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+letNonRecT t1 t2 f = letT (nonRecT t1 (,)) t2 (uncurry f)++-- | Rewrite all children of an expression of the form: @Let@ (@NonRec@ 'Id' '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'+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'+letNonRecOneR :: RewriteH CoreExpr -> RewriteH CoreExpr -> RewriteH CoreExpr+letNonRecOneR r1 r2 = letOneR (nonRecR r1) r2+++-- | Translate an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'+letRecT :: (Int -> TranslateH CoreDef a1) -> TranslateH CoreExpr a2 -> ([a1] -> a2 -> b) -> TranslateH CoreExpr b+letRecT ts t = letT (recT ts id) t++-- | Rewrite all children of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'+letRecAllR :: (Int -> RewriteH CoreDef) -> RewriteH CoreExpr -> RewriteH CoreExpr+letRecAllR rs r = letAllR (recAllR rs) r++-- | Rewrite any children of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'+letRecAnyR :: (Int -> RewriteH CoreDef) -> RewriteH CoreExpr -> RewriteH CoreExpr+letRecAnyR rs r = letAnyR (recAnyR rs) r++-- | Rewrite one child of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'+letRecOneR :: (Int -> RewriteH CoreDef) -> RewriteH CoreExpr -> RewriteH CoreExpr+letRecOneR rs r = letOneR (recOneR rs) r+++-- | Translate an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'+letRecDefT :: (Int -> TranslateH CoreExpr a1) -> TranslateH CoreExpr a2 -> ([(Id,a1)] -> a2 -> b) -> TranslateH CoreExpr b+letRecDefT ts t = letRecT (\ n -> defT (ts n) (,)) t++-- | Rewrite all children of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'+letRecDefAllR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreExpr -> RewriteH CoreExpr+letRecDefAllR rs r = letRecAllR (\ n -> defR (rs n)) r++-- | Rewrite any children of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'+letRecDefAnyR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreExpr -> RewriteH CoreExpr+letRecDefAnyR rs r = letRecAnyR (\ n -> defR (rs n)) r++-- | Rewrite one child of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'+letRecDefOneR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreExpr -> RewriteH CoreExpr+letRecDefOneR rs r = letRecOneR (\ n -> defR (rs n)) r+++-- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Id'], 'CoreExpr')]+caseAltT :: TranslateH CoreExpr a1 -> (Int -> TranslateH CoreExpr a2) -> (a1 -> Id -> Type -> [(AltCon,[Id],a2)] -> b) -> TranslateH CoreExpr b+caseAltT t ts = caseT t (\ n -> altT (ts n) (,,))++-- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Id'], 'CoreExpr')]+caseAltAllR :: RewriteH CoreExpr -> (Int -> RewriteH CoreExpr) -> RewriteH CoreExpr+caseAltAllR t ts = caseAllR t (\ n -> altR (ts n))++-- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Id'], 'CoreExpr')]+caseAltAnyR :: RewriteH CoreExpr -> (Int -> RewriteH CoreExpr) -> RewriteH CoreExpr+caseAltAnyR t ts = caseAnyR t (\ n -> altR (ts n))++-- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Id'], 'CoreExpr')]+caseAltOneR :: RewriteH CoreExpr -> (Int -> RewriteH CoreExpr) -> RewriteH CoreExpr+caseAltOneR t ts = caseOneR t (\ n -> altR (ts n))++---------------------------------------------------------------------++-- | Promote a rewrite on 'ModGuts' to a rewrite on 'Core'.+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 'CoreBind' to a rewrite on 'Core'.+promoteBindR :: RewriteH CoreBind -> RewriteH Core+promoteBindR = promoteWithFailMsgR "This rewrite can only succeed at binding group nodes."++-- | Promote a rewrite on 'CoreDef' to a rewrite on 'Core'.+promoteDefR :: RewriteH CoreDef -> RewriteH Core+promoteDefR = promoteWithFailMsgR "This rewrite can only succeed at recursive definition nodes."++-- | Promote a rewrite on 'CoreAlt' to a rewrite on 'Core'.+promoteAltR :: RewriteH CoreAlt -> RewriteH Core+promoteAltR = promoteWithFailMsgR "This rewrite can only succeed at case alternative nodes."++-- | Promote a rewrite on 'CoreExpr' to a rewrite on 'Core'.+promoteExprR :: RewriteH CoreExpr -> RewriteH Core+promoteExprR = promoteWithFailMsgR "This rewrite can only succeed at expression nodes."++---------------------------------------------------------------------++-- | Promote a translate on 'ModGuts' to a translate on 'Core'.+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 'CoreBind' to a translate on 'Core'.+promoteBindT :: TranslateH CoreBind b -> TranslateH Core b+promoteBindT = promoteWithFailMsgT "This translate can only succeed at binding group nodes."++-- | Promote a translate on 'CoreDef' to a translate on 'Core'.+promoteDefT :: TranslateH CoreDef b -> TranslateH Core b+promoteDefT = promoteWithFailMsgT "This translate can only succeed at recursive definition nodes."++-- | Promote a translate on 'CoreAlt' to a translate on 'Core'.+promoteAltT :: TranslateH CoreAlt b -> TranslateH Core b+promoteAltT = promoteWithFailMsgT "This translate can only succeed at case alternative nodes."++-- | Promote a translate on 'CoreExpr' to a translate on 'Core'.+promoteExprT :: TranslateH CoreExpr b -> TranslateH Core b+promoteExprT = promoteWithFailMsgT "This translate can only succeed at expression nodes."++---------------------------------------------------------------------

@@ -0,0 +1,163 @@+{-# LANGUAGE TupleSections, GADTs, KindSignatures #-}++module Language.HERMIT.Monad+          (+            -- * The HERMIT Monad+            HermitM+          , runHM+          , liftCoreM+          , newVarH+          , newTypeVarH+          , cloneIdH+            -- * Saving Definitions+          , Label+          , DefStash+          , saveDef+          , lookupDef+          , getStash+          , HermitMEnv(..)+          , DebugMessage(..)+          , mkHermitMEnv+          , sendDebugMessage+) where++import Prelude hiding (lookup)++import Data.Map++import GhcPlugins hiding (empty)+import MonadUtils       -- from GHC++import Control.Monad+import Control.Arrow++import Language.KURE.Combinators+import Language.KURE.Utilities++import Language.HERMIT.CoreExtra+import Language.HERMIT.Context++----------------------------------------------------------------------------++-- | A label for individual defintions.+type Label = String++-- | A store of saved definitions.+type DefStash = Map Label CoreDef++-- | A way of sending messages to top level+newtype HermitMEnv = HermitMEnv { hs_debugChan :: DebugMessage -> HermitM () }++-- | The HERMIT monad is kept abstract.+newtype HermitM a = HermitM (HermitMEnv -> DefStash -> CoreM (KureMonad (DefStash, a)))++runHermitM :: HermitM a -> HermitMEnv -> DefStash -> CoreM (KureMonad (DefStash, a))+runHermitM (HermitM f) = f++getStash :: HermitM DefStash+getStash = HermitM (\ _ s -> return $ return (s, s))++putStash :: DefStash -> HermitM ()+putStash s = HermitM (\ _ _ -> return $ return (s, ()))++sendDebugMessage :: DebugMessage -> HermitM ()+sendDebugMessage msg =+        do env <- HermitM $ \ ch s -> return $ return (s, ch)+           hs_debugChan env msg++-- | Save a definition for future use.+saveDef :: Label -> CoreDef -> HermitM ()+saveDef l d = getStash >>= (insert l d >>> putStash)++-- | Lookup a previously saved definition.+lookupDef :: Label -> HermitM CoreDef+lookupDef l = getStash >>= (lookup l >>> maybe (fail "Definition not found.") return)++-- | 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++----------------------------------------------------------------------------++instance Functor HermitM where+-- fmap :: (a -> b) -> HermitM a -> HermitM b+   fmap = liftM++instance Applicative HermitM where+-- pure :: a -> HermitM a+   pure  = return++-- (<*>) :: HermitM (a -> b) -> HermitM a -> HermitM b+   (<*>) = ap++instance Monad HermitM where+-- return :: a -> HermitM a+   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)++-- 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)++----------------------------------------------------------------------------++-- | 'CoreM' can be lifted to 'HermitM'.+liftCoreM :: CoreM a -> HermitM a+liftCoreM ma = HermitM $ \ _ s -> do a <- ma+                                     return (return (s,a))++instance MonadIO HermitM where+   liftIO = liftCoreM . liftIO++instance MonadUnique HermitM where+   getUniqueSupplyM = liftCoreM getUniqueSupplyM++instance MonadThings HermitM where+   lookupThing = liftCoreM . lookupThing++----------------------------------------------------------------------------++newName :: String -> HermitM 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++-- | 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+++-- 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+        in+          case (isTyVar b) of+            True -> newTypeVarH name ty+            _    -> newVarH name ty++----------------------------------------------------------------------------++-- | A message packet.+data DebugMessage :: * where+        DebugTick    :: String                    -> DebugMessage+        DebugCore    :: String -> Context -> Core -> DebugMessage       -- A postcard++mkHermitMEnv :: (DebugMessage -> HermitM ()) -> HermitMEnv+mkHermitMEnv debugger = HermitMEnv+                { hs_debugChan = debugger+                }

@@ -0,0 +1,42 @@+module Language.HERMIT.Plugin+       ( -- * The HERMIT Plugin+         HermitPass+       , hermitPlugin+)  where++import GhcPlugins+import Data.List+import System.IO++-- | Given a list of 'CommandLineOption's, produce the 'ModGuts' to 'ModGuts' function required to build a plugin.+type HermitPass = [CommandLineOption] -> ModGuts -> CoreM ModGuts++-- | Build a hermit plugin. This mainly handles the per-module options.+hermitPlugin :: HermitPass -> Plugin+hermitPlugin hp = defaultPlugin { installCoreToDos = install }+    where+        install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+        install opts todos = do+            reinitializeGlobals++            -- This is a bit of a hack; otherwise we lose what we've not seen+            liftIO $ hSetBuffering stdout NoBuffering++            let+                myPass = CoreDoPluginPass "HERMIT" $ modFilter hp opts+                -- at front, for now+                allPasses = myPass : todos++            return allPasses++-- | Determine whether to act on this module, choose plugin pass.+modFilter :: HermitPass -> HermitPass+modFilter hp opts guts | null modOpts && not (null opts) = return guts -- don't process this module+                       | otherwise    = hp modOpts guts+    where modOpts = filterOpts opts guts++-- | Filter options to those pertaining to this module, stripping module prefix.+filterOpts :: [CommandLineOption] -> ModGuts -> [CommandLineOption]+filterOpts opts guts = [ drop len nm | nm <- opts, modName `isPrefixOf` nm ]+    where modName = showSDoc (ppr $ mg_module guts)+          len = length modName + 1 -- for the colon

@@ -0,0 +1,391 @@+{-# LANGUAGE FlexibleInstances #-}++module Language.HERMIT.PrettyPrinter where++import GhcPlugins hiding ((<>))++import Text.PrettyPrint.MarkedHughesPJ as PP+import Language.HERMIT.Kure+import Control.Arrow+import Data.Monoid hiding ((<>))+import Data.Default+import Data.Char+import qualified Data.Map as M+import System.IO+++-- A HERMIT document+type DocH = MDoc HermitMark++-- These are the zero-width marks on the document+data HermitMark+        = PushAttr Attr+        | PopAttr+    deriving Show++-- These are the attributes+data Attr = PathAttr Path+          | Color SyntaxForColor+          | SpecialFont+    deriving Show++data SyntaxForColor             -- (suggestion)+        = KeywordColor          -- bold+        | SyntaxColor+        | VarColor+        | TypeColor+        | LitColor+    deriving Show++attr :: Attr -> DocH -> DocH+attr a p = mark (PushAttr a) <> p <> mark PopAttr++-- Hack, till we get 'PathAttr' working properly+-- The problem is that attributes span over multiple lines,+-- messing up the latex output++attrP :: Path -> DocH -> DocH+attrP _ doc = doc -- attr . PathAttr++varColor :: DocH -> DocH+varColor = attr (Color VarColor)++keywordColor :: DocH -> DocH+keywordColor = attr (Color KeywordColor)++markColor :: SyntaxForColor -> DocH -> DocH+markColor = attr . Color++specialFont :: DocH -> DocH+specialFont = attr SpecialFont+++type PrettyH a = TranslateH a DocH++-- These are *recommendations* to the pretty printer.++data PrettyOptions = PrettyOptions+        { po_fullyQualified  :: Bool            -- Do you show fully qualified names?+        , po_exprTypes       :: ShowOption      -- Do you hide types, and type arguments, as <>?+        , po_typesForBinders :: ShowOption      -- Do you give the types for all bindings?+        , po_highlight       :: Maybe Path      -- This region should be highlighted (for sub-expression)+        , po_depth           :: Maybe Int       -- below this depth are ..., Nothing => infinite+        , po_notes           :: Bool            -- ^ notes might be added to output+        , po_ribbon          :: Float+        , po_width           :: Int+        } deriving Show++data ShowOption = Show | Abstract | Omit+        deriving (Eq, Ord, Show, Read)++instance Default PrettyOptions where+  def = PrettyOptions+        { po_fullyQualified  = False+        , po_exprTypes       = Abstract+        , po_typesForBinders = Omit+        , po_highlight       = Nothing+        , po_depth           = Nothing+        , po_notes           = False+        , po_ribbon          = 1.2+        , po_width           = 80+        }++-----------------------------------------------------------------++-- The characters for special symbols, which have a special alphabet++data SpecialSymbol+        = LambdaSymbol+        | TypeOfSymbol+        | RightArrowSymbol+        | TypeSymbol+        | TypeBindSymbol+        | ForallSymbol+        deriving (Show, Eq, Ord, Bounded, Enum)++class RenderSpecial a where+        renderSpecial :: SpecialSymbol -> a+++instance RenderSpecial Char where+        renderSpecial LambdaSymbol        = '\\'  -- lambda+        renderSpecial TypeOfSymbol        = ':'   -- ::+        renderSpecial RightArrowSymbol    = '>'   -- ->+        renderSpecial TypeSymbol          = 'T'   -- <<type>>>+        renderSpecial TypeBindSymbol      = 'a'   -- a+        renderSpecial ForallSymbol      = 'F'   -- forall++newtype ASCII = ASCII String++instance Monoid ASCII where+        mempty = ASCII ""+        mappend (ASCII xs) (ASCII ys) = ASCII (xs ++ ys)++instance RenderSpecial ASCII where+        renderSpecial LambdaSymbol        = ASCII "\\"  -- lambda+        renderSpecial TypeOfSymbol        = ASCII "::"   -- ::+        renderSpecial RightArrowSymbol    = ASCII "->"   -- ->+        renderSpecial TypeSymbol          = ASCII "*"   -- <<type>>>+        renderSpecial TypeBindSymbol      = ASCII "*"   -- a+        renderSpecial ForallSymbol        = ASCII "\\/"++newtype Unicode = Unicode Char++instance RenderSpecial Unicode where+        renderSpecial LambdaSymbol        = Unicode '\x03BB'+        renderSpecial TypeOfSymbol        = Unicode '\x2237'     -- called PROPORTION+        renderSpecial RightArrowSymbol    = Unicode '\x2192'+        renderSpecial TypeSymbol          = Unicode '\x25b2'+        renderSpecial TypeBindSymbol      = Unicode '\x25B9'+        renderSpecial ForallSymbol        = Unicode '\x2200'++newtype LaTeX = LaTeX String++instance Monoid LaTeX where+        mempty = LaTeX ""+        mappend (LaTeX xs) (LaTeX ys) = LaTeX (xs ++ ys)++instance RenderSpecial LaTeX where+        renderSpecial LambdaSymbol        = LaTeX "\\ensuremath{\\lambda}"+        renderSpecial TypeOfSymbol        = LaTeX ":\\!:"  -- too wide+        renderSpecial RightArrowSymbol    = LaTeX "\\ensuremath{\\shortrightarrow}"+        renderSpecial TypeSymbol          = LaTeX "\\ensuremath{\\blacktriangle}"+        renderSpecial TypeBindSymbol      = LaTeX "\\ensuremath{\\triangleright}"+        renderSpecial ForallSymbol        = LaTeX "\\ensuremath{\\forall}"+++newtype HTML = HTML String++instance Monoid HTML where+        mempty = HTML ""+        mappend (HTML xs) (HTML ys) = HTML (xs ++ ys)++instance RenderSpecial HTML where+        renderSpecial LambdaSymbol        = HTML "&#955;"+        renderSpecial TypeOfSymbol        = HTML "&#8759;"+        renderSpecial RightArrowSymbol    = HTML "&#8594;"+        renderSpecial TypeSymbol          = HTML "&#9650;"+        renderSpecial TypeBindSymbol      = HTML "&#9657;"+        renderSpecial ForallSymbol        = HTML "&#8704;"+++renderSpecialFont :: (RenderSpecial a) => Char -> Maybe a+renderSpecialFont = fmap renderSpecial . flip M.lookup specialFontMap++specialFontMap :: M.Map Char SpecialSymbol+specialFontMap = M.fromList+                [ (renderSpecial s,s)+                | s <- [minBound..maxBound]+                ]+++class (RenderSpecial a, Monoid a) => RenderCode a where+        rStart :: a+        rStart = mempty+        rEnd :: a+        rEnd = mempty++        rDoHighlight :: Bool -> [Attr]           -> a+        rPutStr      :: String -> a+++-- This is what the pretty printer can see+data PrettyState = PrettyState+        { prettyPath  :: Path+        , prettyColor :: Maybe SyntaxForColor+        }++--stackToPrettyState :: [Attr] -> PrettyState+--stackToPrettyState =++renderCode :: RenderCode a => PrettyOptions -> DocH -> a+renderCode opts doc = rStart `mappend` PP.fullRender PP.PageMode w rib marker (\ _ -> rEnd) doc []+  where+          -- options+          w = po_width opts+          rib = po_ribbon opts++          marker ::  RenderCode a => PP.TextDetails HermitMark -> ([Attr] -> a) -> ([Attr]-> a)+          marker m rest cols@(SpecialFont:_) = case m of+                  PP.Chr ch   -> special [ch] `mappend` rest cols+                  PP.Str str  -> special str `mappend` rest cols+                  PP.PStr str -> special str `mappend` rest cols+                  PP.Mark (PopAttr)    ->+                        let (_:cols') = cols in rDoHighlight False cols' `mappend` rest cols'+                  PP.Mark (PushAttr _) -> error "renderCode: can not have marks inside special symbols"+          marker m rest cols = case m of+                  PP.Chr ch   -> rPutStr [ch] `mappend` rest cols+                  PP.Str str  -> rPutStr str `mappend` rest cols+                  PP.PStr str -> rPutStr str `mappend` rest cols+                  PP.Mark (PushAttr a) ->+                        let cols' = a : cols in rDoHighlight True cols' `mappend` rest cols'+                  PP.Mark (PopAttr) -> do+                        let (_:cols') = cols in rDoHighlight False cols' `mappend` rest cols'++          special txt = mconcat [ code | Just code <- map renderSpecialFont txt ]+++-- Other options for pretty printing:+-- * Does a top level program should function names, or complete listings?++-- This is the hacky old pretty printer, using the new API+ghcCorePrettyH :: PrettyH Core+ghcCorePrettyH =+           promoteT (ppModule :: PrettyH ModGuts)+        <+ promoteT (ppH      :: PrettyH CoreProgram)+        <+ promoteT (ppH      :: PrettyH CoreBind)+        <+ promoteT (ppDef    :: PrettyH CoreDef)+        <+ promoteT (ppH      :: PrettyH CoreExpr)+        <+ promoteT (ppH      :: PrettyH CoreAlt)+  where++        ppH :: (Outputable a) => PrettyH a+        ppH = arr (PP.text . showSDoc . ppr)++        ppModule :: PrettyH ModGuts+        ppModule = mg_module ^>> ppH++        ppDef :: PrettyH CoreDef+        ppDef = (\ (Def v e) -> (v,e)) ^>> ppH++--        arr (PP.text . ppr . mg_module)++-- Later, this will have depth, and other pretty print options.+class Show2 a where+        show2 :: a -> String++instance Show2 Core where+        show2 (ModGutsCore   m)  = show2 m+        show2 (ProgramCore   p)  = show2 p+        show2 (BindCore      bd) = show2 bd+        show2 (ExprCore      e)  = show2 e+        show2 (AltCore       a)  = show2 a+        show2 (DefCore       a)  = show2 a++instance Show2 ModGuts where+        show2 modGuts =+                "[ModGuts for " ++ showSDoc (ppr (mg_module modGuts)) ++ "]\n" +++                 show (length (mg_binds modGuts)) ++ " binding group(s)\n" +++                 show (length (mg_rules modGuts)) ++ " rule(s)\n" +++                 showSDoc (ppr (mg_rules modGuts))+++instance Show2 CoreProgram where+        show2 codeProg =+                "[Code Program]\n" +++                showSDoc (ppr codeProg)++instance Show2 CoreExpr where+        show2 expr =+                "[Expr]\n" +++                showSDoc (ppr expr)++instance Show2 CoreAlt where+        show2 alt =+                "[alt]\n" +++                showSDoc (ppr alt)+++instance Show2 CoreBind where+        show2 bind =+                "[Bind]\n" +++                showSDoc (ppr bind)++instance Show2 CoreDef where+        show2 (Def v e) =+                "[Def]\n" +++                showSDoc (ppr v) ++ " = " ++ showSDoc (ppr e)++--- Moving the renders back into the core hermit++-------------------------------------------------------------------------------++coreRenders :: [(String,Handle -> PrettyOptions -> DocH -> IO ())]+coreRenders =+        [ ("latex", \ h w doc -> do+                        let pretty = latexToString $ renderCode w doc+                        hPutStr h pretty)+        , ("html", \ h w doc -> do+                        let HTML pretty = renderCode w doc+                        hPutStr h pretty)+        , ("ascii", \ h w doc -> do+                        let (ASCII pretty) = renderCode w doc+                        hPutStrLn h pretty)+        , ("debug", \ h w doc -> do+                        let (DebugPretty pretty) = renderCode w doc+                        hPutStrLn h pretty)+        ]++latexVerbatim :: String -> LaTeX -> LaTeX+latexVerbatim str (LaTeX v) = LaTeX (str ++ v)++latexToString :: LaTeX -> String+latexToString (LaTeX orig) = unlines $ map trunkSpaces $ lines orig where+  trunkSpaces txt = case span isSpace txt of+                       ([],rest) -> rest+                       (pre,rest) -> "\\hspace{" ++ show (length pre) ++ "\\hermitspace}" ++ rest++instance RenderCode LaTeX where+        rPutStr txt  = LaTeX txt++        rDoHighlight False _ = LaTeX "}"+        rDoHighlight _ [] = LaTeX $ "{"+        rDoHighlight _ (Color col:_) = LaTeX $ "{" ++ case col of+                        KeywordColor -> "\\color{hermit:keyword}"       -- blue+                        SyntaxColor  -> "\\color{hermit:syntax}"        -- red+                        VarColor     -> ""+                        TypeColor    -> "\\color{hermit:type}"          -- green+                        LitColor     -> "\\color{hermit:lit}"           -- cyan+        rDoHighlight o (_:rest) = rDoHighlight o rest++        rEnd = LaTeX "\n" -- \\end{Verbatim}"++{- | Use css to do the colors+ -+ - > <style type="text/css">+ - >  .hermit-syntax {+ - >      color: red;+ - >  </style>+ -}++instance RenderCode HTML where+        rPutStr txt  = HTML txt++        rDoHighlight False _ = HTML "</span>"+        rDoHighlight _ [] = HTML $ "<span>"+        rDoHighlight _ (Color col:_) = HTML $ case col of+                        KeywordColor -> "<span class=\"hermit-keyword\">"       -- blue+                        SyntaxColor  -> "<span class=\"hermit-syntax\">"        -- red+                        VarColor     -> "<span>"+                        TypeColor    -> "<span class=\"hermit-type\">"          -- green+                        LitColor     -> "<span class=\"hermit-lit\">"           -- cyan+        rDoHighlight o (_:rest) = rDoHighlight o rest+        rEnd = HTML "\n"+++instance RenderCode ASCII where+        rPutStr txt  = ASCII txt++        rDoHighlight _ _ = ASCII ""++        rEnd = ASCII "\n"++data DebugPretty = DebugPretty String++instance RenderSpecial DebugPretty where+        renderSpecial sym = DebugPretty ("{" ++ show sym ++ "}")++instance Monoid DebugPretty where+        mempty = DebugPretty ""+        mappend (DebugPretty xs) (DebugPretty ys) = DebugPretty $ xs ++ ys++instance RenderCode DebugPretty where+        rStart = DebugPretty "(START)\n"++        rPutStr txt  = DebugPretty txt++        rDoHighlight True  stk = DebugPretty $ show (True,stk)+        rDoHighlight False stk = DebugPretty $ show (False,stk)++        rEnd = DebugPretty "(END)\n"+

@@ -0,0 +1,76 @@+-- | Output the raw Expr constructors. Helpful for writing pattern matching rewrites.+module Language.HERMIT.PrettyPrinter.AST where++import Control.Arrow hiding ((<+>))++import Data.Char (isSpace)+import Data.Traversable (sequenceA)++import qualified GhcPlugins as GHC+import Language.HERMIT.Kure+import Language.HERMIT.PrettyPrinter++import Text.PrettyPrint.MarkedHughesPJ as PP++listify :: (MDoc a -> MDoc a -> MDoc a) -> [MDoc a] -> MDoc a+listify _  []     = text "[]"+listify op (d:ds) = op (text "[ " <> d) (foldr (\e es -> op (text ", " <> e) es) (text "]") ds)++-- | like vcat and hcat, only make the list syntax explicit+vlist, hlist :: [MDoc a] -> MDoc a+vlist = listify ($$)+hlist = listify (<+>)++corePrettyH :: PrettyOptions -> PrettyH Core+corePrettyH opts =+       promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)+    <+ promoteT (ppProgram  :: PrettyH GHC.CoreProgram)+    <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)+    <+ promoteT (ppCoreDef  :: PrettyH CoreDef)+    <+ promoteT (ppModGuts  :: PrettyH GHC.ModGuts)+    <+ promoteT (ppCoreAlt  :: PrettyH GHC.CoreAlt)+  where+    hideNotes = po_notes opts++    -- Use for any GHC structure, the 'showSDoc' prefix is to remind us+    -- that we are eliding infomation here.+    ppSDoc :: (GHC.Outputable a) => a -> MDoc b+    ppSDoc = toDoc . (if hideNotes then id else ("showSDoc: " ++)) . GHC.showSDoc . GHC.ppr+        where toDoc s | any isSpace s = parens (text s)+                      | otherwise     = text s++    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)++    ppCoreExpr :: PrettyH GHC.CoreExpr+    ppCoreExpr = varT (\i -> text "Var" <+> varColor (ppSDoc i))+              <+ litT (\i -> text "Lit" <+> ppSDoc i)+              <+ appT ppCoreExpr ppCoreExpr (\ a b -> text "App" $$ nest 2 (cat [parens a, parens b]))+              <+ lamT ppCoreExpr (\ v e -> text "Lam" <+> varColor (ppSDoc v) $$ nest 2 (parens e))+              <+ letT ppCoreBind ppCoreExpr (\ b e -> text "Let" $$ nest 2 (cat [parens b, parens e]))+              <+ caseT ppCoreExpr (const ppCoreAlt) (\s b ty alts ->+                        text "Case" $$ nest 2 (parens s)+                                    $$ nest 2 (ppSDoc b)+                                    $$ nest 2 (ppSDoc ty)+                                    $$ nest 2 (vlist 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))+              <+ typeT (\ty -> text "Type" <+> nest 2 (ppSDoc ty))+              <+ coercionT (\co -> text "Coercion" $$ nest 2 (ppSDoc co))++    ppCoreBind :: PrettyH GHC.CoreBind+    ppCoreBind = nonRecT ppCoreExpr (\i e -> text "NonRec" <+> ppSDoc i $$ nest 2 (parens e))+              <+ recT (const ppCoreDef) (\bnds -> text "Rec" $$ nest 2 (vlist bnds))++    ppCoreAlt :: PrettyH GHC.CoreAlt+    ppCoreAlt = altT ppCoreExpr $ \ con ids e -> text "Alt" <+> ppSDoc con+                                                            <+> (hlist $ map ppSDoc ids)+                                                            $$ nest 2 (parens e)++    -- GHC uses a tuple, which we print here. The CoreDef type is our doing.+    ppCoreDef :: PrettyH CoreDef+    ppCoreDef = defT ppCoreExpr $ \ i e -> parens $ varColor (ppSDoc i) <> text "," <> e

@@ -0,0 +1,226 @@+-- | Output the raw Expr constructors. Helpful for writing pattern matching rewrites.+module Language.HERMIT.PrettyPrinter.Clean where++import Control.Arrow hiding ((<+>))++import Data.Char (isSpace)+import Data.Traversable (sequenceA)++import qualified GhcPlugins as GHC+import Language.HERMIT.Kure+import Language.HERMIT.PrettyPrinter+import Language.HERMIT.GHC++import Text.PrettyPrint.MarkedHughesPJ as PP++listify :: (MDoc a -> MDoc a -> MDoc a) -> [MDoc a] -> MDoc a+listify _  []     = text "[]"+listify op (d:ds) = op (text "[ " <> d) (foldr (\e es -> op (text ", " <> e) es) (text "]") ds)++-- | like vcat and hcat, only make the list syntax explicit+vlist, hlist :: [MDoc a] -> MDoc a+vlist = listify ($$)+hlist = listify (<+>)++data RetExpr+        = RetLam [DocH] DocH+        | RetLet [DocH] DocH+        | RetApp DocH [RetExpr]+        | RetExpr DocH+        | RetAtom DocH         -- parens not needed+        | RetEmpty++isAtom :: RetExpr -> Bool+isAtom (RetAtom _) = True+isAtom _           = False++specialSymbol :: SpecialSymbol -> DocH+specialSymbol = markColor SyntaxColor . specialFont . char . renderSpecial++symbol :: Char -> DocH+symbol = markColor SyntaxColor . char++keyword :: String -> DocH+keyword = markColor KeywordColor . text++ppParens :: DocH -> DocH+ppParens p = symbol '(' <> p <> symbol ')' -- :: markColor SyntaxColor++atomExpr :: RetExpr -> DocH+atomExpr (RetAtom e) = e+atomExpr other       = ppParens (normalExpr other)++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 (RetApp fn xs) = sep [ hsep (fn : map atomExpr (takeWhile isAtom xs))+                                , nest 2 (sep (map atomExpr (dropWhile isAtom xs))) ]+normalExpr (RetExpr e0)    = e0+normalExpr (RetAtom e0)    = e0+normalExpr (RetEmpty)      = empty++typeSymbol :: DocH+typeSymbol = markColor TypeColor (specialFont $ char $ renderSpecial TypeSymbol)++typeBindSymbol :: DocH+typeBindSymbol = markColor TypeColor (specialFont $ char $ renderSpecial TypeBindSymbol)++corePrettyH :: PrettyOptions -> PrettyH Core+corePrettyH opts =+       promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)+    <+ promoteT (ppProgram  :: PrettyH GHC.CoreProgram)+    <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)+    <+ promoteT (ppCoreDef  :: PrettyH CoreDef)+    <+ promoteT (ppModGuts  :: PrettyH GHC.ModGuts)+    <+ promoteT (ppCoreAlt  :: PrettyH GHC.CoreAlt)+  where+    hideNotes = True++    ppVar :: GHC.Var -> DocH+    ppVar = ppName . GHC.varName++    ppName :: GHC.Name -> DocH+    ppName nm+            | isInfix name = ppParens $ varColor $ text name+            | otherwise    = varColor $ text name+      where name = GHC.occNameString $ GHC.nameOccName $ nm+            isInfix = all (\ n -> n `elem` "!@#$%^&*-._+=:?/\\<>'")+++    -- 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++    -- Use for any GHC structure, the 'showSDoc' prefix is to remind us+    -- that we are eliding infomation here.+    ppSDoc :: (GHC.Outputable a) => a -> MDoc b+    ppSDoc = toDoc . (if hideNotes then id else ("showSDoc: " ++)) . GHC.showSDoc . GHC.ppr+        where toDoc s | any isSpace s = parens (text s)+                      | otherwise     = text s++    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))+                                     | 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)++    ppCoreExpr :: PrettyH GHC.CoreExpr+    ppCoreExpr = ppCoreExprR >>^ normalExpr++    appendArg xs (RetEmpty) = xs+    appendArg xs e          = xs ++ [e]++    appendBind Nothing  xs = xs+    appendBind (Just v) xs = v : xs++    ppCoreExprR :: TranslateH GHC.CoreExpr RetExpr+    ppCoreExprR = do+           ret <- ppCoreExprPR+           absPath <- absPathT+           return $ ret (rootPath absPath)++    ppCoreExprPR :: TranslateH GHC.CoreExpr (Path -> RetExpr)+    ppCoreExprPR = lamT ppCoreExprR (\ v e _ -> case e of+                                              RetLam vs e0  -> RetLam (appendBind (ppBinder v) vs) e0+                                              _             -> RetLam (appendBind (ppBinder v) []) (normalExpr e))++               <+ letT ppCoreBind ppCoreExprR+                                   (\ bd e _ -> case e of+                                              RetLet vs e0  -> RetLet (bd : vs) e0+                                              _             -> RetLet [bd] (normalExpr e))+               -- HACKs+{-+               <+ (acceptR (\ e -> case e of+                                     GHC.App (GHC.Var v) (GHC.Type t) | po_exprTypes opts == Abstract -> True+                                     _ -> False) >>>+                           (appT ppCoreExprR ppCoreExprR (\ (RetAtom e1) (RetAtom e2) ->+                                    RetAtom (e1 <+> e2))))+-}+               <+ (acceptR (\ e -> case e of+                                     GHC.App (GHC.Type _) (GHC.Lam {}) | po_exprTypes opts == Omit -> True+                                     GHC.App (GHC.App (GHC.Var _) (GHC.Type _)) (GHC.Lam {}) | po_exprTypes opts == Omit -> True+                                     _ -> False) "TODO: add decent error message here" >>>+                           (appT ppCoreExprR ppCoreExprR (\ (RetAtom e1) (RetLam vs e0) _ ->+                                    RetExpr $ hang (e1 <+>+                                                        symbol '(' <>+                                                        specialSymbol LambdaSymbol <+>+                                                        hsep vs <+>+                                                        specialSymbol RightArrowSymbol) 2 (e0 <> symbol ')')))+++                  )++               <+ appT ppCoreExprR ppCoreExprR+                                   (\ e1 e2 _ -> case e1 of+                                              RetApp f xs   -> RetApp f (appendArg xs e2)+                                              _             -> case e2 of -- if our only args are types, and they are omitted, don't paren+                                                                RetEmpty -> e1+                                                                args -> RetApp (atomExpr e1) (appendArg [] args))+               <+ 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)+                                  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+              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++    ppCoreExpr0 :: PrettyH GHC.CoreExpr+    ppCoreExpr0 = caseT ppCoreExpr (const ppCoreAlt) (\ s b _ty alts ->+                        (keywordColor (text "case") <+> s <+> keywordColor (text "of") <+> ppIdBinder b) $$+                          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))+--              <+ typeT (\ty -> text "Type" <+> nest 2 (ppSDoc ty))+              <+ coercionT (\co -> text "Coercion" $$ nest 2 (ppSDoc co))++    ppCoreBind :: PrettyH GHC.CoreBind+    ppCoreBind = nonRecT ppCoreExprR ppDefFun+              <+ recT (const ppCoreDef) (\ bnds -> keywordColor (text "rec") <+> vcat bnds)++    ppCoreAlt :: PrettyH GHC.CoreAlt+    ppCoreAlt = altT ppCoreExpr $ \ con ids e -> case con of+                  GHC.DataAlt dcon -> hang (ppName (GHC.dataConName dcon) <+> ppIds ids) 2 e+                  GHC.LitAlt lit   -> hang (ppSDoc lit <+> ppIds ids) 2 e+                  GHC.DEFAULT      -> symbol '_' <+> ppIds ids <+> e+          where+                 ppIds ids | null ids  = specialSymbol RightArrowSymbol+                           | otherwise = hsep (map ppIdBinder ids) <+> specialSymbol RightArrowSymbol++    -- GHC uses a tuple, which we print here. The CoreDef type is our doing.+    ppCoreDef :: PrettyH CoreDef+    ppCoreDef = defT ppCoreExprR ppDefFun++    ppDefFun :: GHC.Id -> RetExpr -> DocH+    ppDefFun i e = case e of+                    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 '='

@@ -0,0 +1,59 @@+-- | Output the raw Expr constructors. Helpful for writing pattern matching rewrites.+module Language.HERMIT.PrettyPrinter.GHC where++import Control.Arrow hiding ((<+>))++import Data.Char (isSpace)++import qualified GhcPlugins as GHC+import Language.HERMIT.Kure+import Language.HERMIT.PrettyPrinter++import Text.PrettyPrint.MarkedHughesPJ as PP++listify :: (MDoc a -> MDoc a -> MDoc a) -> [MDoc a] -> MDoc a+listify _  []     = text "[]"+listify op (d:ds) = op (text "[ " <> d) (foldr (\e es -> op (text ", " <> e) es) (text "]") ds)++-- | like vcat and hcat, only make the list syntax explicit+vlist, hlist :: [MDoc a] -> MDoc a+vlist = listify ($$)+hlist = listify (<+>)++corePrettyH :: PrettyOptions -> PrettyH Core+corePrettyH opts =+       promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)+    <+ promoteT (ppProgram  :: PrettyH GHC.CoreProgram)+    <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)+    <+ promoteT (ppCoreDef  :: PrettyH CoreDef)+    <+ promoteT (ppModGuts  :: PrettyH GHC.ModGuts)+    <+ promoteT (ppCoreAlt  :: PrettyH GHC.CoreAlt)+  where+    hideNotes = po_notes opts++    -- Use for any GHC structure, the 'showSDoc' prefix is to remind us+    -- that we are eliding infomation here.+    ppSDoc :: (GHC.Outputable a) => a -> MDoc b+    ppSDoc = toDoc . (if hideNotes then id else ("showSDoc: " ++)) . GHC.showSDoc . GHC.ppr+        where toDoc s | any isSpace s = parens (text s)+                      | otherwise     = text s++    ppModGuts :: PrettyH GHC.ModGuts+    ppModGuts = arr (ppSDoc . GHC.mg_binds)++    -- DocH is not a monoid, so we can't use listT here+    ppProgram :: PrettyH GHC.CoreProgram+    ppProgram = arr ppSDoc++    ppCoreExpr :: PrettyH GHC.CoreExpr+    ppCoreExpr = arr ppSDoc++    ppCoreBind :: PrettyH GHC.CoreBind+    ppCoreBind = arr ppSDoc++    ppCoreAlt :: PrettyH GHC.CoreAlt+    ppCoreAlt = arr ppSDoc++    -- GHC uses a tuple, which we print here. The CoreDef type is our doing.+    ppCoreDef :: PrettyH CoreDef+    ppCoreDef = defT ppCoreExpr $ \ i e -> ppSDoc i <> text "=" <> e

@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+-- | JSON pretty printer+module Language.HERMIT.PrettyPrinter.JSON where++import Control.Arrow++import Data.Aeson+import Data.Aeson.Types+import qualified Data.Text as T++import qualified GhcPlugins as GHC+import Language.HERMIT.Kure+import Language.HERMIT.PrettyPrinter++corePrettyH :: PrettyOptions -> TranslateH Core Value+corePrettyH _opts =+       promoteT ppCoreExpr+    <+ promoteT ppProgram+    <+ promoteT ppCoreBind+    <+ promoteT ppCoreDef+    <+ promoteT ppModGuts+    <+ promoteT ppCoreAlt+  where+    mkCon :: String -> Pair+    mkCon con = "con" .= con++    -- Use for any GHC structure, the 'showSDoc' prefix is to remind us+    -- that we are eliding infomation here.+    ppSDoc :: (GHC.Outputable a) => a -> Value+    ppSDoc = String . T.pack . GHC.showSDoc . GHC.ppr++    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)++    ppCoreExpr :: TranslateH GHC.CoreExpr Value+    ppCoreExpr = varT (\i -> object [mkCon "Var", "value" .= ppSDoc i])+              <+ litT (\i -> object [mkCon "Lit", "value" .= ppSDoc i])+              <+ appT ppCoreExpr ppCoreExpr (\ a b -> object [mkCon "App", "lhs" .= a, "rhs" .= b])+              <+ lamT ppCoreExpr (\ v e -> object [mkCon "Lam", "var" .= ppSDoc v, "body" .= e])+              <+ letT ppCoreBind ppCoreExpr (\ b e -> object [mkCon "Let", "binds" .= b, "exp" .= e])+              <+ caseT ppCoreExpr (const ppCoreAlt) (\s b ty alts ->+                        object [ mkCon "Case"+                               , "s" .= s+                               , "caseBndr" .= ppSDoc b+                               , "type" .= ppSDoc ty+                               , "alts" .= alts ])+              <+ castT ppCoreExpr (\e co -> object [mkCon "Cast", "exp" .= e, "cast" .= ppSDoc co])+              <+ tickT ppCoreExpr (\i e  -> object [mkCon "Tick", "tick" .= ppSDoc i, "exp" .= e])+              <+ typeT (\ty -> object [mkCon "Type", "type" .= ppSDoc ty])+              <+ coercionT (\co -> object [mkCon "Coercion", "coercion" .= ppSDoc co])++    ppCoreBind :: TranslateH GHC.CoreBind Value+    ppCoreBind = nonRecT ppCoreExpr (\i e -> object [mkCon "NonRec", "var" .= ppSDoc i, "exp" .= e])+              <+ recT (const ppCoreDef) (\bnds -> object [mkCon "Rec", "binds" .= bnds])++    ppCoreAlt :: TranslateH GHC.CoreAlt Value+    ppCoreAlt = altT ppCoreExpr $ \ con ids e -> object [ mkCon "Alt"+                                                        , "altcon" .= ppSDoc con+                                                        , "ids" .= map ppSDoc ids+                                                        , "exp" .= e ]++    ppCoreDef :: TranslateH CoreDef Value+    ppCoreDef = defT ppCoreExpr $ \ i e -> object [mkCon "CoreDef", "var" .= ppSDoc i, "exp" .= e]

@@ -0,0 +1,276 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+module Language.HERMIT.Primitive.AlphaConversion where++import GhcPlugins hiding (empty)++import Control.Arrow+import Data.Char (isDigit)+import Data.List (intersect, (\\), nub)++import Language.HERMIT.Context+import Language.HERMIT.Monad+import Language.HERMIT.Kure+import Language.HERMIT.External+import Language.HERMIT.Primitive.GHC(freeVarsT, substR)++import Language.HERMIT.Primitive.Common++import qualified Language.Haskell.TH as TH++import Prelude hiding (exp)++externals :: [External]+externals = map (.+ Deep)+         [  external "alpha" alpha+               [ "renames the bound variables at the current node."]+         ,  external "alpha-lam" (promoteExprR . alphaLam . Just)+               [ "renames the bound variable in a Lambda expression to the given name."]+         ,  external "alpha-lam" (promoteExprR $ alphaLam Nothing)+               [ "renames the bound variable in a Lambda expression."]+         ,  external "alpha-case-binder" (promoteExprR . alphaCaseBinder . Just)+               [ "renames the binder in a Case expression to the given name."]+         ,  external "alpha-case-binder" (promoteExprR $ alphaCaseBinder Nothing)+               [ "renames the binder in a Case expression."]+         ,  external "alpha-alt" (promoteAltR alphaAlt)+               [ "renames all binders in a Case alternative."]+         ,  external "alpha-case" (promoteExprR alphaCase)+               [ "renames all binders in a Case alternative."]+         ,  external "alpha-let" (promoteExprR . alphaLetOne . Just)+               [ "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)+               [ "renames the bound variable in a top-level binding with one binder to the given name."]+         ,  external "alpha-top" (promoteProgramR 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, ...)"]++         ]++-----------------------------------------------------------------------+--+-- freshNameGen is a function used in conjunction with cloneIdH, which clones an existing Id.+-- But, what name should the new Id have?+-- cloneIdH generates a new Unique -- so we are positive that the new Id 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+--  x  goes to x0 or x1 or ...+-- and we do not want this newly generated name to shadow either:+-- 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)++freshNameGen :: (Maybe TH.Name) -> [Id] -> (String -> String)+freshNameGen newName idsToAvoid =+        case newName of+          Just name -> const (show name)+          Nothing   -> inventNames idsToAvoid++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++inventNames :: [Id] -> String -> String+inventNames curr old = head+                     [ nm+                     | nm <- old : [ base ++ show uq | uq <- [start ..] :: [Int] ]+                     , nm `notElem` names+                     ]+   where+           names = 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++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)++ifShadowingR :: RewriteH CoreExpr+ifShadowingR = do shadows <- shadowedNamesT+                  case shadows of+                    [] -> fail "Bindings at this node do not shadow."+                    _  -> idR++-- | 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')++-- | 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.+--   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++-----------------------------------------------------------------------++-- | Alpha rename a lambda binder.  Optionally takes a suggested new name.+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')++-----------------------------------------------------------------------++-- | Alpha rename a case binder.  Optionally takes a suggested new name.+alphaCaseBinder :: Maybe TH.Name -> RewriteH CoreExpr+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)++-----------------------------------------------------------------------++-- | 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))++-- | 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++-----------------------------------------------------------------------++-- | Rename all identifiers bound in a case expression.+alphaCase :: RewriteH CoreExpr+alphaCase = alphaCaseBinder Nothing >+> caseAnyR (fail "") (const alphaAlt)++-----------------------------------------------------------------------++-- | Alpha rename a non-recursive let binder.  Optionally takes a suggested new name.+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)++-- | 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)++                        letRecDefT (\ _ -> renameIdR v v') (renameIdR v v') (\ bs e -> Let (Rec $ (map.first) (replaceId v v') bs) e)++-- | 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++-- | 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+alphaLetRecOne mn = setFailMsg (wrongFormForAlpha "Let (Rec [(v,e1)]) e2") $+                    do Let (Rec [(v, _)]) _ <- idR+                       alphaLetRecId mn v++-- | Rename the identifier bound in a let with a single bound identifier.  Optionally takes a suggested new name.+alphaLetOne :: Maybe TH.Name -> RewriteH CoreExpr+alphaLetOne mn = alphaLetNonRec mn <+ alphaLetRecOne mn++-- | Rename all identifiers bound in a Let.+alphaLet :: RewriteH CoreExpr+alphaLet = alphaLetRec <+ alphaLetNonRec Nothing++-----------------------------------------------------------------------++-- | 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+                        nameModifier <- consNonRecT (freshNameGenT mn) idR (\ _ nameGen _ -> nameGen)+                        v' <- constT (cloneIdH nameModifier v)+                        consNonRecT idR (renameIdR v v') (\ _ e1 e2 -> 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)++-- | 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++-- | 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+                        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 mn = alphaConsNonRec mn <+ alphaConsRecOne mn++-- | Rename all identifiers bound in a Let.+alphaCons :: RewriteH CoreProgram+alphaCons = alphaConsRec <+ alphaConsNonRec Nothing++-----------------------------------------------------------------------++-- | Alpha rename any bindings at this node.  Note: does not rename case alternatives unless invoked on the alternative.+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)))++-----------------------------------------------------------------------++wrongFormForAlpha :: String -> String+wrongFormForAlpha s = "Cannot alpha-rename: " ++ wrongExprForm s

@@ -0,0 +1,94 @@+{-# 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+    , letVarsT+    , wrongExprForm+    ) where++import GhcPlugins++import Control.Arrow++import Data.List+import Data.Monoid++import Language.HERMIT.Kure++import Language.HERMIT.Primitive.GHC+++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++instance BindEnv CoreAlt where+    bindings (_,vs,_) = vs++instance BindEnv CoreExpr where+    bindings (Lam b _)          = [b]+    bindings (Let bs _)         = bindings bs+    bindings (Case _ sc _ alts) = sc : (nub (concat (map bindings alts)))+    bindings _                  = []++instance BindEnv CoreProgram where+    bindings prog = nub (concat (map bindings prog))++instance BindEnv CoreDef  where+    bindings (Def b _) = [b]++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++-- 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+letVarsT :: TranslateH CoreExpr [Var]+letVarsT = do Let bs _ <- idR+              return (bindings bs)++-- | List of the list of Ids bound by each case alternative+caseAltVarsT :: TranslateH CoreExpr [[Id]]+caseAltVarsT = caseT mempty (const (extractT bindingVarsT)) $ \ () _ _ 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++-- | 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]++-- | 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)++------------------------------------------------------------------------------++wrongExprForm :: String -> String+wrongExprForm form = "Expression does not have the form: " ++ form++------------------------------------------------------------------------------

@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}+module Language.HERMIT.Primitive.Debug+       ( -- * Debugging Primitives+         externals+       , traceR+       , observeR+       , observeFailureR+       )+where++import Language.HERMIT.Kure+import Language.HERMIT.External+import Language.HERMIT.Monad++-- | Exposed debugging 'External's.+externals :: [External]+externals = map (.+ Debug)+         [ external "trace" (traceR :: String -> RewriteH Core)+                [ "give a side-effect message as output when processing this command" ]+         , external "observe" (observeR :: String -> RewriteH Core)+                [ "give a side-effect message as output, and observe the value being processed" ]+         , external "observe-failure" (observeFailureR :: String -> RewriteH Core -> RewriteH Core)+                [ "give a side-effect message if the rewrite fails, including the failing input" ]+         ]++-- | If the 'Rewrite' fails, print out the 'Core', with a message.+observeFailureR :: (Injection a Core, Generic a ~ Core) => String -> RewriteH a -> RewriteH a+observeFailureR str m = m <+ observeR str++-- | Print out the 'Core', with a message.+observeR :: (Injection a Core, Generic a ~ Core) => String -> RewriteH a+observeR msg = extractR $ sideEffectR $ \ cxt core ->+        sendDebugMessage $ DebugCore msg cxt core++-- | Just say something, every time the rewrite is done.+traceR :: String -> RewriteH a+traceR msg = sideEffectR $ \ _ _ -> sendDebugMessage $ DebugTick msg

@@ -0,0 +1,133 @@+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, TupleSections #-}+module Language.HERMIT.Primitive.Fold+    ( externals+    , foldR+    , stashFoldR+    ) where++import GhcPlugins hiding (empty)++import Control.Applicative+import Control.Monad++import qualified Data.Map as Map++import Language.HERMIT.Monad+import Language.HERMIT.Context+import Language.HERMIT.External+import Language.HERMIT.Kure+import Language.HERMIT.GHC++import Language.HERMIT.Primitive.GHC hiding (externals)+import Language.HERMIT.Primitive.Unfold hiding (externals)++import qualified Language.Haskell.TH as TH++import Prelude hiding (exp)++------------------------------------------------------------------------++externals :: [External]+externals =+         [ external "fold" (promoteExprR . foldR)+                ["fold a definition"+                ,""+                ,"double :: Int -> Int"+                ,"double x = x + x"+                ,""+                ,"5 + 5 + 6"+                ,"any-bu (fold 'double)"+                ,"double 5 + 6"+                ,""+                ,"Note: due to associativity, if you wanted to fold 5 + 6 + 6, "+                ,"you first need to apply an associativity rewrite."+                ] .+ Context .+ Deep+         , external "fold" (promoteExprR . stashFoldR)+                ["Fold a remembered definition."] .+ Context .+ Deep+         ]++------------------------------------------------------------------------++stashFoldR :: String -> RewriteH CoreExpr+stashFoldR label = prefixFailMsg "Fold failed: " $+                   contextfreeT $ \ e -> do+    Def i rhs <- lookupDef label+    maybe (fail "no match.")+          return+          (fold i rhs e)++foldR :: TH.Name -> RewriteH CoreExpr+foldR nm =  prefixFailMsg "Fold failed: " $+    translate $ \ c e -> do+        i <- case filter (\i -> nm `cmpTHName2Id` i) $ Map.keys (hermitBindings c) of+                [i] -> return i+                _ -> fail "cannot find name."+        either fail+               (\(rhs,_d) -> maybe (fail "no match.")+                                   return+                                   (fold i rhs e))+               (getUnfolding False False i c)++fold :: Id -> CoreExpr -> CoreExpr -> Maybe CoreExpr+fold i lam exp = do+    let (vs,body) = foldArgs lam+        -- return Nothing if not equal, so sequence will fail below+        checkEqual :: Maybe CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr+        checkEqual m1 m2 = ifM (exprEqual <$> m1 <*> m2) m1 Nothing++    al <- foldMatch vs body exp++    let m = Map.fromListWith checkEqual [(k,Just v) | (k,v) <- al ]++    es <- sequence [ join (Map.lookup v m) | v <- vs ]+    return $ mkCoreApps (Var i) es++-- | Collect arguments to function we are folding, so we can unify with them.+foldArgs :: CoreExpr -> ([Var], CoreExpr)+foldArgs = go []+    where go vs (Lam v e) = go (v:vs) e+          go vs e         = (reverse vs, e)++-- Note: return list can have duplicate keys, caller is responsible+-- for checking that dupes refer to same expression+foldMatch :: [Var]          -- ^ vars that can unify with anything+          -> CoreExpr       -- ^ pattern we are matching on+          -> CoreExpr       -- ^ expression we are checking+          -> Maybe [(Var,CoreExpr)] -- ^ mapping of vars to expressions, or failure+foldMatch vs (Var i) e | i `elem` vs = return [(i,e)]+                       | otherwise   = case e of+                                         Var i' | i == i' -> return []+                                         _                -> Nothing+foldMatch _  (Lit l) (Lit l') | l == l' = return []+foldMatch vs (App e a) (App e' a') = do+    x <- foldMatch vs e e'+    y <- foldMatch vs a a'+    return (x ++ y)+foldMatch vs (Lam v e) (Lam v' e') | v == v' = foldMatch (filter (==v) vs) e e'+foldMatch vs (Let (NonRec v rhs) e) (Let (NonRec v' rhs') e') | v == v' = do+    x <- foldMatch vs rhs rhs'+    y <- foldMatch (filter (==v) vs) e e'+    return (x ++ y)+foldMatch vs (Let (Rec bnds) e) (Let (Rec bnds') e') | length bnds == length bnds' = do+    let vs' = filter (`elem` map fst bnds) vs+        bmatch (v,rhs) (v',rhs') | v == v' = foldMatch vs' rhs rhs'+        bmatch _ _ = Nothing+    x <- zipWithM bmatch bnds bnds'+    y <- foldMatch vs' e e'+    return (concat x ++ y)+foldMatch vs (Tick t e) (Tick t' e') | t == t' = foldMatch vs e e'+-- TODO: showPpr hack in the rest of these!+-- TODO: we don't care if b == b' if they are not used anywhere+foldMatch vs (Case s b ty alts) (Case s' b' ty' alts')+  | (b == b') && (showPpr ty == showPpr ty') && (length alts == length alts') = do+    x <- foldMatch vs s s'+    let vs' = filter (==b) vs+        altMatch (ac, is, e) (ac', is', e') | (ac == ac') && (is == is') =+            foldMatch (filter (`elem` is) vs') e e'+        altMatch _ _ = Nothing+    y <- zipWithM altMatch alts alts'+    return (x ++ concat y)+foldMatch vs (Cast e c) (Cast e' c') | showPpr c == showPpr c' = foldMatch vs e e'+foldMatch _ (Type t) (Type t') | showPpr t == showPpr t' = return []+foldMatch _ (Coercion c) (Coercion c') | showPpr c == showPpr c' = return []+foldMatch _ _ _ = Nothing

@@ -0,0 +1,405 @@+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, TupleSections #-}+module Language.HERMIT.Primitive.GHC where++import GhcPlugins hiding (empty)+import qualified Language.HERMIT.GHC as GHC+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 Language.HERMIT.CoreExtra+import Language.HERMIT.Kure+import Language.HERMIT.Monad+import Language.HERMIT.External+import Language.HERMIT.Context+-- import Language.HERMIT.GHC++import qualified Language.Haskell.TH as TH+-- import Debug.Trace++import Prelude hiding (exp)++------------------------------------------------------------------------++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 "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+         , 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"+                , "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+         , 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+         , 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+         , 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 ->+          -- 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."+++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."++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+                                     _ -> 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)+safeLetSubstR :: RewriteH CoreExpr+safeLetSubstR =  prefixFailMsg "Safe let-substition failed: " $+                 translate $ \ env exp ->+    let   -- Lit?+          safeBind (Var {})   = True+          safeBind (Lam {})   = True+          safeBind e@(App {}) =+                 case collectArgs e of+                   (Var f,args) -> arityOf env f > length (filter (not . isTypeArg) args)+                   (other,args) -> case collectBinders other of+                                     (bds,_) -> length bds > length args+          safeBind _          = False++          safeSubst NoOccInfo = False   -- unknown!+          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+      -- By (our) definition, types are a trivial bind+      Let (NonRec b _) _+         | isTyVar b -> apply letSubstR env exp+      Let (NonRec b be) _+         | isId b && (safeBind be || safeSubst (occInfo (idInfo b)))+                     -> apply letSubstR env exp+         | otherwise -> fail "safety critera not met."+      _ -> fail "expression is not a non-recursive Let."++-- | 'safeLetSubstPlusR' tries to inline a stack of bindings, stopping when reaches+-- the end of the stack of lets.+safeLetSubstPlusR :: RewriteH CoreExpr+safeLetSubstPlusR = tryR (letT idR safeLetSubstPlusR Let) >>> safeLetSubstR++------------------------------------------------------------------------++-- | Output a list of all free variables in an expression.+freeIdsQuery :: TranslateH CoreExpr String+freeIdsQuery = freeIdsT >>^ (("Free identifiers are: " ++) . showVars)++-- | Show a human-readable version of a 'Var'.+showVar :: Var -> String+showVar = show . showSDoc . ppr++-- | Show a human-readable version of a list of 'Var's.+showVars :: [Var] -> String+showVars = show . map (showSDoc . ppr)++freeIdsT :: TranslateH CoreExpr [Id]+freeIdsT = arr coreExprFreeIds++freeVarsT :: TranslateH CoreExpr [Var]+freeVarsT = arr coreExprFreeVars++-- note: exprFreeVars get *all* free variables, including types+coreExprFreeVars :: CoreExpr -> [Var]+coreExprFreeVars  = uniqSetToList . exprFreeVars++-- note: exprFreeIds is only value-level free variables+coreExprFreeIds :: CoreExpr -> [Id]+coreExprFreeIds  = uniqSetToList . exprFreeIds++------------------------------------------------------------------------++-- | [from GHC documentation] De-shadowing the program is sometimes a useful pre-pass.+-- It can be done simply by running over the bindings with an empty substitution,+-- becuase substitution returns a result that has no-shadowing guaranteed.+--+-- (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++------------------------------------------------------------------------+{-+lookupRule :: (Activation -> Bool)	-- When rule is active+	    -> IdUnfoldingFun		-- When Id can be unfolded+            -> InScopeSet+	    -> Id -> [CoreExpr]+	    -> [CoreRule] -> Maybe (CoreRule, CoreExpr)+-}++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+    -- First, we normalize the lhs, so we can match it+    (Var fn,args) <- return $ collectArgs e+    -- Question: does this include Id's, or Var's (which include type names)+    -- Assumption: Var's.+    let in_scope = mkInScopeSet (mkVarEnv [ (v,v) | v <- coreExprFreeVars e ])+        -- The rough_args are just an attempt to try eliminate silly things+        -- that will never match+        _rough_args = map (const Nothing) args   -- rough_args are never used!!! FIX ME!+    -- Finally, we try match the rules+    -- 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)+            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)++rules ::  String -> RewriteH CoreExpr+rules r = do+        theRules <- getHermitRules+        case lookup r theRules of+               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+    rb <- liftCoreM getRuleBase+    let other_rules = [ rule+                        | top_bnds <- mg_binds (hermitModGuts env)+                        , bnd <- case top_bnds of+                                     Rec bnds -> map fst bnds+                                     NonRec b _ -> [b]+                        , rule <- idCoreRules bnd+                        ]+    return [ ( unpackFS (ruleName r), [r] )+           | r <- mg_rules (hermitModGuts env) ++ other_rules ++ concat (nameEnvElts rb)+           ]++rules_help :: TranslateH Core String+rules_help = do+    rulesEnv <- getHermitRules+    return  $ (show (map fst rulesEnv) ++ "\n") +++              showSDoc (pprRulesForUser $ concatMap snd rulesEnv)++makeRule :: String -> Id -> CoreExpr -> CoreRule+makeRule rule_name nm =   mkRule True   -- auto-generated+                                 False  -- local+                                 (mkFastString rule_name)+                                 NeverActive    -- because we need to call for these+                                 (varName nm)+                                 []+                                 []++-- TODO: check if a top-level binding+addCoreBindAsRule :: String -> TH.Name -> RewriteH ModGuts+addCoreBindAsRule rule_name nm = contextfreeT $ \ modGuts ->+        case [ (v,e)+             | top_bnds <- mg_binds modGuts+             , (v,e) <- case top_bnds of+                            Rec bnds -> bnds+                            NonRec b e -> [(b,e)]+             ,  nm `GHC.cmpTHName2Id` v+             ] of+         [] -> fail $ "can not find binding " ++ show nm+         [(v,e)] -> return $ modGuts { mg_rules = mg_rules modGuts+                                              ++ [makeRule rule_name v e]+                                     }+         _ -> fail $ "found multiple bindings for " ++ show nm++----------------------------------------------------------------------++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++----------------------------------------------------------------------++occurAnalyseExpr :: CoreExpr -> CoreExpr+occurAnalyseExpr = OccurAnal.occurAnalyseExpr+++occurAnalyseExprR :: RewriteH CoreExpr+occurAnalyseExprR = contextfreeT $ \ exp -> return (occurAnalyseExpr exp)+++++{- Does not work (no export)+-- Here is a hook into the occur analysis, and a way of looking at the result+occAnalysis ::  CoreExpr -> UsageDetails+occAnalysis = fst . occAnal (initOccEnv all_active_rules)++lookupUsageDetails :: UsageDetails -> Var -> Maybe OccInfo+lookupUsageDetails = lookupVarEnv++-}++{-+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+++-- The ideas for this function are directly extracted from+-- the GHC function, CoreUtils.eqExprX+bindEqual :: CoreBind -> CoreBind -> Maybe Bool+bindEqual  (Rec ps1) (Rec ps2) = Just $ all2 (eqExprX id_unf env') rs1 rs2+      where+        id_unf _ = noUnfolding      -- Don't expand+        (bs1,rs1) = unzip ps1+        (bs2,rs2) = unzip ps2+        env = mkInScopeSet $ exprsFreeVars (rs1 ++ rs2) -- emptyInScopeSet+        env' = rnBndrs2 (mkRnEnv2 env) bs1 bs2++bindEqual  (NonRec _ e1) (NonRec _ e2) = Just $ exprEqual e1 e2++bindEqual _ _ = Nothing++--------------------------------------------------------++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 _             _             = 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+        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"+          Just True  -> return ()++--------------------------------------------------------+++-- try figure out the arity of an Id+arityOf:: Context -> Id -> Int+arityOf env nm =+     case lookupHermitBinding nm env of+        Nothing       -> idArity nm+        Just (LAM {}) -> 0+        -- 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++-------------------------------------------++-- remove a cast;+-- TODO: check for validity of removing this cast+castElimination :: RewriteH CoreExpr+castElimination = do+        Cast e _ <- idR+        return e++{-+    go (Cast e co)      | isReflCo co' = go e+       	                | otherwise    = Cast (go e) co'+                        where+                          co' = optCoercion (getCvSubst subst) co+-}+

@@ -0,0 +1,74 @@+module Language.HERMIT.Primitive.Inline 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.Kure+import Language.HERMIT.Context+import Language.HERMIT.External++import qualified Language.Haskell.TH as TH++externals :: [External]+externals =+            [ external "inline" (promoteExprR inline :: RewriteH Core)+                [ "(Var n) ==> <defn of n>, fails otherwise" ].+ Eval .+ Deep .+ TODO+            , external "inline-scrutinee" (promoteExprR inlineScrutinee :: RewriteH Core)+                [ "(Var n) ==> <defn of n>, fails otherwise"+                , "In the case of case binders, replaces with scrutinee expression, "+                , "rather than constructor or literal." ].+ Eval .+ Deep .+ TODO+            , external "inline" (promoteExprR . inlineName :: TH.Name -> RewriteH Core)+                [ "Restrict inlining to a given name" ].+ Eval .+ Deep .+ TODO+            , external "inline-case-binder" (promoteExprR inlineCaseBinder :: RewriteH Core)+                [ "Inline if this variable is a case binder." ].+ Eval .+ Deep .+ Bash .+ TODO+            ]++inlineName :: TH.Name -> RewriteH CoreExpr+inlineName nm = (varT (cmpTHName2Id nm) >>= guardM) >> inline++inline :: RewriteH CoreExpr+inline = configurableInline False False++inlineScrutinee :: RewriteH CoreExpr+inlineScrutinee = configurableInline True False++inlineCaseBinder :: RewriteH CoreExpr+inlineCaseBinder = configurableInline False True++-- | The implementation of inline, an important transformation.+-- This *only* works on a Var of the given name. It can trivially+-- be prompted to more general cases.+configurableInline :: Bool -- ^ Inline the scrutinee instead of the patten match (for case binders).+                   -> Bool -- ^ Only inline if this variable is a case binder.+                   -> RewriteH CoreExpr+configurableInline scrutinee caseBinderOnly =+   prefixFailMsg "Inline failed: " $+   withPatFailMsg (wrongExprForm "Var v") $+   do (c, Var v) <- exposeT+      (e,d) <- getUnfolding scrutinee caseBinderOnly v c+      return e >>> accepterR (extractT $ ensureDepth d) "values in inlined expression have been rebound."+++-- | Ensure all the free variables in an expression were bound above a given depth.+-- Assumes minimum depth is 0.+ensureDepth :: Int -> TranslateH Core Bool+ensureDepth d = do+    frees <- promoteT freeVarsT+    ds <- collectT $ do c <- contextT+                        promoteExprT $ varT $ \ i -> if i `elem` frees+                                                       then maybe (i,0) (\b -> (i,hermitBindingDepth b)) (lookupHermitBinding i c)+                                                       else (i,0)+    -- traceR $ "greater values (" ++ show d ++ "): " ++ show (filter ((> d) . snd) ds)+    return $ all (toSnd (<= d)) ds++-- | 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.")

@@ -0,0 +1,77 @@+module Language.HERMIT.Primitive.Kure+       ( -- * KURE Strategies+         -- This list contains reflections of the KURE strategies as 'External's.+         externals+       )+where++import Control.Arrow++import Language.HERMIT.Kure+import Language.HERMIT.External++------------------------------------------------------------------------------------++externals :: [External]+externals = map (.+ KURE)+   [ external "id"         (idR :: RewriteH Core)+       [ "perform the identity"] .+ Shallow+   , external "fail"       (fail :: String -> RewriteH Core)+       [ "a failing rewrite"]+   , external "<+"         ((<+) :: RewriteH Core -> RewriteH Core -> RewriteH Core)+       [ "perform the first translate, and then, if it fails, perform the second rewrite" ]+   , external ">>>"        ((>>>) :: RewriteH Core -> RewriteH Core -> RewriteH Core)+       [ "compose rewrites, requiring both to succeed" ]+   , external ">+>"        ((>+>) :: RewriteH Core -> RewriteH Core -> RewriteH Core)+       [ "compose rewrites, allowing one to fail" ]+   , external "try"        (tryR :: RewriteH Core -> RewriteH Core)+       [ "tries a rewrite, and performs an identity if this rewrite fails" ]+   , external "repeat"     (repeatR :: RewriteH Core -> RewriteH Core)+       [ "repeats a rewrite until it would fail" ] .+ Loop+   , external "all"        (allR :: RewriteH Core -> RewriteH Core)+       [ "apply a rewrite to all children of the node, requiring success at every child" ] .+ Shallow+   , external "any"        (anyR :: RewriteH Core -> RewriteH Core)+       [ "apply a rewrite to all children of the node, requiring success for at least one child" ] .+ Shallow+   , external "one"        (oneR :: RewriteH Core -> RewriteH Core)+       [ "apply a rewrite to the first child of the node for which it can succeed" ] .+ Shallow+   , external "all-bu"     (allbuR :: RewriteH Core -> RewriteH Core)+       [ "promotes a rewrite to operate over an entire tree in bottom-up order, requiring success at each node" ] .+ Deep+   , external "all-td"     (alltdR :: RewriteH Core -> RewriteH Core)+       [ "promotes a rewrite to operate over an entire tree in top-down order, requiring success at every node" ] .+ Deep+   , external "all-du"     (allduR :: RewriteH Core -> RewriteH Core)+       [ "apply a rewrite twice, in a top-down and bottom-up way, using one single tree traversal",+         "succeeding if they all succeed"] .+ Deep+   , external "any-bu"     (anybuR :: RewriteH Core -> RewriteH Core)+       [ "promotes a rewrite to operate over an entire tree in bottom-up order, requiring success for at least one node" ] .+ Deep+   , external "any-td"     (anytdR :: RewriteH Core -> RewriteH Core)+       [ "promotes a rewrite to operate over an entire tree in top-down order, requiring success for at least one node" ] .+ Deep+   , external "any-du"     (anyduR :: RewriteH Core -> RewriteH Core)+       [ "apply a rewrite twice, in a top-down and bottom-up way, using one single tree traversal",+         "succeeding if any succeed"] .+ Deep+   , external "one-td"     (onetdR :: RewriteH Core -> RewriteH Core)+       [ "applies a rewrite to the first node (in a top-down order) for which it can succeed" ] .+ Deep+   , external "one-bu"     (onebuR :: RewriteH Core -> RewriteH Core)+       [ "applies a rewrite to the first node (in a bottom-up order) for which it can succeed" ] .+ Deep+   , external "prune-td"   (prunetdR :: RewriteH Core -> RewriteH Core)+       [ "attempt to apply a rewrite in a top-down manner, prunning at successful rewrites" ] .+ Deep+   , external "innermost"  (innermostR :: RewriteH Core -> RewriteH Core)+       [ "a fixed-point traveral, starting with the innermost term" ] .+ Deep .+ Loop+   , external "focus"      (hfocusR :: TranslateH Core Path -> RewriteH Core -> RewriteH Core)+       [ "apply a rewrite to a focal point"] .+ Navigation .+ Deep+   , external "focus"      (hfocusT :: TranslateH Core Path -> TranslateH Core String -> TranslateH Core String)+       [ "apply a query at a focal point"] .+ Navigation .+ Deep+   , external "when"       ((>>) :: TranslateH Core () -> RewriteH Core -> RewriteH Core)+       [ "apply a rewrite only if the check succeeds" ] .+ Predicate+   , 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+                  pathR p r++hfocusT :: TranslateH Core Path -> TranslateH Core String -> TranslateH Core String+hfocusT tp t = do p <- tp+                  pathT p t++------------------------------------------------------------------------------------

@@ -0,0 +1,139 @@+-- Andre Santos' Local Transformations (Ch 3 in his dissertation)+module Language.HERMIT.Primitive.Local where++import GhcPlugins++import Language.HERMIT.Kure+import Language.HERMIT.Monad+import Language.HERMIT.External++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 qualified Language.Haskell.TH as TH++import Control.Arrow++------------------------------------------------------------------------------++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"+                     , "expression (won't duplicate work)" ]                                 .+ Eval .+ Shallow+         , external "beta-reduce-plus" (promoteExprR betaReducePlus :: RewriteH Core)+                     [ "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+         , external "eta-reduce" (promoteExprR etaReduce :: RewriteH Core)+                     [ "(\\ v -> E1 v) ==> E1, fails otherwise" ]                            .+ Eval .+ Shallow .+ Bash+         , external "eta-expand" (promoteExprR . etaExpand :: TH.Name -> RewriteH Core)+                     [ "'eta-expand v' performs E1 ==> (\\ v -> E1 v), fails otherwise" ]    .+ Shallow .+ Introduce+         ]+         ++ Let.externals+         ++ Case.externals++------------------------------------------------------------------------------++betaReduce :: RewriteH CoreExpr+betaReduce = prefixFailMsg "Beta reduction failed: " $+             setFailMsg (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+        e <- idR+        let (f,xs) = collectArgs e+        guardMsg (p (length xs)) "incorrect number of arguments."++        let (vs,e0) = collectBinders f++        guardMsg (length vs >= length xs) "insufficent lambdas."++        let (vs1,vs2) = splitAt (length xs) vs++        return+           $ mkLets (zipWith NonRec vs1 xs)+           $ mkLams vs2 e0++-- TODO: inline this everywhere+betaReducePlus :: RewriteH CoreExpr+betaReducePlus = multiBetaReduce (> 0)++{-++        tagFailR "betaReducePlus failed." $+        appT liftLambda idR App >>> beta_reduce+  where+          -- lift lambda finds the (perhaps hidden) lambda, and brings it out+          liftLambda = observeR "pre-liftLambda" >>> liftLambda' >>> observeR "post-liftLambda"+          liftLambda' =+                   (do e@(Lam {}) <- idR+                       return e)+                <+ (betaReducePlus+                        >>> observeR "liftLambda(UP)"+                            -- let v = e in ...+                            -- TODO: check scope here+                        >>> (do Let bds (Lam v e) <- idR+                                return (Lam v (Let bds e)))+                   )+-}++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++------------------------------------------------------------------------------++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) $ showSDoc (ppr 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) $ showSDoc (ppr v1) ++ " is free in the function being applied."+       return f)++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."++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++------------------------------------------------------------------------------

@@ -0,0 +1,202 @@+-- Andre Santos' Local Transformations (Ch 3 in his dissertation)+module Language.HERMIT.Primitive.Local.Case+       ( -- * Rewrites on Case Expressions+         externals+       , letFloatCase+       , caseFloatApp+       , caseFloatArg+       , caseFloatCase+       , caseFloatLet+       , caseFloat+       , caseReduce+       , caseSplit+       , caseSplitInline+       )+where+++import GhcPlugins++import Data.List+import Control.Arrow+import Control.Applicative++import Language.HERMIT.GHC+import Language.HERMIT.Kure+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 qualified Language.Haskell.TH as TH++-- NOTE: these are hard to test in small examples, as GHC does them for us, so use with caution+------------------------------------------------------------------------------++-- | Externals relating to Case expressions.+externals :: [External]+externals =+         [ -- 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)+         --             [ "case v1 of v2 -> e ==> e[v1/v2]" ]                                         .+ Unimplemented .+ Eval+         --   -- Again, don't think the lhs of this rule is possible to construct in core.+         -- , external "default-binding-elim" (promoteR $ not_defined "default-binding-elim" :: RewriteH Core)+         --             [ "case v of ...;w -> e ==> case v of ...;w -> e[v/w]" ]                      .+ Unimplemented .+ Eval+         --   -- 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)+                     [ "(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+         , external "case-float-case" (promoteExprR caseFloatCase :: RewriteH Core)+                     [ "case (case ec of alt1 -> e1) of alta -> ea ==> case ec of alt1 -> case e1 of alta -> ea" ] .+ Commute .+ Eval .+ Bash+         , external "case-float-let" (promoteExprR caseFloatLet :: RewriteH Core)+                     [ "let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e" ] .+ Commute .+ Shallow .+ Bash+         , external "case-float" (promoteExprR caseFloat :: RewriteH Core)+                     [ "Float a Case whatever the context." ] .+ Commute .+ Shallow .+ PreCondition+         , external "case-reduce" (promoteExprR caseReduce :: RewriteH Core)+                     [ "case-of-known-constructor"+                     , "case C v1..vn of C w1..wn -> e ==> e[v1/w1..vn/wn]" ] .+ Shallow .+ Eval .+ Bash+         , external "case-split" (promoteExprR . caseSplit :: TH.Name -> RewriteH Core)+                [ "case-split 'x"+                , "e ==> case x of C1 vs -> e; C2 vs -> e, where x is free in e" ]+         , external "case-split-inline" (caseSplitInline :: TH.Name -> RewriteH Core)+                [ "Like case-split, but additionally inlines the matched constructor "+                , "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)+          >>> caseAllR idR (\i -> if null (captures !! i) then idR else alphaAlt)+         )+          idR+          (\(Case s b _ty alts) v -> let newTy = exprType (App (case head alts of (_,_,f) -> f) v)+                                     in Case s b newTy [ (c, ids, App f v)+                                                       | (c,ids,f) <- alts ])++-- | @f (case s of alt1 -> e1; alt2 -> e2)@ ==> @case s of alt1 -> f e1; alt2 -> f e2@+--   Only safe if @f@ is strict.+caseFloatArg :: RewriteH CoreExpr+caseFloatArg = prefixFailMsg "Case floating from App argument failed: " $+  do+    captures      <- appT freeVarsT caseAltVarsT (map . intersect)+    binderCapture <- appT freeVarsT caseBinderVarT intersect+    appT idR+         ((if null binderCapture 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))+                                    in Case s b newTy [ (c, ids, App f e)+                                                      | (c,ids,e) <- alts ])++-- | case (case s1 of alt11 -> e11; alt12 -> e12) of alt21 -> e21; alt22 -> e22+--   ==>+--   case s1 of+--     alt11 -> case e11 of alt21 -> e21; alt22 -> e22+--     alt12 -> case e12 of alt21 -> e21; alt22 -> e22+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+    -- 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)+           >>> 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 ])++-- | let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e+caseFloatLet :: RewriteH CoreExpr+caseFloatLet = prefixFailMsg "Case floating from Let failed: " $+  do vs <- letNonRecT caseAltVarsT idR (\ letVar caseVars _ -> elem letVar $ concat caseVars)+     let bdsAction = if not vs then idR else nonRecR alphaCase+     letT bdsAction idR $ \ (NonRec v (Case s b ty alts)) e -> Case s b ty [ (con, ids, Let (NonRec v ec) e) | (con, ids, ec) <- alts]+++-- | Float a Case whatever the context.+caseFloat :: RewriteH CoreExpr+caseFloat = setFailMsg "Unsuitable expression for Case floating." $+            caseFloatApp <+ caseFloatArg <+ caseFloatCase <+ caseFloatLet++-- | Case-of-known-constructor rewrite.+caseReduce :: RewriteH CoreExpr+caseReduce = letTransform >>> tryR (repeatR letSubstR)+    where letTransform = prefixFailMsg "Case reduction failed: " $+                         withPatFailMsg (wrongExprForm "Case e v t alts") $+                         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+                                    []   -> fail "no matching alternative."+                                    _    -> fail "more than one matching alternative."++-- | If expression is a constructor application, return the relevant bits.+isDataCon :: CoreExpr -> Maybe (DataCon, [CoreExpr])+isDataCon expr = case fn of+                    Var i -> do dc <- isDataConId_maybe i+                                return (dc, args)+                    _ -> fail "not a var"+    where (fn, args) = collectArgs expr++-- | We don't want to use the recursive let here, so nest a bunch of non-recursive lets+nestedLets :: CoreExpr -> [(Id, CoreExpr)] -> CoreExpr+nestedLets = foldr (\(b,rhs) -> Let $ NonRec b rhs)++-- | Case split a free variable in an expression:+--+-- Assume expression e which mentions x :: [a]+--+-- e ==> case x of x+--         [] -> e+--         (a:b) -> e+caseSplit :: TH.Name -> RewriteH CoreExpr+caseSplit nm = do+    frees <- freeIdsT+    contextfreeT $ \ e ->+        case [ i | i <- frees, cmpTHName2Id 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 ]+                                        return (dc,as)) dcs+                return $ Case (Var i) i (exprType e) [ (DataAlt dc, as, e) | (dc,as) <- dcsAndVars ]++-- | Like caseSplit, but additionally inlines the constructor applications+-- for each occurance of the named variable.+--+-- > caseSplitInline nm = caseSplit nm >>> anybuR (inlineName nm)+caseSplitInline :: TH.Name -> RewriteH Core+caseSplitInline nm = promoteR (caseSplit nm) >>> anybuR (promoteExprR $ inlineName nm)+

@@ -0,0 +1,100 @@+-- Andre Santos' Local Transformations (Ch 3 in his dissertation)+module Language.HERMIT.Primitive.Local.Let+       ( -- * Rewrites on Let Expressions+         externals+       , letIntro+       , letFloatApp+       , letFloatArg+       , letFloatLet+       , letFloatExpr+       , letFloatLetTop+       , letToCase+       )+where++import GhcPlugins++import Data.List+import Data.Monoid++import Language.HERMIT.Kure+import Language.HERMIT.Monad+import Language.HERMIT.External++import Language.HERMIT.Primitive.Common+import Language.HERMIT.Primitive.GHC hiding (externals)+import Language.HERMIT.Primitive.AlphaConversion hiding (externals)++import qualified Language.Haskell.TH as TH++------------------------------------------------------------------------------++-- | Externals relating to Let expressions.+externals :: [External]+externals =+         [ external "let-intro" (promoteExprR . letIntro :: TH.Name -> RewriteH Core)+                [ "e => (let v = e in v), name of v is provided" ]                      .+ Shallow .+ Introduce+         -- , 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)+                     [ "(let v = ev in e) x ==> let v = ev in e x" ]                    .+ Commute .+ Shallow .+ Bash+         , 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-let" (promoteProgramR letFloatLetTop <+ 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" (promoteProgramR 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+         ]++-- not_defined :: String -> RewriteH CoreExpr+-- not_defined nm = fail $ nm ++ " not implemented!"++-- | 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)++-- | (let v = ev in e) x ==> let v = ev in e x+letFloatApp :: RewriteH CoreExpr+letFloatApp = prefixFailMsg "Let floating from App function failed: " $+  do vs <- appT letVarsT freeVarsT intersect+     let letAction = if null vs then idR else alphaLet+     appT letAction idR $ \ (Let bnds e) x -> Let bnds $ App e x++-- | f (let v = ev in e) ==> let v = ev in f e+letFloatArg :: RewriteH CoreExpr+letFloatArg = prefixFailMsg "Let floating from App argument failed: " $+  do vs <- appT freeVarsT letVarsT intersect+     let letAction = if null vs then idR else alphaLet+     appT idR letAction $ \ f (Let bnds e) -> Let bnds $ App f e++-- let v = (let w = ew in ev) in e ==> let w = ew in let v = ev in e+letFloatLet :: RewriteH CoreExpr+letFloatLet = prefixFailMsg "Let floating from Let failed: " $+  do vs <- letNonRecT letVarsT freeVarsT (\ _ -> intersect)+     let bdsAction = if null vs then idR else nonRecR alphaLet+     letT bdsAction idR $ \ (NonRec v (Let bds ev)) e -> Let bds $ Let (NonRec v ev) e++-- | Float a Let through an expression, whatever the context.+letFloatExpr :: RewriteH CoreExpr+letFloatExpr = setFailMsg "Unsuitable expression for Let floating." $+               letFloatApp <+ letFloatArg <+ letFloatLet++-- | 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)++-- | let v = ev in e ==> case ev of v -> e+letToCase :: RewriteH CoreExpr+letToCase = prefixFailMsg "Converting Let to Case failed: " $+  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')]

@@ -0,0 +1,117 @@+module Language.HERMIT.Primitive.Navigation+       ( -- * Navigation+         externals+       , bindGroup+       , namedBinding+       , bindingGroupOf+       , considerName+       , rhsOf+       , considerables+       , considerTargets+       )+where++import GhcPlugins as GHC++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)+            [+              external "consider" considerName+                [ "consider '<v> focuses on the definition of <v>" ]+            , external "consider" considerConstruct+                [ "consider <c> focuses on the first construct <c>.",+                  recognizedConsiderables]+            , external "rhs-of" rhsOf+                [ "rhs-of '<v> focuses on the right-hand-side of the definition of <v>" ]+            , external "binding-group-of" bindingGroupOf+                [ "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++-- | Find the path to the definiiton of the provided name.+considerName :: TH.Name -> TranslateH Core Path+considerName = oneNonEmptyPathToT . namedBinding++-- | Find the path to the RHS of the definition of the given name.+rhsOf :: TH.Name -> TranslateH Core Path+rhsOf nm = onePathToT (namedBinding nm) >>^ (++ [0])++-- | 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 _  _                        =  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 _  _                        =  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+++data Considerable = Binding | Definition | CaseAlt | Variable | Literal | Application | Lambda | LetIn | CaseOf | Casty | Ticky | TypeVar | Coerce++recognizedConsiderables :: String+recognizedConsiderables = "Recognized constructs are: " ++ show (map fst considerables)++-- | Lookup table for constructs that can be considered; the keys are the arguments the user can give to the \"consider\" command.+considerables ::  [(String,Considerable)]+considerables =   [ ("bind",Binding)+                  , ("def",Definition)+                  , ("alt",CaseAlt)+                  , ("var",Variable)+                  , ("lit",Literal)+                  , ("app",Application)+                  , ("lam",Lambda)+                  , ("let",LetIn)+                  , ("case",CaseOf)+                  , ("cast",Casty)+                  , ("tick",Ticky)+                  , ("type",TypeVar)+                  , ("coerce",Coerce)+                  ]++considerConstruct :: String -> TranslateH Core Path+considerConstruct str = case string2considerable str of+                          Nothing -> fail $ "Unrecognized construct \"" ++ str ++ "\". " ++ recognizedConsiderables ++ ".  Or did you mean \"consider '" ++ str ++ "\"?"+                          Just c  -> oneNonEmptyPathToT (underConsideration c)++string2considerable :: String -> Maybe Considerable+string2considerable = flip lookup considerables++underConsideration :: Considerable -> Core -> Bool+underConsideration Binding     (BindCore _)               = True+underConsideration Definition  (BindCore (NonRec _ _))    = True+underConsideration Definition  (DefCore _)                = True+underConsideration CaseAlt     (AltCore _)                = True+underConsideration Variable    (ExprCore (Var _))         = True+underConsideration Literal     (ExprCore (Lit _))         = True+underConsideration Application (ExprCore (App _ _))       = True+underConsideration Lambda      (ExprCore (Lam _ _))       = True+underConsideration LetIn       (ExprCore (Let _ _))       = True+underConsideration CaseOf      (ExprCore (Case _ _ _ _))  = True+underConsideration Casty       (ExprCore (Cast _ _))      = True+underConsideration Ticky       (ExprCore (Tick _ _))      = True+underConsideration TypeVar     (ExprCore (Type _))        = True+underConsideration Coerce      (ExprCore (Coercion _))    = True+underConsideration _           _                          = False

@@ -0,0 +1,326 @@+{-# LANGUAGE TypeFamilies, FlexibleInstances #-}++-- Placeholder for new prims+module Language.HERMIT.Primitive.New where++import GhcPlugins as GHC hiding (varName)+--import Convert (thRdrNameGuesses)+-- import OccName(varName)++import Control.Applicative+import Control.Arrow+import Control.Monad++import Data.List(intercalate,intersect)++import Language.HERMIT.Context+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.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)+                [ "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 .+ TODO+         , 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)+                [ "inline a definition, and apply the arguments; tranditional unfold"]+         , external "push" (promoteExprR . push :: TH.Name -> RewriteH Core)+                [ "push a function <f> into argument."+                , "Unsafe if f is not strict." ] .+ PreCondition+                        -- TODO: does not work with rules with no arguments+         , external "unfold-rule" ((\ nm -> promoteExprR (rules nm >>> cleanupUnfold)) :: String -> RewriteH Core)+                [ "apply a named GHC rule" ]+         , external "var" (promoteExprT . isVar :: TH.Name -> TranslateH Core ())+                 [ "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)" ]+         , 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+         ]+++isVar :: TH.Name -> TranslateH CoreExpr ()+isVar nm = varT (cmpTHName2Id nm) >>= guardM++simplifyR :: RewriteH Core+simplifyR = innermostR (promoteExprR (unfold (TH.mkName ".") <+ betaReducePlus <+ safeLetSubstR <+ caseReduce <+ dce))++-- 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++    -- 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)++        let used = concat $ zipWith intersect (map (flip take ids) [1..]) frees++        if null used+          then do+            tupleConId <- findId c $ "(" ++ replicate (length bnds - 1) ',' ++ ")"++            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++            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"++-- 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 ->+         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 e] +++                                        ["Free Variables: " ++ showVars (coreExprFreeVars e)] +++                                           case e of+                                             Var v -> ["Identifier Info: " ++ showIdInfo v]+                                             _     -> []+                          _          -> []+         in+             return (intercalate "\n" $ [pa,node,con,bds] ++ expExtra)++exprTypeT :: TranslateH CoreExpr String+exprTypeT = arr showExprType++showExprType :: CoreExpr -> String+showExprType = showSDoc . ppr . exprType++showIdInfo :: Id -> String+showIdInfo v = showSDoc $ 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+  where+    f True  = "Rewrite would succeed."+    f False = "Rewrite would fail."++findId :: (MonadUnique m, MonadIO m, MonadThings m) => Context -> String -> m Id+findId c = findIdMG (hermitModGuts c)++findIdMG :: (MonadUnique m, MonadIO m, MonadThings 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  -> fail $ "too many " ++ nm ++ " found:\n" ++ intercalate ", " (map showPpr ns)++ --   liftIO $ print ("VAR", GHC.showSDoc . GHC.ppr $ namedFn)++-- |  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)+-- It is used at the level of the top-redex.+cleanupUnfold :: RewriteH CoreExpr+cleanupUnfold = betaReducePlus >>> safeLetSubstPlusR++unfold :: TH.Name -> RewriteH CoreExpr+unfold nm = translate $ \ env e0 -> do+        let n = appCount e0+        let sub :: RewriteH Core+            sub = pathR (replicate n 0) (promoteR $ inlineName nm)++            sub2 :: RewriteH CoreExpr+            sub2 = extractR sub++        e1 <- apply sub2 env e0++        -- only cleanup if 1 or more arguments+        if n > 0 then apply cleanupUnfold env e1+                 else return e1++-- match in a top-down manner,+withUnfold :: RewriteH Core -> RewriteH Core+withUnfold rr = prefixFailMsg "any-call failed: " $+                readerT $ \ e -> case e of+        ExprCore (App {}) -> childR 1 rec >+> (rr <+ childR 0 rec)+        ExprCore (Var {}) -> rr+        _                 -> anyR rec+   where++        rec :: RewriteH Core+        rec = withUnfold rr+++-- | Push a function through a Case or Let expression.+--   Unsafe if the function is not strict.+push :: TH.Name -> RewriteH CoreExpr+push nm = prefixFailMsg "push failed: " $+     do e <- idR+        case collectArgs e of+          (Var v,args) -> do+                  guardMsg (nm `cmpTHName2Id` v) $ "could not 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+                     Case {} -> caseFloatArg+                     Let {}  -> letFloatArg+                     _       -> fail "argument is not a Case or Let."+          _ -> fail "no function to match."

@@ -0,0 +1,100 @@+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, TupleSections #-}+module Language.HERMIT.Primitive.Unfold+    ( externals+    , stashDef+    , stashApply+    , getUnfolding+    ) where++import GhcPlugins hiding (empty)+import Control.Monad+import Control.Applicative++import Language.HERMIT.Primitive.GHC hiding (externals)+import Language.HERMIT.Primitive.Common++import Language.HERMIT.CoreExtra+import Language.HERMIT.Kure+import Language.HERMIT.Monad+import Language.HERMIT.External+import Language.HERMIT.Context++import Prelude hiding (exp)++------------------------------------------------------------------------++externals :: [External]+externals =+         [ external "remember" stashDef+                ["Remember the current binding, allowing it to be folded/unfolded in the future."]+         , external "unfold" (promoteExprR . stashApply)+                ["Unfold a remembered definition."]+         ]++------------------------------------------------------------------------++-- NOTE: Using a Rewrite because of the way the Kernel is set up.+--       This is a temperary hack until we work out the best way to structure the Kernel.++-- | Stash a binding with a name for later use.+-- Allows us to look at past definitions.+stashDef :: String -> RewriteH Core+stashDef label = sideEffectR $ \ _ core ->+  case core of+    DefCore def           -> saveDef label def+    BindCore (NonRec i e) -> saveDef label (Def i e)+    _                     -> fail "stashDef: not a binding"++-- | Stash a binding with a name for later use.+-- Allows us to look at past definitions.+-- stashDef :: String -> TranslateH Core ()+-- stashDef label = contextfreeT $ \ core ->+--     case core of+--         DefCore def -> saveDef label def+--         BindCore (NonRec i e) -> saveDef label (Def i e)+--         _           -> fail "stashDef: not a binding"++-- | Apply a stashed definition (like inline, but looks in stash instead of context).+stashApply :: String -> RewriteH CoreExpr+stashApply label = setFailMsg "Inlining stashed definition failed: " $+                   withPatFailMsg (wrongExprForm "Var v") $+                   do (c, Var v) <- exposeT+                      constT $ do Def i rhs <- lookupDef label+                                  if idName i == idName v -- Is there a reason we're not just using equality on Id?+                                    then ifM (all (inScope c) <$> apply freeVarsT c rhs)+                                             (return rhs)+                                             (fail "some free variables in stashed definition are no longer in scope.")+                                    else fail $ "stashed definition applies to " ++ showPpr i ++ " not " ++ showPpr v++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)+getUnfolding scrutinee caseBinderOnly i c =+    case lookupHermitBinding i c of+        Nothing -> case unfoldingInfo (idInfo i) of+                     CoreUnfolding { uf_tmpl = uft } -> if caseBinderOnly then fail "not a case binder" else return (uft, 0)+                     _                               -> fail $ "cannot find " ++ show i ++ " in Env or IdInfo."+        Just (LAM {}) -> fail $ show i ++ " is lambda-bound"+        Just (BIND depth _ e') -> if caseBinderOnly then fail "not a case binder" else return (e', depth)+        Just (CASE depth s coreAlt) -> return $ if scrutinee+                                                 then (s, depth)+                                                 else let tys = tyConAppArgs (idType i)+                                                       in either (,depth) (,depth+1) (alt2Exp s tys coreAlt)++-- | Convert lhs of case alternative to a constructor application expression,+--   or a default expression in the case of the DEFAULT alternative.+--   Accepts a list of types to apply to the constructor before the value args.+--+-- > data T a b = C a b Int+--+-- Pseudocode:+--+-- > alt2Exp (...) [a,b] (C, [x,y,z]) ==> C a b (x::a) (y::b) (z::Int)+--+-- The 'Either' denotes whether we picked the default (scrutinee) or built an expression.+-- This matters for the depth check.+alt2Exp :: CoreExpr -> [Type] -> (AltCon,[Id]) -> Either CoreExpr CoreExpr+alt2Exp d _   (DEFAULT   , _ ) = Left d+alt2Exp _ _   (LitAlt l  , _ ) = Right $ Lit l+alt2Exp _ tys (DataAlt dc, as) = Right $ mkCoreConApps dc (map Type tys ++ map Var as)

@@ -0,0 +1,12 @@++-- 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+

@@ -0,0 +1,752 @@+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, GADTs, KindSignatures, TypeFamilies, DeriveDataTypeable #-}++module Language.HERMIT.Shell.Command+       ( -- * The HERMIT Command-line Shell+         commandLine+) where++import qualified GhcPlugins as GHC++import Control.Applicative+import Control.Arrow hiding (loop)+import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception.Base hiding (catch)+import Control.Monad.State+import Control.Monad.Error++import Data.Char+import Data.Monoid+import Data.List (intercalate, isPrefixOf, nub)+import Data.Default (def)+import Data.Dynamic+import qualified Data.Map as M+import Data.Maybe++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++-- import Language.HERMIT.Primitive.GHC+++import Prelude hiding (catch)++import System.Console.ANSI+import System.IO++import qualified Text.PrettyPrint.MarkedHughesPJ as PP++import System.Console.Haskeline hiding (catch)++-- There are 3 types of commands, AST effect-ful, Shell effect-ful, and Queries.++data ShellCommand :: * where+   AstEffect     :: AstEffect                -> ShellCommand+   ShellEffect   :: ShellEffect              -> ShellCommand+   QueryFun      :: QueryFun                 -> ShellCommand+   MetaCommand   :: MetaCommand              -> ShellCommand++-- | AstEffects are things that are recorded in our log and saved files.++data AstEffect+   -- | This applys a rewrite (giving a whole new lower-level AST)+   = Apply      (RewriteH Core)+   -- | This changes the current location using a computed path+   | Pathfinder (TranslateH Core Path)+   -- | This changes the currect location using directions+   | Direction  Direction+   -- | This changes the current location using a give path+   | PushFocus Path++   | BeginScope+   | EndScope+   | Tag String                 -- ^ Adding a tag+   -- | A precondition or other predicate that must not fail+   | CorrectnessCritera  (TranslateH Core ())+   deriving Typeable++instance Extern AstEffect where+    type Box AstEffect = AstEffect+    box i = i+    unbox i = i++data ShellEffect :: * where+   SessionStateEffect    :: (CommandLineState -> SessionState -> IO SessionState) -> ShellEffect+   deriving Typeable++data QueryFun :: * where+   QueryT        :: TranslateH Core String   -> QueryFun+   -- These two be can generalized into+   --  (CommandLineState -> IO String)+   Display       ::                             QueryFun+   Message       :: String                   -> QueryFun+   Inquiry       ::(CommandLineState -> SessionState -> IO String) -> QueryFun+   deriving Typeable++instance Extern QueryFun where+    type Box QueryFun = QueryFun+    box i = i+    unbox i = i++data MetaCommand+   = Resume+   | Abort+   | Dump String String String Int+   | LoadFile String  -- load a file on top of the current node+   | SaveFile String+   deriving Typeable++instance Extern MetaCommand where+    type Box MetaCommand = MetaCommand+    box i = i+    unbox i = i++-- TODO: Use another word, Navigation is a more general concept+-- Perhaps VersionNavigation+data Navigation = Back                  -- back (up) the derivation tree+                | Step                  -- down one step; assumes only one choice+                | Goto Int              -- goto a specific node, if possible+                | GotoTag String        -- goto a specific named tag+        deriving Show++data ShellCommandBox = ShellCommandBox ShellCommand deriving Typeable++instance Extern ShellEffect where+    type Box ShellEffect = ShellEffect+    box i = i+    unbox i = i++instance Extern ShellCommand where+    type Box ShellCommand = ShellCommandBox+    box = ShellCommandBox+    unbox (ShellCommandBox i) = i++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)+                , interp $ \ (TranslateCoreStringBox tt) -> QueryFun (QueryT tt)+                , interp $ \ (TranslateCoreCheckBox tt)  -> AstEffect (CorrectnessCritera tt)+                , interp $ \ (effect :: AstEffect)       -> AstEffect effect+                , interp $ \ (effect :: ShellEffect)     -> ShellEffect effect+                , interp $ \ (query :: QueryFun)         -> QueryFun query+                , interp $ \ (meta :: MetaCommand)       -> MetaCommand meta+                ]+-- TODO: move this into the shell, it is completely specific to the way+-- the shell works. What about list, for example?++--interpKernelCommand :: [Interp KernelCommand]+--interpKernelCommand =+--             [ Interp $ \ (KernelCommandBox cmd)      -> cmd+--             ]++shell_externals :: [External]+shell_externals = map (.+ Shell)+   [+     external "resume"          Resume    -- HERMIT Kernel Exit+       [ "stops HERMIT; resumes compile" ]+   , external "abort"           Abort     -- UNIX Exit+       [ "hard UNIX-style exit; does not return to GHC; does not save" ]+   , external "display"         Display+       [ "redisplays current state" ]+   , external "left"            (Direction L)+       [ "move to the next child"]+   , external "right"           (Direction R)+       [ "move to the previous child"]+   , external "up"              (Direction U)+       [ "move to the parent"]+   , external "down"            (Direction D)+       [ "move to the first child"]+   , external "tag"             Tag+       [ "tag <label> names the current AST with a label" ]+   , external "navigate"        (SessionStateEffect $ \ _ st -> return $ st { cl_nav = True })+       [ "switch to navigate mode" ]+   , external "command-line"    (SessionStateEffect $ \ _ st -> return $ st { cl_nav = False })+       [ "switch to command line mode" ]+   , external "top"            (Direction T)+       [ "move to root of tree" ]+   , external "back"            (SessionStateEffect $ navigation Back)+       [ "go back in the derivation" ]                                          .+ VersionControl+   , external "log"             (Inquiry showDerivationTree)+       [ "go back in the derivation" ]                                          .+ VersionControl+   , external "step"            (SessionStateEffect $ navigation Step)+       [ "step forward in the derivation" ]                                     .+ VersionControl+   , external "goto"            (SessionStateEffect . navigation . Goto)+       [ "goto a specific step in the derivation" ]                             .+ VersionControl+   , external "goto"            (SessionStateEffect . navigation . GotoTag)+       [ "goto a named step in the derivation" ]+   , external "setpp"           (\ pp -> SessionStateEffect $ \ _ st ->+       case M.lookup pp pp_dictionary of+         Nothing -> do+            putStrLn $ "List of Pretty Printers: " ++ intercalate ", " (M.keys pp_dictionary)+            return st+         Just _ -> return $ st { cl_pretty = pp })+       [ "set the pretty printer"+       , "use 'setpp ls' to list available pretty printers" ]+   , external "set-renderer"    changeRenderer+       [ "set the output renderer mode"]+   , external "set-renderer"    showRenderers+       [ "set the output renderer mode"]+   , external "dump"    Dump+       [ "dump <filename> <pretty-printer> <renderer> <width>"]+   , external "set-width"   (\ n -> SessionStateEffect $ \ _ st -> return $ st { cl_width = n })+       ["set the width of the screen"]+   , external "set-pp-expr-type"+                (\ str -> SessionStateEffect $ \ _ st -> case reads str :: [(ShowOption,String)] of+                                                 [(opt,"")] -> return $ st { cl_pretty_opts =+                                                                                 (cl_pretty_opts st) { po_exprTypes = opt }+                                                                           }+                                                 _ -> return st)+       ["set how to show expression-level types (Show|Abstact|Omit)"]+   , external "{"   BeginScope+       ["push current lens onto a stack"]       -- tag as internal+   , external "}"   EndScope+       ["pop a lens off a stack"]               -- tag as internal+   , external "load"  LoadFile+       ["load <filename> : load a file of commands into the current derivation"]+   , external "save"  SaveFile+       ["save <filename> : save the current complete derivation into a file"]+   ]++showRenderers :: QueryFun+showRenderers = Message $ "set-renderer " ++ show (map fst finalRenders)++changeRenderer :: String -> ShellEffect+changeRenderer renderer = SessionStateEffect $ \ _ st ->+        case lookup renderer finalRenders of+          Nothing -> return st          -- should fail with message+          Just r  -> return $ st { cl_render = r }++----------------------------------------------------------------------------------++catch :: IO a -> (String -> IO a) -> IO a+catch = catchJust (\ (err :: IOException) -> return (show err))++pretty :: SessionState -> PrettyH Core+pretty ss = case M.lookup (cl_pretty ss) pp_dictionary of+                Just pp -> pp (cl_pretty_opts ss)+                Nothing -> pure (PP.text $ "<<no pretty printer for " ++ cl_pretty ss ++ ">>")++showFocus :: MonadIO m => CLM m ()+showFocus = do+    st <- get+    -- No not show focus while loading+    ifM (gets (cl_loading . cl_session))+        (return ())+        (iokm2clm' "Rendering error: "+                   (liftIO . cl_render (cl_session st) stdout (cl_pretty_opts $ cl_session st))+                   (queryS (cl_kernel st) (cl_cursor $ cl_session st) (pretty $ cl_session st) (cl_kernel_env $ cl_session st))+        )++-------------------------------------------------------------------------------++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 -> IO (KureMonad 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+        -- and the session state (perhaps in a seperate state?)+        , cl_session      :: SessionState+        }++newSAST :: ExprH -> SAST -> CommandLineState -> CommandLineState+newSAST expr sast st = st { cl_session = (cl_session st) { cl_cursor = sast }+                          , cl_graph = (cl_cursor (cl_session st), expr, sast) : cl_graph st+                          }++-- 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_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+        }++-------------------------------------------------------------------------------++data CompletionType = ConsiderC -- complete with possible arguments to consider+                    | InlineC   -- complete with names that can be inlined+                    | CommandC  -- complete using dictionary commands (default)+                    | 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?+--       for instance, completing "any-bu (inline " should be different than completing just "inline "+--       this would also allow typed completion?+completionType :: String -> CompletionType+completionType = go . dropWhile isSpace+    where go rPrev = case [ ty | (nm, ty) <- opts, reverse nm `isPrefixOf` rPrev ] of+                        []  -> CommandC+                        [t] -> t+                        ts  -> AmbiguousC ts+          opts = [ ("inline"  , InlineC  )+                 , ("consider", ConsiderC)+                 , ("rhs-of"  , ConsiderC)+                 ]++completionQuery :: CommandLineState -> CompletionType -> IO (TranslateH Core [String])+completionQuery _ ConsiderC = return $ considerTargets >>^ ((++ map fst considerables) . map ('\'':))+completionQuery _ InlineC   = return $ inlineTargets   >>^ map ('\'':)+completionQuery s CommandC  = return $ pure (M.keys (cl_dict s))+-- Need to modify opts in completionType function. No key can be a suffix of another key.+completionQuery _ (AmbiguousC ts) = do+    putStrLn "\nCannot tab complete: ambiguous completion type."+    putStrLn $ "Possibilities: " ++ intercalate ", " (map show ts)+    return (pure [])++shellComplete :: MVar CommandLineState -> String -> String -> IO [Completion]+shellComplete mvar rPrev so_far = do+    st <- readMVar mvar+    targetQuery <- completionQuery st (completionType rPrev)+    -- (liftM.liftM) (map simpleCompletion . nub . filter (so_far `isPrefixOf`))+    --     $ 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.+    return $ (map simpleCompletion . nub . filter (so_far `isPrefixOf`)) cl++-- | The first argument is a list of files to load.+commandLine :: [String] -> Behavior -> GHC.ModGuts -> GHC.CoreM GHC.ModGuts+commandLine filesToLoad behavior modGuts = do+    let dict = dictionary $ all_externals shell_externals+    let ws_complete = " ()"++    let startup = do+            modify $ \st -> st { cl_session = (cl_session st) { cl_loading = True } }+            sequence_ [ performMetaCommand $ case fileName of+                         "abort"  -> Abort+                         "resume" -> Resume+                         _        -> LoadFile fileName+                      | fileName <- reverse filesToLoad+                      , not (null fileName)+                      ] `ourCatch` \ msg -> liftIO . putStrLn $ "Booting Failure: " ++ msg+            modify $ \st -> st { cl_session = (cl_session st) { cl_loading = False } }++    var <- GHC.liftIO $ atomically $ newTVar M.empty++    flip scopedKernel modGuts $ \ skernel sast -> do++        let sessionState = SessionState sast "clean" def unicodeConsole 80 False False var+            shellState = CommandLineState [] [] dict skernel sessionState++        completionMVar <- newMVar shellState++        _ <- runInputTBehavior behavior+                (setComplete (completeWordWithPrev Nothing ws_complete (shellComplete completionMVar)) defaultSettings)+                (evalStateT (runErrorT (startup >> showFocus >> loop completionMVar)) shellState)++        return ()++loop :: (MonadIO m, m ~ InputT IO) => MVar CommandLineState -> CLM m ()+loop completionMVar = loop'+  where loop' = do+            st <- get+            -- so the completion can get the current state+            liftIO $ modifyMVar_ completionMVar (const $ return st)+            -- liftIO $ print (cl_pretty st, cl_cursor (cl_session st))+            let SAST n = cl_cursor (cl_session st)+            maybeLine <- if cl_nav (cl_session st)+                           then liftIO getNavCmd+                           else lift $ lift $ getInputLine $ "hermit<" ++ show n ++ "> "++            case maybeLine of+                Nothing             -> performMetaCommand Resume+                Just ('-':'-':_msg) -> loop'+                Just line           ->+                    if all isSpace line+                    then loop'+                    else (case parseStmtsH line of+                                Left  msg   -> throwError ("Parse failure: " ++ msg)+                                Right stmts -> evalStmts stmts)+                         `ourCatch` (liftIO . putStrLn)+                           >> loop'++ourCatch :: (MonadIO n) => CLM IO () -> (String -> CLM n ()) -> CLM n ()+ourCatch m failure = do+                st <- get+                (res,st') <- liftIO $ runStateT (runErrorT m) st+                put st'+                case res of+                  Left msg -> failure msg+                  Right () -> return ()++++evalStmts :: (MonadIO m) => [StmtH ExprH] -> CLM m ()+evalStmts = mapM_ evalExpr . scopes+    where scopes :: [StmtH ExprH] -> [ExprH]+          scopes [] = []+          scopes (ExprH e:ss) = e : scopes ss+          scopes (ScopeH s:ss) = (CmdName "{" : scopes s) ++ [CmdName "}"] ++ scopes ss+++evalExpr :: (MonadIO m) => ExprH -> CLM m ()+evalExpr expr = do+    dict <- gets cl_dict+    case interpExprH dict interpShellCommand expr of+      Left msg  -> throwError msg+      Right cmd -> case cmd of+                     AstEffect effect   -> performAstEffect effect expr+                     ShellEffect effect -> performShellEffect effect+                     QueryFun query     -> performQuery query+                     MetaCommand meta   -> performMetaCommand meta++-------------------------------------------------------------------------------++-- TODO: This can be refactored. We always showFocus. Also, Perhaps return a modifier, not ()+--   UPDATE: Not true.  We don't always showFocus.+-- TODO: All of these should through an exception if they fail to execute the command as given.++performAstEffect :: MonadIO m => AstEffect -> ExprH -> CLM m ()+performAstEffect (Apply rr) expr = do+    st <- get+    iokm2clm' "Rewrite failed: "+              (\ ast' -> put (newSAST expr ast' st) >> showFocus)+              (applyS (cl_kernel st) (cl_cursor $ cl_session st) rr (cl_kernel_env $ cl_session st))++performAstEffect (Pathfinder t) expr = do+    st <- get+    -- An extension to the Path+    iokm2clm' "Cannot find path: "+              (\ p -> do ast <- iokm2clm "Path is invalid: " $ modPathS (cl_kernel st) (cl_cursor (cl_session st)) (extendLocalPath p) (cl_kernel_env $ cl_session st)+                         put $ newSAST expr ast st+                         showFocus)+              (queryS (cl_kernel st) (cl_cursor $ cl_session st) t (cl_kernel_env $ cl_session st))++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))+        put $ newSAST expr ast st+        showFocus++performAstEffect EndScope expr = do+        st <- get+        ast <- liftIO $ endScopeS (cl_kernel st) (cl_cursor (cl_session st))+        put $ newSAST expr ast st+        showFocus++performAstEffect (Tag tag) _ = do+        st <- get+        put (st { cl_tags = (tag, cl_cursor $ cl_session st) : cl_tags st })++performAstEffect (CorrectnessCritera q) expr = do+        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 ++ "]"+++-------------------------------------------------------------------------------++performShellEffect :: MonadIO m => ShellEffect -> CLM m ()+performShellEffect (SessionStateEffect f) = do+        st <- get+        opt <- liftIO (fmap Right (f st $ cl_session st) `catch` \ str -> return (Left str))+        case opt of+          Right s_st' -> do put (st { cl_session = s_st' })+                            showFocus+          Left err -> throwError err++-------------------------------------------------------------------------------++performQuery :: MonadIO m => QueryFun -> CLM m ()+performQuery (QueryT q) = do+    st <- get+    iokm2clm' "Query failed: "+              putStrToConsole+              (queryS (cl_kernel st) (cl_cursor $ cl_session st) q (cl_kernel_env $ cl_session st))++performQuery (Inquiry f) = do+    st <- get+    str <- liftIO $ f st (cl_session st)+    putStrToConsole str++-- 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))++-------------------------------------------------------------------------------++performMetaCommand :: MonadIO m => MetaCommand -> CLM m ()+performMetaCommand Abort  = gets cl_kernel >>= (liftIO . abortS)+performMetaCommand Resume = do st <- get+                               liftIO $ resumeS (cl_kernel st) (cl_cursor $ cl_session st)+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"+performMetaCommand (LoadFile fileName) = do+        putStrToConsole $ "[loading " ++ fileName ++ "]"+        res <- liftIO $ try (readFile fileName)+        case res of+          Right str -> case parseStmtsH (normalize str) of+                        Left  msg  -> throwError ("Parse failure: " ++ msg)+                        Right stmts -> do+                            load_st <- gets (cl_loading . cl_session)+                            modify $ \st -> st { cl_session = (cl_session st) { cl_loading = True } }+                            evalStmts stmts `catchError` (\ err -> do+                                    modify $ \ st -> st { cl_session = (cl_session st) { cl_loading = load_st } }+                                    throwError err)+                            modify $ \st -> st { cl_session = (cl_session st) { cl_loading = load_st } }+                            putStrToConsole $ "[done, loaded " ++ show (numStmtsH stmts) ++  " commands]" -- TODO: This is better than saying "N", but not very robust.+                            showFocus+          Left (err :: IOException) -> throwError ("IO error: " ++ show err)+  where+   normalize = unlines+             . map (++ ";")     -- HACK!+             . map rmComment+             . lines+   rmComment []     = []+   rmComment xs     | "--" `isPrefixOf` xs = [] -- we need a real parser and lexer here!+   rmComment (x:xs) = x : rmComment xs++performMetaCommand (SaveFile fileName) = do+        st <- get+        putStrToConsole $ "[saving " ++ fileName ++ "]"+        -- no checks to see if you are clobering; be careful+        liftIO $ writeFile fileName $ showGraph (cl_graph st) (cl_tags st) (SAST 0)+++-------------------------------------------------------------------------------++putStrToConsole :: MonadIO m => String -> CLM m ()+putStrToConsole str = ifM (gets (cl_loading . cl_session))+                          (return ())+                          (liftIO $ putStrLn str)++-------------------------------------------------------------------------------++newtype UnicodeTerminal = UnicodeTerminal (Handle -> Maybe Path -> IO ())++instance RenderSpecial UnicodeTerminal where+        renderSpecial sym = UnicodeTerminal $ \ h _ -> hPutStr h [ch]+                where (Unicode ch) = renderSpecial sym++instance Monoid UnicodeTerminal where+        mempty = UnicodeTerminal $ \ _ _ -> return ()+        mappend (UnicodeTerminal f1) (UnicodeTerminal f2) = UnicodeTerminal $ \ h p -> f1 h p >> f2 h p++finalRenders :: [(String,Handle -> PrettyOptions -> DocH -> IO ())]+finalRenders =+        [ ("unicode-terminal", unicodeConsole)+        ] ++ coreRenders++unicodeConsole :: Handle -> PrettyOptions -> DocH -> IO ()+unicodeConsole h w doc = do+    let (UnicodeTerminal prty) = renderCode w doc+    prty h Nothing+++instance RenderCode UnicodeTerminal where+        rPutStr txt  = UnicodeTerminal $ \ h _ -> hPutStr h txt++        rDoHighlight _ [] = UnicodeTerminal $ \ h _ -> hSetSGR h [Reset]+        rDoHighlight _ (Color col:_) = UnicodeTerminal $ \ h _ -> do+                hSetSGR h [ Reset ]+                hSetSGR h $ case col of+                        KeywordColor -> [ SetConsoleIntensity BoldIntensity+                                        , SetColor Foreground Dull Blue+                                        ]+                        SyntaxColor  -> [ SetColor Foreground Dull Red ]+                        VarColor     -> []   -- as is+                        TypeColor    -> [ SetColor Foreground Dull Green ]+                        LitColor     -> [ SetColor Foreground Dull Cyan ]+        rDoHighlight o (_:rest) = rDoHighlight o rest+        rEnd = UnicodeTerminal $ \ h _ -> hPutStrLn h ""++--------------------------------------------------------++navigation :: Navigation -> CommandLineState -> SessionState -> IO SessionState+navigation whereTo st sess_st =+    case whereTo of+      Goto n -> do+           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+      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+      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)"+             [(_,cmd,d) ] -> do+                           putStrLn $ "step : " ++ unparseExprH cmd+                           return $ sess_st { cl_cursor = d }+             _ -> fail "Cannot step forward (multiple choices)"+      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)"+             [(s,cmd,_) ] -> do+                           putStrLn $ "back, unstepping : " ++ unparseExprH cmd+                           return $ sess_st { cl_cursor = s }+             _          -> fail "Cannot step backwards (multiple choices, impossible!)"++--------------------------------------------------------++getNavCmd :: IO (Maybe String)+getNavCmd = do+        b_in <- hGetBuffering stdin+        hSetBuffering stdin NoBuffering+        b_out <- hGetBuffering stdin+        hSetBuffering stdout NoBuffering+        ec_in <- hGetEcho stdin+        hSetEcho stdin False+        putStr "(navigation mode; use arrow keys, escape to quit, '?' for help)"+        r <- readCh []+        putStr "\n"+        hSetBuffering stdin b_in+        hSetBuffering stdout b_out+        hSetEcho stdin ec_in+        return r+  where+   readCh xs = do+        x <- getChar+        let str = xs ++ [x]+        (fromMaybe reset $ lookup str cmds) str++   reset _ = do+        putStr "\BEL"+        readCh []++   res str _ = return (Just str)++   cmds = [ ("\ESC" , \ str -> ifM (hReady stdin)+                                   (readCh str)+                                   (return $ Just "command-line"))+          , ("\ESC[" , readCh)+          , ("\ESC[A", res "up")+          , ("\ESC[B", res "down")+          , ("\ESC[C", res "right")+          , ("\ESC[D", res "left")+          , ("?",      res "nav-commands")+          , ("f",      res "step")+          ] +++          [ (show n, res (show n)) | n <- [0..9] :: [Int] ]+++showDerivationTree :: CommandLineState -> SessionState -> IO String+showDerivationTree st ss = return $ unlines $ showRefactorTrail graph tags 0 me+  where+          graph = [ (a,[unparseExprH b],c) | (SAST a,b,SAST c) <- cl_graph st ]+          tags  = [ (n,nm) | (nm,SAST n) <- cl_tags st ]+          SAST me = cl_cursor ss++showRefactorTrail :: (Eq a, Show a) => [(a,[String],a)] -> [(a,String)] -> a -> a -> [String]+showRefactorTrail db tags a me =+        case [ (b,c) | (a0,b,c) <- db, a == a0 ] of+           [] -> [show' 3 a ++ " " ++ dot ++ tags_txt]+           ((b,c):bs) ->+                      [show' 3 a ++ " " ++ dot ++ (if not (null bs) then "->" else "") ++ tags_txt ] +++                      ["    " ++ "| " ++ txt | txt <- b ] +++                      showRefactorTrail db tags c me +++                      if null bs+                      then []+                      else [] :+                          showRefactorTrail [ (a',b',c') | (a',b',c') <- db+                                                          , not (a == a' && c == c')+                                                          ]  tags a me++  where+          dot = if a == me then "*" else "o"+          show' n x = replicate (n - length (show a)) ' ' ++ show x+          tags_txt = concat [ ' ' : txt+                            | (n,txt) <- tags+                            , n == a+                            ]+++showGraph :: [(SAST,ExprH,SAST)] -> [(String,SAST)] -> SAST -> String+showGraph graph tags this@(SAST n) =+        (if length paths > 1 then "tag " ++ show n ++ "\n" else "") +++        concat (intercalate+                ["goto " ++ show n ++ "\n"]+                [ [ unparseExprH b ++ "\n" ++ showGraph graph tags c ]+                | (b,c) <- paths+                ])+  where+          paths = [ (b,c) | (a,b,c) <- graph, a == this ]++----------------------------------------------------------------------------------------------++cl_kernel_env  :: SessionState -> HermitMEnv+cl_kernel_env ss = mkHermitMEnv $ \ msg -> case msg of+                DebugTick    msg'      -> do+                        c <- GHC.liftIO $ tick (cl_tick ss) msg'+                        GHC.liftIO $ putStrLn $ "<" ++ show c ++ "> " ++ msg'+                DebugCore  msg' cxt core -> do+                        GHC.liftIO $ putStrLn $ "[" ++ msg' ++ "]"+                        doc :: DocH <- apply (pretty ss) cxt core+                        GHC.liftIO $ cl_render ss stdout (cl_pretty_opts ss) doc++-- tick counter+tick :: TVar (M.Map String Int) -> String -> IO Int+tick var msg = atomically $ do+        m <- readTVar var+        let c = case M.lookup msg m of+                Nothing -> 1+                Just x  -> x + 1+        writeTVar var (M.insert msg c m)+        return c+