hermit 0.1.8.0 → 0.2.0.0

raw patch · 51 files changed

+3900/−2140 lines, 51 filesdep ~kurePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: kure

API changes (from Hackage documentation)

Files

• dist/build/Language/HERMIT/Parser.hs +16/−18
• dist/build/Language/HERMIT/ParserCore.hs +14/−27
• examples/concatVanishes/ConcatVanishes.hss +1/−2
• examples/concatVanishes/HList.hs +0/−5
• examples/concatVanishes/QSort.hss +0/−2
• examples/evaluation/Eval.hss +5/−5
• examples/factorial/Fac.hss +3/−3
• examples/fib-tuple/Fib.hss +8/−7
• examples/flatten/Flatten.hss +1/−1
• examples/hanoi/Hanoi.hss +11/−11
• examples/last/Last.hss +2/−2
• examples/mean/Mean.hs +1/−2
• examples/mean/Mean.hss +11/−11
• examples/qsort/QSort.hss +7/−2
• examples/reverse/Reverse.hss +1/−1
• hermit.cabal +31/−8
• src/Language/HERMIT/Context.hs +182/−101
• src/Language/HERMIT/Core.hs +171/−20
• src/Language/HERMIT/Dictionary.hs +41/−52
• src/Language/HERMIT/External.hs +121/−44
• src/Language/HERMIT/GHC.hs +80/−46
• src/Language/HERMIT/Interp.hs +6/−2
• src/Language/HERMIT/Kernel/Scoped.hs +49/−47
• src/Language/HERMIT/Kure.hs +1357/−712
• src/Language/HERMIT/Kure/SumTypes.hs +255/−0
• src/Language/HERMIT/Monad.hs +1/−24
• src/Language/HERMIT/Optimize.hs +28/−19
• src/Language/HERMIT/Parser.y +13/−12
• src/Language/HERMIT/ParserCore.y +10/−21
• src/Language/HERMIT/PrettyPrinter/AST.hs +55/−24
• src/Language/HERMIT/PrettyPrinter/Clean.hs +294/−246
• src/Language/HERMIT/PrettyPrinter/Common.hs +129/−66
• src/Language/HERMIT/PrettyPrinter/GHC.hs +10/−2
• src/Language/HERMIT/Primitive/AlphaConversion.hs +77/−78
• src/Language/HERMIT/Primitive/Common.hs +67/−53
• src/Language/HERMIT/Primitive/Debug.hs +17/−2
• src/Language/HERMIT/Primitive/FixPoint.hs +15/−13
• src/Language/HERMIT/Primitive/Fold.hs +8/−8
• src/Language/HERMIT/Primitive/GHC.hs +188/−83
• src/Language/HERMIT/Primitive/Inline.hs +59/−26
• src/Language/HERMIT/Primitive/Kure.hs +11/−4
• src/Language/HERMIT/Primitive/Local.hs +23/−18
• src/Language/HERMIT/Primitive/Local/Case.hs +94/−70
• src/Language/HERMIT/Primitive/Local/Cast.hs +29/−24
• src/Language/HERMIT/Primitive/Local/Let.hs +70/−51
• src/Language/HERMIT/Primitive/Navigation.hs +43/−22
• src/Language/HERMIT/Primitive/Navigation/Crumbs.hs +100/−0
• src/Language/HERMIT/Primitive/New.hs +23/−35
• src/Language/HERMIT/Primitive/Unfold.hs +29/−29
• src/Language/HERMIT/Shell/Command.hs +90/−62
• src/Language/HERMIT/Syntax.hs +43/−17

@@ -10,11 +10,11 @@ import Data.Char (isSpace) import Data.List (intercalate) -import Language.HERMIT.Syntax+import Language.HERMIT.Syntax (isScriptInfixIdChar, isScriptIdFirstChar, isScriptIdChar) import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts --- parser produced by Happy Version 1.18.10+-- parser produced by Happy Version 1.18.6  newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11 = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607@@ -342,8 +342,7 @@ 	_ -> happyError' (tk:tks) 	} -happyError_ 14# tk tks = happyError' tks-happyError_ _ tk tks = happyError' (tk:tks)+happyError_ tk tks = happyError' (tk:tks)  happyThen :: () => Either String a -> (a -> Either String b) -> Either String b happyThen = (>>=)@@ -406,11 +405,11 @@ lexer ('[' :cs)    = fmap (ListStart:)  $ lexer cs lexer (',' :cs)    = fmap (ListDelim:)  $ lexer cs lexer (']' :cs)    = fmap (ListEnd:)    $ lexer cs-lexer s@(c:cs)     | isSpace       c = lexer cs-                   | isIdFirstChar c = let (i,s') = span isIdChar s-                                       in fmap (Ident i:) $ lexer s'-                   | isInfixId     c = let (op,s') = span isInfixId s-                                       in fmap (InfixOp op:) $ lexer s'+lexer s@(c:cs)     | isSpace             c = lexer cs+                   | isScriptIdFirstChar c = let (i,s') = span isScriptIdChar s+                                              in fmap (Ident i:) $ lexer s'+                   | isScriptInfixIdChar c = let (op,s') = span isScriptInfixIdChar s+                                              in fmap (InfixOp op:) $ lexer s' lexer s            = Left $ "lexer: no match on " ++ s  lexString :: String -> Either String (String,String)@@ -450,17 +449,17 @@  unparseExprH :: ExprH -> String unparseExprH (SrcName nm)-    | nm /= "" && (all isInfixId nm || isIdFirstChar (head nm) && all (isIdChar) (tail nm)) = "'" ++ nm+    | nm /= "" && (all isScriptInfixIdChar nm || isScriptIdFirstChar (head nm) && all isScriptIdChar (tail nm)) = "'" ++ nm     | otherwise = "'\"" ++ concatMap escape nm ++ "\""         where escape '\"' = "\\\""               escape c    = [c] unparseExprH (CmdName nm)-    | nm == "{"       = "{ "-    | nm == "}"       = " }"-    | all isIdChar nm = nm-    | otherwise       = show nm     -- with quotes+    | nm == "{"             = "{ "+    | nm == "}"             = " }"+    | all isScriptIdChar nm = nm+    | otherwise             = show nm     -- with quotes unparseExprH (AppH (AppH (CmdName nm) e1) e2)-    | all isInfixId nm+    | all isScriptInfixIdChar nm     = unparseAtom e1 ++ " " ++ nm ++ " " ++ unparseAtom e2 unparseExprH (AppH e1 e2) = unparseExprH e1 ++ " " ++ unparseAtom e2 unparseExprH (CoreH s)    = "[|" ++ s ++ "|]"@@ -658,10 +657,9 @@ -- Error recovery (0# is the error token)  -- parse error if we are in recovery and we fail again-happyFail 0# tk old_st _ stk@(x `HappyStk` _) =-     let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+happyFail  0# tk old_st _ stk = --	trace "failing" $ -        happyError_ i tk+    	happyError_ tk  {-  We don't need state discarding for our restricted implementation of     "error".  In fact, it can cause some bogus parses, so I've disabled it

@@ -4,7 +4,7 @@ module Language.HERMIT.ParserCore (parseCore) where  import Control.Monad.Reader-import Data.Char (isSpace, isAlpha, isAlphaNum, isDigit)+import Data.Char (isSpace, isDigit)  import GhcPlugins @@ -12,6 +12,7 @@ import Language.HERMIT.External import Language.HERMIT.Monad import Language.HERMIT.Primitive.Common+import Language.HERMIT.Syntax (isCoreInfixIdChar, isCoreIdFirstChar, isCoreIdChar)  import Language.KURE.MonadCatch (prefixFailMsg) @@ -19,7 +20,7 @@ import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts --- parser produced by Happy Version 1.18.10+-- parser produced by Happy Version 1.18.6  newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607@@ -226,8 +227,7 @@ 	_ -> happyError' (tk:tks) 	} -happyError_ 34# tk tks = happyError' tks-happyError_ _ tk tks = happyError' (tk:tks)+happyError_ tk tks = happyError' (tk:tks)  happyThen :: () => CoreParseM a -> (a -> CoreParseM b) -> CoreParseM b happyThen = (>>=)@@ -262,7 +262,7 @@  type CoreParseM a = ReaderT HermitC HermitM a -parseError :: [Token] -> CoreParseM a+parseError :: Monad m => [Token] -> m a parseError ts = fail $ "core parse error: " ++ show ts  data Token@@ -314,29 +314,17 @@                      in case rest of                            ('\"':cs') -> fmap (Tstring str:) $ lexer cs'                            _          -> Left "lexer: no matching quote"-lexer s@(c:cs)     | isSpace       c = lexer cs-                   | isDigit       c = let (i,s') = span isDigit s-                                       in fmap (Tinteger (read i):) $ lexer s'-                   | isIdFirstChar c = let (i,s') = span isIdChar s-                                       in fmap (Tname i:) $ lexer s'-                   | isInfixId     c = let (op,s') = span isInfixId s-                                       in fmap (Tname op:) $ lexer s'+lexer s@(c:cs) | isSpace           c = lexer cs+               | isDigit           c = let (i,s') = span isDigit s+                                         in fmap (Tinteger (read i):) $ lexer s'+               | isCoreIdFirstChar c = let (i,s') = span isCoreIdChar s+                                         in fmap (Tname i:) $ lexer s'+               | isCoreInfixIdChar c = let (op,s') = span isCoreInfixIdChar s+                                         in fmap (Tname op:) $ lexer s' lexer s            = Left $ "lexer: no match on " ++ s  --------------------------------------------- --- | Chars that are valid in identifiers anywhere.-isIdFirstChar :: Char -> Bool-isIdFirstChar c = c `elem` "_$[]:.=" || isAlpha c---- | Chars that are valid in identifiers, but not as the first character.-isIdChar :: Char -> Bool-isIdChar c = isAlphaNum c || c `elem` "#-'" || isIdFirstChar c---- | Chars that are valid in infix operators.-isInfixId :: Char -> Bool-isInfixId c = c `elem` "+*/._-:<>"- parseCore :: CoreString -> HermitC -> HermitM CoreExpr parseCore (CoreString s) c =     case lexer s of@@ -529,10 +517,9 @@ -- Error recovery (0# is the error token)  -- parse error if we are in recovery and we fail again-happyFail 0# tk old_st _ stk@(x `HappyStk` _) =-     let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+happyFail  0# tk old_st _ stk = --	trace "failing" $ -        happyError_ i tk+    	happyError_ tk  {-  We don't need state discarding for our restricted implementation of     "error".  In fact, it can cause some bogus parses, so I've disabled it

@@ -1,7 +1,6 @@ ww-split-param 1 [|wrap|] [|unwrap|] 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 "(:) ++")+innermost (case-float-let >+> bash >+> push 'repH >+> unfold-rule "repH ++" >+> unfold-rule "repH (:)" >+> unfold-rule "repH []" >+> unfold-rule "[] ++" >+> unfold-rule "[] ++" >+> unfold-rule "(:) ++") any-td (unfold-rule "rep-abs-fusion") any-call (unfold 'absH)

@@ -24,10 +24,5 @@ {-# 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                   #-}

@@ -3,5 +3,3 @@ { load "ConcatVanishes.hss" } one-td let-subst bash--

@@ -2,15 +2,15 @@ consider 'eval ww-split [| wrap |] [| unwrap |] {rhs-of 'work-   eta-expand 'e ; 0-   eta-expand 's ; 0-   eta-expand 'f ; 0+   eta-expand 'e ; lam-body+   eta-expand 's ; lam-body+   eta-expand 'f ; lam-body    unfold 'unwrap    one-td (unfold 'f)    bash    {-     consider case ; 2 ; 0 ; abstract 'm-     consider case ; 2 ; 0 ; abstract 'n+     consider case ; [case-alt 1, alt-rhs] ; abstract 'm+     consider case ; [case-alt 1, alt-rhs] ; abstract 'n    }    any-bu (fold 'unwrap)    any-bu (foreward (ww-fusion [| wrap |] [|unwrap|] [|work|]))

@@ -8,8 +8,8 @@   one-td (unfold 'wrap)   simplify   {-    consider alt ; 0 ; case-float-arg-    consider alt ; 0 ; case-float-arg+    consider alt ; alt-rhs ; case-float-arg+    consider alt ; alt-rhs ; case-float-arg   }   one-td (unfold '-)   one-td (unfold '*)@@ -19,4 +19,4 @@ simplify innermost (case-float <+ case-reduce) simplify-{ consider let ; 1 ; eta-expand 'n ; any-call (unfold 'wrap) }+{ [def-rhs, let-body] ; eta-expand 'n ; any-call (unfold 'wrap) }

@@ -8,7 +8,7 @@  -- work = unwrap (f (wrap work)) -0 ; eta-expand 'n+def-rhs ; eta-expand 'n  -- work n = unwrap (f (wrap work)) n @@ -16,19 +16,20 @@  -- work n = (f (wrap work) n, f (wrap work) (n+1)) -0 ; case-split-inline 'n+lam-body ; 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-call (unfold 'f) }+{ case-alt 0 ; any-call (unfold 'f) }+{ [ case-alt 1, alt-rhs, app-arg] ; any-call (unfold 'f) } simplify  -- work 0     = (0, 1) -- work (n+1) = (f (wrap work) (n+1), wrap work (n+1) + wrap work n) -2 ; 0 ; { 1 ; any-call (unfold origwork) }+[ case-alt 1, alt-rhs ]+{ app-arg ; any-call (unfold origwork) }  -- work 0     = (0, 1) -- work (n+1) = (f (wrap work) (n+1), wrap (unwrap (f (wrap work))) (n+1) + wrap (unwrap (f (wrap work))) n)@@ -38,8 +39,8 @@ -- 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 }+{ arg 3 ; arg 1 ; let-intro 'x }+{ arg 2 ; let-intro 'y } innermost let-float try (reorder-lets ['x,'y]) one-td (fold 'y)

@@ -7,7 +7,7 @@ any-call (unfold 'unwrap) simplify {rhs-of 'work-   0+   lam-body    eta-expand 'acc    innermost case-float    any-call (unfold-rule "repH ++")

@@ -10,13 +10,13 @@   any-call (unfold 'unwrap)    -- establish the zero base case-  down ; down ; down ; down ; down+  [ def-rhs, lam-body, lam-body, lam-body, lam-body]   case-split-inline 'n-  { 1 ; any-call (unfold 'f) ; simplify }+  { case-alt 0 ; any-call (unfold 'f) ; simplify }    -- establish the one base case-  { 2 ; down ; case-split-inline 'a-    { 1 ; any-call (unfold 'f) ; simplify+  { [case-alt 1, alt-rhs] ; case-split-inline 'a+    { case-alt 0 ; any-call (unfold 'f) ; simplify       any-call (unfold origwork)       any-call (foreward (ww-assumption-A [| wrap |] [| unwrap |]))       any-call (unfold 'f)@@ -24,7 +24,7 @@       any-call (unfold-rule "[] ++")       any-call (unfold-rule "++ []")     }-    { 2 ; any-call (unfold 'f) ; simplify+    { case-alt 1 ; any-call (unfold 'f) ; simplify        any-call (unfold origwork)       any-call (foreward (ww-assumption-A [| wrap |] [| unwrap |]))@@ -37,13 +37,13 @@        -- time to let intro       -- need a "occurance 'work" like consider-      { down-        { 1-          { 0 ; 1-            { 0 ; 1 ; let-intro 'u }-            { 1 ; 1 ; let-intro 'v }+      { alt-rhs+        { arg 5+          { arg 1+            { arg 1 ; let-intro 'u }+            { arg 2 ; arg 2 ; let-intro 'v }           }-          { 1 ; 1 ; 0 ; 1 ; let-intro 'w }+          { arg 2 ; arg 2 ; arg 1 ; let-intro 'w }         }         innermost let-float         try (reorder-lets ['u,'v,'w])

@@ -3,9 +3,9 @@ ww-split-param 1 [|wrap|] [|unwrap|] {rhs-of 'work    eta-expand 'b-   0+   lam-body    eta-expand 'bs-   0+   lam-body    unfold 'unwrap    unfold 'f    bash

@@ -1,8 +1,7 @@-module Main where+module Main (main, mean) where  import Prelude hiding (sum, length) -{-# NOINLINE mean #-} mean :: [Int] -> Int mean xs = sum xs `div` length xs 

@@ -1,28 +1,28 @@-{rhs-of 'mean ; 0-  { 1 ; let-intro 'l }-  { 0 ; 1 ; let-intro 's }+{rhs-of 'mean ; lam-body+  { arg 2 ; let-intro 's }+  { arg 3 ; let-intro 'l }   innermost let-float   try (reorder-lets ['s,'l])   let-tuple 'sl-  { 0 ; abstract 'xs ; 0 ; let-intro 'sumlength }+  { case-expr ; abstract 'xs ; app-fun ; let-intro 'sumlength } } innermost let-float consider 'sumlength nonrec-to-rec           -- since we intend sumlength to be a recursive function-0+rec-def 0 remember sumlen-{ 0 ; 0+{ [def-rhs, lam-body]   case-split-inline 'xs   any-call (unfold 'sum)   any-call (unfold 'length)   simplify-  2+  case-alt 1   alpha-alt ['y,'ys]-  0-  { 1 ; 1 ; let-intro 'l }-  { 0 ; 1 ; 1 ; let-intro 's }+  alt-rhs+  { arg 3 ; arg 3 ; let-intro 'l }+  { arg 2 ; arg 3 ; let-intro 's }   innermost let-float   try (reorder-lets ['s,'l])   let-tuple 'sl-  { 0 ; fold sumlen }+  { case-expr ; fold sumlen } }

@@ -8,11 +8,16 @@ simplify {rhs-of 'work   alpha-lam 'xs+  lam-body   any-td case-float-arg-  0   eta-expand 'acc   bash-  {consider case ; consider case ; consider alt+  one-td inline-case-binder -- this used to be part of bash+  bash+  lam-body+  {  case-alt 1+     any-td (push 'repH)+     consider alt      alpha-alt ['bs,'cs]      any-td (unfold-rule "repH ++")      any-bu case-float-arg

@@ -8,7 +8,7 @@ simplify {rhs-of 'work    alpha-lam 'ys-   0+   lam-body    eta-expand 'acc    innermost case-float    one-td (unfold-rule "repH ++")

@@ -1,5 +1,5 @@ Name:                hermit-Version:             0.1.8.0+Version:             0.2.0.0 Synopsis:            Haskell Equational Reasoning Model-to-Implementation Tunnel Description:   HERMIT uses Haskell to express semi-formal models,@@ -36,12 +36,12 @@   .   @    $ hermit Reverse.hs Reverse.hss resume-   [starting HERMIT v0.1.8.0 on Reverse.hs]+   [starting HERMIT v0.2.0.0 on Reverse.hs]    % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:Main:Reverse.hss -fplugin-opt=HERMIT:Main:resume    [1 of 2] Compiling HList            ( HList.hs, HList.o )    Loading package ghc-prim ... linking ... done.    ...-   Loading package hermit-0.1.8.0 ... linking ... done.+   Loading package hermit-0.2.0.0 ... linking ... done.    [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )    Linking Reverse ...    $ ./Reverse@@ -52,13 +52,34 @@   .   @    $ hermit Reverse.hs-   [starting HERMIT v0.1.8.0 on Reverse.hs]+   [starting HERMIT v0.2.0.0 on Reverse.hs]    % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:Main:    [1 of 2] Compiling HList            ( HList.hs, HList.o )    Loading package ghc-prim ... linking ... done.    ...-   Loading package hermit-0.1.8.0 ... linking ... done.+   Loading package hermit-0.2.0.0 ... linking ... done.    [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )+   ===================== Welcome to HERMIT =====================+   HERMIT is a toolkit for the interactive transformation of GHC+   core language programs. Documentation on HERMIT can be found+   on the HERMIT web page at:+   http:\/\/www.ittc.ku.edu\/csdl\/fpg\/software\/hermit.html+   .+   You have just loaded the interactive shell. To exit, type+   \"abort\" or \"resume\" to abort or resume GHC compilation.+   .+   Type \"help\" for instructions on how to list or search the+   available HERMIT commands.+   .+   To get started, you could try the following:+   \ \ - type \"consider 'foo\", where \"foo\" is a function+   \ \ \ \ defined in the module;+   \ \ - type \"set-pp-type Show\" to switch on typing information;+   \ \ - use natural numbers such as \"0\" and \"1\" to descend into+   \ \ \ \ the definition, and \"up\" to ascend;+   \ \ - type \"info\" for more information about the current node;+   \ \ - type \"log\" to display an activity log.+   =============================================================    module main:Main where    \ \ rev ∷ ∀ a . [a] -> [a]    \ \ unwrap ∷ ∀ a . ([a] -> [a]) -> [a] -> H a@@ -132,7 +153,7 @@                  data-default >= 0.5.0,                  ghc >= 7.6,                  haskeline >= 0.7.0.3,-                 kure >= 2.6.22,+                 kure >= 2.7.1,                  marked-pretty >= 0.1,                  mtl >= 2.1.2,                  operational >= 0.2.2.1,@@ -155,6 +176,7 @@        Language.HERMIT.Kernel        Language.HERMIT.Kernel.Scoped        Language.HERMIT.Kure+       Language.HERMIT.Kure.SumTypes        Language.HERMIT.Monad        Language.HERMIT.Optimize        Language.HERMIT.Parser@@ -175,6 +197,7 @@        Language.HERMIT.Primitive.Local.Case        Language.HERMIT.Primitive.Local.Cast        Language.HERMIT.Primitive.Navigation+       Language.HERMIT.Primitive.Navigation.Crumbs        Language.HERMIT.Primitive.New        Language.HERMIT.Primitive.Unfold @@ -204,5 +227,5 @@     Ghc-Options:  source-repository head-  type:     git-  location: git://github.com/ku-fpg/hermit.git+    type:     git+    location: git://github.com/ku-fpg/hermit.git

@@ -1,150 +1,231 @@-{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE InstanceSigs, ConstraintKinds, MultiParamTypeClasses #-}  module Language.HERMIT.Context-       ( -- * The HERMIT Context+       ( -- * HERMIT Contexts+         -- ** The Standard Context          HermitC        , initHermitC-         -- ** Adding to the Context-       , addAltBindings-       , addBinding-       , addCaseBinding+         -- ** Bindings+       , HermitBindingSite(..)+       , BindingDepth+       , HermitBinding+       , hermitBindingSiteExpr+       , hermitBindingExpr+         -- ** Adding bindings to contexts+       , AddBindings(..)+       , addBindingGroup        , addLambdaBinding-         -- ** Reading from the Context-       , hermitBindings-       , hermitDepth-       , hermitPath-       , hermitModGuts-       , lookupHermitBinding-       , boundVars+       , addAltBindings+       , addCaseWildBinding+       , addForallBinding+         -- ** Reading bindings from the context+       , BoundVars(..)        , boundIn        , findBoundVars-         -- ** Bindings-       , HermitBinding(..)-       , hermitBindingDepth+       , ReadBindings(..)+       , lookupHermitBinding+         -- ** Accessing the Global Reader Environment from the context+       , HasGlobalRdrEnv(..)+         -- ** Accessing GHC rewrite rules from the context+       , HasCoreRules(..) ) where  import Prelude hiding (lookup) import GhcPlugins hiding (empty)+import Data.Monoid (mempty) import Data.Map hiding (map, foldr, filter)+import qualified Data.Set as S import qualified Language.Haskell.TH as TH -import Language.HERMIT.GHC- import Language.KURE +import Language.HERMIT.Core+import Language.HERMIT.GHC+ ------------------------------------------------------------------------ +-- | The depth of a binding.  Used, for example, to detect shadowing when inlining.+type BindingDepth = Int++ -- | 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. We store both the scrutinised expression,-                                          --   and the case alternative 'AltCon' (which can be converted to Constructor or Literal) and identifiers.+--   Bound expressions cannot be inlined without checking for shadowing issues (using the depth information).+data HermitBindingSite+        = REC CoreExpr+        | NONREC CoreExpr+        | LAM+        | CASEALT+        | FORALL+        | CASEWILD CoreExpr (AltCon,[Var])  -- ^ We store both the scrutinised expression, and the case alternative 'AltCon' (which can be converted to Constructor or Literal) and variables. --- | Get the depth of a binding.-hermitBindingDepth :: HermitBinding -> Int-hermitBindingDepth (LAM d)      = d-hermitBindingDepth (BIND d _ _) = d-hermitBindingDepth (CASE d _ _) = d-{-# INLINE hermitBindingDepth #-}+type HermitBinding = (BindingDepth, HermitBindingSite) +-- | Retrieve the expression in a 'HermitBindingSite', if there is one.+hermitBindingSiteExpr :: HermitBindingSite -> Maybe CoreExpr+hermitBindingSiteExpr b = case b of+                            REC e        -> Just e+                            NONREC e     -> Just e+                            CASEWILD e _ -> Just e+                            _            -> Nothing++-- | Retrieve the expression in a 'HermitBinding', if there is one.+hermitBindingExpr :: HermitBinding -> Maybe CoreExpr+hermitBindingExpr = hermitBindingSiteExpr . snd+ ------------------------------------------------------------------------ +-- | A class of contexts that can have HERMIT bindings added to them.+class AddBindings c where+  -- | Add a complete set of parrallel bindings to the context.+  --   (Parallel bindings occur in recursive let bindings and case alternatives.)+  --   This can also be used for solitary bindings (e.g. lambdas).+  --   Bindings are added in parallel sets to help with shadowing issues.+  addHermitBindings :: [(Var,HermitBindingSite)] -> c -> c++-- | Here the bindings are just discarded.+instance AddBindings (SnocPath crumb) where+  addHermitBindings :: [(Var,HermitBindingSite)] -> SnocPath crumb -> SnocPath crumb+  addHermitBindings _ = id++-------------------------------------------++-- | Add a single binding to the context.+addHermitBinding  :: AddBindings c => Var -> HermitBindingSite -> c -> c+addHermitBinding v bd = addHermitBindings [(v,bd)]++-- | Add all bindings in a binding group to a context.+addBindingGroup :: AddBindings c => CoreBind -> c -> c+addBindingGroup (NonRec v e) = addHermitBinding  v (NONREC e)+addBindingGroup (Rec ies)    = addHermitBindings [ (i, REC e) | (i,e) <- ies ]++-- | Add a wildcard binding for a specific case alternative.+addCaseWildBinding :: AddBindings c => (Id,CoreExpr,CoreAlt) -> c -> c+addCaseWildBinding (i,e,(con,vs,_)) = addHermitBinding i (CASEWILD e (con,vs))++-- | Add a lambda bound variable to a context.+--   All that is known is the variable, which may shadow something.+--   If so, we don't worry about that here, it is instead checked during inlining.+addLambdaBinding :: AddBindings c => Var -> c -> c+addLambdaBinding v = addHermitBinding v LAM++-- | Add the variables bound by a 'DataCon' in a case.+--   They are all bound at the same depth.+addAltBindings :: AddBindings c => [Var] -> c -> c+addAltBindings vs = addHermitBindings [ (v, CASEALT) | v <- vs ]++-- | Add a universally quantified type variable to a context.+addForallBinding :: AddBindings c => TyVar -> c -> c+addForallBinding v = addHermitBinding v FORALL++------------------------------------------------------------------------++-- | A class of contexts that stores the set of variables in scope that have been bound during the traversal.+class BoundVars c where+  boundVars :: c -> S.Set Var++-- | List all variables bound in the context that match the given name.+findBoundVars :: BoundVars c => TH.Name -> c -> [Var]+findBoundVars nm = filter (cmpTHName2Var nm) . S.toList . boundVars+++-- | A class of contexts from which HERMIT bindings can be retrieved.+class BoundVars c => ReadBindings c where+  hermitDepth    :: c -> BindingDepth+  hermitBindings :: c -> Map Var HermitBinding++-- | Determine if a variable is bound in a context.+boundIn :: ReadBindings c => Var -> c -> Bool+boundIn i c = i `member` hermitBindings c++-- | Lookup the binding for a variable in a context.+lookupHermitBinding :: ReadBindings c => Var -> c -> Maybe HermitBinding+lookupHermitBinding v = lookup v . hermitBindings++------------------------------------------------------------------------++-- | A class of contexts that store GHC rewrite rules.+class HasCoreRules c where+  hermitCoreRules :: c -> [CoreRule]++------------------------------------------------------------------------++-- | A class of contexts that store the Global Reader Environment.+class HasGlobalRdrEnv c where+  hermitGlobalRdrEnv :: c -> GlobalRdrEnv++------------------------------------------------------------------------+ -- | 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 HermitC = HermitC-        { hermitBindings :: Map Var HermitBinding   -- ^ All (important) bindings in scope.-        , hermitDepth    :: Int                     -- ^ The depth of the bindings.-        , hermitPath     :: AbsolutePath            -- ^ The 'AbsolutePath' to the current node from the root.-        , hermitModGuts  :: ModGuts                 -- ^ The 'ModGuts' of the current module.+        { hermitC_bindings       :: Map Var HermitBinding   -- ^ All (important) bindings in scope.+        , hermitC_depth          :: BindingDepth            -- ^ The depth of the bindings.+        , hermitC_path           :: AbsolutePath Crumb      -- ^ The 'AbsolutePath' to the current node from the root.+        , hermitC_globalRdrEnv   :: GlobalRdrEnv            -- ^ The top-level lexical environment.+        , hermitC_coreRules      :: [CoreRule]              -- ^ GHC rewrite RULES.         }  ------------------------------------------------------------------------ --- | The HERMIT context stores an 'AbsolutePath' to the current node in the tree.-instance PathContext HermitC where-  absPath :: HermitC -> AbsolutePath-  absPath = hermitPath-  {-# INLINE absPath #-}--  (@@) :: HermitC -> Int -> HermitC-  c @@ n = c { hermitPath = hermitPath c @@ n }-  {-# INLINE (@@) #-}- -- | Create the initial HERMIT 'HermitC' by providing a 'ModGuts'. initHermitC :: ModGuts -> HermitC-initHermitC modGuts = HermitC empty 0 rootAbsPath modGuts-{-# INLINE initHermitC #-}+initHermitC modGuts = HermitC+                        { hermitC_bindings      = empty+                        , hermitC_depth         = 0+                        , hermitC_path          = mempty+                        , hermitC_globalRdrEnv  = mg_rdr_env modGuts+                        , hermitC_coreRules     = mg_rules modGuts ++ other_rules+                        } +    where other_rules :: [CoreRule]+          other_rules = mg_binds modGuts >>= bindToIdExprs >>= (idCoreRules . fst)+ ------------------------------------------------------------------------ --- | Add all bindings in a binding group to a context.-addBinding :: CoreBind -> HermitC -> HermitC-addBinding corebind c = let nextDepth = succ (hermitDepth c)-                            hbds      = hermitBindings c-                            newBds    = case corebind of-                                          NonRec v e  -> insert v (BIND nextDepth False e) hbds-                                          Rec bds     -> hbds `union` fromList [ (b, BIND nextDepth True e) | (b,e) <- bds ]-                                                         -- Notice how all recursive binding in a binding group are at the same depth.-                        in c { hermitBindings = newBds-                             , hermitDepth    = nextDepth-                             }-{-# INLINE addBinding #-}+-- | Retrieve the 'AbsolutePath' to the current node, from the HERMIT context.+instance ReadPath HermitC Crumb where+  absPath :: HermitC -> AbsolutePath Crumb+  absPath = hermitC_path --- | Add the bindings for a specific case alternative.-addCaseBinding :: (Id,CoreExpr,CoreAlt) -> HermitC -> HermitC-addCaseBinding (v,e,(con,vs,_)) c = let nextDepth = succ (hermitDepth c)-                                     in c { hermitBindings = insert v (CASE nextDepth e (con,vs)) (hermitBindings c)-                                          , hermitDepth    = nextDepth-                                          }-{-# INLINE addCaseBinding #-}+-- | Extend the 'AbsolutePath' stored in the HERMIT context.+instance ExtendPath HermitC Crumb where+  (@@) :: HermitC -> Crumb -> HermitC+  c @@ n = c { hermitC_path = hermitC_path c @@ n } --- | Add a lambda bound variable to a context.---   All that is known is the variable, which may shadow something.---   If so, we don't worry about that here, it is instead checked during inlining.-addLambdaBinding :: Var -> HermitC -> HermitC-addLambdaBinding v c = let nextDepth = succ (hermitDepth c)-                        in c { hermitBindings = insert v (LAM nextDepth) (hermitBindings c)-                             , hermitDepth    = nextDepth-                             }-{-# INLINE addLambdaBinding #-}+------------------------------------------------------------------------ --- | Add the variables 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 :: [Var] -> HermitC -> HermitC-addAltBindings vs c = let nextDepth = succ (hermitDepth c)-                       in c { hermitBindings = foldr (\ v bds -> insert v (LAM nextDepth) bds) (hermitBindings c) vs-                            , hermitDepth    = nextDepth-                            }-{-# INLINE addAltBindings #-}--- TODO: Is treating case-alternative bindings as lambda bindings okay?---       There's no issues with lambda bindings being sequential and case-alternative bindings being in parallel?+instance AddBindings HermitC where+  addHermitBindings :: [(Var,HermitBindingSite)] -> HermitC -> HermitC+  addHermitBindings vbs c = let nextDepth = succ (hermitC_depth c)+                                vhbs      = [ (v, (nextDepth,b)) | (v,b) <- vbs ]+                             in c { hermitC_bindings = fromList vhbs `union` hermitC_bindings c+                                  , hermitC_depth    = nextDepth+                                  }  ------------------------------------------------------------------------ --- | Lookup the binding for a variable in a context.-lookupHermitBinding :: Var -> HermitC -> Maybe HermitBinding-lookupHermitBinding n env = lookup n (hermitBindings env)-{-# INLINE lookupHermitBinding #-}+instance BoundVars HermitC where+  boundVars :: HermitC -> S.Set Var+  boundVars =  keysSet . hermitC_bindings --- | List all the variables bound in a context.-boundVars :: HermitC -> [Var]-boundVars = keys . hermitBindings-{-# INLINE boundVars #-}+instance ReadBindings HermitC where+  hermitDepth :: HermitC -> BindingDepth+  hermitDepth = hermitC_depth --- | Determine if a variable is bound in a context.-boundIn :: Var -> HermitC -> Bool-boundIn i c = i `elem` boundVars c-{-# INLINE boundIn #-}+  hermitBindings :: HermitC -> Map Var HermitBinding+  hermitBindings = hermitC_bindings  ------------------------------------------------------------------------ --- | List all variables bound in the context that match the given name.-findBoundVars :: TH.Name -> HermitC -> [Var]-findBoundVars nm = filter (cmpTHName2Var nm) . boundVars-{-# INLINE findBoundVars #-}+instance HasCoreRules HermitC where+  hermitCoreRules :: HermitC -> [CoreRule]+  hermitCoreRules = hermitC_coreRules++------------------------------------------------------------------------++instance HasGlobalRdrEnv HermitC where+  hermitGlobalRdrEnv :: HermitC -> GlobalRdrEnv+  hermitGlobalRdrEnv = hermitC_globalRdrEnv  ------------------------------------------------------------------------

@@ -1,9 +1,9 @@+{-# LANGUAGE LambdaCase #-}+ module Language.HERMIT.Core           (             -- * Generic Data Type-            -- $typenote-            Core(..)-          , CoreProg(..)+            CoreProg(..)           , CoreDef(..)           , CoreTickish             -- * Conversions to/from 'Core'@@ -19,6 +19,12 @@           , funArgResTypes           , funsWithInverseTypes           , appCount+            -- * Crumbs+          , Crumb(..)+          , showCrumbs+--          , crumbToDeprecatedInt+          , deprecatedLeftSibling+          , deprecatedRightSibling ) where  import GhcPlugins@@ -26,22 +32,7 @@ import Language.KURE.Combinators.Monad import Language.KURE.MonadCatch -------------------------------------------------------------------------- $typenote---   NOTE: 'Type' is not included in the sum type.---   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.-data Core = GutsCore  ModGuts            -- ^ The module.-          | ProgCore  CoreProg           -- ^ A program (a telescope of top-level binding groups).-          | BindCore  CoreBind           -- ^ A binding group.-          | DefCore   CoreDef            -- ^ A recursive definition.-          | ExprCore  CoreExpr           -- ^ An expression.-          | AltCore   CoreAlt            -- ^ A case alternative.+import Data.List (intercalate)  --------------------------------------------------------------------- @@ -113,7 +104,7 @@ appCount :: CoreExpr -> Int appCount (App e1 _) = appCount e1 + 1 appCount _          = 0-{-# INLINE appCount #-}+-- don't inline, recursive  ----------------------------------------------------------------------- @@ -138,5 +129,165 @@                                    guardM (eqType gdom fcod)                                    return (fdom,fcod) {-# INLINE funsWithInverseTypes #-}++-----------------------------------------------------------------------++-- | Crumbs record a path through the tree, using descriptive constructor names.+data Crumb =+           -- ModGuts+             ModGuts_Prog+           -- Prog+           | ProgCons_Head | ProgCons_Tail+           -- Bind+           | NonRec_RHS | NonRec_Var+           | Rec_Def Int+           -- Def+           | Def_Id | Def_RHS+           -- Expr+           | Var_Id+           | Lit_Lit+           | App_Fun | App_Arg+           | Lam_Var | Lam_Body+           | Let_Bind | Let_Body+           | Case_Scrutinee | Case_Binder | Case_Type | Case_Alt Int+           | Cast_Expr | Cast_Co+           | Tick_Tick | Tick_Expr+           | Type_Type+           | Co_Co+           -- Alt+           | Alt_Con | Alt_Var Int | Alt_RHS+           -- Type+           | TyVarTy_TyVar+           | LitTy_TyLit+           | AppTy_Fun | AppTy_Arg+           | TyConApp_TyCon | TyConApp_Arg Int+           | FunTy_Dom | FunTy_CoDom+           | ForAllTy_Var | ForAllTy_Body+           -- Coercion+           | Refl_Type+           | TyConAppCo_TyCon | TyConAppCo_Arg Int+           | AppCo_Fun | AppCo_Arg+           | ForAllCo_TyVar | ForAllCo_Body+           | CoVarCo_CoVar+           | AxiomInstCo_Axiom | AxiomInstCo_Index | AxiomInstCo_Arg Int+           | UnsafeCo_Left | UnsafeCo_Right+           | SymCo_Co+           | TransCo_Left | TransCo_Right+           | NthCo_Int | NthCo_Co+           | InstCo_Co | InstCo_Type+           | LRCo_LR | LRCo_Co+           deriving (Eq,Read,Show)+           -- TODO: Write a prettier Show instance+++showCrumbs :: [Crumb] -> String+showCrumbs crs = "[" ++ intercalate ", " (map showCrumb crs) ++ "]"++-- Note, these should match the external names in Language.HERMIT.Primitive.Navigation.Crumbs+showCrumb :: Crumb -> String+showCrumb = \case+               ModGuts_Prog   -> "prog"+               ProgCons_Head  -> "prog-head"+               ProgCons_Tail  -> "prog-tail"+               NonRec_RHS     -> "nonrec-rhs"+               Rec_Def n      -> "rec-def " ++ show n+               Def_RHS        -> "def-rhs"+               App_Fun        -> "app-fun"+               App_Arg        -> "app-arg"+               Lam_Body       -> "lam-body"+               Let_Bind       -> "let-bind"+               Let_Body       -> "let-body"+               Case_Scrutinee -> "case-expr"+               Case_Type      -> "case-type"+               Case_Alt n     -> "case-alt " ++ show n+               Cast_Expr      -> "cast-expr"+               Cast_Co        -> "cast-co"+               Tick_Expr      -> "tick-expr"+               Alt_RHS        -> "alt-rhs"+               Type_Type      -> "type"+               Co_Co          -> "coercion"+               -- Types+               AppTy_Fun      -> "appTy-fun"+               AppTy_Arg      -> "appTy-arg"+               TyConApp_Arg n -> "tyCon-arg " ++ show n+               FunTy_Dom      -> "fun-dom"+               FunTy_CoDom    -> "fun-cod"+               ForAllTy_Body  -> "forall-body"+               -- Coercions+               Refl_Type         -> "refl-type"+               TyConAppCo_Arg n  -> "coCon-arg " ++ show n+               AppCo_Fun         -> "appCo-fun"+               AppCo_Arg         -> "appCo-arg"+               ForAllCo_Body     -> "coForall-body"+               AxiomInstCo_Arg n -> "axiom-inst " ++ show n+               UnsafeCo_Left     -> "unsafe-left"+               UnsafeCo_Right    -> "unsafe-right"+               SymCo_Co          -> "sym-co"+               TransCo_Left      -> "trans-left"+               TransCo_Right     -> "trans-right"+               NthCo_Co          -> "nth-co"+               InstCo_Co         -> "inst-co"+               InstCo_Type       -> "inst-type"+               LRCo_Co           -> "lr-co"++               _              -> "Warning: Crumb should not be in use!  This is probably Neil's fault."++{-+-- | Earlier versions of HERMIT used 'Int' as the crumb type.+--   This function maps a 'Crumb' back to that corresponding 'Int', for backwards compatibility purposes.+crumbToDeprecatedInt :: Crumb -> Maybe Int+crumbToDeprecatedInt = \case+                          ModGuts_Prog   -> Just 0+                          ProgCons_Bind  -> Just 0+                          ProgCons_Tail  -> Just 1+                          NonRec_RHS     -> Just 0+                          NonRec_Var     -> Nothing+                          Rec_Def n      -> Just n+                          Def_Id         -> Nothing+                          Def_RHS        -> Just 0+                          App_Fun        -> Just 0+                          App_Arg        -> Just 1+                          Lam_Var        -> Nothing+                          Lam_Body       -> Just 0+                          Let_Bind       -> Just 0+                          Let_Body       -> Just 1+                          Case_Scrutinee -> Just 0+                          Case_Binder    -> Nothing+                          Case_Type      -> Nothing+                          Case_Alt n     -> Just (n + 1)+                          Cast_Expr      -> Just 0+                          Cast_Co        -> Nothing+                          Tick_Tick      -> Nothing+                          Tick_Expr      -> Just 0+                          Type_Type      -> Nothing+                          Co_Co          -> Nothing+                          Alt_Con        -> Nothing+                          Alt_Var _      -> Nothing+                          Alt_RHS        -> Just 0+-}+-- | Converts a 'Crumb' into the 'Crumb' pointing to its left-sibling, if a such a 'Crumb' exists.+--   This is for backwards compatibility purposes with the old Int representation.+deprecatedLeftSibling :: Crumb -> Maybe Crumb+deprecatedLeftSibling = \case+                           ProgCons_Tail       -> Just ProgCons_Head+                           Rec_Def n | n > 0   -> Just (Rec_Def (n-1))+                           App_Arg             -> Just App_Fun+                           Let_Body            -> Just Let_Bind+                           Case_Alt n | n == 0 -> Just Case_Scrutinee+                                      | n >  0 -> Just (Case_Alt (n-1))+                           _                   -> Nothing++-- | Converts a 'Crumb' into the 'Crumb' pointing to its right-sibling, if a such a 'Crumb' exists.+--   This is for backwards compatibility purposes with the old Int representation.+deprecatedRightSibling :: Crumb -> Maybe Crumb+deprecatedRightSibling = \case+                           ProgCons_Head       -> Just ProgCons_Tail+                           Rec_Def n           -> Just (Rec_Def (n+1))+                           App_Fun             -> Just App_Arg+                           Let_Bind            -> Just Let_Body+                           Case_Scrutinee      -> Just (Case_Alt 0)+                           Case_Alt n          -> Just (Case_Alt (n+1))+                           _                   -> Nothing+  -----------------------------------------------------------------------

@@ -4,18 +4,19 @@     ( -- * The HERMIT Dictionary       -- | This is the main namespace. Things tend to be untyped, because the API is accessed via (untyped) names.       Dictionary-    , all_externals-    , dictionary+    , externals+    , mkDict     , pp_dictionary-    , metaCmd+    , bashR+    , bashDebugR     ) where --- import Data.Default (def)+import Control.Arrow+ import Data.Dynamic import Data.List import Data.Map (Map, fromList, toList) -import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.External @@ -42,12 +43,14 @@ --   Looking up a 'Dynamic' (via a 'String' key) returns a list, as there can be multiple 'Dynamic's with the same name. type Dictionary = Map String [Dynamic] -prim_externals :: [External]-prim_externals =+-- | List of all 'External's provided by HERMIT.+externals :: [External]+externals =        Alpha.externals     ++ Debug.externals     ++ FixPoint.externals     ++ Fold.externals+    ++ GHC.externals     ++ Inline.externals     ++ Kure.externals     ++ Local.externals@@ -55,14 +58,9 @@     ++ New.externals     ++ Unfold.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 a dictionary from a list of 'External's.-dictionary :: [External] -> Dictionary-dictionary externs = toDictionary externs'+mkDict :: [External] -> Dictionary+mkDict externs = toDictionary externs'   where         msg = layoutTxt 60 (map (show . fst) dictionaryOfTags)         externs' = externs ++@@ -70,25 +68,22 @@                     [ "(this message)" ] .+ Query .+ Shell                 , external "help" (help_command externs')                     ([ "help <command>|<category>|categories|all|<search-string>"-                     , "displays help about a command or category."+                     , "Displays help about a command, or all commands in a category."                      , "Multiple items may match."                      , ""-                     , "categories: " ++ head msg+                     , "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+                , external "bash" (bashR externs) (bashHelp externs) .+ Eval .+ Deep .+ Loop+                , external "debug-bash" (bashDebugR True externs)+                    [ "verbose bash - most useful with set-auto-corelint True" ] .+ Eval .+ Deep .+ Loop                 ]  --------------------------------------------------------------------------  -- | The pretty-printing dictionaries.-pp_dictionary :: Map String (PrettyOptions -> PrettyH Core)+pp_dictionary :: Map String (PrettyOptions -> PrettyH CoreTC) pp_dictionary = fromList         [ ("clean",  Clean.corePrettyH)         , ("ast",    AST.corePrettyH)@@ -112,21 +107,21 @@ make_help = concatMap snd . toList . toHelp  help_command :: [External] -> String -> String-help_command externals m+help_command exts m         | [(ct :: CmdTag,"")] <- reads m-        = unlines $ make_help $ filter (tagMatch ct) externals-help_command externals "all"-        = unlines $ make_help externals+        = unlines $ make_help $ filter (tagMatch ct) exts+help_command exts "all"+        = unlines $ make_help exts help_command _ "categories" = unlines $-                [ "categories" ] +++                [ "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+help_command exts m = unlines $ make_help $ pathPrefix m+    where pathPrefix p = filter (isInfixOf p . externName) exts  layoutTxt :: Int -> [String] -> [String] layoutTxt n (w1:w2:ws) | length w1 + length w2 >= n = w1 : layoutTxt n (w2:ws)@@ -135,28 +130,22 @@  -------------------------------------------------------------------------- --- TODO: We need to think harder about bash/metaCmd.+bashPredicate :: CmdTag+bashPredicate = Bash --- 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] ])+bashR :: [External] -> RewriteH Core+bashR = bashDebugR False -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] ])+bashDebugR :: Bool -> [External] -> RewriteH Core+bashDebugR debug exts =+    setFailMsg "bashR: nothing to do."+    $ innermostR $ orR [ if debug then rr >>> Debug.observeR (externName e) else rr+                       | (e,rr) <- matchingExternals bashPredicate exts ] -------------------------------------+bashHelp :: [External] -> [String]+bashHelp exts =+    "Iteratively apply the following rewrites until nothing changes:"+    : [ externName e | (e,_ :: RewriteH Core) <- matchingExternals bashPredicate exts ]++--------------------------------------------------------------------------+

@@ -13,6 +13,7 @@        , toHelp        , external        , Extern(..)+       , matchingExternals        -- * Tags        , CmdTag(..)        , TagE@@ -27,12 +28,16 @@        , TagBox(..)        , IntBox(..)        , RewriteCoreBox(..)+       , RewriteCoreTCBox(..)        , BiRewriteCoreBox(..)        , TranslateCoreStringBox(..)+       , TranslateCoreTCStringBox(..)        , TranslateCoreCheckBox(..)        , NameBox(..)        , CoreString(..)        , CoreBox(..)+       , CrumbBox(..)+       , PathBox(..)        , TranslateCorePathBox(..)        , StringBox(..)        , NameListBox(..)@@ -62,28 +67,29 @@ --   (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.+data CmdTag = Shell          -- ^ Shell-specific 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)+            | Deep           -- ^ Command may make a deep change, can be O(n).+            | Shallow        -- ^ Command operates on local nodes only, 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.+            | 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 are run by 'Language.HERMIT.Dictionary.bash'.-            | Context        -- ^ A command that uses its context, such as inline-            | Unsafe         -- ^ Commands that are either not type safe (may cause core lint to fail),-                             --   or allow behavior-altering changes.+            | Context        -- ^ A command that uses its context, such as inlining.+            | Unsafe         -- ^ Commands that are not type safe (may cause Core Lint to fail),+                             --   or may otherwise change the semantics of the program. -            | TODO           -- ^ TODO: check before the release.-            | Unimplemented  -- ^ Something is not finished yet, do not use.+            | TODO           -- ^ An incomplete or potentially buggy command.             | Experiment     -- ^ Things we are trying out.+            | Deprecated     -- ^ A command that will be removed in a future release;+                             --   it has probably been renamed or subsumed by another command.   -- Unsure about these@@ -111,32 +117,32 @@   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, such as inlining")-          , (Unsafe,       "Commands that are not type safe (may cause core lint to fail), or allow behavior-altering changes")+          [ (Shell,        "Shell-specific command.")+          , (Eval,         "The arrow of evaluation (reduces a term).")+          , (KURE,         "Direct reflection of a combinator from 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,        "A question 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,        "A command specifically to help debugging.")+          , (VersionControl,"Version control for Core syntax.")+          , (Bash,         "A command that runs as part of the \"bash\" command.")+          , (Context,      "A command that uses its context, such as inlining.")+          , (Unsafe,       "Commands that are not type safe (may cause Core Lint to fail), or may otherwise change the semantics of the program.") -          , (TODO,         "TO BE assessed before a release")-          , (Unimplemented,"Something is not finished yet; do not used")-          , (Experiment,   "Things we are trying out")+          , (TODO,         "An incomplete or potentially buggy command.")+          , (Experiment,   "Things we are trying out, use at your own risk.")+          , (Deprecated,   "A command that will be removed in a future release; it has probably been renamed or subsumed by another command.")           ]   -- Unfortunately, record update syntax seems to associate to the right.--- This guy saves us some parentheses.+-- These operators save us some parentheses. infixl 3 .+ infixr 4 .|| infixr 5 .&@@ -217,6 +223,12 @@         , externTags = []         } +-- | Get all the 'External's which match a given tag predicate+-- and box a Translate of the appropriate type.+matchingExternals :: (Extern tr, Tag t) => t -> [External] -> [(External, tr)]+matchingExternals tag exts = [ (e,tr) | e <- exts, tagMatch tag e+                                      , Just tr <- [fmap unbox $ fromDynamic $ externFun e] ]+ -- | Build a 'Data.Map' from names to 'Dynamic' values. toDictionary :: [External] -> Map ExternalName [Dynamic] toDictionary@@ -259,11 +271,15 @@     -- | 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@@ -271,6 +287,8 @@     box = TagBox     unbox (TagBox t) = t +-----------------------------------------------------------------+ data IntBox = IntBox Int deriving Typeable  instance Extern Int where@@ -278,63 +296,118 @@     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+    unbox (RewriteCoreBox r) = r +-----------------------------------------------------------------++data RewriteCoreTCBox = RewriteCoreTCBox (RewriteH CoreTC) deriving Typeable++instance Extern (RewriteH CoreTC) where+    type Box (RewriteH CoreTC) = RewriteCoreTCBox+    box = RewriteCoreTCBox+    unbox (RewriteCoreTCBox r) = r++-----------------------------------------------------------------+ data BiRewriteCoreBox = BiRewriteCoreBox (BiRewriteH Core) deriving Typeable  instance Extern (BiRewriteH Core) where     type Box (BiRewriteH Core) = BiRewriteCoreBox     box = BiRewriteCoreBox-    unbox (BiRewriteCoreBox i) = i+    unbox (BiRewriteCoreBox b) = b +----------------------------------------------------------------- +data TranslateCoreTCStringBox = TranslateCoreTCStringBox (TranslateH CoreTC String) deriving Typeable++instance Extern (TranslateH CoreTC String) where+    type Box (TranslateH CoreTC String) = TranslateCoreTCStringBox+    box = TranslateCoreTCStringBox+    unbox (TranslateCoreTCStringBox t) = t++-----------------------------------------------------------------+ 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+    unbox (TranslateCoreStringBox t) = t +-----------------------------------------------------------------+ data TranslateCoreCheckBox = TranslateCoreCheckBox (TranslateH Core ()) deriving Typeable  instance Extern (TranslateH Core ()) where     type Box (TranslateH Core ()) = TranslateCoreCheckBox     box = TranslateCoreCheckBox-    unbox (TranslateCoreCheckBox i) = i+    unbox (TranslateCoreCheckBox t) = t +-----------------------------------------------------------------+ data NameBox = NameBox (TH.Name) deriving Typeable  instance Extern TH.Name where     type Box TH.Name = NameBox     box = NameBox-    unbox (NameBox i) = i+    unbox (NameBox n) = n -data TranslateCorePathBox = TranslateCorePathBox (TranslateH Core Path) deriving Typeable+----------------------------------------------------------------- -instance Extern (TranslateH Core Path) where-    type Box (TranslateH Core Path) = TranslateCorePathBox+-- TODO: We now have CrumbBoc, PathBox and TranslateCorePathBox.+--       Ints are interpreted as a TranslateCorePathBox.+--       This all needs cleaning up.++data CrumbBox = CrumbBox Crumb deriving Typeable++instance Extern Crumb where+    type Box Crumb = CrumbBox+    box = CrumbBox+    unbox (CrumbBox cr) = cr++-----------------------------------------------------------------++data PathBox = PathBox PathH deriving Typeable++instance Extern PathH where+    type Box PathH = PathBox+    box = PathBox+    unbox (PathBox p) = p++-----------------------------------------------------------------++data TranslateCorePathBox = TranslateCorePathBox (TranslateH Core PathH) deriving Typeable++instance Extern (TranslateH Core PathH) where+    type Box (TranslateH Core PathH) = TranslateCorePathBox     box = TranslateCorePathBox-    unbox (TranslateCorePathBox i) = i+    unbox (TranslateCorePathBox t) = t +-----------------------------------------------------------------+ newtype CoreString = CoreString { unCoreString :: String } data CoreBox = CoreBox CoreString deriving Typeable  instance Extern CoreString where     type Box CoreString = CoreBox     box = CoreBox-    unbox (CoreBox i) = i+    unbox (CoreBox s) = s +-----------------------------------------------------------------+ data StringBox = StringBox String deriving Typeable  instance Extern String where     type Box String = StringBox     box = StringBox-    unbox (StringBox i) = i+    unbox (StringBox s) = s  ----------------------------------------------------------------- @@ -345,9 +418,13 @@     box = NameListBox     unbox (NameListBox l) = l +-----------------------------------------------------------------+ data StringListBox = StringListBox [String] deriving Typeable  instance Extern [String] where     type Box [String] = StringListBox     box = StringListBox     unbox (StringListBox l) = l++-----------------------------------------------------------------

@@ -1,41 +1,61 @@ {-# LANGUAGE CPP #-} module Language.HERMIT.GHC-        ( -- * GHC Imports-        -- | Things that have been copied from GHC, or imported directly, for various reasons.-          ppIdInfo-        , var2String-        , thRdrNameGuesses-        , name2THName-        , var2THName-        , cmpTHName2Name-        , cmpString2Name-        , cmpTHName2Var-        , cmpString2Var-        , unqualifiedVarName-        , findNameFromTH-        , alphaTyVars-        , Type(..)-        , GhcException(..)-        , throwGhcException-        , exprArity-) where+    ( -- * GHC Imports+      -- | Things that have been copied from GHC, or imported directly, for various reasons.+      ppIdInfo+    , var2String+    , thRdrNameGuesses+    , name2THName+    , var2THName+    , cmpTHName2Name+    , cmpString2Name+    , cmpTHName2Var+    , cmpString2Var+    , fqName+    , uqName+    , findNamesFromString+    , findNamesFromTH+    , alphaTyVars+    , Type(..)+    , TyLit(..)+    , GhcException(..)+    , throwGhcException+    , exprArity+    , Language.HERMIT.GHC.coAxiomName+#if __GLASGOW_HASKELL__ > 706+    , CoAxiom.BranchIndex+    , CoAxiom.CoAxiom+    , CoAxiom.Branched+#endif+    ) where -import GhcPlugins+import GhcPlugins as GHC  -- hacky direct GHC imports import Convert (thRdrNameGuesses) import TysPrim (alphaTyVars)-import TypeRep (Type(..))+import TypeRep (Type(..),TyLit(..)) import Panic (GhcException(ProgramError), throwGhcException) import CoreArity  #if __GLASGOW_HASKELL__ <= 706 import Data.Maybe (isJust)+#else+import qualified CoAxiom -- for coAxiomName #endif import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax (showName)  -------------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ <= 706+coAxiomName :: CoAxiom -> Name+coAxiomName = GHC.coAxiomName+#else+coAxiomName :: CoAxiom.CoAxiom br -> Name+coAxiomName = CoAxiom.coAxiomName+#endif+ -- varName :: Var -> Name -- nameOccName :: Name -> OccName -- occNameString :: OccName -> String@@ -44,48 +64,62 @@ -- getOccString :: NamedThing a => a -> String  -- TH.nameBase :: TH.Name -> String+-- showName :: TH.Name -> String -- TH.mkName :: String -> TH.Name --- | Convert a variable to a neat string for printing.+-- | Get the unqualified name from a 'Name'.+uqName :: Name -> String+uqName = getOccString -- equivalent to: occNameString . getOccName++-- | Get the fully qualified name from a 'Name'.+fqName :: Name -> String+fqName nm = modStr ++ uqName nm+    where modStr = maybe "" (\m -> moduleNameString (moduleName m) ++ ".") (nameModule_maybe nm)++-- | Convert a variable to a neat string for printing (unqualfied name). var2String :: Var -> String-var2String = occNameString . nameOccName . varName -- TODO: would getOccString be okay here?+var2String = uqName . varName  -- | Converts a GHC 'Name' to a Template Haskell 'TH.Name', going via a 'String'. name2THName :: Name -> TH.Name-name2THName = TH.mkName . getOccString+name2THName = TH.mkName . uqName  -- | Converts an 'Var' to a Template Haskell 'TH.Name', going via a 'String'. var2THName :: Var -> TH.Name var2THName = name2THName . varName --- | Get the unqualified name from an Var.-unqualifiedVarName :: Var -> String-unqualifiedVarName = TH.nameBase . var2THName+-- | Compare a 'String' to a 'Name' for equality.+-- Strings containing a period are assumed to be fully qualified names.+cmpString2Name :: String -> Name -> Bool+cmpString2Name str nm | isQualified str = str == fqName nm+                      | otherwise       = str == uqName nm --- | Hacks until we can find the correct way of doing these.-cmpTHName2Name :: TH.Name -> Name -> Bool-cmpTHName2Name th_nm = cmpString2Name (TH.nameBase th_nm)+isQualified :: String -> Bool+isQualified [] = False+isQualified xs = '.' `elem` init xs -- pathological case is compose --- | Hacks until we can find the correct way of doing these.-cmpString2Name :: String -> Name -> Bool-cmpString2Name str nm = str == getOccString nm -- occNameString (nameOccName ghc_nm)+-- | Compare a 'String' to a 'Var' for equality. See 'cmpString2Name'.+cmpString2Var :: String -> Var -> Bool+cmpString2Var str = cmpString2Name str . varName --- | Hacks until we can find the correct way of doing these.+-- | Compare a 'TH.Name' to a 'Name' for equality. See 'cmpString2Name'.+cmpTHName2Name :: TH.Name -> Name -> Bool+cmpTHName2Name th_nm = cmpString2Name (showName th_nm)++-- | Compare a 'TH.Name' to a 'Var' for equality. See 'cmpString2Name'. cmpTHName2Var :: TH.Name -> Var -> Bool cmpTHName2Var nm = cmpTHName2Name nm . varName --- | Hacks until we can find the correct way of doing these.-cmpString2Var :: String -> Var -> Bool-cmpString2Var str = cmpString2Name str . varName+-- | Find 'Name's matching a given fully qualified or unqualified name.+-- If given name is fully qualified, will only return first result, which is assumed unique.+findNamesFromString :: GlobalRdrEnv -> String -> [Name]+findNamesFromString rdrEnv str | isQualified str = take 1 res+                               | otherwise       = res+    where res = [ nm | elt <- globalRdrEnvElts rdrEnv, let nm = gre_name elt, cmpString2Name str nm ] --- | 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)-        ]+-- | Find 'Name's matching a 'TH.Name'. See 'findNamesFromString'.+findNamesFromTH :: GlobalRdrEnv -> TH.Name -> [Name]+findNamesFromTH rdrEnv = findNamesFromString rdrEnv . showName  -- | Pretty-print an identifier. ppIdInfo :: Id -> IdInfo -> SDoc@@ -112,7 +146,7 @@     has_caf_info = not (mayHaveCafRefs caf_info)      str_info = strictnessInfo info-    has_strictness = +    has_strictness = #if __GLASGOW_HASKELL__ > 706         True #else

@@ -17,6 +17,7 @@  import Language.HERMIT.External import Language.HERMIT.Parser+import Language.HERMIT.Kure (deprecatedIntToPathT)  -- | 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@@ -62,17 +63,18 @@ interpExpr' _   env (ListH exprs) = do dyns <- liftM fromDynList $ mapM (interpExpr' True env) exprs                                        return $    toBoxedList dyns NameListBox                                                 ++ toBoxedList dyns StringListBox+                                                ++ toBoxedList dyns PathBox interpExpr' rhs env (CmdName str)                                         -- An Int is either a Path, or will be interpreted specially later.   | all isDigit str                     = let i = read str in                                           return [ toDyn $ IntBox i-                                                 , toDyn $ TranslateCorePathBox (return [i])+                                                 , toDyn $ TranslateCorePathBox (deprecatedIntToPathT i) -- TODO: Find a better long-term solution.                                                  ]   | 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+  -- best case: 'help ls' works instead of 'help "ls"'. this is likewise done in the 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)@@ -82,3 +84,5 @@    where            dynApply' :: [Dynamic] -> [Dynamic] -> [Dynamic]            dynApply' fs xs = [ r | f <- fs, x <- xs, Just r <- return (dynApply f x)]++-------------------------------------------

@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes, FlexibleContexts #-} module Language.HERMIT.Kernel.Scoped        (          Direction(..)@@ -10,15 +10,19 @@        , scopedKernel ) where + import Control.Arrow import Control.Concurrent.STM import Control.Exception (bracketOnError, catch, SomeException) +import Data.Maybe (fromMaybe)+import Data.Monoid (mempty) import qualified Data.IntMap as I  import GhcPlugins hiding (Direction,L)  import Language.HERMIT.Core+import Language.HERMIT.Context import Language.HERMIT.Kure import Language.HERMIT.Monad import Language.HERMIT.Kernel@@ -29,69 +33,67 @@ 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 []+type LocalPath = SnocPath+type LocalPathH = LocalPath Crumb --- | Convert between path representations.-localPath2Path :: LocalPath -> Path-localPath2Path (LocalPath p) = reverse p+pathStack2Paths :: [LocalPath crumb] -> LocalPath crumb -> [Path crumb]+pathStack2Paths ps p = reverse (map snocPathToPath (p:ps)) -localPaths2Paths :: [LocalPath] -> [Path]-localPaths2Paths = reverse . map localPath2Path+-- | Add a 'Path' to the end of a 'LocalPath'.+extendLocalPath :: Path crumb -> LocalPath crumb -> LocalPath crumb+extendLocalPath p (SnocPath sp) = SnocPath (reverse p ++ sp)+{-# INLINE extendLocalPath #-}  -- | 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+moveLocally :: Direction -> LocalPathH -> LocalPathH+moveLocally d (SnocPath p) = case p of+                               []     -> mempty+                               cr:crs -> case d of+                                           T -> mempty+                                           U -> SnocPath crs+                                           L -> SnocPath (fromMaybe cr (deprecatedLeftSibling cr)  : crs)+                                           R -> SnocPath (fromMaybe cr (deprecatedRightSibling cr) : crs) --- | 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 ModGuts Core-pathStackToLens ps p = injectL >>> pathL (concat $ localPaths2Paths (p:ps))+pathStackToLens :: (Injection ModGuts g, Walker HermitC g) => [LocalPathH] -> LocalPathH -> LensH ModGuts g+pathStackToLens ps p = injectL >>> pathL (concat $ pathStack2Paths ps p) +-- This function is used to check the validity of paths, so which sum type we use is important.+testPathStackT :: [LocalPathH] -> LocalPathH -> TranslateH ModGuts Bool+testPathStackT ps p = testLensT (pathStackToLens ps p :: LensH ModGuts CoreTC)+ ----------------------------------------------------------------------------  -- | An alternative HERMIT kernel, that provides scoping. data ScopedKernel = ScopedKernel-        { resumeS     ::            SAST                                              -> IO (KureM ())-        , abortS      ::                                                                 IO ()-        , applyS      ::            SAST -> RewriteH Core             -> HermitMEnv   -> IO (KureM SAST)-        , queryS      :: forall a . SAST -> TranslateH Core a         -> HermitMEnv   -> IO (KureM a)-        , deleteS     ::            SAST                                              -> IO (KureM ())-        , listS       ::                                                                 IO [SAST]-        , pathS       ::            SAST                                              -> IO (KureM [Path])-        , modPathS    ::            SAST -> (LocalPath -> LocalPath)  -> HermitMEnv   -> IO (KureM SAST)-        , beginScopeS ::            SAST                                              -> IO (KureM SAST)-        , endScopeS   ::            SAST                                              -> IO (KureM SAST)-        -- means of accessing the underlying kernel, obviously for unsafe purposes-        , kernelS     ::                                                                 Kernel-        , toASTS      ::            SAST                                              -> IO (KureM AST)-        }+  { resumeS      ::            SAST                                              -> IO (KureM ())+  , abortS       ::                                                                 IO ()+  , applyS       :: forall g. (Injection ModGuts g, Walker HermitC g) =>+                               SAST -> RewriteH g                  -> HermitMEnv -> IO (KureM SAST)+  , queryS       :: forall a g . (Injection ModGuts g, Walker HermitC g) =>+                               SAST -> TranslateH g a              -> HermitMEnv -> IO (KureM a)+  , deleteS      ::            SAST                                              -> IO (KureM ())+  , listS        ::                                                                 IO [SAST]+  , pathS        ::            SAST                                              -> IO (KureM [PathH])+  , modPathS     ::            SAST -> (LocalPathH -> LocalPathH)  -> HermitMEnv -> IO (KureM SAST)+  , beginScopeS  ::            SAST                                              -> IO (KureM SAST)+  , endScopeS    ::            SAST                                              -> IO (KureM SAST)+  -- means of accessing the underlying kernel, obviously for unsafe purposes+  , kernelS      ::                                                                 Kernel+  , toASTS       ::            SAST                                              -> IO (KureM AST)+  }  -- | 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)+type SASTStore = I.IntMap (AST, [LocalPathH], LocalPathH) -get :: Monad m => Int -> SASTStore -> m (AST, [LocalPath], LocalPath)+get :: Monad m => Int -> SASTStore -> m (AST, [LocalPathH], LocalPathH) get sAst m = maybe (fail "scopedKernel: invalid SAST") return (I.lookup sAst m)  -- | Ensures that the TMVar is replaced when an error is thrown, and all exceptions are lifted into KureM failures.@@ -106,7 +108,7 @@ --   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))]+    store <- newTMVarIO $ I.fromList [(0,(initAST, [], mempty))]     key <- newTMVarIO (1::Int)      let newKey = do@@ -146,11 +148,11 @@             , pathS       = \ (SAST sAst) -> catchFails $ do                                 m <- atomically $ readTMVar store                                 (_, base, rel) <- get sAst m-                                return $ localPaths2Paths (rel : base)+                                return $ pathStack2Paths base rel             , 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+                                queryK kernel ast (testPathStackT base rel') env                                   >>= runKureM (\ b -> if rel == rel'                                                         then fail "Path is unchanged, nothing to do."                                                         else if b@@ -162,7 +164,7 @@             , beginScopeS = \ (SAST sAst) -> safeTakeTMVar store $ \m -> do                                 (ast, base, rel) <- get sAst m                                 atomically $ do k <- newKey-                                                putTMVar store $ I.insert k (ast, rel : base, emptyLocalPath) m+                                                putTMVar store $ I.insert k (ast, rel : base, mempty) m                                                 return $ SAST k             , endScopeS   = \ (SAST sAst) -> safeTakeTMVar store $ \m -> do                                 (ast, base, _) <- get sAst m

@@ -1,713 +1,1358 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TupleSections, LambdaCase, InstanceSigs, ScopedTypeVariables #-}--module Language.HERMIT.Kure-       (-       -- * KURE--       -- | 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.BiTranslate-       , module Language.KURE.Lens-       -- * Synonyms-       -- | In HERMIT, 'Translate', 'Rewrite' and 'Lens' always operate on the same context and monad.-       , TranslateH-       , RewriteH-       , BiRewriteH-       , LensH-       -- * Congruence combinators-       -- ** Modguts-       , modGutsT, modGutsR-       -- ** Program-       , progNilT-       , progConsT, progConsAllR, progConsAnyR, progConsOneR-       -- ** 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-       , promoteProgR-       , promoteBindR-       , promoteDefR-       , promoteExprR-       , promoteAltR-       -- ** BiRewrite Promotions-       , promoteExprBiR-       -- ** Translate Promotions-       , promoteModGutsT-       , promoteProgT-       , promoteBindT-       , promoteDefT-       , promoteExprT-       , promoteAltT-       )-where--import GhcPlugins hiding (empty)--import Language.KURE-import Language.KURE.BiTranslate-import Language.KURE.Lens--import Language.HERMIT.Core-import Language.HERMIT.Context-import Language.HERMIT.Monad--import Control.Monad-------------------------------------------------------------------------type TranslateH a b = Translate HermitC HermitM a b-type RewriteH a     = Rewrite   HermitC HermitM a-type BiRewriteH a   = BiRewrite HermitC HermitM a-type LensH a b      = Lens      HermitC HermitM a b---- I find it annoying that Applicative is not a superclass of Monad.-(<$>) :: Monad m => (a -> b) -> m a -> m b-(<$>) = liftM-{-# INLINE (<$>) #-}--(<*>) :: Monad m => m (a -> b) -> m a -> m b-(<*>) = ap-{-# INLINE (<*>) #-}-------------------------------------------------------------------------instance Injection ModGuts Core where--  inject :: ModGuts -> Core-  inject = GutsCore-  {-# INLINE inject #-}--  project :: Core -> Maybe ModGuts-  project (GutsCore guts) = Just guts-  project _                  = Nothing-  {-# INLINE project #-}---instance Injection CoreProg Core where--  inject :: CoreProg -> Core-  inject = ProgCore-  {-# INLINE inject #-}--  project :: Core -> Maybe CoreProg-  project (ProgCore bds) = Just bds-  project _              = Nothing-  {-# INLINE project #-}---instance Injection CoreBind Core where--  inject :: CoreBind -> Core-  inject = BindCore-  {-# INLINE inject #-}--  project :: Core -> Maybe CoreBind-  project (BindCore bnd)  = Just bnd-  project _               = Nothing-  {-# INLINE project #-}---instance Injection CoreDef Core where--  inject :: CoreDef -> Core-  inject = DefCore-  {-# INLINE inject #-}--  project :: Core -> Maybe CoreDef-  project (DefCore def) = Just def-  project _             = Nothing-  {-# INLINE project #-}---instance Injection CoreAlt Core where--  inject :: CoreAlt -> Core-  inject = AltCore-  {-# INLINE inject #-}--  project :: Core -> Maybe CoreAlt-  project (AltCore expr) = Just expr-  project _              = Nothing-  {-# INLINE project #-}---instance Injection CoreExpr Core where--  inject :: CoreExpr -> Core-  inject = ExprCore-  {-# INLINE inject #-}--  project :: Core -> Maybe CoreExpr-  project (ExprCore expr) = Just expr-  project _               = Nothing-  {-# INLINE project #-}-------------------------------------------------------------------------instance Walker HermitC Core where--  allR :: forall m. MonadCatch m => Rewrite HermitC m Core -> Rewrite HermitC m Core-  allR r = prefixFailMsg "allR failed: " $-           rewrite $ \ c -> \case-             GutsCore guts  -> inject <$> apply allRmodguts c guts-             ProgCore p     -> inject <$> apply allRprog c p-             BindCore bn    -> inject <$> apply allRbind c bn-             DefCore def    -> inject <$> apply allRdef c def-             AltCore alt    -> inject <$> apply allRalt c alt-             ExprCore e     -> inject <$> apply allRexpr c e-    where-      allRmodguts :: MonadCatch m => Rewrite HermitC m ModGuts-      allRmodguts = modGutsR (extractR r)-      {-# INLINE allRmodguts #-}--      allRprog :: MonadCatch m => Rewrite HermitC m CoreProg-      allRprog = readerT $ \case-                              ProgCons _ _ -> progConsAllR (extractR r) (extractR r)-                              _            -> idR-      {-# INLINE allRprog #-}--      allRbind :: MonadCatch m => Rewrite HermitC m CoreBind-      allRbind = readerT $ \case-                              NonRec _ _  -> nonRecR (extractR r)-                              Rec _       -> recAllR (const $ extractR r)-      {-# INLINE allRbind #-}--      allRdef :: MonadCatch m => Rewrite HermitC m CoreDef-      allRdef = defR (extractR r)-      {-# INLINE allRdef #-}--      allRalt :: MonadCatch m => Rewrite HermitC m CoreAlt-      allRalt = altR (extractR r)-      {-# INLINE allRalt #-}--      allRexpr :: MonadCatch m => Rewrite HermitC m CoreExpr-      allRexpr = readerT $ \case-                              App _ _      -> appAllR (extractR r) (extractR r)-                              Lam _ _      -> lamR (extractR r)-                              Let _ _      -> letAllR (extractR r) (extractR r)-                              Case _ _ _ _ -> caseAllR (extractR r) (const $ extractR r)-                              Cast _ _     -> castR (extractR r)-                              Tick _ _     -> tickR (extractR r)-                              _            -> idR-      {-# INLINE allRexpr #-}---- NOTE: I tried telling GHC to inline allR and compilation hit the (default) simplifier tick limit.--- TODO: Investigate whether that was achieving useful optimisations.--------------------------------------------------------------------------- | Translate a module.---   Slightly different to the other congruence combinators: it passes in /all/ of the original to the reconstruction function.-modGutsT :: Monad m => Translate HermitC m CoreProg a -> (ModGuts -> a -> b) -> Translate HermitC m ModGuts b-modGutsT t f = translate $ \ c guts -> f guts <$> apply t (c @@ 0) (bindsToProg $ mg_binds guts)-{-# INLINE modGutsT #-}---- | Rewrite the 'CoreProg' child of a module.-modGutsR :: Monad m => Rewrite HermitC m CoreProg -> Rewrite HermitC m ModGuts-modGutsR r = modGutsT r (\ guts p -> guts {mg_binds = progToBinds p})-{-# INLINE modGutsR #-}--------------------------------------------------------------------------- | Translate an empty list.-progNilT :: Monad m => b -> Translate HermitC m CoreProg b-progNilT b = contextfreeT $ \case-                               ProgNil       -> return b-                               ProgCons _ _  -> fail "not an empty program node."-{-# INLINE progNilT #-}---- | Translate a program of the form: ('CoreBind' @:@ 'CoreProg')-progConsT :: Monad m => Translate HermitC m CoreBind a1 -> Translate HermitC m CoreProg a2 -> (a1 -> a2 -> b) -> Translate HermitC m CoreProg b-progConsT t1 t2 f = translate $ \ c -> \case-                                          ProgCons bd p -> f <$> apply t1 (c @@ 0) bd <*> apply t2 (addBinding bd c @@ 1) p-                                          _             -> fail "not a non-empty program node."-{-# INLINE progConsT #-}---- | Rewrite all children of a program of the form: ('CoreBind' @:@ 'CoreProg')-progConsAllR :: Monad m => Rewrite HermitC m CoreBind -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg-progConsAllR r1 r2 = progConsT r1 r2 ProgCons-{-# INLINE progConsAllR #-}---- | Rewrite any children of a program of the form: ('CoreBind' @:@ 'CoreProg')-progConsAnyR :: MonadCatch m => Rewrite HermitC m CoreBind -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg-progConsAnyR r1 r2 = unwrapAnyR $ progConsAllR (wrapAnyR r1) (wrapAnyR r2)-{-# INLINE progConsAnyR #-}---- | Rewrite one child of a program of the form: ('CoreBind' @:@ 'CoreProg')-progConsOneR :: MonadCatch m => Rewrite HermitC m CoreBind -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg-progConsOneR r1 r2 = unwrapOneR $  progConsAllR (wrapOneR r1) (wrapOneR r2)-{-# INLINE progConsOneR #-}--------------------------------------------------------------------------- | Translate a binding group of the form: @NonRec@ 'Var' 'CoreExpr'-nonRecT :: Monad m => Translate HermitC m CoreExpr a -> (Var -> a -> b) -> Translate HermitC m CoreBind b-nonRecT t f = translate $ \ c -> \case-                                    NonRec v e -> f v <$> apply t (c @@ 0) e-                                    _          -> fail "not a non-recursive binding-group node."-{-# INLINE nonRecT #-}---- | Rewrite the 'CoreExpr' child of a binding group of the form: @NonRec@ 'Var' 'CoreExpr'-nonRecR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreBind-nonRecR r = nonRecT r NonRec-{-# INLINE nonRecR #-}---- | Translate a binding group of the form: @Rec@ ['CoreDef']-recT :: Monad m => (Int -> Translate HermitC m CoreDef a) -> ([a] -> b) -> Translate HermitC m CoreBind b-recT t f = translate $ \ c -> \case-         Rec bds -> -- Notice how we add the scoping bindings here *before* descending into each individual definition.-                    let c' = addBinding (Rec bds) c-                     in f <$> sequence [ apply (t n) (c' @@ n) (Def v e) -- here we convert from (Id,CoreExpr) to CoreDef-                                       | ((v,e),n) <- zip bds [0..]-                                       ]-         _       -> fail "not a recursive binding-group node."-{-# INLINE recT #-}---- | Rewrite all children of a binding group of the form: @Rec@ ['CoreDef']-recAllR :: Monad m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreBind-recAllR rs = recT rs defsToRecBind-{-# INLINE recAllR #-}---- | Rewrite any children of a binding group of the form: @Rec@ ['CoreDef']-recAnyR :: MonadCatch m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreBind-recAnyR rs = unwrapAnyR $ recAllR (wrapAnyR . rs)-{-# INLINE recAnyR #-}---- | Rewrite one child of a binding group of the form: @Rec@ ['CoreDef']-recOneR :: MonadCatch m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreBind-recOneR rs = unwrapOneR $ recAllR (wrapOneR . rs)-{-# INLINE recOneR #-}--------------------------------------------------------------------------- | Translate a recursive definition of the form: @Def@ 'Id' 'CoreExpr'-defT :: Monad m => Translate HermitC m CoreExpr a -> (Id -> a -> b) -> Translate HermitC m CoreDef b-defT t f = translate $ \ c (Def v e) -> f v <$> apply t (c @@ 0) e-{-# INLINE defT #-}---- | Rewrite the 'CoreExpr' child of a recursive definition of the form: @Def@ 'Id' 'CoreExpr'-defR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreDef-defR r = defT r Def-{-# INLINE defR #-}--------------------------------------------------------------------------- | Translate a case alternative of the form: ('AltCon', ['Var'], 'CoreExpr')-altT :: Monad m => Translate HermitC m CoreExpr a -> (AltCon -> [Var] -> a -> b) -> Translate HermitC m CoreAlt b-altT t f = translate $ \ c (con,vs,e) -> f con vs <$> apply t (addAltBindings vs c @@ 0) e-{-# INLINE altT #-}---- | Rewrite the 'CoreExpr' child of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr')-altR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreAlt-altR r = altT r (,,)-{-# INLINE altR #-}--------------------------------------------------------------------------- | Translate an expression of the form: @Var@ 'Id'-varT :: Monad m => (Id -> b) -> Translate HermitC m CoreExpr b-varT f = contextfreeT $ \case-                           Var v -> return (f v)-                           _     -> fail "not a variable node."-{-# INLINE varT #-}---- | Translate an expression of the form: @Lit@ 'Literal'-litT :: Monad m => (Literal -> b) -> Translate HermitC m CoreExpr b-litT f = contextfreeT $ \case-                           Lit x -> return (f x)-                           _     -> fail "not a literal node."-{-# INLINE litT #-}---- | Translate an expression of the form: @App@ 'CoreExpr' 'CoreExpr'-appT :: Monad m => Translate HermitC m CoreExpr a1 -> Translate HermitC m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate HermitC m CoreExpr b-appT t1 t2 f = translate $ \ c -> \case-                                     App e1 e2 -> f <$> apply t1 (c @@ 0) e1 <*> apply t2 (c @@ 1) e2-                                     _         -> fail "not an application node."-{-# INLINE appT #-}---- | Rewrite all children of an expression of the form: @App@ 'CoreExpr' 'CoreExpr'-appAllR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-appAllR r1 r2 = appT r1 r2 App-{-# INLINE appAllR #-}---- | Rewrite any children of an expression of the form: @App@ 'CoreExpr' 'CoreExpr'-appAnyR :: MonadCatch m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-appAnyR r1 r2 = unwrapAnyR $ appAllR (wrapAnyR r1) (wrapAnyR r2)-{-# INLINE appAnyR #-}---- | Rewrite one child of an expression of the form: @App@ 'CoreExpr' 'CoreExpr'-appOneR :: MonadCatch m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-appOneR r1 r2 = unwrapOneR $ appAllR (wrapOneR r1) (wrapOneR r2)-{-# INLINE appOneR #-}---- | Translate an expression of the form: @Lam@ 'Var' 'CoreExpr'-lamT :: Monad m => Translate HermitC m CoreExpr a -> (Var -> a -> b) -> Translate HermitC m CoreExpr b-lamT t f = translate $ \ c -> \case-                                 Lam v e -> f v <$> apply t (addLambdaBinding v c @@ 0) e-                                 _       -> fail "not a lambda node."-{-# INLINE lamT #-}---- | Rewrite the 'CoreExpr' child of an expression of the form: @Lam@ 'Var' 'CoreExpr'-lamR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-lamR r = lamT r Lam-{-# INLINE lamR #-}---- | Translate an expression of the form: @Let@ 'CoreBind' 'CoreExpr'-letT :: Monad m => Translate HermitC m CoreBind a1 -> Translate HermitC m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate HermitC m CoreExpr b-letT t1 t2 f = translate $ \ c -> \case-        Let bds e -> -- Note we use the *original* context for the binding group.-                     -- If the bindings are recursive, they will be added to the context by recT.-                     f <$> apply t1 (c @@ 0) bds <*> apply t2 (addBinding bds c @@ 1) e-        _         -> fail "not a let node."-{-# INLINE letT #-}---- | Rewrite all children of an expression of the form: @Let@ 'CoreBind' 'CoreExpr'-letAllR :: Monad m => Rewrite HermitC m CoreBind -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-letAllR r1 r2 = letT r1 r2 Let-{-# INLINE letAllR #-}---- | Rewrite any children of an expression of the form: @Let@ 'CoreBind' 'CoreExpr'-letAnyR :: MonadCatch m => Rewrite HermitC m CoreBind -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-letAnyR r1 r2 = unwrapAnyR $ letAnyR (wrapAnyR r1) (wrapAnyR r2)-{-# INLINE letAnyR #-}---- | Rewrite one child of an expression of the form: @Let@ 'CoreBind' 'CoreExpr'-letOneR :: MonadCatch m => Rewrite HermitC m CoreBind -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-letOneR r1 r2 = unwrapOneR $ letOneR (wrapOneR r1) (wrapOneR r2)-{-# INLINE letOneR #-}----- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']-caseT :: Monad m => Translate HermitC m CoreExpr a1 -> (Int -> Translate HermitC m CoreAlt a2) -> (a1 -> Id -> Type -> [a2] -> b) -> Translate HermitC m CoreExpr b-caseT t ts f = translate $ \ c -> \case-         Case e x ty alts -> f <$> apply t (c @@ 0) e-                               <*> return x-                               <*> return ty-                               <*> sequence [ apply (ts n) (addCaseBinding (x,e,alt) c @@ (n+1)) alt-                                            | (alt,n) <- zip alts [0..]-                                            ]-         _                -> fail "not a case node."-{-# INLINE caseT #-}---- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']-caseAllR :: Monad m => Rewrite HermitC m CoreExpr -> (Int -> Rewrite HermitC m CoreAlt) -> Rewrite HermitC m CoreExpr-caseAllR r rs = caseT r rs Case-{-# INLINE caseAllR #-}---- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']-caseAnyR :: MonadCatch m => Rewrite HermitC m CoreExpr -> (Int -> Rewrite HermitC m CoreAlt) -> Rewrite HermitC m CoreExpr-caseAnyR r rs = unwrapAnyR $ caseAllR (wrapAnyR r) (wrapAnyR . rs)-{-# INLINE caseAnyR #-}---- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']-caseOneR :: MonadCatch m => Rewrite HermitC m CoreExpr -> (Int -> Rewrite HermitC m CoreAlt) -> Rewrite HermitC m CoreExpr-caseOneR r rs = unwrapOneR $ caseAllR (wrapOneR r) (wrapOneR . rs)-{-# INLINE caseOneR #-}---- | Translate an expression of the form: @Cast@ 'CoreExpr' 'Coercion'-castT :: Monad m => Translate HermitC m CoreExpr a -> (a -> Coercion -> b) -> Translate HermitC m CoreExpr b-castT t f = translate $ \ c -> \case-                                  Cast e cast -> f <$> apply t (c @@ 0) e <*> return cast-                                  _           -> fail "not a cast node."-{-# INLINE castT #-}---- | Rewrite the 'CoreExpr' child of an expression of the form: @Cast@ 'CoreExpr' 'Coercion'-castR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-castR r = castT r Cast-{-# INLINE castR #-}---- | Translate an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr'-tickT :: Monad m => Translate HermitC m CoreExpr a -> (CoreTickish -> a -> b) -> Translate HermitC m CoreExpr b-tickT t f = translate $ \ c -> \case-        Tick tk e -> f tk <$> apply t (c @@ 0) e-        _         -> fail "not a tick node."-{-# INLINE tickT #-}---- | Rewrite the 'CoreExpr' child of an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr'-tickR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-tickR r = tickT r Tick-{-# INLINE tickR #-}---- | Translate an expression of the form: @Type@ 'Type'-typeT :: Monad m => (Type -> b) -> Translate HermitC m CoreExpr b-typeT f = contextfreeT $ \case-                            Type t -> return (f t)-                            _      -> fail "not a type node."-{-# INLINE typeT #-}---- | Translate an expression of the form: @Coercion@ 'Coercion'-coercionT :: Monad m => (Coercion -> b) -> Translate HermitC m CoreExpr b-coercionT f = contextfreeT $ \case-                                Coercion co -> return (f co)-                                _           -> fail "not a coercion node."-{-# INLINE coercionT #-}--------------------------------------------------------------------------- Some composite congruence combinators to export.---- | Translate a binding group of the form: @Rec@ [('Id', 'CoreExpr')]-recDefT :: Monad m => (Int -> Translate HermitC m CoreExpr a1) -> ([(Id,a1)] -> b) -> Translate HermitC m CoreBind b-recDefT ts = recT (\ n -> defT (ts n) (,))-{-# INLINE recDefT #-}---- | Rewrite all children of a binding group of the form: @Rec@ [('Id', 'CoreExpr')]-recDefAllR :: Monad m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreBind-recDefAllR rs = recAllR (\ n -> defR (rs n))-{-# INLINE recDefAllR #-}---- | Rewrite any children of a binding group of the form: @Rec@ [('Id', 'CoreExpr')]-recDefAnyR :: MonadCatch m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreBind-recDefAnyR rs = recAnyR (\ n -> defR (rs n))-{-# INLINE recDefAnyR #-}---- | Rewrite one child of a binding group of the form: @Rec@ [('Id', 'CoreExpr')]-recDefOneR :: MonadCatch m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreBind-recDefOneR rs = recOneR (\ n -> defR (rs n))-{-# INLINE recDefOneR #-}----- | Translate a program of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'-consNonRecT :: Monad m => Translate HermitC m CoreExpr a1 -> Translate HermitC m CoreProg a2 -> (Var -> a1 -> a2 -> b) -> Translate HermitC m CoreProg b-consNonRecT t1 t2 f = progConsT (nonRecT t1 (,)) t2 (uncurry f)-{-# INLINE consNonRecT #-}---- | Rewrite all children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'-consNonRecAllR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg-consNonRecAllR r1 r2 = progConsAllR (nonRecR r1) r2-{-# INLINE consNonRecAllR #-}---- | Rewrite any children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'-consNonRecAnyR :: MonadCatch m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg-consNonRecAnyR r1 r2 = progConsAnyR (nonRecR r1) r2-{-# INLINE consNonRecAnyR #-}---- | Rewrite one child of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'-consNonRecOneR :: MonadCatch m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg-consNonRecOneR r1 r2 = progConsOneR (nonRecR r1) r2-{-# INLINE consNonRecOneR #-}----- | Translate an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'-consRecT :: Monad m => (Int -> Translate HermitC m CoreDef a1) -> Translate HermitC m CoreProg a2 -> ([a1] -> a2 -> b) -> Translate HermitC m CoreProg b-consRecT ts t = progConsT (recT ts id) t-{-# INLINE consRecT #-}---- | Rewrite all children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'-consRecAllR :: Monad m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg-consRecAllR rs r = progConsAllR (recAllR rs) r-{-# INLINE consRecAllR #-}---- | Rewrite any children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'-consRecAnyR :: MonadCatch m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg-consRecAnyR rs r = progConsAnyR (recAnyR rs) r-{-# INLINE consRecAnyR #-}---- | Rewrite one child of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'-consRecOneR :: MonadCatch m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg-consRecOneR rs r = progConsOneR (recOneR rs) r-{-# INLINE consRecOneR #-}----- | Translate an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'-consRecDefT :: Monad m => (Int -> Translate HermitC m CoreExpr a1) -> Translate HermitC m CoreProg a2 -> ([(Id,a1)] -> a2 -> b) -> Translate HermitC m CoreProg b-consRecDefT ts t = consRecT (\ n -> defT (ts n) (,)) t-{-# INLINE consRecDefT #-}---- | Rewrite all children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'-consRecDefAllR :: Monad m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg-consRecDefAllR rs r = consRecAllR (\ n -> defR (rs n)) r-{-# INLINE consRecDefAllR #-}---- | Rewrite any children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'-consRecDefAnyR :: MonadCatch m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg-consRecDefAnyR rs r = consRecAnyR (\ n -> defR (rs n)) r-{-# INLINE consRecDefAnyR #-}---- | Rewrite one child of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'-consRecDefOneR :: MonadCatch m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg-consRecDefOneR rs r = consRecOneR (\ n -> defR (rs n)) r-{-# INLINE consRecDefOneR #-}----- | Translate an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'-letNonRecT :: Monad m => Translate HermitC m CoreExpr a1 -> Translate HermitC m CoreExpr a2 -> (Var -> a1 -> a2 -> b) -> Translate HermitC m CoreExpr b-letNonRecT t1 t2 f = letT (nonRecT t1 (,)) t2 (uncurry f)-{-# INLINE letNonRecT #-}---- | Rewrite all children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'-letNonRecAllR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-letNonRecAllR r1 r2 = letAllR (nonRecR r1) r2-{-# INLINE letNonRecAllR #-}---- | Rewrite any children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'-letNonRecAnyR :: MonadCatch m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-letNonRecAnyR r1 r2 = letAnyR (nonRecR r1) r2-{-# INLINE letNonRecAnyR #-}---- | Rewrite one child of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'-letNonRecOneR :: MonadCatch m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-letNonRecOneR r1 r2 = letOneR (nonRecR r1) r2-{-# INLINE letNonRecOneR #-}----- | Translate an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'-letRecT :: Monad m => (Int -> Translate HermitC m CoreDef a1) -> Translate HermitC m CoreExpr a2 -> ([a1] -> a2 -> b) -> Translate HermitC m CoreExpr b-letRecT ts t = letT (recT ts id) t-{-# INLINE letRecT #-}---- | Rewrite all children of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'-letRecAllR :: Monad m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-letRecAllR rs r = letAllR (recAllR rs) r-{-# INLINE letRecAllR #-}---- | Rewrite any children of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'-letRecAnyR :: MonadCatch m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-letRecAnyR rs r = letAnyR (recAnyR rs) r-{-# INLINE letRecAnyR #-}---- | Rewrite one child of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'-letRecOneR :: MonadCatch m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-letRecOneR rs r = letOneR (recOneR rs) r-{-# INLINE letRecOneR #-}----- | Translate an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'-letRecDefT :: Monad m => (Int -> Translate HermitC m CoreExpr a1) -> Translate HermitC m CoreExpr a2 -> ([(Id,a1)] -> a2 -> b) -> Translate HermitC m CoreExpr b-letRecDefT ts t = letRecT (\ n -> defT (ts n) (,)) t-{-# INLINE letRecDefT #-}---- | Rewrite all children of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'-letRecDefAllR :: Monad m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-letRecDefAllR rs r = letRecAllR (\ n -> defR (rs n)) r-{-# INLINE letRecDefAllR #-}---- | Rewrite any children of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'-letRecDefAnyR :: MonadCatch m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-letRecDefAnyR rs r = letRecAnyR (\ n -> defR (rs n)) r-{-# INLINE letRecDefAnyR #-}---- | Rewrite one child of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'-letRecDefOneR :: MonadCatch m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr-letRecDefOneR rs r = letRecOneR (\ n -> defR (rs n)) r-{-# INLINE letRecDefOneR #-}----- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]-caseAltT :: Monad m => Translate HermitC m CoreExpr a1 -> (Int -> Translate HermitC m CoreExpr a2) -> (a1 -> Id -> Type -> [(AltCon,[Var],a2)] -> b) -> Translate HermitC m CoreExpr b-caseAltT t ts = caseT t (\ n -> altT (ts n) (,,))-{-# INLINE caseAltT #-}---- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]-caseAltAllR :: Monad m => Rewrite HermitC m CoreExpr -> (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreExpr-caseAltAllR t ts = caseAllR t (\ n -> altR (ts n))-{-# INLINE caseAltAllR #-}---- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]-caseAltAnyR :: MonadCatch m => Rewrite HermitC m CoreExpr -> (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreExpr-caseAltAnyR t ts = caseAnyR t (\ n -> altR (ts n))-{-# INLINE caseAltAnyR #-}---- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]-caseAltOneR :: MonadCatch m => Rewrite HermitC m CoreExpr -> (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreExpr-caseAltOneR t ts = caseOneR t (\ n -> altR (ts n))-{-# INLINE caseAltOneR #-}--------------------------------------------------------------------------- | Promote a rewrite on 'ModGuts' to a rewrite on 'Core'.-promoteModGutsR :: Monad m => Rewrite HermitC m ModGuts -> Rewrite HermitC m Core-promoteModGutsR = promoteWithFailMsgR "This rewrite can only succeed at the module level."-{-# INLINE promoteModGutsR #-}---- | Promote a rewrite on 'CoreProg' to a rewrite on 'Core'.-promoteProgR :: Monad m => Rewrite HermitC m CoreProg -> Rewrite HermitC m Core-promoteProgR = promoteWithFailMsgR "This rewrite can only succeed at program nodes (the top-level)."-{-# INLINE promoteProgR #-}---- | Promote a rewrite on 'CoreBind' to a rewrite on 'Core'.-promoteBindR :: Monad m => Rewrite HermitC m CoreBind -> Rewrite HermitC m Core-promoteBindR = promoteWithFailMsgR "This rewrite can only succeed at binding group nodes."-{-# INLINE promoteBindR #-}---- | Promote a rewrite on 'CoreDef' to a rewrite on 'Core'.-promoteDefR :: Monad m => Rewrite HermitC m CoreDef -> Rewrite HermitC m Core-promoteDefR = promoteWithFailMsgR "This rewrite can only succeed at recursive definition nodes."-{-# INLINE promoteDefR #-}---- | Promote a rewrite on 'CoreAlt' to a rewrite on 'Core'.-promoteAltR :: Monad m => Rewrite HermitC m CoreAlt -> Rewrite HermitC m Core-promoteAltR = promoteWithFailMsgR "This rewrite can only succeed at case alternative nodes."-{-# INLINE promoteAltR #-}---- | Promote a rewrite on 'CoreExpr' to a rewrite on 'Core'.-promoteExprR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m Core-promoteExprR = promoteWithFailMsgR "This rewrite can only succeed at expression nodes."-{-# INLINE promoteExprR #-}--------------------------------------------------------------------------- | Promote a bidirectional rewrite on 'CoreExpr' to a bidirectional rewrite on 'Core'.-promoteExprBiR :: Monad m => BiRewrite HermitC m CoreExpr -> BiRewrite HermitC m Core-promoteExprBiR b = bidirectional (promoteExprR $ forewardT b) (promoteExprR $ backwardT b)-{-# INLINE promoteExprBiR #-}--------------------------------------------------------------------------- | Promote a translate on 'ModGuts' to a translate on 'Core'.-promoteModGutsT :: Monad m => Translate HermitC m ModGuts b -> Translate HermitC m Core b-promoteModGutsT = promoteWithFailMsgT "This translate can only succeed at the module level."-{-# INLINE promoteModGutsT #-}---- | Promote a translate on 'CoreProg' to a translate on 'Core'.-promoteProgT :: Monad m => Translate HermitC m CoreProg b -> Translate HermitC m Core b-promoteProgT = promoteWithFailMsgT "This translate can only succeed at program nodes (the top-level)."-{-# INLINE promoteProgT #-}---- | Promote a translate on 'CoreBind' to a translate on 'Core'.-promoteBindT :: Monad m => Translate HermitC m CoreBind b -> Translate HermitC m Core b-promoteBindT = promoteWithFailMsgT "This translate can only succeed at binding group nodes."-{-# INLINE promoteBindT #-}---- | Promote a translate on 'CoreDef' to a translate on 'Core'.-promoteDefT :: Monad m => Translate HermitC m CoreDef b -> Translate HermitC m Core b-promoteDefT = promoteWithFailMsgT "This translate can only succeed at recursive definition nodes."-{-# INLINE promoteDefT #-}---- | Promote a translate on 'CoreAlt' to a translate on 'Core'.-promoteAltT :: Monad m => Translate HermitC m CoreAlt b -> Translate HermitC m Core b-promoteAltT = promoteWithFailMsgT "This translate can only succeed at case alternative nodes."-{-# INLINE promoteAltT #-}---- | Promote a translate on 'CoreExpr' to a translate on 'Core'.-promoteExprT :: Monad m => Translate HermitC m CoreExpr b -> Translate HermitC m Core b-promoteExprT = promoteWithFailMsgT "This translate can only succeed at expression nodes."-{-# INLINE promoteExprT #-}-+{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, TupleSections, LambdaCase, InstanceSigs, ScopedTypeVariables #-}++module Language.HERMIT.Kure+       (+       -- * KURE++       -- | 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.BiTranslate+       , module Language.KURE.Lens+       -- * Sub-Modules+       , module Language.HERMIT.Kure.SumTypes+       -- * Synonyms+       , TranslateH+       , RewriteH+       , BiRewriteH+       , LensH+       , PathH++       -- * Congruence combinators+       -- ** Modguts+       , modGutsT, modGutsR+       -- ** Program+       , progNilT+       , progConsT, progConsAllR, progConsAnyR, progConsOneR+       -- ** Binding Groups+       , nonRecT, nonRecAllR, nonRecAnyR, nonRecOneR+       , recT, recAllR, recAnyR, recOneR+       -- ** Recursive Definitions+       , defT, defAllR, defAnyR, defOneR+       -- ** Case Alternatives+       , altT, altAllR, altAnyR, altOneR+       -- ** Expressions+       , varT, varR+       , litT, litR+       , appT, appAllR, appAnyR, appOneR+       , lamT, lamAllR, lamAnyR, lamOneR+       , letT, letAllR, letAnyR, letOneR+       , caseT, caseAllR, caseAnyR, caseOneR+       , castT, castAllR, castAnyR, castOneR+       , tickT, tickAllR, tickAnyR, tickOneR+       , typeT, typeR+       , coercionT, coercionR+       -- ** 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+       -- ** Types+       , tyVarT, tyVarR+       , litTyT, litTyR+       , appTyT, appTyAllR, appTyAnyR, appTyOneR+       , funTyT, funTyAllR, funTyAnyR, funTyOneR+       , forAllTyT, forAllTyAllR, forAllTyAnyR, forAllTyOneR+       , tyConAppT, tyConAppAllR, tyConAppAnyR, tyConAppOneR+       -- ** Coercions+       , reflT, reflR+       , tyConAppCoT, tyConAppCoAllR, tyConAppCoAnyR, tyConAppCoOneR+       , appCoT, appCoAllR, appCoAnyR, appCoOneR+       , forAllCoT, forAllCoAllR, forAllCoAnyR, forAllCoOneR+       , coVarCoT, coVarCoR+       , axiomInstCoT, axiomInstCoAllR, axiomInstCoAnyR, axiomInstCoOneR+       , unsafeCoT, unsafeCoAllR, unsafeCoAnyR, unsafeCoOneR+       , symCoT, symCoR+       , transCoT, transCoAllR, transCoAnyR, transCoOneR+       , nthCoT, nthCoAllR, nthCoAnyR, nthCoOneR+       , instCoT, instCoAllR, instCoAnyR, instCoOneR+#if __GLASGOW_HASKELL__ > 706+       , lrCoT, lrCoAllR, lrCoAnyR, lrCoOneR+#else+#endif+       -- * Promotion Combinators+       -- ** Rewrite Promotions+       , promoteModGutsR+       , promoteProgR+       , promoteBindR+       , promoteDefR+       , promoteExprR+       , promoteAltR+       -- ** BiRewrite Promotions+       , promoteExprBiR+       -- ** Translate Promotions+       , promoteModGutsT+       , promoteProgT+       , promoteBindT+       , promoteDefT+       , promoteExprT+       , promoteAltT+       -- * Conversion to deprecated Int representation+       , deprecatedIntToCrumbT+       , deprecatedIntToPathT+       )+where++import GhcPlugins hiding (empty)++import Language.KURE+import Language.KURE.BiTranslate+import Language.KURE.Lens++import Language.HERMIT.Context+import Language.HERMIT.Core+import Language.HERMIT.GHC+import Language.HERMIT.Monad+import Language.HERMIT.Kure.SumTypes++import Control.Monad++---------------------------------------------------------------------++type TranslateH a b = Translate HermitC HermitM a b+type RewriteH a     = Rewrite   HermitC HermitM a+type BiRewriteH a   = BiRewrite HermitC HermitM a+type LensH a b      = Lens      HermitC HermitM a b+type PathH          = Path Crumb++-- I find it annoying that Applicative is not a superclass of Monad.+(<$>) :: Monad m => (a -> b) -> m a -> m b+(<$>) = liftM+{-# INLINE (<$>) #-}++(<*>) :: Monad m => m (a -> b) -> m a -> m b+(<*>) = ap+{-# INLINE (<*>) #-}++---------------------------------------------------------------------++-- | Walking over modules, programs, binding groups, definitions, expressions and case alternatives.+instance (ExtendPath c Crumb, AddBindings c) => Walker c Core where++  allR :: forall m. MonadCatch m => Rewrite c m Core -> Rewrite c m Core+  allR r = prefixFailMsg "allR failed: " $+           rewrite $ \ c -> \case+             GutsCore guts  -> inject <$> apply allRmodguts c guts+             ProgCore p     -> inject <$> apply allRprog c p+             BindCore bn    -> inject <$> apply allRbind c bn+             DefCore def    -> inject <$> apply allRdef c def+             AltCore alt    -> inject <$> apply allRalt c alt+             ExprCore e     -> inject <$> apply allRexpr c e+    where+      allRmodguts :: MonadCatch m => Rewrite c m ModGuts+      allRmodguts = modGutsR (extractR r)+      {-# INLINE allRmodguts #-}++      allRprog :: MonadCatch m => Rewrite c m CoreProg+      allRprog = readerT $ \case+                              ProgCons{}  -> progConsAllR (extractR r) (extractR r)+                              _           -> idR+      {-# INLINE allRprog #-}++      allRbind :: MonadCatch m => Rewrite c m CoreBind+      allRbind = readerT $ \case+                              NonRec{}  -> nonRecAllR idR (extractR r) -- we don't descend into the Var+                              Rec _     -> recAllR (const $ extractR r)+      {-# INLINE allRbind #-}++      allRdef :: MonadCatch m => Rewrite c m CoreDef+      allRdef = defAllR idR (extractR r) -- we don't descend into the Id+      {-# INLINE allRdef #-}++      allRalt :: MonadCatch m => Rewrite c m CoreAlt+      allRalt = altAllR idR (const idR) (extractR r) -- we don't descend into the AltCon or Vars+      {-# INLINE allRalt #-}++      allRexpr :: MonadCatch m => Rewrite c m CoreExpr+      allRexpr = readerT $ \case+                              App{}   -> appAllR (extractR r) (extractR r)+                              Lam{}   -> lamAllR idR (extractR r) -- we don't descend into the Var+                              Let{}   -> letAllR (extractR r) (extractR r)+                              Case{}  -> caseAllR (extractR r) idR idR (const $ extractR r) -- we don't descend into the case binder or Type+                              Cast{}  -> castAllR (extractR r) idR -- we don't descend into the Coercion+                              Tick{}  -> tickAllR idR (extractR r) -- we don't descend into the Tickish+                              _       -> idR+      {-# INLINE allRexpr #-}++-- NOTE: I tried telling GHC to inline allR and compilation hit the (default) simplifier tick limit.+-- TODO: Investigate whether that was achieving useful optimisations.++---------------------------------------------------------------------++-- | Walking over types (only).+instance (ExtendPath c Crumb, AddBindings c) => Walker c Type where++  allR :: MonadCatch m => Rewrite c m Type -> Rewrite c m Type+  allR r = prefixFailMsg "allR failed: " $+           readerT $ \case+                        AppTy{}     -> appTyAllR r r+                        FunTy{}     -> funTyAllR r r+                        ForAllTy{}  -> forAllTyAllR idR r+                        TyConApp{}  -> tyConAppAllR idR (const r)+                        _           -> idR++---------------------------------------------------------------------++-- | Walking over coercions (only).+instance (ExtendPath c Crumb, AddBindings c) => Walker c Coercion where++  allR :: MonadCatch m => Rewrite c m Coercion -> Rewrite c m Coercion+  allR r = prefixFailMsg "allR failed: " $+           readerT $ \case+                        TyConAppCo{}  -> tyConAppCoAllR idR (const r)+                        AppCo{}       -> appCoAllR r r+                        ForAllCo{}    -> forAllCoAllR idR r+                        SymCo{}       -> symCoR r+                        TransCo{}     -> transCoAllR r r+                        NthCo{}       -> nthCoAllR idR r+                        InstCo{}      -> instCoAllR r idR+#if __GLASGOW_HASKELL__ > 706+                        LRCo{}        -> lrCoAllR idR r+                        AxiomInstCo{} -> axiomInstCoAllR idR idR (const r)+#else+                        AxiomInstCo{} -> axiomInstCoAllR idR (const r)+#endif+                        _             -> idR++---------------------------------------------------------------------++-- | Walking over types and coercions.+instance (ExtendPath c Crumb, AddBindings c) => Walker c TyCo where++  allR :: forall m. MonadCatch m => Rewrite c m TyCo -> Rewrite c m TyCo+  allR r = prefixFailMsg "allR failed: " $+           rewrite $ \ c -> \case+             TypeCore ty     -> inject <$> apply (allR $ extractR r) c ty -- exploiting the fact that types do not contain coercions+             CoercionCore co -> inject <$> apply allRcoercion c co+    where+      allRcoercion :: MonadCatch m => Rewrite c m Coercion+      allRcoercion = readerT $ \case+                              Refl{}        -> reflR (extractR r)+                              TyConAppCo{}  -> tyConAppCoAllR idR (const $ extractR r) -- we don't descend into the TyCon+                              AppCo{}       -> appCoAllR (extractR r) (extractR r)+                              ForAllCo{}    -> forAllCoAllR idR (extractR r) -- we don't descend into the TyVar+                              UnsafeCo{}    -> unsafeCoAllR (extractR r) (extractR r)+                              SymCo{}       -> symCoR (extractR r)+                              TransCo{}     -> transCoAllR (extractR r) (extractR r)+                              InstCo{}      -> instCoAllR (extractR r) (extractR r)+                              NthCo{}       -> nthCoAllR idR (extractR r) -- we don't descend into the Int+#if __GLASGOW_HASKELL__ > 706+                              LRCo{}        -> lrCoAllR idR (extractR r)+                              AxiomInstCo{} -> axiomInstCoAllR idR idR (const $ extractR r) -- we don't descend into the axiom or index+#else+                              AxiomInstCo{} -> axiomInstCoAllR idR (const $ extractR r) -- we don't descend into the axiom+#endif+                              _             -> idR+      {-# INLINE allRcoercion #-}++---------------------------------------------------------------------++-- | Walking over modules, programs, binding groups, definitions, expressions and case alternatives.+instance (ExtendPath c Crumb, AddBindings c) => Walker c CoreTC where++  allR :: forall m. MonadCatch m => Rewrite c m CoreTC -> Rewrite c m CoreTC+  allR r = prefixFailMsg "allR failed: " $+           rewrite $ \ c -> \case+             Core (GutsCore guts)  -> inject <$> apply allRmodguts c guts+             Core (ProgCore p)     -> inject <$> apply allRprog c p+             Core (BindCore bn)    -> inject <$> apply allRbind c bn+             Core (DefCore def)    -> inject <$> apply allRdef c def+             Core (AltCore alt)    -> inject <$> apply allRalt c alt+             Core (ExprCore e)     -> inject <$> apply allRexpr c e+             TyCo tyCo             -> inject <$> apply (allR $ extractR r) c tyCo -- exploiting the fact that only types and coercions appear within types and coercions+    where+      allRmodguts :: MonadCatch m => Rewrite c m ModGuts+      allRmodguts = modGutsR (extractR r)+      {-# INLINE allRmodguts #-}++      allRprog :: MonadCatch m => Rewrite c m CoreProg+      allRprog = readerT $ \case+                              ProgCons{}  -> progConsAllR (extractR r) (extractR r)+                              _           -> idR+      {-# INLINE allRprog #-}++      allRbind :: MonadCatch m => Rewrite c m CoreBind+      allRbind = readerT $ \case+                              NonRec{}  -> nonRecAllR idR (extractR r) -- we don't descend into the Var+                              Rec _     -> recAllR (const $ extractR r)+      {-# INLINE allRbind #-}++      allRdef :: MonadCatch m => Rewrite c m CoreDef+      allRdef = defAllR idR (extractR r) -- we don't descend into the Id+      {-# INLINE allRdef #-}++      allRalt :: MonadCatch m => Rewrite c m CoreAlt+      allRalt = altAllR idR (const idR) (extractR r) -- we don't descend into the AltCon or Vars+      {-# INLINE allRalt #-}++      allRexpr :: MonadCatch m => Rewrite c m CoreExpr+      allRexpr = readerT $ \case+                              App{}      -> appAllR (extractR r) (extractR r)+                              Lam{}      -> lamAllR idR (extractR r) -- we don't descend into the Var+                              Let{}      -> letAllR (extractR r) (extractR r)+                              Case{}     -> caseAllR (extractR r) idR (extractR r) (const $ extractR r) -- we don't descend into the case binder+                              Cast{}     -> castAllR (extractR r) (extractR r)+                              Tick{}     -> tickAllR idR (extractR r) -- we don't descend into the Tickish+                              Type{}     -> typeR (extractR r)+                              Coercion{} -> coercionR (extractR r)+                              _          -> idR+      {-# INLINE allRexpr #-}++---------------------------------------------------------------------++-- | Translate a module.+--   Slightly different to the other congruence combinators: it passes in /all/ of the original to the reconstruction function.+modGutsT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreProg a -> (ModGuts -> a -> b) -> Translate c m ModGuts b+modGutsT t f = translate $ \ c guts -> f guts <$> apply t (c @@ ModGuts_Prog) (bindsToProg $ mg_binds guts)+{-# INLINE modGutsT #-}++-- | Rewrite the 'CoreProg' child of a module.+modGutsR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreProg -> Rewrite c m ModGuts+modGutsR r = modGutsT r (\ guts p -> guts {mg_binds = progToBinds p})+{-# INLINE modGutsR #-}++---------------------------------------------------------------------++-- | Translate an empty list.+progNilT :: Monad m => b -> Translate c m CoreProg b+progNilT b = contextfreeT $ \case+                               ProgNil       -> return b+                               ProgCons _ _  -> fail "not an empty program."+{-# INLINE progNilT #-}++-- | Translate a program of the form: ('CoreBind' @:@ 'CoreProg')+progConsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind a1 -> Translate c m CoreProg a2 -> (a1 -> a2 -> b) -> Translate c m CoreProg b+progConsT t1 t2 f = translate $ \ c -> \case+                                          ProgCons bd p -> f <$> apply t1 (c @@ ProgCons_Head) bd <*> apply t2 (addBindingGroup bd c @@ ProgCons_Tail) p+                                          _             -> fail "not a non-empty program."+{-# INLINE progConsT #-}++-- | Rewrite all children of a program of the form: ('CoreBind' @:@ 'CoreProg')+progConsAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg+progConsAllR r1 r2 = progConsT r1 r2 ProgCons+{-# INLINE progConsAllR #-}++-- | Rewrite any children of a program of the form: ('CoreBind' @:@ 'CoreProg')+progConsAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg+progConsAnyR r1 r2 = unwrapAnyR $ progConsAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE progConsAnyR #-}++-- | Rewrite one child of a program of the form: ('CoreBind' @:@ 'CoreProg')+progConsOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg+progConsOneR r1 r2 = unwrapOneR $  progConsAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE progConsOneR #-}++---------------------------------------------------------------------++-- | Translate a binding group of the form: @NonRec@ 'Var' 'CoreExpr'+nonRecT :: (ExtendPath c Crumb, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreBind b+nonRecT t1 t2 f = translate $ \ c -> \case+                                        NonRec v e -> f <$> apply t1 (c @@ NonRec_Var) v <*> apply t2 (c @@ NonRec_RHS) e+                                        _          -> fail "not a non-recursive binding group."+{-# INLINE nonRecT #-}++-- | Rewrite all children of a binding group of the form: @NonRec@ 'Var' 'CoreExpr'+nonRecAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreBind+nonRecAllR r1 r2 = nonRecT r1 r2 NonRec+{-# INLINE nonRecAllR #-}++-- | Rewrite any children of a binding group of the form: @NonRec@ 'Var' 'CoreExpr'+nonRecAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreBind+nonRecAnyR r1 r2 = unwrapAnyR (nonRecAllR (wrapAnyR r1) (wrapAnyR r2))+{-# INLINE nonRecAnyR #-}++-- | Rewrite one child of a binding group of the form: @NonRec@ 'Var' 'CoreExpr'+nonRecOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreBind+nonRecOneR r1 r2 = unwrapOneR (nonRecAllR (wrapOneR r1) (wrapOneR r2))+{-# INLINE nonRecOneR #-}+++-- | Translate a binding group of the form: @Rec@ ['CoreDef']+recT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a) -> ([a] -> b) -> Translate c m CoreBind b+recT t f = translate $ \ c -> \case+         Rec bds -> -- Notice how we add the scoping bindings here *before* descending into each individual definition.+                    let c' = addBindingGroup (Rec bds) c+                     in f <$> sequence [ apply (t n) (c' @@ Rec_Def n) (Def v e) -- here we convert from (Id,CoreExpr) to CoreDef+                                       | ((v,e),n) <- zip bds [0..]+                                       ]+         _       -> fail "not a recursive binding group."+{-# INLINE recT #-}++-- | Rewrite all children of a binding group of the form: @Rec@ ['CoreDef']+recAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind+recAllR rs = recT rs defsToRecBind+{-# INLINE recAllR #-}++-- | Rewrite any children of a binding group of the form: @Rec@ ['CoreDef']+recAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind+recAnyR rs = unwrapAnyR $ recAllR (wrapAnyR . rs)+{-# INLINE recAnyR #-}++-- | Rewrite one child of a binding group of the form: @Rec@ ['CoreDef']+recOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind+recOneR rs = unwrapOneR $ recAllR (wrapOneR . rs)+{-# INLINE recOneR #-}++---------------------------------------------------------------------++-- | Translate a recursive definition of the form: @Def@ 'Id' 'CoreExpr'+defT :: (ExtendPath c Crumb, Monad m) => Translate c m Id a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreDef b+defT t1 t2 f = translate $ \ c (Def v e) -> f <$> apply t1 (c @@ Def_Id) v <*> apply t2 (c @@ Def_RHS) e+{-# INLINE defT #-}++-- | Rewrite all children of a recursive definition of the form: @Def@ 'Id' 'CoreExpr'+defAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef+defAllR r1 r2 = defT r1 r2 Def+{-# INLINE defAllR #-}++-- | Rewrite any children of a recursive definition of the form: @Def@ 'Id' 'CoreExpr'+defAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef+defAnyR r1 r2 = unwrapAnyR (defAllR (wrapAnyR r1) (wrapAnyR r2))+{-# INLINE defAnyR #-}++-- | Rewrite one child of a recursive definition of the form: @Def@ 'Id' 'CoreExpr'+defOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef+defOneR r1 r2 = unwrapOneR (defAllR (wrapOneR r1) (wrapOneR r2))+{-# INLINE defOneR #-}++---------------------------------------------------------------------++-- | Translate a case alternative of the form: ('AltCon', ['Var'], 'CoreExpr')+altT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m AltCon a1 -> (Int -> Translate c m Var a2) -> Translate c m CoreExpr a3 -> (a1 -> [a2] -> a3 -> b) -> Translate c m CoreAlt b+altT t1 ts t2 f = translate $ \ c (con,vs,e) -> f <$> apply t1 (c @@ Alt_Con) con+                                                  <*> sequence [ apply (ts n) (c @@ Alt_Var n) v | (v,n) <- zip vs [1..] ]+                                                  <*> apply t2 (addAltBindings vs c @@ Alt_RHS) e+{-# INLINE altT #-}++-- | Rewrite all children of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr')+altAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt+altAllR r1 rs r2 = altT r1 rs r2 (,,)+{-# INLINE altAllR #-}++-- | Rewrite any children of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr')+altAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt+altAnyR r1 rs r2 = unwrapAnyR (altAllR (wrapAnyR r1) (wrapAnyR . rs) (wrapAnyR r2))+{-# INLINE altAnyR #-}++-- | Rewrite one child of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr')+altOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt+altOneR r1 rs r2 = unwrapOneR (altAllR (wrapOneR r1) (wrapOneR . rs) (wrapOneR r2))+{-# INLINE altOneR #-}++---------------------------------------------------------------------++-- | Translate an expression of the form: @Var@ 'Id'+varT :: (ExtendPath c Crumb, Monad m) => Translate c m Id b -> Translate c m CoreExpr b+varT t = translate $ \ c -> \case+                               Var v -> apply t (c @@ Var_Id) v+                               _     -> fail "not a variable."+{-# INLINE varT #-}++-- | Rewrite the 'Id' child in an expression of the form: @Var@ 'Id'+varR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Id -> Rewrite c m CoreExpr+varR r = varT (Var <$> r)+{-# INLINE varR #-}+++-- | Translate an expression of the form: @Lit@ 'Literal'+litT :: (ExtendPath c Crumb, Monad m) => Translate c m Literal b -> Translate c m CoreExpr b+litT t = translate $ \ c -> \case+                               Lit x -> apply t (c @@ Lit_Lit) x+                               _     -> fail "not a literal."+{-# INLINE litT #-}++-- | Rewrite the 'Literal' child in an expression of the form: @Lit@ 'Literal'+litR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Literal -> Rewrite c m CoreExpr+litR r = litT (Lit <$> r)+{-# INLINE litR #-}+++-- | Translate an expression of the form: @App@ 'CoreExpr' 'CoreExpr'+appT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreExpr a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b+appT t1 t2 f = translate $ \ c -> \case+                                     App e1 e2 -> f <$> apply t1 (c @@ App_Fun) e1 <*> apply t2 (c @@ App_Arg) e2+                                     _         -> fail "not an application."+{-# INLINE appT #-}++-- | Rewrite all children of an expression of the form: @App@ 'CoreExpr' 'CoreExpr'+appAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+appAllR r1 r2 = appT r1 r2 App+{-# INLINE appAllR #-}++-- | Rewrite any children of an expression of the form: @App@ 'CoreExpr' 'CoreExpr'+appAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+appAnyR r1 r2 = unwrapAnyR $ appAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE appAnyR #-}++-- | Rewrite one child of an expression of the form: @App@ 'CoreExpr' 'CoreExpr'+appOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+appOneR r1 r2 = unwrapOneR $ appAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE appOneR #-}+++-- | Translate an expression of the form: @Lam@ 'Var' 'CoreExpr'+lamT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b+lamT t1 t2 f = translate $ \ c -> \case+                                     Lam v e -> f <$> apply t1 (c @@ Lam_Var) v <*> apply t2 (addLambdaBinding v c @@ Lam_Body) e+                                     _       -> fail "not a lambda."+{-# INLINE lamT #-}++-- | Rewrite all children of an expression of the form: @Lam@ 'Var' 'CoreExpr'+lamAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+lamAllR r1 r2 = lamT r1 r2 Lam+{-# INLINE lamAllR #-}++-- | Rewrite any children of an expression of the form: @Lam@ 'Var' 'CoreExpr'+lamAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+lamAnyR r1 r2 = unwrapAnyR $ lamAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE lamAnyR #-}++-- | Rewrite one child of an expression of the form: @Lam@ 'Var' 'CoreExpr'+lamOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+lamOneR r1 r2 = unwrapOneR $ lamAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE lamOneR #-}+++-- | Translate an expression of the form: @Let@ 'CoreBind' 'CoreExpr'+letT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b+letT t1 t2 f = translate $ \ c -> \case+        Let bds e -> -- Note we use the *original* context for the binding group.+                     -- If the bindings are recursive, they will be added to the context by recT.+                     f <$> apply t1 (c @@ Let_Bind) bds <*> apply t2 (addBindingGroup bds c @@ Let_Body) e+        _         -> fail "not a let node."+{-# INLINE letT #-}++-- | Rewrite all children of an expression of the form: @Let@ 'CoreBind' 'CoreExpr'+letAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letAllR r1 r2 = letT r1 r2 Let+{-# INLINE letAllR #-}++-- | Rewrite any children of an expression of the form: @Let@ 'CoreBind' 'CoreExpr'+letAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letAnyR r1 r2 = unwrapAnyR $ letAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE letAnyR #-}++-- | Rewrite one child of an expression of the form: @Let@ 'CoreBind' 'CoreExpr'+letOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letOneR r1 r2 = unwrapOneR $ letAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE letOneR #-}+++-- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']+caseT :: (ExtendPath c Crumb, AddBindings c, Monad m)+      => Translate c m CoreExpr e+      -> Translate c m Id w+      -> Translate c m Type ty+      -> (Int -> Translate c m CoreAlt alt)+      -> (e -> w -> ty -> [alt] -> b)+      -> Translate c m CoreExpr b+caseT te tw tty talts f = translate $ \ c -> \case+         Case e w ty alts -> f <$> apply te (c @@ Case_Scrutinee) e+                               <*> apply tw (c @@ Case_Binder) w+                               <*> apply tty (c @@ Case_Type) ty+                               <*> sequence [ apply (talts n) (addCaseWildBinding (w,e,alt) c @@ Case_Alt n) alt+                                            | (alt,n) <- zip alts [0..]+                                            ]+         _                -> fail "not a case."+{-# INLINE caseT #-}++-- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']+caseAllR :: (ExtendPath c Crumb, AddBindings c, Monad m)+         => Rewrite c m CoreExpr+         -> Rewrite c m Id+         -> Rewrite c m Type+         -> (Int -> Rewrite c m CoreAlt)+         -> Rewrite c m CoreExpr+caseAllR re rw rty ralts = caseT re rw rty ralts Case+{-# INLINE caseAllR #-}++-- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']+caseAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m)+         => Rewrite c m CoreExpr+         -> Rewrite c m Id+         -> Rewrite c m Type+         -> (Int -> Rewrite c m CoreAlt)+         -> Rewrite c m CoreExpr+caseAnyR re rw rty ralts = unwrapAnyR $ caseAllR (wrapAnyR re) (wrapAnyR rw) (wrapAnyR rty) (wrapAnyR . ralts)+{-# INLINE caseAnyR #-}++-- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']+caseOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m)+         => Rewrite c m CoreExpr+         -> Rewrite c m Id+         -> Rewrite c m Type+         -> (Int -> Rewrite c m CoreAlt)+         -> Rewrite c m CoreExpr+caseOneR re rw rty ralts = unwrapOneR $ caseAllR (wrapOneR re) (wrapOneR rw) (wrapOneR rty) (wrapOneR . ralts)+{-# INLINE caseOneR #-}+++-- | Translate an expression of the form: @Cast@ 'CoreExpr' 'Coercion'+castT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreExpr a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b+castT t1 t2 f = translate $ \ c -> \case+                                      Cast e co -> f <$> apply t1 (c @@ Cast_Expr) e <*> apply t2 (c @@ Cast_Co) co+                                      _         -> fail "not a cast."+{-# INLINE castT #-}++-- | Rewrite all children of an expression of the form: @Cast@ 'CoreExpr' 'Coercion'+castAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreExpr -> Rewrite c m Coercion -> Rewrite c m CoreExpr+castAllR r1 r2 = castT r1 r2 Cast+{-# INLINE castAllR #-}++-- | Rewrite any children of an expression of the form: @Cast@ 'CoreExpr' 'Coercion'+castAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoreExpr -> Rewrite c m Coercion -> Rewrite c m CoreExpr+castAnyR r1 r2 = unwrapAnyR $ castAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE castAnyR #-}++-- | Rewrite one child of an expression of the form: @Cast@ 'CoreExpr' 'Coercion'+castOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoreExpr -> Rewrite c m Coercion -> Rewrite c m CoreExpr+castOneR r1 r2 = unwrapOneR $ castAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE castOneR #-}+++-- | Translate an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr'+tickT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreTickish a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b+tickT t1 t2 f = translate $ \ c -> \case+                                      Tick tk e -> f <$> apply t1 (c @@ Tick_Tick) tk <*> apply t2 (c @@ Tick_Expr) e+                                      _         -> fail "not a tick."+{-# INLINE tickT #-}++-- | Rewrite all children of an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr'+tickAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreTickish -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+tickAllR r1 r2 = tickT r1 r2 Tick+{-# INLINE tickAllR #-}++-- | Rewrite any children of an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr'+tickAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoreTickish -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+tickAnyR r1 r2 = unwrapAnyR $ tickAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE tickAnyR #-}++-- | Rewrite any children of an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr'+tickOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoreTickish -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+tickOneR r1 r2 = unwrapOneR $ tickAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE tickOneR #-}+++-- | Translate an expression of the form: @Type@ 'Type'+typeT :: (ExtendPath c Crumb, Monad m) => Translate c m Type b -> Translate c m CoreExpr b+typeT t = translate $ \ c -> \case+                                Type ty -> apply t (c @@ Type_Type) ty+                                _       -> fail "not a type."+{-# INLINE typeT #-}++-- | Rewrite the 'Type' child in an expression of the form: @Type@ 'Type'+typeR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Type -> Rewrite c m CoreExpr+typeR r = typeT (Type <$> r)+{-# INLINE typeR #-}+++-- | Translate an expression of the form: @Coercion@ 'Coercion'+coercionT :: (ExtendPath c Crumb, Monad m) => Translate c m Coercion b -> Translate c m CoreExpr b+coercionT t = translate $ \ c -> \case+                                    Coercion co -> apply t (c @@ Co_Co) co+                                    _           -> fail "not a coercion."+{-# INLINE coercionT #-}++-- | Rewrite the 'Coercion' child in an expression of the form: @Coercion@ 'Coercion'+coercionR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Coercion -> Rewrite c m CoreExpr+coercionR r = coercionT (Coercion <$> r)+{-# INLINE coercionR #-}++---------------------------------------------------------------------++-- Some composite congruence combinators to export.++-- | Translate a binding group of the form: @Rec@ [('Id', 'CoreExpr')]+recDefT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> ([(a1,a2)] -> b) -> Translate c m CoreBind b+recDefT ts = recT (\ n -> uncurry defT (ts n) (,))+{-# INLINE recDefT #-}++-- | Rewrite all children of a binding group of the form: @Rec@ [('Id', 'CoreExpr')]+recDefAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind+recDefAllR rs = recAllR (\ n -> uncurry defAllR (rs n))+{-# INLINE recDefAllR #-}++-- | Rewrite any children of a binding group of the form: @Rec@ [('Id', 'CoreExpr')]+recDefAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind+recDefAnyR rs = recAnyR (\ n -> uncurry defAnyR (rs n))+{-# INLINE recDefAnyR #-}++-- | Rewrite one child of a binding group of the form: @Rec@ [('Id', 'CoreExpr')]+recDefOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind+recDefOneR rs = recOneR (\ n -> uncurry defOneR (rs n))+{-# INLINE recDefOneR #-}+++-- | Translate a program of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'+consNonRecT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> Translate c m CoreProg a3 -> (a1 -> a2 -> a3 -> b) -> Translate c m CoreProg b+consNonRecT t1 t2 t3 f = progConsT (nonRecT t1 t2 (,)) t3 (uncurry f)+{-# INLINE consNonRecT #-}++-- | Rewrite all children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'+consNonRecAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consNonRecAllR r1 r2 r3 = progConsAllR (nonRecAllR r1 r2) r3+{-# INLINE consNonRecAllR #-}++-- | Rewrite any children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'+consNonRecAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consNonRecAnyR r1 r2 r3 = progConsAllR (nonRecAnyR r1 r2) r3+{-# INLINE consNonRecAnyR #-}++-- | Rewrite one child of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'+consNonRecOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consNonRecOneR r1 r2 r3 = progConsAllR (nonRecOneR r1 r2) r3+{-# INLINE consNonRecOneR #-}+++-- | Translate an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'+consRecT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a1) -> Translate c m CoreProg a2 -> ([a1] -> a2 -> b) -> Translate c m CoreProg b+consRecT ts t = progConsT (recT ts id) t+{-# INLINE consRecT #-}++-- | Rewrite all children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'+consRecAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consRecAllR rs r = progConsAllR (recAllR rs) r+{-# INLINE consRecAllR #-}++-- | Rewrite any children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'+consRecAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consRecAnyR rs r = progConsAnyR (recAnyR rs) r+{-# INLINE consRecAnyR #-}++-- | Rewrite one child of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'+consRecOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consRecOneR rs r = progConsOneR (recOneR rs) r+{-# INLINE consRecOneR #-}+++-- | Translate an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'+consRecDefT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> Translate c m CoreProg a3 -> ([(a1,a2)] -> a3 -> b) -> Translate c m CoreProg b+consRecDefT ts t = consRecT (\ n -> uncurry defT (ts n) (,)) t+{-# INLINE consRecDefT #-}++-- | Rewrite all children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'+consRecDefAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consRecDefAllR rs r = consRecAllR (\ n -> uncurry defAllR (rs n)) r+{-# INLINE consRecDefAllR #-}++-- | Rewrite any children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'+consRecDefAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consRecDefAnyR rs r = consRecAnyR (\ n -> uncurry defAnyR (rs n)) r+{-# INLINE consRecDefAnyR #-}++-- | Rewrite one child of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'+consRecDefOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consRecDefOneR rs r = consRecOneR (\ n -> uncurry defOneR (rs n)) r+{-# INLINE consRecDefOneR #-}+++-- | Translate an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'+letNonRecT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> Translate c m CoreExpr a3 -> (a1 -> a2 -> a3 -> b) -> Translate c m CoreExpr b+letNonRecT t1 t2 t3 f = letT (nonRecT t1 t2 (,)) t3 (uncurry f)+{-# INLINE letNonRecT #-}++-- | Rewrite all children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'+letNonRecAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letNonRecAllR r1 r2 r3 = letAllR (nonRecAllR r1 r2) r3+{-# INLINE letNonRecAllR #-}++-- | Rewrite any children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'+letNonRecAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letNonRecAnyR r1 r2 r3 = letAnyR (nonRecAnyR r1 r2) r3+{-# INLINE letNonRecAnyR #-}++-- | Rewrite one child of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'+letNonRecOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letNonRecOneR r1 r2 r3 = letOneR (nonRecOneR r1 r2) r3+{-# INLINE letNonRecOneR #-}+++-- | Translate an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'+letRecT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a1) -> Translate c m CoreExpr a2 -> ([a1] -> a2 -> b) -> Translate c m CoreExpr b+letRecT ts t = letT (recT ts id) t+{-# INLINE letRecT #-}++-- | Rewrite all children of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'+letRecAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letRecAllR rs r = letAllR (recAllR rs) r+{-# INLINE letRecAllR #-}++-- | Rewrite any children of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'+letRecAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letRecAnyR rs r = letAnyR (recAnyR rs) r+{-# INLINE letRecAnyR #-}++-- | Rewrite one child of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'+letRecOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letRecOneR rs r = letOneR (recOneR rs) r+{-# INLINE letRecOneR #-}+++-- | Translate an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'+letRecDefT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> Translate c m CoreExpr a3 -> ([(a1,a2)] -> a3 -> b) -> Translate c m CoreExpr b+letRecDefT ts t = letRecT (\ n -> uncurry defT (ts n) (,)) t+{-# INLINE letRecDefT #-}++-- | Rewrite all children of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'+letRecDefAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letRecDefAllR rs r = letRecAllR (\ n -> uncurry defAllR (rs n)) r+{-# INLINE letRecDefAllR #-}++-- | Rewrite any children of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'+letRecDefAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letRecDefAnyR rs r = letRecAnyR (\ n -> uncurry defAnyR (rs n)) r+{-# INLINE letRecDefAnyR #-}++-- | Rewrite one child of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'+letRecDefOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letRecDefOneR rs r = letRecOneR (\ n -> uncurry defOneR (rs n)) r+{-# INLINE letRecDefOneR #-}+++-- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]+caseAltT :: (ExtendPath c Crumb, AddBindings c, Monad m)+         => Translate c m CoreExpr sc+         -> Translate c m Id w+         -> Translate c m Type ty+         -> (Int -> (Translate c m AltCon con, (Int -> Translate c m Var v), Translate c m CoreExpr rhs)) -> (sc -> w -> ty -> [(con,[v],rhs)] -> b)+         -> Translate c m CoreExpr b+caseAltT tsc tw tty talts = caseT tsc tw tty (\ n -> let (tcon,tvs,te) = talts n in altT tcon tvs te (,,))+{-# INLINE caseAltT #-}++-- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]+caseAltAllR :: (ExtendPath c Crumb, AddBindings c, Monad m)+            => Rewrite c m CoreExpr+            -> Rewrite c m Id+            -> Rewrite c m Type+            -> (Int -> (Rewrite c m AltCon, (Int -> Rewrite c m Var), Rewrite c m CoreExpr))+            -> Rewrite c m CoreExpr+caseAltAllR rsc rw rty ralts = caseAllR rsc rw rty (\ n -> let (rcon,rvs,re) = ralts n in altAllR rcon rvs re)+{-# INLINE caseAltAllR #-}++-- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]+caseAltAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m)+            => Rewrite c m CoreExpr+            -> Rewrite c m Id+            -> Rewrite c m Type+            -> (Int -> (Rewrite c m AltCon, (Int -> Rewrite c m Var), Rewrite c m CoreExpr))+            -> Rewrite c m CoreExpr+caseAltAnyR rsc rw rty ralts = caseAnyR rsc rw rty (\ n -> let (rcon,rvs,re) = ralts n in altAnyR rcon rvs re)+{-# INLINE caseAltAnyR #-}++-- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]+caseAltOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m)+            => Rewrite c m CoreExpr+            -> Rewrite c m Id+            -> Rewrite c m Type+            -> (Int -> (Rewrite c m AltCon, (Int -> Rewrite c m Var), Rewrite c m CoreExpr))+            -> Rewrite c m CoreExpr+caseAltOneR rsc rw rty ralts = caseOneR rsc rw rty (\ n -> let (rcon,rvs,re) = ralts n in altOneR rcon rvs re)+{-# INLINE caseAltOneR #-}++---------------------------------------------------------------------++-- | Promote a rewrite on 'ModGuts' to a rewrite on 'Core'.+promoteModGutsR :: (ExtendPath c Crumb, Monad m) => Rewrite c m ModGuts -> Rewrite c m Core+promoteModGutsR = promoteWithFailMsgR "This rewrite can only succeed at the module level."+{-# INLINE promoteModGutsR #-}++-- | Promote a rewrite on 'CoreProg' to a rewrite on 'Core'.+promoteProgR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreProg -> Rewrite c m Core+promoteProgR = promoteWithFailMsgR "This rewrite can only succeed at program nodes (the top-level)."+{-# INLINE promoteProgR #-}++-- | Promote a rewrite on 'CoreBind' to a rewrite on 'Core'.+promoteBindR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreBind -> Rewrite c m Core+promoteBindR = promoteWithFailMsgR "This rewrite can only succeed at binding group nodes."+{-# INLINE promoteBindR #-}++-- | Promote a rewrite on 'CoreDef' to a rewrite on 'Core'.+promoteDefR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreDef -> Rewrite c m Core+promoteDefR = promoteWithFailMsgR "This rewrite can only succeed at recursive definition nodes."+{-# INLINE promoteDefR #-}++-- | Promote a rewrite on 'CoreAlt' to a rewrite on 'Core'.+promoteAltR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreAlt -> Rewrite c m Core+promoteAltR = promoteWithFailMsgR "This rewrite can only succeed at case alternative nodes."+{-# INLINE promoteAltR #-}++-- | Promote a rewrite on 'CoreExpr' to a rewrite on 'Core'.+promoteExprR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreExpr -> Rewrite c m Core+promoteExprR = promoteWithFailMsgR "This rewrite can only succeed at expression nodes."+{-# INLINE promoteExprR #-}++---------------------------------------------------------------------++-- | Promote a bidirectional rewrite on 'CoreExpr' to a bidirectional rewrite on 'Core'.+promoteExprBiR :: (ExtendPath c Crumb, Monad m) => BiRewrite c m CoreExpr -> BiRewrite c m Core+promoteExprBiR b = bidirectional (promoteExprR $ forewardT b) (promoteExprR $ backwardT b)+{-# INLINE promoteExprBiR #-}++---------------------------------------------------------------------++-- | Promote a translate on 'ModGuts' to a translate on 'Core'.+promoteModGutsT :: (ExtendPath c Crumb, Monad m) => Translate c m ModGuts b -> Translate c m Core b+promoteModGutsT = promoteWithFailMsgT "This translate can only succeed at the module level."+{-# INLINE promoteModGutsT #-}++-- | Promote a translate on 'CoreProg' to a translate on 'Core'.+promoteProgT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreProg b -> Translate c m Core b+promoteProgT = promoteWithFailMsgT "This translate can only succeed at program nodes (the top-level)."+{-# INLINE promoteProgT #-}++-- | Promote a translate on 'CoreBind' to a translate on 'Core'.+promoteBindT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreBind b -> Translate c m Core b+promoteBindT = promoteWithFailMsgT "This translate can only succeed at binding group nodes."+{-# INLINE promoteBindT #-}++-- | Promote a translate on 'CoreDef' to a translate on 'Core'.+promoteDefT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreDef b -> Translate c m Core b+promoteDefT = promoteWithFailMsgT "This translate can only succeed at recursive definition nodes."+{-# INLINE promoteDefT #-}++-- | Promote a translate on 'CoreAlt' to a translate on 'Core'.+promoteAltT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreAlt b -> Translate c m Core b+promoteAltT = promoteWithFailMsgT "This translate can only succeed at case alternative nodes."+{-# INLINE promoteAltT #-}++-- | Promote a translate on 'CoreExpr' to a translate on 'Core'.+promoteExprT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreExpr b -> Translate c m Core b+promoteExprT = promoteWithFailMsgT "This translate can only succeed at expression nodes."+{-# INLINE promoteExprT #-}+++---------------------------------------------------------------------+---------------------------------------------------------------------++-- Types++-- | Translate a type of the form: @TyVarTy@ 'TyVar'+tyVarT :: (ExtendPath c Crumb, Monad m) => Translate c m TyVar b -> Translate c m Type b+tyVarT t = translate $ \ c -> \case+                                 TyVarTy v -> apply t (c @@ TyVarTy_TyVar) v+                                 _         -> fail "not a type variable."+{-# INLINE tyVarT #-}++-- | Rewrite the 'TyVar' child of a type of the form: @TyVarTy@ 'TyVar'+tyVarR :: (ExtendPath c Crumb, Monad m) => Rewrite c m TyVar -> Rewrite c m Type+tyVarR r = tyVarT (TyVarTy <$> r)+{-# INLINE tyVarR #-}+++-- | Translate a type of the form: @LitTy@ 'TyLit'+litTyT :: (ExtendPath c Crumb, Monad m) => Translate c m TyLit b -> Translate c m Type b+litTyT t = translate $ \ c -> \case+                                 LitTy x -> apply t (c @@ LitTy_TyLit) x+                                 _       -> fail "not a type literal."+{-# INLINE litTyT #-}++-- | Rewrite the 'TyLit' child of a type of the form: @LitTy@ 'TyLit'+litTyR :: (ExtendPath c Crumb, Monad m) => Rewrite c m TyLit -> Rewrite c m Type+litTyR r = litTyT (LitTy <$> r)+{-# INLINE litTyR #-}+++-- | Translate a type of the form: @AppTy@ 'Type' 'Type'+appTyT :: (ExtendPath c Crumb, Monad m) => Translate c m Type a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Type b+appTyT t1 t2 f = translate $ \ c -> \case+                                     AppTy ty1 ty2 -> f <$> apply t1 (c @@ AppTy_Fun) ty1 <*> apply t2 (c @@ AppTy_Arg) ty2+                                     _             -> fail "not a type application."+{-# INLINE appTyT #-}++-- | Rewrite all children of a type of the form: @AppTy@ 'Type' 'Type'+appTyAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Type+appTyAllR r1 r2 = appTyT r1 r2 AppTy+{-# INLINE appTyAllR #-}++-- | Rewrite any children of a type of the form: @AppTy@ 'Type' 'Type'+appTyAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Type+appTyAnyR r1 r2 = unwrapAnyR $ appTyAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE appTyAnyR #-}++-- | Rewrite one child of a type of the form: @AppTy@ 'Type' 'Type'+appTyOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Type+appTyOneR r1 r2 = unwrapOneR $ appTyAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE appTyOneR #-}+++-- | Translate a type of the form: @FunTy@ 'Type' 'Type'+funTyT :: (ExtendPath c Crumb, Monad m) => Translate c m Type a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Type b+funTyT t1 t2 f = translate $ \ c -> \case+                                     FunTy ty1 ty2 -> f <$> apply t1 (c @@ FunTy_Dom) ty1 <*> apply t2 (c @@ FunTy_CoDom) ty2+                                     _             -> fail "not a function type."+{-# INLINE funTyT #-}++-- | Rewrite all children of a type of the form: @FunTy@ 'Type' 'Type'+funTyAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Type+funTyAllR r1 r2 = funTyT r1 r2 FunTy+{-# INLINE funTyAllR #-}++-- | Rewrite any children of a type of the form: @FunTy@ 'Type' 'Type'+funTyAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Type+funTyAnyR r1 r2 = unwrapAnyR $ funTyAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE funTyAnyR #-}++-- | Rewrite one child of a type of the form: @FunTy@ 'Type' 'Type'+funTyOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Type+funTyOneR r1 r2 = unwrapOneR $ funTyAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE funTyOneR #-}+++-- | Translate a type of the form: @ForAllTy@ 'Var' 'Type'+forAllTyT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Type b+forAllTyT t1 t2 f = translate $ \ c -> \case+                                          ForAllTy v ty -> f <$> apply t1 (c @@ ForAllTy_Var) v <*> apply t2 (addForallBinding v c @@ ForAllTy_Body) ty+                                          _             -> fail "not a forall type."+{-# INLINE forAllTyT #-}++-- | Rewrite all children of a type of the form: @ForAllTy@ 'Var' 'Type'+forAllTyAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type+forAllTyAllR r1 r2 = forAllTyT r1 r2 ForAllTy+{-# INLINE forAllTyAllR #-}++-- | Rewrite any children of a type of the form: @ForAllTy@ 'Var' 'Type'+forAllTyAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type+forAllTyAnyR r1 r2 = unwrapAnyR $ forAllTyAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE forAllTyAnyR #-}++-- | Rewrite one child of a type of the form: @ForAllTy@ 'Var' 'Type'+forAllTyOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type+forAllTyOneR r1 r2 = unwrapOneR $ forAllTyAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE forAllTyOneR #-}+++-- | Translate a type of the form: @TyConApp@ 'TyCon' ['KindOrType']+tyConAppT :: (ExtendPath c Crumb, Monad m) => Translate c m TyCon a1 -> (Int -> Translate c m KindOrType a2) -> (a1 -> [a2] -> b) -> Translate c m Type b+tyConAppT t ts f = translate $ \ c -> \case+                                         TyConApp con tys -> f <$> apply t (c @@ TyConApp_TyCon) con <*> sequence [ apply (ts n) (c @@ TyConApp_Arg n) ty | (ty,n) <- zip tys [0..] ]+                                         _                -> fail "not a type-constructor application."+{-# INLINE tyConAppT #-}++-- | Rewrite all children of a type of the form: @TyConApp@ 'TyCon' ['KindOrType']+tyConAppAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m TyCon -> (Int -> Rewrite c m KindOrType) -> Rewrite c m Type+tyConAppAllR r rs = tyConAppT r rs TyConApp+{-# INLINE tyConAppAllR #-}++-- | Rewrite any children of a type of the form: @TyConApp@ 'TyCon' ['KindOrType']+tyConAppAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m TyCon -> (Int -> Rewrite c m KindOrType) -> Rewrite c m Type+tyConAppAnyR r rs = unwrapAnyR $ tyConAppAllR (wrapAnyR r) (wrapAnyR . rs)+{-# INLINE tyConAppAnyR #-}++-- | Rewrite one child of a type of the form: @TyConApp@ 'TyCon' ['KindOrType']+tyConAppOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m TyCon -> (Int -> Rewrite c m KindOrType) -> Rewrite c m Type+tyConAppOneR r rs = unwrapOneR $ tyConAppAllR (wrapOneR r) (wrapOneR . rs)+{-# INLINE tyConAppOneR #-}++---------------------------------------------------------------------+---------------------------------------------------------------------++-- Coercions++-- | Translate a coercion of the form: @Refl@ 'Type'+reflT :: (ExtendPath c Crumb, Monad m) => Translate c m Type b -> Translate c m Coercion b+reflT t = translate $ \ c -> \case+                                 Refl ty -> apply t (c @@ Refl_Type) ty+                                 _       -> fail "not a reflexive coercion."+{-# INLINE reflT #-}++-- | Rewrite the 'Type' child of a coercion of the form: @Refl@ 'Type'+reflR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Type -> Rewrite c m Coercion+reflR r = reflT (Refl <$> r)+{-# INLINE reflR #-}+++-- | Translate a coercion of the form: @TyConAppCo@ 'TyCon' ['Coercion']+tyConAppCoT :: (ExtendPath c Crumb, Monad m) => Translate c m TyCon a1 -> (Int -> Translate c m Coercion a2) -> (a1 -> [a2] -> b) -> Translate c m Coercion b+tyConAppCoT t ts f = translate $ \ c -> \case+                                           TyConAppCo con coes -> f <$> apply t (c @@ TyConAppCo_TyCon) con <*> sequence [ apply (ts n) (c @@ TyConAppCo_Arg n) co | (co,n) <- zip coes [0..] ]+                                           _                   -> fail "not a type-constructor coercion."+{-# INLINE tyConAppCoT #-}++-- | Rewrite all children of a coercion of the form: @TyConAppCo@ 'TyCon' ['Coercion']+tyConAppCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m TyCon -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion+tyConAppCoAllR r rs = tyConAppCoT r rs TyConAppCo+{-# INLINE tyConAppCoAllR #-}++-- | Rewrite any children of a coercion of the form: @TyConAppCo@ 'TyCon' ['Coercion']+tyConAppCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m TyCon -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion+tyConAppCoAnyR r rs = unwrapAnyR $ tyConAppCoAllR (wrapAnyR r) (wrapAnyR . rs)+{-# INLINE tyConAppCoAnyR #-}++-- | Rewrite one child of a coercion of the form: @TyConAppCo@ 'TyCon' ['Coercion']+tyConAppCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m TyCon -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion+tyConAppCoOneR r rs = unwrapOneR $ tyConAppCoAllR (wrapOneR r) (wrapOneR . rs)+{-# INLINE tyConAppCoOneR #-}+++-- | Translate a coercion of the form: @AppCo@ 'Coercion' 'Coercion'+appCoT :: (ExtendPath c Crumb, Monad m) => Translate c m Coercion a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b+appCoT t1 t2 f = translate $ \ c -> \case+                                     AppCo co1 co2 -> f <$> apply t1 (c @@ AppCo_Fun) co1 <*> apply t2 (c @@ AppCo_Arg) co2+                                     _             -> fail "not a coercion application."+{-# INLINE appCoT #-}++-- | Rewrite all children of a coercion of the form: @AppCo@ 'Coercion' 'Coercion'+appCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Coercion -> Rewrite c m Coercion -> Rewrite c m Coercion+appCoAllR r1 r2 = appCoT r1 r2 AppCo+{-# INLINE appCoAllR #-}++-- | Rewrite any children of a coercion of the form: @AppCo@ 'Coercion' 'Coercion'+appCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Coercion -> Rewrite c m Coercion -> Rewrite c m Coercion+appCoAnyR r1 r2 = unwrapAnyR $ appCoAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE appCoAnyR #-}++-- | Rewrite one child of a coercion of the form: @AppCo@ 'Coercion' 'Coercion'+appCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Coercion -> Rewrite c m Coercion -> Rewrite c m Coercion+appCoOneR r1 r2 = unwrapOneR $ appCoAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE appCoOneR #-}+++-- | Translate a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion'+forAllCoT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m TyVar a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b+forAllCoT t1 t2 f = translate $ \ c -> \case+                                          ForAllCo v co -> f <$> apply t1 (c @@ ForAllCo_TyVar) v <*> apply t2 (addForallBinding v c @@ ForAllCo_Body) co+                                          _             -> fail "not a forall coercion."+{-# INLINE forAllCoT #-}++-- | Rewrite all children of a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion'+forAllCoAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion+forAllCoAllR r1 r2 = forAllCoT r1 r2 ForAllCo+{-# INLINE forAllCoAllR #-}++-- | Rewrite any children of a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion'+forAllCoAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion+forAllCoAnyR r1 r2 = unwrapAnyR $ forAllCoAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE forAllCoAnyR #-}++-- | Rewrite one child of a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion'+forAllCoOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion+forAllCoOneR r1 r2 = unwrapOneR $ forAllCoAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE forAllCoOneR #-}+++-- | Translate a coercion of the form: @CoVarCo@ 'CoVar'+coVarCoT :: (ExtendPath c Crumb, Monad m) => Translate c m CoVar b -> Translate c m Coercion b+coVarCoT t = translate $ \ c -> \case+                                   CoVarCo v -> apply t (c @@ CoVarCo_CoVar) v+                                   _         -> fail "not a coercion variable."+{-# INLINE coVarCoT #-}++-- | Rewrite the 'CoVar' child of a coercion of the form: @CoVarCo@ 'CoVar'+coVarCoR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoVar -> Rewrite c m Coercion+coVarCoR r = coVarCoT (CoVarCo <$> r)+{-# INLINE coVarCoR #-}++#if __GLASGOW_HASKELL__ > 706+-- | Translate a coercion of the form: @AxiomInstCo@ ('CoAxiom' 'Branched') 'BranchIndex' ['Coercion']+axiomInstCoT :: (ExtendPath c Crumb, Monad m) => Translate c m (CoAxiom Branched) a1 -> Translate c m BranchIndex a2 -> (Int -> Translate c m Coercion a3) -> (a1 -> a2 -> [a3] -> b) -> Translate c m Coercion b+axiomInstCoT t1 t2 ts f = translate $ \ c -> \case+                                                AxiomInstCo ax idx coes -> f <$> apply t1 (c @@ AxiomInstCo_Axiom) ax <*> apply t2 (c @@ AxiomInstCo_Index) idx <*> sequence [ apply (ts n) (c @@ AxiomInstCo_Arg n) co | (co,n) <- zip coes [0..] ]+                                                _                       -> fail "not a coercion axiom instantiation."+#else+-- | Translate a coercion of the form: @AxiomInstCo@ 'CoAxiom' ['Coercion']+axiomInstCoT :: (ExtendPath c Crumb, Monad m) => Translate c m CoAxiom a1 -> (Int -> Translate c m Coercion a2) -> (a1 -> [a2] -> b) -> Translate c m Coercion b+axiomInstCoT t ts f = translate $ \ c -> \case+                                            AxiomInstCo ax coes -> f <$> apply t (c @@ AxiomInstCo_Axiom) ax <*> sequence [ apply (ts n) (c @@ AxiomInstCo_Arg n) co | (co,n) <- zip coes [0..] ]+                                            _                   -> fail "not a coercion axiom instantiation."+#endif+{-# INLINE axiomInstCoT #-}++#if __GLASGOW_HASKELL__ > 706+-- | Rewrite all children of a coercion of the form: @AxiomInstCo@ ('CoAxiom' 'Branched') 'BranchIndex' ['Coercion']+axiomInstCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m (CoAxiom Branched) -> Rewrite c m BranchIndex -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion+axiomInstCoAllR r1 r2 rs = axiomInstCoT r1 r2 rs AxiomInstCo+#else+-- | Rewrite all children of a coercion of the form: @AxiomInstCo@ 'CoAxiom' ['Coercion']+axiomInstCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoAxiom -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion+axiomInstCoAllR r rs = axiomInstCoT r rs AxiomInstCo+#endif+{-# INLINE axiomInstCoAllR #-}++#if __GLASGOW_HASKELL__ > 706+-- | Rewrite any children of a coercion of the form: @AxiomInstCo@ ('CoAxiom' 'Branched') 'BranchIndex' ['Coercion']+axiomInstCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m (CoAxiom Branched) -> Rewrite c m BranchIndex -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion+axiomInstCoAnyR r1 r2 rs = unwrapAnyR $ axiomInstCoAllR (wrapAnyR r1) (wrapAnyR r2) (wrapAnyR . rs)+#else+-- | Rewrite any children of a coercion of the form: @AxiomInstCo@ 'CoAxiom' ['Coercion']+axiomInstCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoAxiom -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion+axiomInstCoAnyR r rs = unwrapAnyR $ axiomInstCoAllR (wrapAnyR r) (wrapAnyR . rs)+#endif+{-# INLINE axiomInstCoAnyR #-}++#if __GLASGOW_HASKELL__ > 706+-- | Rewrite one child of a coercion of the form: @AxiomInstCo@ ('CoAxiom' 'Branched') 'BranchIndex' ['Coercion']+axiomInstCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m (CoAxiom Branched) -> Rewrite c m BranchIndex -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion+axiomInstCoOneR r1 r2 rs = unwrapOneR $ axiomInstCoAllR (wrapOneR r1) (wrapOneR r2) (wrapOneR . rs)+#else+-- | Rewrite one child of a coercion of the form: @AxiomInstCo@ 'CoAxiom' ['Coercion']+axiomInstCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoAxiom -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion+axiomInstCoOneR r rs = unwrapOneR $ axiomInstCoAllR (wrapOneR r) (wrapOneR . rs)+#endif+{-# INLINE axiomInstCoOneR #-}++-- | Translate a coercion of the form: @UnsafeCo@ 'Type' 'Type'+unsafeCoT :: (ExtendPath c Crumb, Monad m) => Translate c m Type a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b+unsafeCoT t1 t2 f = translate $ \ c -> \case+                                          UnsafeCo ty1 ty2 -> f <$> apply t1 (c @@ UnsafeCo_Left) ty1 <*> apply t2 (c @@ UnsafeCo_Right) ty2+                                          _                -> fail "not an unsafe coercion."+{-# INLINE unsafeCoT #-}++-- | Rewrite all children of a coercion of the form: @UnsafeCo@ 'Type' 'Type'+unsafeCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Coercion+unsafeCoAllR r1 r2 = unsafeCoT r1 r2 UnsafeCo+{-# INLINE unsafeCoAllR #-}++-- | Rewrite any children of a coercion of the form: @UnsafeCo@ 'Type' 'Type'+unsafeCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Coercion+unsafeCoAnyR r1 r2 = unwrapAnyR $ unsafeCoAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE unsafeCoAnyR #-}++-- | Rewrite one child of a coercion of the form: @UnsafeCo@ 'Type' 'Type'+unsafeCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Coercion+unsafeCoOneR r1 r2 = unwrapOneR $ unsafeCoAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE unsafeCoOneR #-}+++-- | Translate a coercion of the form: @SymCo@ 'Coercion'+symCoT :: (ExtendPath c Crumb, Monad m) => Translate c m Coercion b -> Translate c m Coercion b+symCoT t = translate $ \ c -> \case+                                   SymCo co -> apply t (c @@ SymCo_Co) co+                                   _        -> fail "not a symmetric coercion."+{-# INLINE symCoT #-}++-- | Rewrite the 'Coercion' child of a coercion of the form: @SymCo@ 'Coercion'+symCoR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Coercion -> Rewrite c m Coercion+symCoR r = symCoT (SymCo <$> r)+{-# INLINE symCoR #-}+++-- | Translate a coercion of the form: @TransCo@ 'Coercion' 'Coercion'+transCoT :: (ExtendPath c Crumb, Monad m) => Translate c m Coercion a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b+transCoT t1 t2 f = translate $ \ c -> \case+                                          TransCo co1 co2 -> f <$> apply t1 (c @@ TransCo_Left) co1 <*> apply t2 (c @@ TransCo_Right) co2+                                          _               -> fail "not a transitive coercion."+{-# INLINE transCoT #-}++-- | Rewrite all children of a coercion of the form: @TransCo@ 'Coercion' 'Coercion'+transCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Coercion -> Rewrite c m Coercion -> Rewrite c m Coercion+transCoAllR r1 r2 = transCoT r1 r2 TransCo+{-# INLINE transCoAllR #-}++-- | Rewrite any children of a coercion of the form: @TransCo@ 'Coercion' 'Coercion'+transCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Coercion -> Rewrite c m Coercion -> Rewrite c m Coercion+transCoAnyR r1 r2 = unwrapAnyR $ transCoAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE transCoAnyR #-}++-- | Rewrite one child of a coercion of the form: @TransCo@ 'Coercion' 'Coercion'+transCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Coercion -> Rewrite c m Coercion -> Rewrite c m Coercion+transCoOneR r1 r2 = unwrapOneR $ transCoAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE transCoOneR #-}+++-- | Translate a coercion of the form: @NthCo@ 'Int' 'Coercion'+nthCoT :: (ExtendPath c Crumb, Monad m) => Translate c m Int a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b+nthCoT t1 t2 f = translate $ \ c -> \case+                                          NthCo n co -> f <$> apply t1 (c @@ NthCo_Int) n <*> apply t2 (c @@ NthCo_Co) co+                                          _          -> fail "not an Nth coercion."+{-# INLINE nthCoT #-}++-- | Rewrite all children of a coercion of the form: @NthCo@ 'Int' 'Coercion'+nthCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Int -> Rewrite c m Coercion -> Rewrite c m Coercion+nthCoAllR r1 r2 = nthCoT r1 r2 NthCo+{-# INLINE nthCoAllR #-}++-- | Rewrite any children of a coercion of the form: @NthCo@ 'Int' 'Coercion'+nthCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Int -> Rewrite c m Coercion -> Rewrite c m Coercion+nthCoAnyR r1 r2 = unwrapAnyR $ nthCoAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE nthCoAnyR #-}++-- | Rewrite one child of a coercion of the form: @NthCo@ 'Int' 'Coercion'+nthCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Int -> Rewrite c m Coercion -> Rewrite c m Coercion+nthCoOneR r1 r2 = unwrapOneR $ nthCoAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE nthCoOneR #-}+++#if __GLASGOW_HASKELL__ > 706+-- | Translate a coercion of the form: @LRCo@ 'LeftOrRight' 'Coercion'+lrCoT :: (ExtendPath c Crumb, Monad m) => Translate c m LeftOrRight a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b+lrCoT t1 t2 f = translate $ \ c -> \case+                                      LRCo lr co -> f <$> apply t1 (c @@ LRCo_LR) lr <*> apply t2 (c @@ LRCo_Co) co+                                      _          -> fail "not a left/right coercion."+{-# INLINE lrCoT #-}++-- | Translate all children of a coercion of the form: @LRCo@ 'LeftOrRight' 'Coercion'+lrCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m LeftOrRight -> Rewrite c m Coercion -> Rewrite c m Coercion+lrCoAllR r1 r2 = lrCoT r1 r2 LRCo+{-# INLINE lrCoAllR #-}++-- | Translate any children of a coercion of the form: @LRCo@ 'LeftOrRight' 'Coercion'+lrCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m LeftOrRight -> Rewrite c m Coercion -> Rewrite c m Coercion+lrCoAnyR r1 r2 = unwrapAnyR $ lrCoAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE lrCoAnyR #-}++-- | Translate one child of a coercion of the form: @LRCo@ 'LeftOrRight' 'Coercion'+lrCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m LeftOrRight -> Rewrite c m Coercion -> Rewrite c m Coercion+lrCoOneR r1 r2 = unwrapOneR $ lrCoAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE lrCoOneR #-}+#else+#endif+++-- | Translate a coercion of the form: @InstCo@ 'Coercion' 'Type'+instCoT :: (ExtendPath c Crumb, Monad m) => Translate c m Coercion a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b+instCoT t1 t2 f = translate $ \ c -> \case+                                          InstCo co ty -> f <$> apply t1 (c @@ InstCo_Co) co <*> apply t2 (c @@ InstCo_Type) ty+                                          _            -> fail "not a coercion instantiation."+{-# INLINE instCoT #-}++-- | Rewrite all children of a coercion of the form: @InstCo@ 'Coercion' 'Type'+instCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Coercion -> Rewrite c m Type -> Rewrite c m Coercion+instCoAllR r1 r2 = instCoT r1 r2 InstCo+{-# INLINE instCoAllR #-}++-- | Rewrite any children of a coercion of the form: @InstCo@ 'Coercion' 'Type'+instCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Coercion -> Rewrite c m Type -> Rewrite c m Coercion+instCoAnyR r1 r2 = unwrapAnyR $ instCoAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE instCoAnyR #-}++-- | Rewrite one child of a coercion of the form: @InstCo@ 'Coercion' 'Type'+instCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Coercion -> Rewrite c m Type -> Rewrite c m Coercion+instCoOneR r1 r2 = unwrapOneR $ instCoAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE instCoOneR #-}++---------------------------------------------------------------------+---------------------------------------------------------------------++-- | Earlier versions of HERMIT used 'Int' as the crumb type.+--   This translation maps an 'Int' to the corresponding 'Crumb', for backwards compatibility purposes.+deprecatedIntToCrumbT :: Monad m => Int -> Translate c m Core Crumb+deprecatedIntToCrumbT n = contextfreeT $ \case+                                            GutsCore _                 | n == 0                        -> return ModGuts_Prog+                                            AltCore _                  | n == 0                        -> return Alt_RHS+                                            DefCore _                  | n == 0                        -> return Def_RHS+                                            ProgCore (ProgCons _ _)    | n == 0                        -> return ProgCons_Head+                                                                       | n == 1                        -> return ProgCons_Tail+                                            BindCore (NonRec _ _)      | n == 0                        -> return NonRec_RHS+                                            BindCore (Rec bds)         | (n >= 0) && (n < length bds)  -> return (Rec_Def n)+                                            ExprCore (App _ _)         | n == 0                        -> return App_Fun+                                                                       | n == 1                        -> return App_Arg+                                            ExprCore (Lam _ _)         | n == 0                        -> return Lam_Body+                                            ExprCore (Let _ _)         | n == 0                        -> return Let_Bind+                                                                       | n == 1                        -> return Let_Body+                                            ExprCore (Case _ _ _ alts) | n == 0                        -> return Case_Scrutinee+                                                                       | (n > 0) && (n <= length alts) -> return (Case_Alt (n-1))+                                            ExprCore (Cast _ _)        | n == 0                        -> return Cast_Expr+                                            ExprCore (Tick _ _)        | n == 0                        -> return Tick_Expr+                                            _                                                          -> fail ("Child " ++ show n ++ " does not exist.")+{-# INLINE deprecatedIntToCrumbT #-}++-- | Builds a path to the first child, based on the old numbering system.+deprecatedIntToPathT :: Monad m => Int -> Translate c m Core PathH+deprecatedIntToPathT =  liftM return . deprecatedIntToCrumbT+{-# INLINE deprecatedIntToPathT #-}++--------------------------------------------------------------------- ---------------------------------------------------------------------

@@ -0,0 +1,255 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, InstanceSigs #-}++module Language.HERMIT.Kure.SumTypes+  ( -- * Sum Types+    Core(..)+  , TyCo(..)+  , CoreTC(..)+  )+where++import GhcPlugins++import Language.KURE.Injection++import Language.HERMIT.Core++---------------------------------------------------------------------++-- | Core is a sum type for use by KURE.  Core = ModGuts + CoreProg + CoreBind + CoreDef + CoreExpr + CoreAlt+data Core = GutsCore  ModGuts            -- ^ The module.+          | ProgCore  CoreProg           -- ^ A program (a telescope of top-level binding groups).+          | BindCore  CoreBind           -- ^ A binding group.+          | DefCore   CoreDef            -- ^ A recursive definition.+          | ExprCore  CoreExpr           -- ^ An expression.+          | AltCore   CoreAlt            -- ^ A case alternative.++-- | TyCo is a sum type for use by KURE.  TyCo = Type + Coercion+data TyCo = TypeCore Type                -- ^ A type.+          | CoercionCore Coercion        -- ^ A coercion.++-- | CoreTC is a sum type for use by KURE.  CoreTC = Core + TyCo+data CoreTC = Core Core+            | TyCo TyCo++---------------------------------------------------------------------++instance Injection ModGuts Core where++  inject :: ModGuts -> Core+  inject = GutsCore+  {-# INLINE inject #-}++  project :: Core -> Maybe ModGuts+  project (GutsCore guts) = Just guts+  project _               = Nothing+  {-# INLINE project #-}+++instance Injection CoreProg Core where++  inject :: CoreProg -> Core+  inject = ProgCore+  {-# INLINE inject #-}++  project :: Core -> Maybe CoreProg+  project (ProgCore bds) = Just bds+  project _              = Nothing+  {-# INLINE project #-}+++instance Injection CoreBind Core where++  inject :: CoreBind -> Core+  inject = BindCore+  {-# INLINE inject #-}++  project :: Core -> Maybe CoreBind+  project (BindCore bnd)  = Just bnd+  project _               = Nothing+  {-# INLINE project #-}+++instance Injection CoreDef Core where++  inject :: CoreDef -> Core+  inject = DefCore+  {-# INLINE inject #-}++  project :: Core -> Maybe CoreDef+  project (DefCore def) = Just def+  project _             = Nothing+  {-# INLINE project #-}+++instance Injection CoreAlt Core where++  inject :: CoreAlt -> Core+  inject = AltCore+  {-# INLINE inject #-}++  project :: Core -> Maybe CoreAlt+  project (AltCore expr) = Just expr+  project _              = Nothing+  {-# INLINE project #-}+++instance Injection CoreExpr Core where++  inject :: CoreExpr -> Core+  inject = ExprCore+  {-# INLINE inject #-}++  project :: Core -> Maybe CoreExpr+  project (ExprCore expr) = Just expr+  project _               = Nothing+  {-# INLINE project #-}++---------------------------------------------------------------------++instance Injection Type TyCo where++  inject :: Type -> TyCo+  inject = TypeCore+  {-# INLINE inject #-}++  project :: TyCo -> Maybe Type+  project (TypeCore ty) = Just ty+  project _             = Nothing+  {-# INLINE project #-}+++instance Injection Coercion TyCo where++  inject :: Coercion -> TyCo+  inject = CoercionCore+  {-# INLINE inject #-}++  project :: TyCo -> Maybe Coercion+  project (CoercionCore ty) = Just ty+  project _                 = Nothing+  {-# INLINE project #-}++---------------------------------------------------------------------++instance Injection Core CoreTC where++  inject :: Core -> CoreTC+  inject = Core+  {-# INLINE inject #-}++  project :: CoreTC -> Maybe Core+  project (Core core) = Just core+  project _           = Nothing+  {-# INLINE project #-}+++instance Injection TyCo CoreTC where++  inject :: TyCo -> CoreTC+  inject = TyCo+  {-# INLINE inject #-}++  project :: CoreTC -> Maybe TyCo+  project (TyCo tyCo) = Just tyCo+  project _           = Nothing+  {-# INLINE project #-}++---------------------------------------------------------------------++instance Injection ModGuts CoreTC where++  inject :: ModGuts -> CoreTC+  inject = Core . GutsCore+  {-# INLINE inject #-}++  project :: CoreTC -> Maybe ModGuts+  project (Core (GutsCore guts)) = Just guts+  project _                      = Nothing+  {-# INLINE project #-}+++instance Injection CoreProg CoreTC where++  inject :: CoreProg -> CoreTC+  inject = Core . ProgCore+  {-# INLINE inject #-}++  project :: CoreTC -> Maybe CoreProg+  project (Core (ProgCore bds)) = Just bds+  project _                     = Nothing+  {-# INLINE project #-}+++instance Injection CoreBind CoreTC where++  inject :: CoreBind -> CoreTC+  inject = Core . BindCore+  {-# INLINE inject #-}++  project :: CoreTC -> Maybe CoreBind+  project (Core (BindCore bnd))  = Just bnd+  project _                      = Nothing+  {-# INLINE project #-}+++instance Injection CoreDef CoreTC where++  inject :: CoreDef -> CoreTC+  inject = Core . DefCore+  {-# INLINE inject #-}++  project :: CoreTC -> Maybe CoreDef+  project (Core (DefCore def)) = Just def+  project _                    = Nothing+  {-# INLINE project #-}+++instance Injection CoreAlt CoreTC where++  inject :: CoreAlt -> CoreTC+  inject = Core . AltCore+  {-# INLINE inject #-}++  project :: CoreTC -> Maybe CoreAlt+  project (Core (AltCore expr)) = Just expr+  project _                     = Nothing+  {-# INLINE project #-}+++instance Injection CoreExpr CoreTC where++  inject :: CoreExpr -> CoreTC+  inject = Core . ExprCore+  {-# INLINE inject #-}++  project :: CoreTC -> Maybe CoreExpr+  project (Core (ExprCore expr)) = Just expr+  project _                      = Nothing+  {-# INLINE project #-}+++instance Injection Type CoreTC where++  inject :: Type -> CoreTC+  inject = TyCo . TypeCore+  {-# INLINE inject #-}++  project :: CoreTC -> Maybe Type+  project (TyCo (TypeCore ty)) = Just ty+  project _                    = Nothing+  {-# INLINE project #-}+++instance Injection Coercion CoreTC where++  inject :: Coercion -> CoreTC+  inject = TyCo . CoercionCore+  {-# INLINE inject #-}++  project :: CoreTC -> Maybe Coercion+  project (TyCo (CoercionCore ty)) = Just ty+  project _                        = Nothing+  {-# INLINE project #-}++---------------------------------------------------------------------

@@ -38,6 +38,7 @@  import Language.HERMIT.Core import Language.HERMIT.Context+import Language.HERMIT.Kure.SumTypes  ---------------------------------------------------------------------------- @@ -55,71 +56,57 @@  runHermitM :: HermitM a -> HermitMEnv -> DefStash -> CoreM (KureM (DefStash, a)) runHermitM (HermitM f) = f-{-# INLINE runHermitM #-}  -- | Get the stash of saved definitions. getStash :: HermitM DefStash getStash = HermitM (\ _ s -> return $ return (s, s))-{-# INLINE getStash #-}  -- | Replace the stash of saved definitions. putStash :: DefStash -> HermitM () putStash s = HermitM (\ _ _ -> return $ return (s, ()))-{-# INLINE putStash #-}  sendDebugMessage :: DebugMessage -> HermitM () sendDebugMessage msg = do env <- HermitM $ \ ch s -> return $ return (s, ch)                           hs_debugChan env msg-{-# INLINE sendDebugMessage #-}  -- | Save a definition for future use. saveDef :: Label -> CoreDef -> HermitM () saveDef l d = getStash >>= (insert l d >>> putStash)-{-# INLINE saveDef #-}  -- | Lookup a previously saved definition. lookupDef :: Label -> HermitM CoreDef lookupDef l = getStash >>= (lookup l >>> maybe (fail "Definition not found.") return)-{-# INLINE lookupDef #-}  -- | 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 >>= runKureM (\ (a,b) -> success a b) failure-{-# INLINE runHM #-}  ----------------------------------------------------------------------------  instance Functor HermitM where   fmap :: (a -> b) -> HermitM a -> HermitM b   fmap = liftM-  {-# INLINE fmap #-}  instance Applicative HermitM where   pure :: a -> HermitM a   pure = return-  {-# INLINE pure #-}    (<*>) :: HermitM (a -> b) -> HermitM a -> HermitM b   (<*>) = ap-  {-# INLINE (<*>) #-}  instance Monad HermitM where   return :: a -> HermitM a   return a = HermitM $ \ _ s -> return (return (s,a))-  {-# INLINE return #-}    (>>=) :: HermitM a -> (a -> HermitM b) -> HermitM b   (HermitM gcm) >>= f = HermitM $ \ env -> gcm env >=> runKureM (\ (s', a) -> runHermitM (f a) env s') (return . fail)-  {-# INLINE (>>=) #-}    fail :: String -> HermitM a   fail msg = HermitM $ \ _ _ -> return (fail msg)-  {-# INLINE fail #-}  instance MonadCatch HermitM where   catchM :: HermitM a -> (String -> HermitM a) -> HermitM a   (HermitM gcm) `catchM` f = HermitM $ \ env s -> gcm env s >>= runKureM (return.return) (\ msg -> runHermitM (f msg) env s)-  {-# INLINE catchM #-}  ---------------------------------------------------------------------------- @@ -127,46 +114,38 @@ liftCoreM :: CoreM a -> HermitM a liftCoreM ma = HermitM $ \ _ s -> do a <- ma                                      return (return (s,a))-{-# INLINE liftCoreM #-}  instance MonadIO HermitM where   liftIO :: IO a -> HermitM a   liftIO = liftCoreM . liftIO-  {-# INLINE liftIO #-}  instance MonadUnique HermitM where   getUniqueSupplyM :: HermitM UniqSupply   getUniqueSupplyM = liftCoreM getUniqueSupplyM-  {-# INLINE getUniqueSupplyM #-}  instance MonadThings HermitM where   lookupThing :: Name -> HermitM TyThing   lookupThing = liftCoreM . lookupThing-  {-# INLINE lookupThing #-}  instance HasDynFlags HermitM where   getDynFlags :: HermitM DynFlags   getDynFlags = liftCoreM getDynFlags-  {-# INLINE getDynFlags #-}  ----------------------------------------------------------------------------  newName :: String -> HermitM Name newName name = do uq <- getUniqueM                   return $ mkSystemVarName uq $ mkFastString name-{-# INLINE newName #-}  -- | Make a unique identifier for a specified type based on a provided name. newIdH :: String -> Type -> HermitM Id newIdH name ty = do name' <- newName name                     return $ mkLocalId name' ty-{-# INLINE newIdH #-}  -- | Make a unique type variable for a specified kind based on a provided name. newTyVarH :: String -> Kind -> HermitM TyVar newTyVarH name kind = do name' <- newName name                          return $ mkTyVar name' kind-{-# INLINE newTyVarH #-}  -- | This gives an new version of a 'Var', with the same info, and a new textual name. cloneVarH :: (String -> String) -> Var -> HermitM Var@@ -177,7 +156,6 @@           if isTyVar v            then newTyVarH name ty            else newIdH name ty-{-# INLINE cloneVarH #-}  ---------------------------------------------------------------------------- @@ -189,6 +167,5 @@ mkHermitMEnv debugger = HermitMEnv                 { hs_debugChan = debugger                 }-{-# INLINE mkHermitMEnv #-}  ----------------------------------------------------------------------------

@@ -1,4 +1,4 @@-{-# LANGUAGE KindSignatures, GADTs #-}+{-# LANGUAGE KindSignatures, GADTs, FlexibleContexts #-} module Language.HERMIT.Optimize     ( -- * The HERMIT Plugin       optimize@@ -16,6 +16,8 @@     , after     , before     , allPhases+    , firstPhase+    , lastPhase     ) where  import GhcPlugins hiding (singleton, liftIO, display)@@ -26,27 +28,28 @@  import Data.Default -import Language.HERMIT.Core+import Language.HERMIT.Dictionary import Language.HERMIT.External hiding (Query, Shell) import Language.HERMIT.Kernel.Scoped+import Language.HERMIT.Context import Language.HERMIT.Kure import Language.HERMIT.Monad import Language.HERMIT.Plugin import Language.HERMIT.PrettyPrinter.Common import qualified Language.HERMIT.PrettyPrinter.Clean as Clean-import qualified Language.HERMIT.Shell.Command as Shell+import Language.HERMIT.Shell.Command  import System.Console.Haskeline (defaultBehavior) import System.IO (stdout)  data OInst :: * -> * where-    RR       :: RewriteH Core                     -> OInst ()-    Query    :: TranslateH Core a                 -> OInst a     Shell    :: [External] -> [CommandLineOption] -> OInst ()     Guard    :: (PhaseInfo -> Bool) -> OM ()      -> OInst ()     -- with some refactoring of the interpreter I'm pretty sure     -- we can make Focus polymorphic-    Focus    :: TranslateH Core Path -> OM ()     -> OInst ()+    Focus    :: (Injection GHC.ModGuts g, Walker HermitC g) => TranslateH g PathH -> OM () -> OInst ()+    RR       :: (Injection GHC.ModGuts g, Walker HermitC g) => RewriteH g                  -> OInst ()+    Query    :: (Injection GHC.ModGuts g, Walker HermitC g) => TranslateH g a              -> OInst a  -- using operational, but would we nice to use Neil's constrained-normal package! type OM a = ProgramT OInst (StateT InterpState IO) a@@ -54,12 +57,12 @@ optimize :: ([CommandLineOption] -> OM ()) -> Plugin optimize f = hermitPlugin $ \ phaseInfo -> runOM phaseInfo . f -data InterpState = +data InterpState =     InterpState { isAST :: SAST-                , isPretty :: PrettyOptions -> PrettyH Core+                , isPretty :: PrettyOptions -> PrettyH CoreTC                 , isPrettyOptions :: PrettyOptions                 -- TODO: remove once shell can return-                , shellHack :: Maybe ([External], [CommandLineOption]) +                , shellHack :: Maybe ([External], [CommandLineOption])                 } type InterpM a = StateT InterpState IO a @@ -74,16 +77,16 @@          initState = InterpState initSAST Clean.corePrettyH def Nothing -        eval :: Path -> ProgramT OInst (StateT InterpState IO) () -> InterpM ()+        eval :: PathH -> ProgramT OInst (StateT InterpState IO) () -> InterpM ()         eval path comp = do             sast <- gets isAST             v <- viewT comp             case v of                 Return _            -> return ()-                RR rr       :>>= k  -> liftIO (applyS kernel sast (pathR path (extractR rr)) env)+                RR rr       :>>= k  -> liftIO (applyS kernel sast (pathR path rr) env)                                         >>= runKureM (\sast' -> modify (\s -> s { isAST = sast' }))                                                      errorAbort >> eval path (k ())-                Query tr    :>>= k  -> liftIO (queryS kernel sast (pathT path (extractT tr)) env)+                Query tr    :>>= k  -> liftIO (queryS kernel sast (pathT path tr) env)                                         >>= runKureM (eval path . k) errorAbort                 -- TODO: rework shell so it can return to k                 --       this will significantly simplify this code@@ -93,22 +96,22 @@                                        -- calling the shell directly causes indefinite MVar problems                                        -- because the state monad never finishes (I think)                 Guard p m   :>>= k  -> when (p phaseInfo) (eval path m) >> eval path (k ())-                Focus tp m  :>>= k  -> liftIO (queryS kernel sast (extractT tp) env)+                Focus tp m  :>>= k  -> liftIO (queryS kernel sast tp env)                                         >>= runKureM (flip eval m) errorAbort >> eval path (k ())      in do st <- execStateT (eval [] opt) initState           let sast = isAST st           maybe (liftIO (resumeS kernel sast) >>= runKureM return errorAbortIO)-                (\(es,os) -> liftIO $ Shell.interactive os defaultBehavior es kernel sast)+                (\(es,os) -> liftIO $ commandLine os defaultBehavior es kernel sast)                 (shellHack st)  interactive :: [External] -> [CommandLineOption] -> OM ()-interactive es os = singleton $ Shell es os+interactive es os = singleton $ Shell (externals ++ es) os  run :: RewriteH Core -> OM () run = singleton . RR -query :: TranslateH Core a -> OM a+query :: (Injection GHC.ModGuts g, Walker HermitC g) => TranslateH g a -> OM a query = singleton . Query  ----------------------------- guards ------------------------------@@ -116,7 +119,7 @@ guard :: (PhaseInfo -> Bool) -> OM () -> OM () guard p = singleton . Guard p -at :: TranslateH Core Path -> OM () -> OM ()+at :: TranslateH Core PathH -> OM () -> OM () at tp = singleton . Focus tp  phase :: Int -> OM () -> OM ()@@ -135,14 +138,20 @@ allPhases :: OM () -> OM () allPhases = guard (const True) +firstPhase :: OM () -> OM ()+firstPhase = guard (null . phasesDone)++lastPhase :: OM () -> OM ()+lastPhase = guard (null . phasesLeft)+ ----------------------------- other ------------------------------  display :: OM () display = do     po <- gets isPrettyOptions-    gets isPretty >>= query . ($ po) >>= liftIO . Shell.unicodeConsole stdout po+    gets isPretty >>= query . liftPrettyH . ($ po) >>= liftIO . unicodeConsole stdout po -setPretty :: (PrettyOptions -> PrettyH Core) -> OM ()+setPretty :: (PrettyOptions -> PrettyH CoreTC) -> OM () setPretty pp = modify $ \s -> s { isPretty = pp }  setPrettyOptions :: PrettyOptions -> OM ()

@@ -9,7 +9,8 @@ import Data.Char (isSpace) import Data.List (intercalate) -import Language.HERMIT.Syntax+import Language.HERMIT.Syntax (isScriptInfixIdChar, isScriptIdFirstChar, isScriptIdChar)+ }  %name parser@@ -119,11 +120,11 @@ lexer ('[' :cs)    = fmap (ListStart:)  $ lexer cs lexer (',' :cs)    = fmap (ListDelim:)  $ lexer cs lexer (']' :cs)    = fmap (ListEnd:)    $ lexer cs-lexer s@(c:cs)     | isSpace       c = lexer cs-                   | isIdFirstChar c = let (i,s') = span isIdChar s-                                       in fmap (Ident i:) $ lexer s'-                   | isInfixId     c = let (op,s') = span isInfixId s-                                       in fmap (InfixOp op:) $ lexer s'+lexer s@(c:cs)     | isSpace             c = lexer cs+                   | isScriptIdFirstChar c = let (i,s') = span isScriptIdChar s+                                              in fmap (Ident i:) $ lexer s'+                   | isScriptInfixIdChar c = let (op,s') = span isScriptInfixIdChar s+                                              in fmap (InfixOp op:) $ lexer s' lexer s            = Left $ "lexer: no match on " ++ s  lexString :: String -> Either String (String,String)@@ -163,17 +164,17 @@  unparseExprH :: ExprH -> String unparseExprH (SrcName nm)-    | nm /= "" && (all isInfixId nm || isIdFirstChar (head nm) && all (isIdChar) (tail nm)) = "'" ++ nm+    | nm /= "" && (all isScriptInfixIdChar nm || isScriptIdFirstChar (head nm) && all isScriptIdChar (tail nm)) = "'" ++ nm     | otherwise = "'\"" ++ concatMap escape nm ++ "\""         where escape '\"' = "\\\""               escape c    = [c] unparseExprH (CmdName nm)-    | nm == "{"       = "{ "-    | nm == "}"       = " }"-    | all isIdChar nm = nm-    | otherwise       = show nm     -- with quotes+    | nm == "{"             = "{ "+    | nm == "}"             = " }"+    | all isScriptIdChar nm = nm+    | otherwise             = show nm     -- with quotes unparseExprH (AppH (AppH (CmdName nm) e1) e2)-    | all isInfixId nm+    | all isScriptInfixIdChar nm     = unparseAtom e1 ++ " " ++ nm ++ " " ++ unparseAtom e2 unparseExprH (AppH e1 e2) = unparseExprH e1 ++ " " ++ unparseAtom e2 unparseExprH (CoreH s)    = "[|" ++ s ++ "|]"

@@ -3,7 +3,7 @@ module Language.HERMIT.ParserCore (parseCore) where  import Control.Monad.Reader-import Data.Char (isSpace, isAlpha, isAlphaNum, isDigit)+import Data.Char (isSpace, isDigit)  import GhcPlugins @@ -11,6 +11,7 @@ import Language.HERMIT.External import Language.HERMIT.Monad import Language.HERMIT.Primitive.Common+import Language.HERMIT.Syntax (isCoreInfixIdChar, isCoreIdFirstChar, isCoreIdChar)  import Language.KURE.MonadCatch (prefixFailMsg) @@ -95,7 +96,7 @@  type CoreParseM a = ReaderT HermitC HermitM a -parseError :: [Token] -> CoreParseM a+parseError :: Monad m => [Token] -> m a parseError ts = fail $ "core parse error: " ++ show ts  data Token@@ -147,28 +148,16 @@                      in case rest of                            ('\"':cs') -> fmap (Tstring str:) $ lexer cs'                            _          -> Left "lexer: no matching quote"-lexer s@(c:cs)     | isSpace       c = lexer cs-                   | isDigit       c = let (i,s') = span isDigit s-                                       in fmap (Tinteger (read i):) $ lexer s'-                   | isIdFirstChar c = let (i,s') = span isIdChar s-                                       in fmap (Tname i:) $ lexer s'-                   | isInfixId     c = let (op,s') = span isInfixId s-                                       in fmap (Tname op:) $ lexer s'+lexer s@(c:cs) | isSpace           c = lexer cs+               | isDigit           c = let (i,s') = span isDigit s+                                         in fmap (Tinteger (read i):) $ lexer s'+               | isCoreIdFirstChar c = let (i,s') = span isCoreIdChar s+                                         in fmap (Tname i:) $ lexer s'+               | isCoreInfixIdChar c = let (op,s') = span isCoreInfixIdChar s+                                         in fmap (Tname op:) $ lexer s' lexer s            = Left $ "lexer: no match on " ++ s  ------------------------------------------------- | Chars that are valid in identifiers anywhere.-isIdFirstChar :: Char -> Bool-isIdFirstChar c = c `elem` "_$[]:.=" || isAlpha c---- | Chars that are valid in identifiers, but not as the first character.-isIdChar :: Char -> Bool-isIdChar c = isAlphaNum c || c `elem` "#-'" || isIdFirstChar c---- | Chars that are valid in infix operators.-isInfixId :: Char -> Bool-isInfixId c = c `elem` "+*/._-:<>"  parseCore :: CoreString -> HermitC -> HermitM CoreExpr parseCore (CoreString s) c =

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- | Output the raw Expr constructors. Helpful for writing pattern matching rewrites. module Language.HERMIT.PrettyPrinter.AST   ( -- * HERMIT's AST Pretty-Printer for GHC Core@@ -8,9 +10,11 @@ import Control.Arrow hiding ((<+>))  import Data.Char (isSpace)-import Data.Traversable (sequenceA) +import GhcPlugins (Coercion(..), Var(..)) import qualified GhcPlugins as GHC++import Language.HERMIT.GHC import Language.HERMIT.Kure import Language.HERMIT.Core import Language.HERMIT.PrettyPrinter.Common@@ -21,7 +25,7 @@  -- | Pretty print a fragment of GHC Core using HERMIT's \"AST\" pretty printer. --   This displays the tree of constructors using nested indentation.-corePrettyH :: PrettyOptions -> PrettyH Core+corePrettyH :: PrettyOptions -> PrettyH CoreTC corePrettyH opts = do     dynFlags <- constT GHC.getDynFlags @@ -37,45 +41,72 @@         ppModGuts :: PrettyH GHC.ModGuts         ppModGuts = arr (ppSDoc . GHC.mg_module) -        -- DocH is not a monoid.-        -- GHC uses a list, which we print here. The CoreProg type is our doing.         ppCoreProg :: PrettyH CoreProg-        ppCoreProg = translate $ \ c -> fmap vlist . sequenceA . map (apply ppCoreBind c) . progToBinds+        ppCoreProg = progConsT ppCoreBind ppCoreProg ($+$) <+ progNilT empty          ppCoreExpr :: PrettyH GHC.CoreExpr-        ppCoreExpr = varT (\i -> text "Var" <+> idColor (ppSDoc i))-                  <+ litT (\i -> text "Lit" <+> ppSDoc i)+        ppCoreExpr = varT (ppVar >>^ \ i -> text "Var" <+> i)+                  <+ litT (arr $ \ x -> text "Lit" <+> ppSDoc x)                   <+ appT ppCoreExpr ppCoreExpr (\ a b -> text "App" $$ nest 2 (cat [parens a, parens b]))-                  <+ lamT ppCoreExpr (\ v e -> text "Lam" <+> idColor (ppSDoc v) $$ nest 2 (parens e))+                  <+ lamT ppVar ppCoreExpr (\ v e -> text "Lam" <+> 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))+                  <+ caseT ppCoreExpr ppVar ppType (const ppCoreAlt) (\s w ty alts ->+                            text "Case" $$ nest 2 (parens s) $$ nest 2 w $$ nest 2 (parens ty) $$ nest 2 (vlist alts))+                  <+ castT ppCoreExpr ppCoercion (\ e co -> text "Cast" $$ nest 2 (cat [parens e, parens co]))+                  <+ tickT (arr ppSDoc) ppCoreExpr (\ tk e  -> text "Tick" $$ nest 2 (tk <+> parens e))+                  <+ typeT (ppType >>^ \ ty -> text "Type" $$ nest 2 (parens ty))+                  <+ coercionT (ppCoercion >>^ \ co -> text "Coercion" $$ nest 2 (parens 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))+        ppCoreBind = nonRecT ppVar ppCoreExpr (\ v e -> text "NonRec" <+> v $$ 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)+        ppCoreAlt = altT (arr ppSDoc) (\ _ -> ppVar) ppCoreExpr $ \ con vs e -> text "Alt" <+> con <+> hlist vs $$ 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 $ idColor (ppSDoc i) <> text "," <> e+        ppCoreDef = defT ppVar ppCoreExpr (\ i e -> text "Def" <+> i $$ nest 2 (parens e)) +        ppType :: PrettyH Type+        ppType =  tyVarT (ppVar >>^ \ v -> tyText "TyVarTy" <+> v)+               <+ litTyT (arr $ \ l -> tyText "LitTy" <+> ppSDoc l)+               <+ appTyT ppType ppType (\ ty1 ty2 -> tyText "AppTy" $$ nest 2 (cat [parens ty1, parens ty2]))+               <+ funTyT ppType ppType (\ ty1 ty2 -> tyText "FunTy" $$ nest 2 (cat [parens ty1, parens ty2]))+               <+ forAllTyT ppVar ppType (\ v ty -> tyText "ForAllTy" <+> v $$ nest 2 (parens ty))+               <+ tyConAppT (arr ppSDoc) (const ppType) (\ con tys -> tyText "TyConApp" <+> con $$ nest 2 (vlist $ map parens tys))++        ppCoercion :: PrettyH Coercion+        ppCoercion =  reflT (ppType >>^ \ ty -> coText "Refl" $$ nest 2 (parens ty))+                   <+ coVarCoT (ppVar >>^ \ v -> coText "CoVarCo" <+> v)+                   <+ symCoT (ppCoercion >>^ \ co -> coText "SymCo" $$ nest 2 (parens co))+                   <+ appCoT ppCoercion ppCoercion (\ co1 co2 -> coText "AppCo" $$ nest 2 (cat [parens co1, parens co2]))+                   <+ forAllCoT ppVar ppCoercion (\ v co -> coText "ForAllCo" <+> v $$ nest 2 (parens co))+                   <+ transCoT ppCoercion ppCoercion (\ co1 co2 -> coText "TransCo" $$ nest 2 (cat [parens co1, parens co2]))+                   <+ tyConAppCoT (arr $ ppSDoc) (const ppCoercion) (\ con coes -> coText "TyConAppCo" <+> con $$ nest 2 (vlist $ map parens coes))+                   <+ unsafeCoT ppType ppType (\ ty1 ty2 -> coText "UnsafeCo" $$ nest 2 (cat [parens ty1, parens ty2]))+                   <+ nthCoT (arr $ coText . show) ppCoercion (\ n co -> coText "NthCo" <+> n $$ parens co)+                   <+ instCoT ppCoercion ppType (\ co ty -> coText "InstCo" $$ nest 2 (cat [parens co, parens ty]))+#if __GLASGOW_HASKELL__ > 706+        -- TODO: Figure out how to properly pp new branched Axioms and Left/Right Coercions+                   <+ axiomInstCoT (arr ppSDoc) (arr ppSDoc) (const ppCoercion) (\ ax idx coes -> coText "AxiomInstCo" <+> ax <+> idx $$ nest 2 (vlist $ map parens coes))+                   <+ lrCoT (arr ppSDoc) ppCoercion (\ lr co -> coText "LRCo" <+> lr $$ nest 2 (parens co))+#else+                   <+ axiomInstCoT (arr ppSDoc) (const ppCoercion) (\ ax coes -> coText "AxiomInstCo" <+> ax $$ nest 2 (vlist $ map parens coes))+#endif++        ppVar :: PrettyH Var+        ppVar = arr $ \ v -> let modCol | GHC.isTyVar v = typeColor+                                        | GHC.isCoVar v = coercionColor+                                        | otherwise     = idColor+                              in modCol (ppSDoc v)+     promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)      <+ promoteT (ppCoreProg :: PrettyH CoreProg)      <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)      <+ promoteT (ppCoreDef  :: PrettyH CoreDef)      <+ promoteT (ppModGuts  :: PrettyH GHC.ModGuts)      <+ promoteT (ppCoreAlt  :: PrettyH GHC.CoreAlt)+     <+ promoteT (ppType     :: PrettyH GHC.Type)+     <+ promoteT (ppCoercion :: PrettyH Coercion)  ---------------------------------------------------------------------------

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, LambdaCase #-}+{-# LANGUAGE CPP, LambdaCase, MultiWayIf #-}  module Language.HERMIT.PrettyPrinter.Clean   ( -- * HERMIT's Clean Pretty-Printer for GHC Core@@ -6,22 +6,27 @@   ) where -import Control.Monad (ap) import Control.Arrow hiding ((<+>))+import Control.Applicative ((<$>)) +import Data.List (intersperse) import Data.Char (isSpace)-import Data.Traversable (sequenceA)-+import Data.Set (notMember) +import GhcPlugins (TyCon(..), Coercion(..), Var(..), Expr(..)) import qualified GhcPlugins as GHC -import Language.HERMIT.Syntax-import Language.HERMIT.Kure+import Language.HERMIT.Context import Language.HERMIT.Core-import Language.HERMIT.PrettyPrinter.Common import Language.HERMIT.GHC+import Language.HERMIT.Kure+import Language.HERMIT.Monad+import Language.HERMIT.Syntax -import TypeRep (TyLit(..))+import Language.HERMIT.PrettyPrinter.Common++import Language.HERMIT.Primitive.Common+ import Pair  import Text.PrettyPrint.MarkedHughesPJ as PP@@ -29,17 +34,91 @@ ------------------------------------------------------------------------------------------------  data RetExpr-        = RetLam [DocH] DocH-        | RetLet [DocH] DocH+        = RetLam PathH [DocH] PathH DocH+        | RetLet PathH [DocH] PathH DocH         | RetApp DocH [RetExpr]+        | RetForAll PathH [DocH] PathH DocH+        | RetArrowType [DocH] -- TODO: store PathH here to mark arrows         | RetExpr DocH         | RetAtom DocH         -- parens not needed         | RetEmpty +retApp :: RetExpr -> RetExpr -> RetExpr+retApp f             RetEmpty = f+retApp RetEmpty      e        = e+retApp (RetApp f es) e        = RetApp f (es ++ [e])+retApp f             e        = RetApp (parenExpr f) [e]++retApps :: RetExpr -> [RetExpr] -> RetExpr+retApps = foldl retApp++retLam :: PathH -> RetExpr -> RetExpr -> RetExpr+retLam _ RetEmpty e            = e+retLam p v (RetLam _ vs pb e)  = RetLam p (parenExpr v : vs) pb e+retLam p v e                   = RetLam p [parenExpr v] (p ++ [Lam_Body]) (normalExpr e)++retLet :: PathH -> RetExpr -> RetExpr -> RetExpr+retLet _ RetEmpty body                    = body+retLet p bnd      (RetLet _ bnds pb body) = RetLet p (normalExpr bnd : bnds) pb body+retLet p bnd      body                    = RetLet p [normalExpr bnd] (p ++ [Let_Body]) (normalExpr body)++retForAll :: PathH -> Crumb -> RetExpr -> RetExpr -> RetExpr+retForAll _ _ RetEmpty ty                      = ty+retForAll p _  v       (RetForAll _ vs pb ty)  = RetForAll p (parenExpr v : vs) pb ty+retForAll p cr v       ty                      = RetForAll p [parenExpr v] (p ++ [cr]) (normalExpr ty)++retArrowType :: RetExpr -> RetExpr -> RetExpr+retArrowType ty1 (RetArrowType tys) = RetArrowType (parenExprExceptApp ty1 : tys)+retArrowType ty1 ty2                = RetArrowType [parenExprExceptApp ty1, parenExprExceptApp ty2]++------------------------------------------------------------------------------------------------++isEmptyR :: RetExpr -> Bool+isEmptyR RetEmpty = True+isEmptyR _        = False+ isAtom :: RetExpr -> Bool isAtom (RetAtom _) = True isAtom _           = False +------------------------------------------------------------------------------------------------++normalExpr :: RetExpr -> DocH+normalExpr  RetEmpty           = empty+normalExpr (RetAtom e)         = e+normalExpr (RetExpr e)         = e+normalExpr (RetLam p vs pb e)  = hang (attrP p (specialSymbol LambdaSymbol) <+> hsep vs <+> attrP pb (specialSymbol RightArrowSymbol)) 2 e+normalExpr (RetLet p vs pb e)  = sep [ attrP p (keyword "let") <+> vcat vs, attrP pb (keyword "in") <+> e ]+normalExpr (RetApp f es)       = let (atoms,exprs) = span isAtom es+                                  in sep [ hsep (f : map normalExpr atoms)+                                         , nest 2 (sep $ map parenExpr exprs) ]+normalExpr (RetForAll p vs pb ty) = attrP p (specialSymbol ForallSymbol) <+> hsep vs <+> attrP pb (symbol '.') <+> ty+normalExpr (RetArrowType tys)     = hsep (intersperse typeArrow tys)++parenExpr :: RetExpr -> DocH+parenExpr RetEmpty      = empty+parenExpr (RetAtom e)   = e+parenExpr (RetApp d []) = d+parenExpr other         = ppParens (normalExpr other)++parenExprExceptApp :: RetExpr -> DocH+parenExprExceptApp e@(RetApp _ _) = normalExpr e+parenExprExceptApp e              = parenExpr e++------------------------------------------------------------------------------------------------++attrPAtomExpr :: PathH -> RetExpr -> RetExpr+attrPAtomExpr p (RetAtom d) = RetAtom (attrP p d)+attrPAtomExpr p (RetExpr d) = RetExpr (attrP p d)+attrPAtomExpr _ e           = e++------------------------------------------------------------------------------------------------++ppParens :: DocH -> DocH+ppParens p = symbol '(' <> p <> symbol ')'++------------------------------------------------------------------------------------------------+ specialSymbol :: SpecialSymbol -> DocH specialSymbol = markColor SyntaxColor . specialFont . char . renderSpecial @@ -49,29 +128,7 @@ keyword :: String -> DocH keyword = markColor KeywordColor . text -ppParens :: DocH -> DocH-ppParens p = symbol '(' <> p <> symbol ')' -normalExprWithParens :: RetExpr -> DocH-normalExprWithParens (RetAtom e)   = e-normalExprWithParens RetEmpty      = empty-normalExprWithParens (RetApp d []) = d-normalExprWithParens other         = ppParens (normalExpr other)--normalExprWithParensExceptApp :: RetExpr -> DocH-normalExprWithParensExceptApp e@(RetApp _ _) = normalExpr e-normalExprWithParensExceptApp e              = normalExprWithParens e--normalExpr :: RetExpr -> DocH-normalExpr (RetLam vs e)  = hang (specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e-normalExpr (RetLet vs e)  = sep [ keyword "let" <+> vcat vs, keyword "in" <+> e ]-normalExpr (RetApp fn xs) = let (xs1,xs2) = span isAtom xs-                             in sep [ hsep (fn : map normalExpr xs1)-                                    , nest 2 (sep $ map normalExprWithParens xs2) ]-normalExpr (RetExpr e)    = e-normalExpr (RetAtom e)    = e-normalExpr (RetEmpty)     = empty- coChar :: Char -> DocH coChar = coercionColor . char @@ -87,12 +144,10 @@ coercionBindSymbol :: DocH coercionBindSymbol = coSymbol CoercionBindSymbol -coText :: String -> DocH-coText = coercionColor . text- coKeyword :: String -> DocH coKeyword = coText -- An alternative would be keyword. + tySymbol :: SpecialSymbol -> DocH tySymbol = typeColor . specialFont . char . renderSpecial @@ -105,270 +160,263 @@ typeArrow :: DocH typeArrow = tySymbol RightArrowSymbol -tyText :: String -> DocH-tyText = typeColor . text- ------------------------------------------------------------------------------------------------ --- | Pretty print a fragment of GHC Core using HERMIT's \"Clean\" pretty printer.-corePrettyH :: PrettyOptions -> PrettyH Core-corePrettyH opts = do-    dynFlags <- constT GHC.getDynFlags+hasType :: DocH -> DocH -> DocH+e `hasType` ty = e <+> tySymbol TypeOfSymbol <+> ty -    let hideNotes = True+------------------------------------------------------------------------------------------------ -        optional :: Maybe DocH -> (DocH -> DocH) -> DocH-        optional Nothing  _ = empty-        optional (Just d) k = k d+-- TODO: PrettyOptions should be in the context. -        ppVar :: GHC.Var -> DocH-        ppVar v = ppName (varColor v) (GHC.varName v)+-- | Pretty print a fragment of GHC Core using HERMIT's \"Clean\" pretty printer.+corePrettyH :: PrettyOptions -> PrettyH CoreTC+corePrettyH opts =+    let+        -- Use for any GHC structure+        ppSDoc :: GHC.Outputable a => PrettyH a+        ppSDoc = do dynFlags <- constT GHC.getDynFlags+                    arr (toDoc . GHC.showSDoc dynFlags . GHC.ppr)+            where toDoc s | any isSpace s = parens (text s)+                          | otherwise     = text s -        varColor :: GHC.Var -> SyntaxForColor+        ppVar :: Translate PrettyC HermitM Var RetExpr+        ppVar = readerT $ \ v -> GHC.varName ^>> ppName (varColor v)++        varColor :: Var -> SyntaxForColor         varColor var | GHC.isTyVar var = TypeColor                      | GHC.isCoVar var = CoercionColor                      | otherwise       = IdColor -        ppName :: SyntaxForColor -> GHC.Name -> DocH-        ppName color nm  = let name = GHC.occNameString (GHC.nameOccName nm)-                               doc  = markColor color (text name)-                            in if all isInfixId name-                                then ppParens doc-                                else doc--        ppLitTy :: TyLit -> DocH-        ppLitTy tylit = typeColor $ text $ case tylit of-                                             NumTyLit i  -> show i-                                             StrTyLit fs -> show fs--        ppTyCon :: GHC.TyCon -> DocH-        ppTyCon = ppName TypeColor . GHC.getName+        ppName :: SyntaxForColor -> Translate PrettyC HermitM GHC.Name RetExpr+        ppName color = (GHC.nameOccName >>> GHC.occNameString) ^>> arr (\ name -> let doc  = markColor color (text name)+                                                                                           -- TODO: is "isScriptInfixId" the right predicate to use here?+                                                                                   in RetAtom $ if all isScriptInfixIdChar name+                                                                                                 then ppParens doc+                                                                                                 else doc+                                                                       ) -        ppTyConCo :: GHC.TyCon -> DocH-        ppTyConCo = ppName CoercionColor . GHC.getName+        ppLitTy :: Translate PrettyC HermitM TyLit RetExpr+        ppLitTy = arr $ \case+                          NumTyLit i  -> RetAtom $ tyText (show i)+                          StrTyLit fs -> RetAtom $ tyText (show fs) -        ppTypeMode :: GHC.Type -> RetExpr-        ppTypeMode t = case po_exprTypes opts of-                         Omit     -> RetEmpty-                         Abstract -> RetAtom typeSymbol-                         _        -> ppCoreType t+        ppTyCon :: Translate PrettyC HermitM TyCon RetExpr+        ppTyCon = GHC.getName ^>> ppName TypeColor -        ppCoercionMode :: GHC.Coercion -> RetExpr-        ppCoercionMode co = case po_coercions opts of-                              Omit     -> RetEmpty-                              Abstract -> RetAtom coercionSymbol-                              Show     -> ppCoreCoercion co-                              Kind     -> RetExpr (coercionSymbol <+> specialSymbol TypeOfSymbol <+> ppCoKind co)+        ppTyConCo :: Translate PrettyC HermitM TyCon RetExpr+        ppTyConCo = GHC.getName ^>> ppName CoercionColor          -- binders are vars that is bound by lambda or case, etc.-        ppBinder :: GHC.Var -> Maybe DocH-        ppBinder var | GHC.isTyVar var = case po_exprTypes opts of-                                           Omit     -> Nothing-                                           Abstract -> Just typeBindSymbol-                                           _        -> Just (ppVar var)-                     | GHC.isCoVar var = case po_coercions opts of-                                           Omit     -> Nothing-                                           Abstract -> Just coercionBindSymbol-                                           Show     -> Just (ppVar var)-                                           Kind     -> Just $ ppParens (coercionBindSymbol <+> specialSymbol TypeOfSymbol <+> ppCoKind (GHC.CoVarCo var))-                                                       -- TODO: refactor this to be more systematic.  It should be possible to request type sigs for all type bindings.-                     | otherwise       = Just $ 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 dynFlags . GHC.ppr-            where toDoc s | any isSpace s = parens (text s)-                          | otherwise     = text s+        -- depending on the mode, they might not be displayed+        ppBinderMode :: Translate PrettyC HermitM Var RetExpr+        ppBinderMode = do v <- idR+                          if+                             | GHC.isTyVar v -> case po_exprTypes opts of+                                                                   Omit     -> return (RetEmpty)+                                                                   Abstract -> return (RetAtom typeBindSymbol)+                                                                   _        -> ppVar+                             | GHC.isCoVar v -> case po_coercions opts of+                                                                   Omit     -> return (RetEmpty)+                                                                   Abstract -> return (RetAtom coercionBindSymbol)+                                                                   Show     -> ppVar+                                                                   Kind     -> do pCoKind <- ppCoKind <<^ CoVarCo+                                                                                  return (RetExpr (coercionBindSymbol `hasType` pCoKind))+                                                                  -- TODO: refactor this to be more systematic.  It should be possible to request type sigs for all type bindings.+                             | otherwise       -> ppVar          ppModGuts :: PrettyH GHC.ModGuts-        ppModGuts =   arr $ \ m -> hang (keyword "module" <+> ppSDoc (GHC.mg_module m) <+> keyword "where") 2-                                   (vcat [ (optional (ppBinder v) (\b -> b <+> specialSymbol TypeOfSymbol <+> normalExpr (ppCoreType $ GHC.idType v)))-                                         | bnd <- GHC.mg_binds m-                                         , v <- case bnd of-                                                  GHC.NonRec f _ -> [f]-                                                  GHC.Rec bnds -> map fst bnds-                                       ])+        ppModGuts = do name <- ppSDoc <<^ GHC.mg_module+                       vtys <- mapT (ppVar &&& (ppType <<^ GHC.idType)) <<< modGutsT progIdsT (\ _ ids -> ids)+                       let defs = [ normalExpr v `hasType` ty | (v,ty) <- vtys ]+                       return $ hang (keyword "module" <+> name <+> keyword "where") 2 (vcat defs)          -- DocH is not a monoid.-        -- GHC uses a list, which we print here. The CoreProg type is our doing.         ppCoreProg :: PrettyH CoreProg-        ppCoreProg = translate $ \ c -> fmap vcat . sequenceA . map (apply ppCoreBind c) . progToBinds+        ppCoreProg = progConsT ppCoreBind ppCoreProg ($+$) <+ progNilT empty -        ppCoreExpr :: PrettyH GHC.CoreExpr-        ppCoreExpr = ppCoreExprR >>^ normalExpr+        ppCoreBind :: PrettyH GHC.CoreBind+        ppCoreBind =   (nonRecT idR (ppCoreExprR &&& ppTypeSig) (,) >>> ppDef)+                    <+ (do p <- rootPathT+                           recT (const ppCoreDef) (\ bnds -> attrP p (keyword "rec") <+> vcat bnds)+                       ) -        ppApp :: RetExpr -> RetExpr -> RetExpr-        ppApp e1 e2 = case e1 of-                        RetApp f xs   -> RetApp f (snocNonEmpty xs e2)-                        _             -> case e2 of -- if there are no (displayed) args then don't parenthesise-                                           RetEmpty -> e1-                                           args     -> RetApp (normalExprWithParens e1) (snocNonEmpty [] args) -        snocNonEmpty :: [RetExpr] -> RetExpr -> [RetExpr]-        snocNonEmpty xs RetEmpty = xs-        snocNonEmpty xs e        = xs ++ [e]+        ppCoreAlt :: PrettyH GHC.CoreAlt+        ppCoreAlt = do p <- rootPathT+                       altT (readerT $ \case+                                          GHC.DataAlt dcon -> return (GHC.dataConName dcon) >>> ppName IdColor >>^ parenExpr+                                          GHC.LitAlt lit   -> return lit >>> ppSDoc+                                          GHC.DEFAULT      -> return (symbol '_')+                            )+                            (\ _ -> ppBinderMode)+                            ppCoreExpr+                            (\ con vs e -> hang (con <+> hsep (map parenExpr vs) <+> attrP p (specialSymbol RightArrowSymbol)) 2 e) -        ppCoreExprR :: TranslateH GHC.CoreExpr RetExpr-        ppCoreExprR = ppCoreExprPR `ap` rootPathT+        ppCoreDef :: PrettyH CoreDef+        ppCoreDef = defT idR (ppCoreExprR &&& ppTypeSig) (,) >>> ppDef -        ppCoreExprPR :: TranslateH GHC.CoreExpr (Path -> RetExpr)-        ppCoreExprPR = lamT ppCoreExprR (\ v e _ -> case e of-                                                  RetLam vs e0  -> RetLam (consMaybe (ppBinder v) vs) e0-                                                  _             -> RetLam (consMaybe (ppBinder v) []) (normalExpr e))+        ppDef :: PrettyH (Var,(RetExpr,DocH))+        ppDef = do p          <- rootPathT+                   (v,(e,ty)) <- idR+                   case po_coercions opts of+                     Omit | GHC.isCoVar v  -> return empty+                     Kind | GHC.isCoVar v  -> return $ case po_exprTypes opts of+                                                         Show -> (coercionBindSymbol `hasType` ty) $+$ (coercionBindSymbol <+> symbol '=' <+> coercionSymbol)+                                                         _    -> coercionBindSymbol <+> attrP p (symbol '=') <+> normalExpr e+                     _                     -> do pv  <- normalExpr ^<< ppBinderMode <<< return v+                                                 let pre  = pv <+> symbol '='+                                                     body = case e of -- This is an ugly hack+                                                              RetLam p' vs pb e0 -> hang (pre <+> attrP p' (specialSymbol LambdaSymbol) <+> hsep vs <+> attrP pb (specialSymbol RightArrowSymbol)) 2 e0+                                                              _                 -> hang pre 2 (normalExpr e)+                                                 return $ case po_exprTypes opts of+                                                            Omit | GHC.isTyVar v -> empty+                                                            Show                 -> (pv `hasType` ty) $+$ body+                                                            _                    -> body -                   <+ letT ppCoreBind ppCoreExprR-                                       (\ bd e _ -> case e of-                                                  RetLet vs e0  -> RetLet (bd : vs) e0-                                                  _             -> RetLet [bd] (normalExpr e))++        ppCoreExpr :: PrettyH GHC.CoreExpr+        ppCoreExpr = ppCoreExprR >>^ normalExpr++        ppCoreExprR :: Translate PrettyC HermitM GHC.CoreExpr RetExpr+        ppCoreExprR = rootPathT >>= ppCoreExprPR+          where+            ppCoreExprPR :: PathH -> Translate PrettyC HermitM GHC.CoreExpr RetExpr+            ppCoreExprPR p =+                      lamT ppBinderMode ppCoreExprR (retLam p)++                   <+ letT (RetExpr <$> ppCoreBind) ppCoreExprR (retLet p)                    -- HACKs     {-                    <+ (acceptR (\ e -> case e of-                                         GHC.App (GHC.Var v) (GHC.Type t) | po_exprTypes opts == Abstract -> True+                                         GHC.App (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+                                         App (Type _) (Lam {}) | po_exprTypes opts == Omit -> True+                                         App (App (Var _) (Type _)) (Lam {}) | po_exprTypes opts == Omit -> True                                          _ -> False) >>>-                               (appT ppCoreExprR ppCoreExprR (\ (RetAtom e1) (RetLam vs e0) _ ->+                               (appT ppCoreExprR ppCoreExprR (\ (RetAtom e1) (RetLam p' vs pb e0) ->                                         RetExpr $ hang (e1 <+>                                                             symbol '(' <>-                                                            specialSymbol LambdaSymbol <+>+                                                            attrP p' (specialSymbol LambdaSymbol) <+>                                                             hsep vs <+>-                                                            specialSymbol RightArrowSymbol) 2 (e0 <> symbol ')')))--+                                                            attrP pb (specialSymbol RightArrowSymbol)) 2 (e0 <> symbol ')')))                       ) -                   <+ appT ppCoreExprR ppCoreExprR (\ e1 e2 _ -> ppApp e1 e2)+                   <+ appT ppCoreExprR ppCoreExprR retApp+                   <+ caseT ppCoreExpr ppVar ppTypeModeR (const ppCoreAlt) (\ s w ty alts -> RetExpr $ attrP p ((keyword "case" <+> s <+> keyword "of" <+> parenExpr w <+> parenExpr ty) $$ nest 2 (vcat alts))) -                   <+ caseT ppCoreExpr (const ppCoreAlt) (\ s b _ alts p -> RetExpr $ attrP p ((keyword "case" <+> s <+> keyword "of" <+> optional (ppBinder b) id) $$ nest 2 (vcat alts)))-                   <+ varT (\ i p -> RetAtom (attrP p $ ppVar i))-                   <+ litT (\ i p -> RetAtom (attrP p $ ppSDoc i))-                   <+ typeT (\ t p -> attrPAtomExpr p $ ppTypeMode t)-                   <+ coercionT (\ co p -> attrPAtomExpr p $ ppCoercionMode co)-                   <+ castT ppCoreExprR (\ e co p -> let e' = normalExprWithParensExceptApp e-                                                      in case ppCoercionMode co of-                                                           RetEmpty    -> e-                                                           RetAtom pCo -> RetExpr $ attrP p (e' <+> castSymbol <+> pCo)-                                                           pCo         -> RetExpr $ attrP p (e' <+> castSymbol <+> normalExprWithParensExceptApp pCo)-                                                     )-                   <+ tickT ppCoreExpr (\ i e p -> RetExpr $ attrP p (text "Tick" $$ nest 2 (ppSDoc i <+> parens e)))+                   <+ varT (attrPAtomExpr p <$> (do (c,i) <- exposeT+                                                    if (GHC.isLocalId i) && (i `notMember` boundVars c)+                                                      then GHC.varName ^>> ppName WarningColor+                                                      else ppVar+                                                )+                           ) -        attrPAtomExpr :: Path -> RetExpr -> RetExpr-        attrPAtomExpr p (RetAtom d) = RetAtom (attrP p d)-        attrPAtomExpr p (RetExpr d) = RetExpr (attrP p d)-        attrPAtomExpr _ e           = e+                   <+ litT ((RetAtom . attrP p) <$> ppSDoc)+                   <+ typeT (attrPAtomExpr p <$> ppTypeModeR)+                   <+ coercionT (attrPAtomExpr p <$> ppCoercionModeR)+                   <+ castT ppCoreExprR ppCoercionModeR (\ e co -> if isEmptyR co+                                                                    then e+                                                                    else RetExpr (parenExprExceptApp e <+> attrP p castSymbol <+> parenExprExceptApp co)+                                                        )+                   <+ tickT ppSDoc ppCoreExprR (\ tk e -> RetExpr $ attrP p (text "Tick" $$ nest 2 (tk <+> parenExpr e))) -        ppCoreType :: GHC.Type -> RetExpr-        ppCoreType (TyVarTy v)   = RetAtom (ppVar v)-        ppCoreType (LitTy tylit) = RetAtom (ppLitTy tylit)-        ppCoreType (AppTy t1 t2) = let e1 = ppCoreType t1-                                       e2 = ppCoreType t2-                                    in ppApp e1 e2-        ppCoreType (FunTy ty1 ty2) = RetExpr $ normalExprWithParensExceptApp (ppCoreType ty1) <+> typeArrow <+> normalExpr (ppCoreType ty2)-        ppCoreType (ForAllTy v ty) = RetExpr $ specialSymbol ForallSymbol <+> ppVar v <+> symbol '.' <+> normalExpr (ppCoreType ty)-        ppCoreType (TyConApp tyCon tys)-                    | GHC.isFunTyCon tyCon, [ty1,ty2] <- tys = ppCoreType (FunTy ty1 ty2)-                    | tyCon == GHC.listTyCon = RetAtom $ tyText "[" <> (case map (normalExpr . ppCoreType) tys of-                                                                            []  -> empty-                                                                            t:_ -> t                     ) <> tyText "]"-                    | GHC.isTupleTyCon tyCon = case map (normalExpr . ppCoreType) tys of-                                                [] -> RetAtom $ tyText "()"-                                                ds -> RetAtom $ tyText "(" <> (foldr1 (\d r -> d <> tyText "," <+> r) ds) <> tyText ")"-                    | otherwise              = RetApp (ppTyCon tyCon) (map ppCoreType tys)+        -------------------------------------------------------------------- -        ppCoreCoercion :: GHC.Coercion -> RetExpr-        ppCoreCoercion (GHC.Refl t)            = let refl = coKeyword "refl"-                                                  in case po_exprTypes opts of-                                                       Omit -> RetAtom refl-                                                       _    -> RetExpr (refl <+> normalExprWithParens (ppTypeMode t))-        ppCoreCoercion (GHC.CoVarCo v)         = RetAtom (ppVar v)-        ppCoreCoercion (GHC.SymCo co)          = RetExpr (coKeyword "sym" <+> normalExprWithParens (ppCoreCoercion co))-        ppCoreCoercion (GHC.ForAllCo v co)     = let e = ppCoreCoercion co-                                                  in case po_exprTypes opts of-                                                       Omit -> e-                                                       _    -> RetExpr (specialSymbol ForallSymbol <+> optional (ppBinder v) (\d -> d <+> symbol '.' <+> normalExprWithParensExceptApp e))-        ppCoreCoercion (GHC.TransCo co1 co2)   = RetExpr (normalExprWithParensExceptApp (ppCoreCoercion co1) <+> coChar ';' <+> normalExprWithParensExceptApp (ppCoreCoercion co2))-        ppCoreCoercion (GHC.UnsafeCo t1 t2)    = RetExpr (ppTypePairCoercion t1 t2)-        ppCoreCoercion (GHC.NthCo n co)        = RetExpr (coKeyword "nth" <+> coText (show n) <+> normalExprWithParens (ppCoreCoercion co))-        ppCoreCoercion (GHC.InstCo co t)       = let e = ppCoreCoercion co-                                                  in case po_exprTypes opts of-                                                       Omit -> e-                                                       _    -> RetExpr (normalExprWithParensExceptApp e <+> coChar '@' <+> normalExprWithParensExceptApp (ppTypeMode t))-        ppCoreCoercion (GHC.TyConAppCo tc cs)  = RetApp (ppTyConCo tc) (map ppCoreCoercion cs)-        ppCoreCoercion (GHC.AppCo co1 co2)     = let e1 = ppCoreCoercion co1-                                                     e2 = ppCoreCoercion co2-                                                  in ppApp e1 e2-#if __GLASGOW_HASKELL__ > 706-        -- TODO: Figure out how to properly pp new branched Axioms and Left/Right Coercions-        ppCoreCoercion (GHC.AxiomInstCo ax idx cs) = RetApp (coercionColor $ ppSDoc ax) (RetAtom (ppSDoc idx) : map ppCoreCoercion cs)-        ppCoreCoercion (GHC.LRCo lr co) = RetApp (coercionColor $ ppSDoc lr) [ppCoreCoercion co]-#else-        ppCoreCoercion (GHC.AxiomInstCo ax cs) = RetApp (coercionColor $ ppSDoc ax) (map ppCoreCoercion cs) -- TODO: add pretty printer for Coercion Axioms-#endif+        ppType :: PrettyH Type+        ppType = ppTypeR >>^ normalExpr -        ppTypePairCoercion :: Type -> Type -> DocH-        ppTypePairCoercion t1 t2 = normalExprWithParensExceptApp (ppTypeMode t1) <+> coChar '~' <+> normalExprWithParensExceptApp (ppTypeMode t2)+        ppTypeModeR :: Translate PrettyC HermitM Type RetExpr+        ppTypeModeR = case po_exprTypes opts of+                        Omit     -> return RetEmpty+                        Abstract -> return (RetAtom typeSymbol)+                        _        -> ppTypeR -        ppCoKind :: GHC.Coercion -> DocH-        ppCoKind = uncurry ppTypePairCoercion . unPair . GHC.coercionKind+        ppTypeR :: Translate PrettyC HermitM Type RetExpr+        ppTypeR = rootPathT >>= ppTypePR+          where+            ppTypePR :: PathH -> Translate PrettyC HermitM Type RetExpr+            ppTypePR p =+                   tyVarT (attrPAtomExpr p <$> ppVar)+                <+ litTyT (attrPAtomExpr p <$> ppLitTy)+                <+ appTyT ppTypeR ppTypeR retApp+                <+ funTyT ppTypeR ppTypeR retArrowType+                <+ forAllTyT ppVar ppTypeR (retForAll p ForAllTy_Body)+                <+ tyConAppT (ppTyCon &&& idR) (const ppTypeR)+                     (\ (pCon,tyCon) tys -> if | GHC.isFunTyCon tyCon && length tys == 2 -> let [ty1,ty2] = tys in retArrowType ty1 ty2+                                               | tyCon == GHC.listTyCon -> RetAtom $ attrP p $ tyText "[" <> (case tys of+                                                                                                                []  -> empty+                                                                                                                t:_ -> normalExpr t)+                                                                                                          <> tyText "]"+                                               | GHC.isTupleTyCon tyCon -> RetAtom $ attrP p $ tyText "(" <> (if null tys+                                                                                                                then empty+                                                                                                                else foldr1 (\ ty r -> ty <> tyText "," <+> r) (map normalExpr tys)+                                                                                                             )+                                                                                                          <> tyText ")"+                                               | otherwise              -> retApps (attrPAtomExpr p pCon) tys+                     ) -        ppCoreTypeSig :: PrettyH GHC.CoreExpr-        ppCoreTypeSig = arr (\case-                                GHC.Coercion c -> ppCoKind c-                                e              -> normalExpr $ ppCoreType $ GHC.exprType e)+        -------------------------------------------------------------------- -        ppCoreBind :: PrettyH GHC.CoreBind-        ppCoreBind = nonRecT (ppCoreExprR &&& ppCoreTypeSig) ppDefFun-                  <+ recT (const ppCoreDef) (\ bnds -> keyword "rec" <+> vcat bnds)+        ppCoercion :: PrettyH Coercion+        ppCoercion = ppCoercionR >>^ normalExpr -        ppCoreAlt :: PrettyH GHC.CoreAlt-        ppCoreAlt = altT ppCoreExpr $ \ con vs e -> let ppVars = if null vs-                                                                  then specialSymbol RightArrowSymbol-                                                                  else hsep (map (flip optional id . ppBinder) vs) <+> specialSymbol RightArrowSymbol-                                                     in case con of-                      GHC.DataAlt dcon -> hang (ppName IdColor (GHC.dataConName dcon) <+> ppVars) 2 e-                      GHC.LitAlt lit   -> hang (ppSDoc lit <+> ppVars) 2 e-                      GHC.DEFAULT      -> symbol '_' <+> ppVars <+> e+        ppCoercionModeR :: Translate PrettyC HermitM Coercion RetExpr+        ppCoercionModeR = case po_coercions opts of+                            Omit     -> return RetEmpty+                            Abstract -> return (RetAtom coercionSymbol)+                            Show     -> ppCoercionR+                            Kind     -> ppCoKind >>^ (\ k -> RetExpr (coercionSymbol `hasType` k)) -        -- GHC uses a tuple, which we print here. The CoreDef type is our doing.-        ppCoreDef :: PrettyH CoreDef-        ppCoreDef = defT (ppCoreExprR &&& ppCoreTypeSig) ppDefFun+        ppCoercionR :: Translate PrettyC HermitM Coercion RetExpr+        ppCoercionR = rootPathT >>= ppCoercionPR+          where+            ppCoercionPR :: PathH -> Translate PrettyC HermitM Coercion RetExpr+            ppCoercionPR p =+                           reflT (ppTypeModeR >>^ \ ty -> RetAtom $ attrP p $ if isEmptyR ty then coText "refl" else coText "<" <> normalExpr ty <> coText ">")+                        <+ coVarCoT (attrPAtomExpr p <$> ppVar)+                        <+ symCoT (ppCoercionR >>^ \ co -> RetExpr (attrP p (coKeyword "sym") <+> parenExpr co))+                        <+ forAllCoT ppBinderMode ppCoercionR (retForAll p ForAllCo_Body)+                        <+ transCoT ppCoercionR ppCoercionR (\ co1 co2 -> RetExpr (parenExprExceptApp co1 <+> attrP p (coChar ';') <+> parenExprExceptApp co2))+                        <+ unsafeCoT ppTypeModeR ppTypeModeR (\ ty1 ty2 -> (if isEmptyR ty1 && isEmptyR ty2 then RetAtom else RetExpr)+                                                                           (attrP p (coKeyword "unsafe") <+> parenExpr ty1 <+> parenExpr ty2)+                                                             )+                        <+ nthCoT idR ppCoercionR (\ n co -> RetExpr (attrP p (coKeyword "nth") <+> attrP p (coText $ show n) <+> parenExpr co))+                        <+ instCoT ppCoercionR ppTypeModeR (\ co ty -> if isEmptyR ty+                                                                         then RetExpr (attrP p (coText "inst") <+> parenExpr co)+                                                                         else RetExpr (parenExprExceptApp co <+> attrP p (coChar '@') <+> parenExprExceptApp ty)+                                                           )+                        <+ tyConAppCoT (attrPAtomExpr p <$> ppTyConCo) (const ppCoercionR) retApps+                        <+ appCoT ppCoercionR ppCoercionR retApp+#if __GLASGOW_HASKELL__ > 706+        -- TODO: Figure out how to properly pp new branched Axioms and Left/Right Coercions+                        <+ axiomInstCoT (coAxiomName ^>> ppName CoercionColor) (RetAtom <$> ppSDoc) (const ppCoercionR) (\ ax idx coes -> RetExpr (attrP p (coText "axiomInst") <+> attrP p (parenExpr ax) <+> attrP p (parenExpr idx) <+> sep (map parenExpr coes)))+                        <+ lrCoT (coercionColor <$> ppSDoc) ppCoercionR (\ lr co -> RetExpr (attrP p lr <+> parenExpr co))+#else+                        <+ axiomInstCoT (coAxiomName ^>> ppName CoercionColor) (const ppCoercionR) (\ ax coes -> RetExpr (attrP p (coText "axiomInst") <+> attrP p (parenExpr ax) <+> sep (map parenExpr coes)))+#endif -        ppDefFun :: GHC.Var -> (RetExpr, DocH) -> DocH-        ppDefFun v (e,ty) = case po_exprTypes opts of-                              Show     -> if GHC.isCoVar v-                                           then let coTySig = specialSymbol TypeOfSymbol <+> ty-                                                 in case po_coercions opts of-                                                      Omit     -> empty-                                                      Show     -> (ppVar v <+> coTySig) $+$ body-                                                      _        -> (coercionBindSymbol <+> coTySig)-                                           else (ppVar v <+> specialSymbol TypeOfSymbol <+> ty) $+$ body-                              Omit     -> if GHC.isTyVar v-                                           then empty-                                           else body-                              _    -> body-            where-                pre = optional (ppBinder v) (<+> symbol '=')-                body = case e of-                        RetLam vs e0 -> hang (pre <+> specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e0-                        _ -> hang pre 2 (normalExpr e)+        ppCoKind :: PrettyH Coercion+        ppCoKind = (GHC.coercionKind >>> unPair) ^>> (ppTypeModeR *** ppTypeModeR) >>^ ( \(ty1,ty2) -> parenExprExceptApp ty1 <+> coText "~#" <+> parenExprExceptApp ty2) -    promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)-     <+ promoteT (ppCoreProg :: PrettyH CoreProg)-     <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)-     <+ promoteT (ppCoreDef  :: PrettyH CoreDef)-     <+ promoteT (ppModGuts  :: PrettyH GHC.ModGuts)-     <+ promoteT (ppCoreAlt  :: PrettyH GHC.CoreAlt)+        -------------------------------------------------------------------- -------------------------------------------------------------------------------------------------+        ppTypeSig :: PrettyH GHC.CoreExpr+        ppTypeSig = coercionT ppCoKind <+ (GHC.exprType ^>> ppType) -consMaybe :: Maybe a -> [a] -> [a]-consMaybe Nothing  as = as-consMaybe (Just a) as = a : as+        --------------------------------------------------------------------++    in  promoteT (ppCoreExpr     :: PrettyH GHC.CoreExpr)+     <+ promoteT (ppCoreProg     :: PrettyH CoreProg)+     <+ promoteT (ppCoreBind     :: PrettyH GHC.CoreBind)+     <+ promoteT (ppCoreDef      :: PrettyH CoreDef)+     <+ promoteT (ppModGuts      :: PrettyH GHC.ModGuts)+     <+ promoteT (ppCoreAlt      :: PrettyH GHC.CoreAlt)+     <+ promoteT (ppType         :: PrettyH GHC.Type)+     <+ promoteT (ppCoercion     :: PrettyH Coercion)  ------------------------------------------------------------------------------------------------

@@ -1,20 +1,62 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeFamilies, InstanceSigs,+             MultiParamTypeClasses, RankNTypes, FlexibleContexts #-} -module Language.HERMIT.PrettyPrinter.Common where+module Language.HERMIT.PrettyPrinter.Common+    ( -- * Documents+      DocH+    , Attr(..)+    , attrP+      -- ** Colors+    , coText+    , tyText+    , coercionColor+    , idColor+    , keywordColor+    , markColor+    , typeColor+    , ShowOption(..)+    , specialFont+    , SpecialSymbol(..)+    , SyntaxForColor(..)+      -- * Renderers+    , coreRenders+    , renderCode+    , RenderCode(..)+    , renderSpecial+    , RenderSpecial+    , Unicode(..)+      -- * Pretty Printer Traversals+    , PrettyH+    , liftPrettyH+    , PrettyC -- intentionally abstract+    , initPrettyC+    , liftPrettyC+    , TranslateDocH(..)+    , TranslateCoreTCDocHBox(..)+      -- * Pretty Printer Options+    , PrettyOptions(..)+    , updateTypeShowOption+    , updateCoShowOption+      -- * Utilities+    , hlist+    , vlist+    ) where -import Control.Arrow hiding ((<+>))+import GhcPlugins hiding (($$), (<>), (<+>))  import Data.Char import Data.Default import Data.Monoid hiding ((<>)) import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S import Data.Typeable -import GhcPlugins hiding ((<>),(<+>),($$))-+import Language.HERMIT.Context import Language.HERMIT.Core import Language.HERMIT.External import Language.HERMIT.Kure+import Language.HERMIT.Monad  import System.IO @@ -26,12 +68,12 @@ -- newtype wrapper for proper instance selection newtype TranslateDocH a = TranslateDocH { unTranslateDocH :: PrettyH a -> TranslateH a DocH } -data TranslateCoreDocHBox = TranslateCoreDocHBox (TranslateDocH Core) deriving Typeable+data TranslateCoreTCDocHBox = TranslateCoreTCDocHBox (TranslateDocH CoreTC) deriving Typeable -instance Extern (TranslateDocH Core) where-    type Box (TranslateDocH Core) = TranslateCoreDocHBox-    box = TranslateCoreDocHBox-    unbox (TranslateCoreDocHBox i) = i+instance Extern (TranslateDocH CoreTC) where+    type Box (TranslateDocH CoreTC) = TranslateCoreTCDocHBox+    box = TranslateCoreTCDocHBox+    unbox (TranslateCoreTCDocHBox i) = i  -- These are the zero-width marks on the document data HermitMark@@ -40,7 +82,7 @@     deriving Show  -- These are the attributes-data Attr = PathAttr Path+data Attr = PathAttr PathH           | Color SyntaxForColor           | SpecialFont     deriving Show@@ -52,6 +94,7 @@         | CoercionColor         | TypeColor         | LitColor+        | WarningColor          -- highlight problems like unbound variables     deriving Show  attr :: Attr -> DocH -> DocH@@ -61,9 +104,15 @@ -- The problem is that attributes span over multiple lines, -- messing up the latex output -attrP :: Path -> DocH -> DocH+attrP :: PathH -> DocH -> DocH attrP _ doc = doc -- attr . PathAttr +tyText :: String -> DocH+tyText = typeColor . PP.text++coText :: String -> DocH+coText = coercionColor . PP.text+ idColor :: DocH -> DocH idColor = markColor IdColor @@ -73,7 +122,6 @@ coercionColor :: DocH -> DocH coercionColor = markColor CoercionColor - keywordColor :: DocH -> DocH keywordColor = markColor KeywordColor @@ -83,18 +131,68 @@ specialFont :: DocH -> DocH specialFont = attr SpecialFont +type PrettyH a = Translate PrettyC HermitM a DocH+-- TODO: change monads to something more restricted? -type PrettyH a = TranslateH a DocH+-- | Context for PrettyH translations.+data PrettyC = PrettyC { prettyC_path :: AbsolutePath Crumb+                       , prettyC_vars :: Set Var}+                       -- TODO: Add PrettyOptions to PrettyC +------------------------------------------------------------------------++instance ReadPath PrettyC Crumb where+  absPath :: PrettyC -> AbsolutePath Crumb+  absPath = prettyC_path+  {-# INLINE absPath #-}++instance ExtendPath PrettyC Crumb where+  (@@) :: PrettyC -> Crumb -> PrettyC+  c @@ n = c { prettyC_path = prettyC_path c @@ n }+  {-# INLINE (@@) #-}++instance AddBindings PrettyC where+  addHermitBindings :: [(Var,HermitBindingSite)] -> PrettyC -> PrettyC+  addHermitBindings vbs c = c { prettyC_vars = foldr S.insert (prettyC_vars c) (map fst vbs) }+                            -- let vhbs = [ (v, (0,b)) | (v,b) <- vbs ] -- TODO: do we care about depth?+                            --  in c { prettyC_bindings = M.fromList vhbs `M.union` prettyC_bindings c }+  {-# INLINE addHermitBindings #-}++-- instance ReadBindings PrettyC where+--   hermitDepth :: PrettyC -> BindingDepth+--   hermitDepth = prettyC_depth++--   hermitBindings :: PrettyC -> M.Map Var HermitBinding+--   hermitBindings = prettyC_bindings+--   {-# INLINE hermitBindings #-}++instance BoundVars PrettyC where+  boundVars :: PrettyC -> Set Var+  boundVars = prettyC_vars++------------------------------------------------------------------------++liftPrettyH :: (ReadBindings c, ReadPath c Crumb) => PrettyH a -> Translate c HermitM a DocH+liftPrettyH pp = translate $ \ c -> apply pp (liftPrettyC c)++liftPrettyC :: (ReadBindings c, ReadPath c Crumb) => c -> PrettyC+liftPrettyC c = PrettyC { prettyC_path  = absPath c+                        , prettyC_vars  = boundVars c }++initPrettyC :: PrettyC+initPrettyC = PrettyC { prettyC_path = mempty+                      , prettyC_vars = S.empty+                      }+ -- 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_coercions       :: ShowOption      -- Do you hide coercions?-        , 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_fullyQualified  :: Bool            -- ^ Do you show fully qualified names?+        , po_exprTypes       :: ShowOption      -- ^ Do you hide types, and type arguments, as <>?+        , po_coercions       :: ShowOption      -- ^ Do you hide coercions?+        , po_typesForBinders :: ShowOption      -- ^ Do you give the types for all bindings?+        , po_highlight       :: Maybe PathH     -- ^ 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@@ -234,23 +332,13 @@   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-        }+    rStart :: a+    rStart = mempty+    rEnd :: a+    rEnd = mempty ---stackToPrettyState :: [Attr] -> PrettyState---stackToPrettyState =+    rDoHighlight :: Bool -> [Attr]           -> a+    rPutStr      :: String -> a  renderCode :: RenderCode a => PrettyOptions -> DocH -> a renderCode opts doc = rStart `mappend` PP.fullRender PP.PageMode w rib marker (\ _ -> rEnd) doc []@@ -259,7 +347,7 @@           w = po_width opts           rib = po_ribbon opts -          marker ::  RenderCode a => PP.TextDetails HermitMark -> ([Attr] -> a) -> ([Attr]-> a)+          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@@ -282,33 +370,6 @@ -- 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 (ppProg   :: PrettyH CoreProg)-        <+ promoteT (ppH      :: PrettyH CoreBind)-        <+ promoteT (ppDef    :: PrettyH CoreDef)-        <+ promoteT (ppH      :: PrettyH CoreExpr)-        <+ promoteT (ppH      :: PrettyH CoreAlt)-  where--        ppH :: (Outputable a) => PrettyH a-        ppH = contextfreeT $ \e -> do-            dynFlags <- getDynFlags-            return $ PP.text $ showSDoc dynFlags $ ppr e--        ppModule :: PrettyH ModGuts-        ppModule = mg_module ^>> ppH--        ppProg :: PrettyH CoreProg-        ppProg = progToBinds ^>> ppH--        ppDef :: PrettyH CoreDef-        ppDef = defToIdExpr ^>> ppH----        arr (PP.text . ppr . mg_module)- --- Moving the renders back into the core hermit  -------------------------------------------------------------------------------@@ -329,8 +390,8 @@                         hPutStrLn h pretty)         ] -latexVerbatim :: String -> LaTeX -> LaTeX-latexVerbatim str (LaTeX v) = LaTeX (str ++ v)+-- latexVerbatim :: String -> LaTeX -> LaTeX+-- latexVerbatim str (LaTeX v) = LaTeX (str ++ v)  latexToString :: LaTeX -> String latexToString (LaTeX orig) = unlines $ map trunkSpaces $ lines orig where@@ -350,6 +411,7 @@                         CoercionColor -> "\\color{hermit:coercion}"      -- yellow                         TypeColor     -> "\\color{hermit:type}"          -- green                         LitColor      -> "\\color{hermit:lit}"           -- cyan+                        WarningColor  -> "\\color{hermit:warning}"       -- black on yellow         rDoHighlight o (_:rest) = rDoHighlight o rest          rEnd = LaTeX "\n" -- \\end{Verbatim}"@@ -374,6 +436,7 @@                         CoercionColor -> "<span class=\"hermit-coercion\">"      -- yellow                         TypeColor     -> "<span class=\"hermit-type\">"          -- green                         LitColor      -> "<span class=\"hermit-lit\">"           -- cyan+                        WarningColor  -> "<span class=\"hermit-warning\">"       -- black on yellow         rDoHighlight o (_:rest) = rDoHighlight o rest         rEnd = HTML "\n" 

@@ -19,7 +19,7 @@ ---------------------------------------------------------------------------  -- | This pretty printer is just a reflection of GHC's standard pretty printer.-corePrettyH :: PrettyOptions -> PrettyH Core+corePrettyH :: PrettyOptions -> PrettyH CoreTC corePrettyH opts = do     dynFlags <- constT GHC.getDynFlags @@ -48,13 +48,21 @@         ppCoreAlt = arr ppSDoc          ppCoreDef :: PrettyH CoreDef-        ppCoreDef = defT ppCoreExpr $ \ i e -> ppSDoc i <> text "=" <> e+        ppCoreDef = defT (arr ppSDoc) ppCoreExpr $ \ i e -> i <+> text "=" <+> e +        ppType :: PrettyH GHC.Type+        ppType = arr ppSDoc++        ppCoercion :: PrettyH GHC.Coercion+        ppCoercion = arr ppSDoc+     promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)      <+ promoteT (ppCoreProg :: PrettyH CoreProg)      <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)      <+ promoteT (ppCoreDef  :: PrettyH CoreDef)      <+ promoteT (ppModGuts  :: PrettyH GHC.ModGuts)      <+ promoteT (ppCoreAlt  :: PrettyH GHC.CoreAlt)+     <+ promoteT (ppType     :: PrettyH GHC.Type)+     <+ promoteT (ppCoercion :: PrettyH GHC.Coercion)  ---------------------------------------------------------------------------

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} module Language.HERMIT.Primitive.AlphaConversion        ( -- * Alpha-Renaming and Shadowing          externals@@ -25,14 +25,16 @@  import GhcPlugins hiding (empty) -import Control.Applicative import Control.Arrow+import Control.Monad (liftM, liftM2) import Data.Char (isDigit)-import Data.List (nub) import Data.Maybe (fromMaybe, listToMaybe) import Data.Monoid+import Data.Set (Set, union, unions, member, notMember, toList, fromList)+import qualified Data.Set as S  import Language.HERMIT.Core+import Language.HERMIT.Context import Language.HERMIT.Monad import Language.HERMIT.Kure import Language.HERMIT.External@@ -49,33 +51,33 @@ -- | Externals for alpha-renaming. externals :: [External] externals = map (.+ Deep)-         [  external "alpha" alpha+         [  external "alpha" (alpha :: RewriteH Core)                [ "Renames the bound variables at the current node."]-         ,  external "alpha-lam" (promoteExprR . alphaLam . Just)+         ,  external "alpha-lam" (promoteExprR . alphaLam . Just :: TH.Name -> RewriteH Core)                [ "Renames the bound variable in a Lambda expression to the given name."]-         ,  external "alpha-lam" (promoteExprR $ alphaLam Nothing)+         ,  external "alpha-lam" (promoteExprR  (alphaLam Nothing) :: RewriteH Core)                [ "Renames the bound variable in a Lambda expression."]-         ,  external "alpha-case-binder" (promoteExprR . alphaCaseBinder . Just)+         ,  external "alpha-case-binder" (promoteExprR . alphaCaseBinder . Just :: TH.Name -> RewriteH Core)                [ "Renames the binder in a Case expression to the given name."]-         ,  external "alpha-case-binder" (promoteExprR $ alphaCaseBinder Nothing)+         ,  external "alpha-case-binder" (promoteExprR (alphaCaseBinder Nothing) :: RewriteH Core)                [ "Renames the binder in a Case expression."]-         ,  external "alpha-alt" (promoteAltR alphaAlt)+         ,  external "alpha-alt" (promoteAltR alphaAlt :: RewriteH Core)                [ "Renames all binders in a Case alternative."]-         ,  external "alpha-alt" (promoteAltR . alphaAltWith)+         ,  external "alpha-alt" (promoteAltR . alphaAltWith :: [TH.Name] -> RewriteH Core)                [ "Renames all binders in a Case alternative using the user-provided list of new names."]-         ,  external "alpha-case" (promoteExprR alphaCase)+         ,  external "alpha-case" (promoteExprR alphaCase :: RewriteH Core)                [ "Renames all binders in a Case alternative."]-         ,  external "alpha-let" (promoteExprR . alphaLetWith)+         ,  external "alpha-let" (promoteExprR . alphaLetWith :: [TH.Name] -> RewriteH Core)                [ "Renames the bound variables in a Let expression using a list of suggested names."]-         ,  external "alpha-let" (promoteExprR alphaLet)+         ,  external "alpha-let" (promoteExprR alphaLet :: RewriteH Core)                [ "Renames the bound variables in a Let expression."]-         ,  external "alpha-top" (promoteProgR . alphaConsWith)+         ,  external "alpha-top" (promoteProgR . alphaConsWith :: [TH.Name] -> RewriteH Core)                [ "Renames the bound identifiers in the top-level binding group at the head of the program using a list of suggested names."]          -- ,  external "alpha-top" (promoteProgR alphaCons)          --       [ "Renames the bound identifiers in the top-level binding at the head of the program."]          -- ,  external "alpha-program" (promoteProgR alphaProg)          --       [ "Renames identifiers bound at the top-level of the program."]-         ,  external "unshadow" unshadow+         ,  external "unshadow" (unshadow :: RewriteH Core)                 [ "Rename local variables with manifestly unique names (x, x0, x1, ...)."]          ] @@ -93,27 +95,27 @@ -- 2.  Any bound variables in context.  -- | List all visible identifiers (in the expression or the context).-visibleVarsT :: TranslateH CoreExpr [Var]-visibleVarsT = boundVarsT `mappend` freeVarsT+visibleVarsT :: (BoundVars c, Monad m) => Translate c m CoreExpr (Set Var)+visibleVarsT = liftM2 union boundVarsT freeVarsT  -- | If a name is provided replace the string with that, --   otherwise modify the string making sure to /not/ clash with any visible variables.-freshNameGenT :: Maybe TH.Name -> TranslateH CoreExpr (String -> String)-freshNameGenT mn = freshNameGenAvoiding mn <$> visibleVarsT+freshNameGenT :: (BoundVars c, Monad m) => Maybe TH.Name -> Translate c m CoreExpr (String -> String)+freshNameGenT mn = freshNameGenAvoiding mn `liftM` visibleVarsT  -- | Use the optional argument if given, otherwise generate a new name avoiding clashes with the list of variables.-freshNameGenAvoiding :: Maybe TH.Name -> [Var] -> (String -> String)+freshNameGenAvoiding :: Maybe TH.Name -> Set Var -> (String -> String) freshNameGenAvoiding mn vs str = maybe (inventNames vs str) TH.nameBase mn  -- | Invent a new String based on the old one, but avoiding clashing with the given list of identifiers.-inventNames :: [Var] -> String -> String+inventNames :: Set Var -> String -> String inventNames curr old = head                      [ nm                      | nm <- old : [ base ++ show uq | uq <- [start ..] :: [Int] ]-                     , nm `notElem` names+                     , nm `notMember` names                      ]    where-           names = nub (map getOccString curr)+           names = S.map getOccString curr            nums = reverse $ takeWhile isDigit (reverse old)            baseLeng = length $ drop (length nums) old            base = take baseLeng old@@ -122,34 +124,34 @@                      _       -> 0  --- | Remove all variables from the first list that shadow a variable in the second list.-shadowedBy :: [Var] -> [Var] -> [Var]-shadowedBy vs fvs = filter (\ v -> getOccString v `elem` map getOccString fvs) vs+-- | Remove all variables from the first set that shadow a variable in the second set.+shadowedBy :: Set Var -> Set Var -> Set Var+shadowedBy vs fvs = S.filter (\ v -> getOccString v `member` S.map getOccString fvs) vs  -- | Lifted version of 'shadowedBy'. --   Additionally, it fails if no shadows are found.-shadowedByT :: TranslateH a [Var] -> TranslateH a [Var] -> TranslateH a [Var]-shadowedByT t1 t2 = setFailMsg "No shadows detected." $ (shadowedBy <$> t1 <*> t2) >>> acceptR (not . null)+shadowedByT :: MonadCatch m => Translate c m a (Set Var) -> Translate c m a (Set Var) -> Translate c m a (Set Var)+shadowedByT t1 t2 = setFailMsg "No shadows detected." $ (liftM2 shadowedBy t1 t2) >>> acceptR (not . S.null)  -- | Rename local variables with manifestly unique names (x, x0, x1, ...). --   Does not rename top-level definitions.-unshadow :: RewriteH Core+unshadow :: forall c. (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core unshadow = setFailMsg "No shadows to eliminate." $            anytdR (promoteExprR unshadowExpr <+ promoteAltR unshadowAlt)    where-    unshadowExpr :: RewriteH CoreExpr-    unshadowExpr = do vs <- shadowedByT (boundVarsT `mappend` freeVarsT) (letVarsT <+ fmap return (caseWildIdT <+ lamVarT))-                      alphaLam Nothing <+ alphaLetVars vs <+ alphaCaseBinder Nothing+    unshadowExpr :: Rewrite c HermitM CoreExpr+    unshadowExpr = do vs <- shadowedByT (liftM2 union boundVarsT freeVarsT) (liftM fromList (letVarsT <+ fmap return (caseWildIdT <+ lamVarT)))+                      alphaLam Nothing <+ alphaLetVars (toList vs) <+ alphaCaseBinder Nothing -    unshadowAlt :: RewriteH CoreAlt-    unshadowAlt = shadowedByT altVarsT (boundVarsT `mappend` altFreeVarsT) >>= alphaAltVars+    unshadowAlt :: Rewrite c HermitM CoreAlt+    unshadowAlt = shadowedByT (liftM fromList altVarsT) (liftM2 union boundVarsT altFreeVarsT) >>= (alphaAltVars . toList)  -----------------------------------------------------------------------  -- | Replace all occurrences of a specified variable. --   Arguments are the variable to replace and the replacement variable, respectively.-replaceVarR :: (Injection a Core) => Var -> Var -> RewriteH a+replaceVarR :: (ExtendPath c Crumb, AddBindings c, Injection a Core, MonadCatch m) => Var -> Var -> Rewrite c m a replaceVarR v v' = extractR $ tryR $ substR v $ varToCoreExpr v'  -- | Given a variable to replace, and a replacement, produce a 'Var' @->@ 'Var' function that@@ -167,142 +169,139 @@ -----------------------------------------------------------------------  -- | Alpha rename a lambda binder.  Optionally takes a suggested new name.-alphaLam :: Maybe TH.Name -> RewriteH CoreExpr+alphaLam :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr alphaLam mn = setFailMsg (wrongFormForAlpha "Lam v e") $-              do (v, nameModifier) <- lamT (freshNameGenT mn) (,)+              do (v, nameModifier) <- lamT idR (freshNameGenT mn) (,)                  v' <- constT (cloneVarH nameModifier v)-                 lamT (replaceVarR v v') (\ _ -> Lam v')+                 lamAnyR (arr $ replaceVar v v') (replaceVarR v v')  -----------------------------------------------------------------------  -- | Alpha rename a case binder.  Optionally takes a suggested new name.-alphaCaseBinder :: Maybe TH.Name -> RewriteH CoreExpr+alphaCaseBinder :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr alphaCaseBinder mn = setFailMsg (wrongFormForAlpha "Case e v ty alts") $                      do Case _ v _ _ <- idR                         nameModifier <- freshNameGenT mn                         v' <- constT (cloneVarH nameModifier v)-                        caseT idR (\ _ -> replaceVarR v v') (\ e _ t alts -> Case e v' t alts)+                        caseAnyR idR (return v') idR (\ _ -> replaceVarR v v')  -----------------------------------------------------------------------  -- | Rename the specified variable in a case alternative.  Optionally takes a suggested new name.-alphaAltVar :: Maybe TH.Name -> Var -> RewriteH CoreAlt-alphaAltVar mn v = do nameModifier <- altT (freshNameGenT mn) (\ _ _ nameGen -> nameGen)+alphaAltVar :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Var -> Rewrite c HermitM CoreAlt+alphaAltVar mn v = do nameModifier <- altT idR (\ _ -> idR) (freshNameGenT mn) (\ _ _ nameGen -> nameGen)                       v' <- constT (cloneVarH nameModifier v)-                      altT (replaceVarR v v') (\ con vs e -> (con, map (replaceVar v v') vs, e))+                      altAnyR (fail "") (\ _ -> arr (replaceVar v v')) (replaceVarR v v')  -- | Rename the specified variables in a case alternative, using the suggested names where provided.-alphaAltVarsWith :: [(Maybe TH.Name,Var)] -> RewriteH CoreAlt+alphaAltVarsWith :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Var)] -> Rewrite c HermitM CoreAlt alphaAltVarsWith = andR . map (uncurry alphaAltVar)  -- | Rename the variables bound in a case alternative with the given list of suggested names.-alphaAltWith :: [TH.Name] -> RewriteH CoreAlt+alphaAltWith :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreAlt alphaAltWith ns = do vs <- altVarsT                      alphaAltVarsWith $ zip (map Just ns) vs  -- | Rename the specified variables in a case alternative.-alphaAltVars :: [Var] -> RewriteH CoreAlt+alphaAltVars :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreAlt alphaAltVars = alphaAltVarsWith . zip (repeat Nothing)  -- | Rename all identifiers bound in a case alternative.-alphaAlt :: RewriteH CoreAlt+alphaAlt :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreAlt alphaAlt = altVarsT >>= alphaAltVars  -----------------------------------------------------------------------  -- | Rename all identifiers bound in a case expression.-alphaCase :: RewriteH CoreExpr-alphaCase = alphaCaseBinder Nothing >+> caseAnyR (fail "") (const alphaAlt)+alphaCase :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+alphaCase = alphaCaseBinder Nothing >+> caseAllR idR idR idR (const alphaAlt)  -----------------------------------------------------------------------  -- | Alpha rename a non-recursive let binder.  Optionally takes a suggested new name.-alphaLetNonRec :: Maybe TH.Name -> RewriteH CoreExpr+alphaLetNonRec :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr alphaLetNonRec mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $-                    do (v, nameModifier) <- letNonRecT idR (freshNameGenT mn) (\ v _ nameMod -> (v, nameMod))+                    do (v, nameModifier) <- letNonRecT idR mempty (freshNameGenT mn) (\ v () nameMod -> (v, nameMod))                        v' <- constT (cloneVarH nameModifier v)-                       letNonRecT idR (replaceVarR v v') (\ _ e1 e2 -> Let (NonRec v' e1) e2)+                       letNonRecAnyR (return v') idR (replaceVarR v v')  -- | Alpha rename a non-recursive let binder if the variable appears in the argument list.  Optionally takes a suggested new name.-alphaLetNonRecVars :: Maybe TH.Name -> [Var] -> RewriteH CoreExpr-alphaLetNonRecVars mn vs = whenM ((`elem` vs) <$> letNonRecVarT) (alphaLetNonRec mn)+alphaLetNonRecVars :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> [Var] -> Rewrite c HermitM CoreExpr+alphaLetNonRecVars mn vs = whenM ((`elem` vs) `liftM` letNonRecVarT) (alphaLetNonRec mn)  -- | Rename the specified identifier bound in a recursive let.  Optionally takes a suggested new name.-alphaLetRecId :: Maybe TH.Name -> Id -> RewriteH CoreExpr+alphaLetRecId :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Id -> Rewrite c HermitM CoreExpr alphaLetRecId mn v = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $-                     do usedVars <- boundVarsT `mappend`-                                    letVarsT  `mappend`-                                    letRecDefT (\ _ -> freeVarsT) freeVarsT (\ bndfvs vs -> concatMap snd bndfvs ++ vs)+                     do usedVars <- liftM2 union boundVarsT+                                                 $ letRecT (\ _ -> defT idR freeVarsT S.insert) freeVarsT (\ bndfvs vs -> unions (vs:bndfvs))+                               --     letVarsT  `mappend`+                              --      letRecDefT (\ _ -> (idR,freeVarsT)) freeVarsT (\ bndfvs vs -> concatMap snd bndfvs ++ vs)                         v' <- constT (cloneVarH (freshNameGenAvoiding mn usedVars) v)-                        letRecDefT (\ _ -> replaceVarR v v')-                                   (replaceVarR v v')-                                   (\ bs e -> Let (Rec $ (map.first) (replaceVar v v') bs) e)+                        letRecDefAnyR (\ _ -> (arr (replaceVar v v'), replaceVarR v v')) (replaceVarR v v')  -- | Rename the specified identifiers in a recursive let, using the suggested names where provided.-alphaLetRecIdsWith :: [(Maybe TH.Name,Id)] -> RewriteH CoreExpr+alphaLetRecIdsWith :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Id)] -> Rewrite c HermitM CoreExpr alphaLetRecIdsWith = andR . map (uncurry alphaLetRecId)  -- | Rename the identifiers bound in a Let with the given list of suggested names.-alphaLetWith :: [TH.Name] -> RewriteH CoreExpr+alphaLetWith :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreExpr alphaLetWith ns = alphaLetNonRec (listToMaybe ns)                   <+ (letRecIdsT >>= (alphaLetRecIdsWith . zip (map Just ns)))  -- | Rename the specified variables bound in a let.-alphaLetVars :: [Var] -> RewriteH CoreExpr+alphaLetVars :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreExpr alphaLetVars vs = alphaLetNonRecVars Nothing vs <+ alphaLetRecIdsWith (zip (repeat Nothing) vs)  -- | Rename all identifiers bound in a Let.-alphaLet :: RewriteH CoreExpr+alphaLet :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr alphaLet = letVarsT >>= alphaLetVars  -----------------------------------------------------------------------  -- | Alpha rename a non-recursive top-level binder.  Optionally takes a suggested new name.-alphaConsNonRec :: TH.Name -> RewriteH CoreProg+alphaConsNonRec :: (ExtendPath c Crumb, AddBindings c) => TH.Name -> Rewrite c HermitM CoreProg alphaConsNonRec n = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $                     do ProgCons (NonRec v _) _ <- idR                        v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v)-                       consNonRecT idR (replaceVarR v v') (\ _ e1 e2 -> ProgCons (NonRec v' e1) e2)+                       consNonRecAnyR (return v') idR (replaceVarR v v')  -- -- | Alpha rename a non-recursive top-level binder if the identifier appears in the argument list.  Optionally takes a suggested new name.--- alphaConsNonRecIds :: Maybe TH.Name -> [Id] -> RewriteH CoreProg+-- alphaConsNonRecIds :: Maybe TH.Name -> [Id] -> Rewrite c m CoreProg -- alphaConsNonRecIds mn vs = whenM ((`elem` vs) <$> consNonRecIdT) (alphaConsNonRec mn)  -- | Rename the specified identifier bound in a recursive top-level binder.  Optionally takes a suggested new name.-alphaConsRecId :: TH.Name -> Id -> RewriteH CoreProg+alphaConsRecId :: (ExtendPath c Crumb, AddBindings c) => TH.Name -> Id -> Rewrite c HermitM CoreProg alphaConsRecId n v =  setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $                       do v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v)-                         consRecDefT (\ _ -> replaceVarR v v')-                                     (replaceVarR v v')-                                     (\ bs e -> ProgCons (Rec $ (map.first) (replaceVar v v') bs) e)+                         consRecDefAnyR (\ _ -> (arr (replaceVar v v'), replaceVarR v v')) (replaceVarR v v')  -- | Rename the specified identifiers in a recursive top-level binding at the head of a program, using the suggested names where provided.-alphaConsRecIdsWith :: [(TH.Name,Id)] -> RewriteH CoreProg+alphaConsRecIdsWith :: (ExtendPath c Crumb, AddBindings c) => [(TH.Name,Id)] -> Rewrite c HermitM CoreProg alphaConsRecIdsWith = andR . map (uncurry alphaConsRecId)  -- | Rename the identifiers bound in the top-level binding at the head of the program with the given list of suggested names.-alphaConsWith :: [TH.Name] -> RewriteH CoreProg+alphaConsWith :: (ExtendPath c Crumb, AddBindings c) => [TH.Name] -> Rewrite c HermitM CoreProg alphaConsWith []     = fail "At least one new name must be provided." alphaConsWith (n:ns) = alphaConsNonRec n <+ (consRecIdsT >>= (alphaConsRecIdsWith . zip (n:ns)))  -- -- | Rename the specified variables bound in the top-level binding at the head of the program.--- alphaConsIds :: [Id] -> RewriteH CoreProg+-- alphaConsIds :: [Id] -> Rewrite c m CoreProg -- alphaConsIds vs = alphaConsNonRecIds Nothing vs <+ alphaConsRecIdsWith (zip (repeat Nothing) vs)  -- -- | Rename all identifiers bound in the top-level binding at the head of the program.--- alphaCons :: RewriteH CoreProg+-- alphaCons :: Rewrite c m CoreProg -- alphaCons = consIdsT >>= alphaConsIds  -----------------------------------------------------------------------  -- -- | Rename all identifiers bound at the top-level.--- alphaProg :: RewriteH CoreProg+-- alphaProg :: Rewrite c m CoreProg -- alphaProg = progNilT ProgNil <+ (alphaCons >>> progConsAllR idR alphaProg)  -----------------------------------------------------------------------  -- | Alpha rename any bindings at this node.  Note: does not rename case alternatives unless invoked on the alternative.-alpha :: RewriteH Core+alpha :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core alpha = setFailMsg "Cannot alpha-rename here." $            promoteExprR (alphaLam Nothing <+ alphaCaseBinder Nothing <+ alphaLet)         <+ promoteAltR alphaAlt

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleContexts #-}+ -- | Note: this module should NOT export externals. It is for common --   transformations needed by the other primitive modules. module Language.HERMIT.Primitive.Common@@ -47,33 +49,38 @@  import Data.List import Data.Monoid+import qualified Data.Set as S +import Control.Monad(liftM)+ import Language.HERMIT.Kure import Language.HERMIT.Core import Language.HERMIT.Context import Language.HERMIT.GHC-import Language.HERMIT.Monad +import Language.HERMIT.Primitive.GHC+ import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax (showName)  ------------------------------------------------------------------------------  -- | Apply a transformation to a value in the current context.-applyInContextT :: Translate c m a b -> a -> Translate c m a b+applyInContextT :: Translate c m a b -> a -> Translate c m x b applyInContextT t a = contextonlyT $ \ c -> apply t c a +-- Note: this is the same as: return a >>> t+ ------------------------------------------------------------------------------  -- | Lift GHC's collectArgs-callT :: TranslateH CoreExpr (CoreExpr, [CoreExpr])-callT = do-    e <- idR-    case e of-        Var {} -> return (e, [])-        App {} -> return (collectArgs e)-        _      -> fail "not an application or variable occurence."+callT :: Monad m => Translate c m CoreExpr (CoreExpr, [CoreExpr])+callT = contextfreeT $ \ e -> case e of+                                Var {} -> return (e, [])+                                App {} -> return (collectArgs e)+                                _      -> fail "not an application or variable occurence." -callPredT :: (Id -> [CoreExpr] -> Bool) -> TranslateH CoreExpr (CoreExpr, [CoreExpr])+callPredT :: Monad m => (Id -> [CoreExpr] -> Bool) -> Translate c m CoreExpr (CoreExpr, [CoreExpr]) callPredT p = do     call@(Var i, args) <- callT     guardMsg (p i args) "predicate failed."@@ -81,146 +88,152 @@  -- | Succeeds if we are looking at an application of given function --   returning zero or more arguments to which it is applied.-callNameT :: TH.Name -> TranslateH CoreExpr (CoreExpr, [CoreExpr])+callNameT :: MonadCatch m => TH.Name -> Translate c m CoreExpr (CoreExpr, [CoreExpr]) callNameT nm = setFailMsg ("callNameT: not a call to " ++ show nm) $     callPredT (const . cmpTHName2Var nm)  -- | Succeeds if we are looking at a fully saturated function call.-callSaturatedT :: TranslateH CoreExpr (CoreExpr, [CoreExpr])+callSaturatedT :: Monad m => Translate c m CoreExpr (CoreExpr, [CoreExpr]) callSaturatedT = callPredT (\ i args -> idArity i == length args) -- TODO: probably better to calculate arity based on Id's type, as --       idArity is conservatively set to zero by default.  -- | Succeeds if we are looking at an application of given function-callNameG :: TH.Name -> TranslateH CoreExpr ()+callNameG :: MonadCatch m => TH.Name -> Translate c m CoreExpr () callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >>= \_ -> constT (return ())  -- | Succeeds if we are looking at an application of a data constructor.-callDataConT :: TranslateH CoreExpr (DataCon, [Type], [CoreExpr])+callDataConT :: MonadCatch m => Translate c m CoreExpr (DataCon, [Type], [CoreExpr]) callDataConT = prefixFailMsg "callDataConT failed:" $+#if __GLASGOW_HASKELL__ > 706+    do mb <- contextfreeT $ \ e -> let in_scope = mkInScopeSet (mkVarEnv [ (v,v) | v <- S.toList (coreExprFreeVars e) ])+                                   in return $ exprIsConApp_maybe (in_scope, idUnfolding) e+       maybe (fail "not a datacon application.") return mb+#else     contextfreeT (return . exprIsConApp_maybe idUnfolding)         >>= maybe (fail "not a datacon application.") return+#endif  -- | Succeeds if we are looking at an application of a named data constructor.-callDataConNameT :: TH.Name -> TranslateH CoreExpr (DataCon, [Type], [CoreExpr])+callDataConNameT :: MonadCatch m => TH.Name -> Translate c m CoreExpr (DataCon, [Type], [CoreExpr]) callDataConNameT nm = do     res@(dc,_,_) <- callDataConT     guardMsg (cmpTHName2Name nm (dataConName dc)) "wrong datacon."     return res  -- | Apply a rewrite to all applications of a given function in a top-down manner, pruning on success.-callsR :: TH.Name -> RewriteH CoreExpr -> RewriteH Core+callsR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Rewrite c m CoreExpr -> Rewrite c m Core callsR nm rr = prunetdR (promoteExprR $ callNameG nm >> rr)  -- | Apply a translate to all applications of a given function in a top-down manner, --   pruning on success, collecting the results.-callsT :: TH.Name -> TranslateH CoreExpr b -> TranslateH Core [b]+callsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Translate c m CoreExpr b -> Translate c m Core [b] callsT nm t = collectPruneT (promoteExprT $ callNameG nm >> t)  ------------------------------------------------------------------------------  -- | List all identifiers bound at the top-level in a program.-progIdsT :: TranslateH CoreProg [Id]+progIdsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreProg [Id] progIdsT = progNilT [] <+ progConsT bindVarsT progIdsT (++)  -- | List the identifiers bound by the top-level binding group at the head of the program.-consIdsT :: TranslateH CoreProg [Id]+consIdsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreProg [Id] consIdsT = progConsT bindVarsT mempty (\ vs () -> vs)  -- | List the identifiers bound by a recursive top-level binding group at the head of the program.-consRecIdsT :: TranslateH CoreProg [Id]+consRecIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg [Id] consRecIdsT = progConsT recIdsT mempty (\ vs () -> vs)  -- | Return the identifier bound by a non-recursive top-level binding at the head of the program.-consNonRecIdT :: TranslateH CoreProg Id+consNonRecIdT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg Id consNonRecIdT = progConsT nonRecVarT mempty (\ v () -> v)  -- | List all variables bound in a binding group.-bindVarsT :: TranslateH CoreBind [Var]-bindVarsT = fmap return nonRecVarT <+ recIdsT+bindVarsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreBind [Var]+bindVarsT = liftM return nonRecVarT <+ recIdsT  -- | Return the variable bound by a non-recursive let expression.-nonRecVarT :: TranslateH CoreBind Var-nonRecVarT = nonRecT mempty (\ v () -> v)+nonRecVarT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreBind Var+nonRecVarT = nonRecT idR mempty (\ v () -> v)  -- | List all identifiers bound in a recursive binding group.-recIdsT :: TranslateH CoreBind [Id]+recIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind [Id] recIdsT = recT (\ _ -> defIdT) id  -- | Return the identifier bound by a recursive definition.-defIdT :: TranslateH CoreDef Id-defIdT = defT mempty (\ v () -> v)+defIdT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreDef Id+defIdT = defT idR mempty (\ v () -> v)  -- | Return the variable bound by a lambda expression.-lamVarT :: TranslateH CoreExpr Var-lamVarT = lamT mempty (\ v () -> v)+lamVarT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var+lamVarT = lamT idR mempty (\ v () -> v)  -- | List the variables bound by a let expression.-letVarsT :: TranslateH CoreExpr [Var]+letVarsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreExpr [Var] letVarsT = letT bindVarsT mempty (\ vs () -> vs)  -- | List the identifiers bound by a recursive let expression.-letRecIdsT :: TranslateH CoreExpr [Id]+letRecIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Id] letRecIdsT = letT recIdsT mempty (\ vs () -> vs)  -- | Return the variable bound by a non-recursive let expression.-letNonRecVarT :: TranslateH CoreExpr Var+letNonRecVarT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var letNonRecVarT = letT nonRecVarT mempty (\ v () -> v)  -- | List all variables bound by a case expression (in the alternatives and the wildcard binder).-caseVarsT :: TranslateH CoreExpr [Var]-caseVarsT = caseT mempty (\ _ -> altVarsT) (\ () v _ vss -> v : nub (concat vss))+caseVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Var]+caseVarsT = caseT mempty idR mempty (\ _ -> altVarsT) (\ () v () vss -> v : nub (concat vss))  -- | Return the case wildcard binder.-caseWildIdT :: TranslateH CoreExpr Id-caseWildIdT = caseT mempty (\ _ -> return ()) (\ () v _ _ -> v)+caseWildIdT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Id+caseWildIdT = caseT mempty idR mempty (\ _ -> idR) (\ () i () _ -> i)  -- | List the variables bound by all alternatives in a case expression.-caseAltVarsT :: TranslateH CoreExpr [[Var]]-caseAltVarsT = caseT mempty (\ _ -> altVarsT) (\ () _ _ vss -> vss)+caseAltVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [[Var]]+caseAltVarsT = caseT mempty mempty mempty (\ _ -> altVarsT) (\ () () () vss -> vss)  -- | List the variables bound by a case alternative.-altVarsT :: TranslateH CoreAlt [Var]-altVarsT = altT mempty (\ _ vs () -> vs)+altVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreAlt [Var]+altVarsT = altT mempty (\ _ -> idR) mempty (\ () vs () -> vs)  ------------------------------------------------------------------------------  -- Need a better error type so that we can factor out the repetition.  -- | Lifted version of 'boundVars'.-boundVarsT :: TranslateH a [Var]+boundVarsT :: (BoundVars c, Monad m) => Translate c m a (S.Set Var) boundVarsT = contextonlyT (return . boundVars)  -- | Find the unique variable bound in the context that matches the given name, failing if it is not unique.-findBoundVarT :: TH.Name -> TranslateH a Var-findBoundVarT nm = prefixFailMsg ("Cannot resolve name " ++ TH.nameBase nm ++ ", ") $+findBoundVarT :: (BoundVars c, MonadCatch m) => TH.Name -> Translate c m a Var+findBoundVarT nm = prefixFailMsg ("Cannot resolve name " ++ showName nm ++ ", ") $                         do c <- contextT                            case findBoundVars nm c of                              []         -> fail "no matching variables in scope."                              [v]        -> return v                              _ : _ : _  -> fail "multiple matching variables in scope." --- | Lookup the name in the 'HermitC' first, then, failing that, in GHC's global reader environment.-findIdT :: TH.Name -> TranslateH a Id-findIdT nm = prefixFailMsg ("Cannot resolve name " ++ TH.nameBase nm ++ ", ") $+-- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.+findIdT :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m, MonadCatch m) => TH.Name -> Translate c m a Id+findIdT nm = prefixFailMsg ("Cannot resolve name " ++ showName nm ++ ", ") $              contextonlyT (findId nm) -findId :: TH.Name -> HermitC -> HermitM Id+findId :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m) => TH.Name -> c -> m Id findId nm c = case findBoundVars nm c of                 []         -> findIdMG nm c                 [v]        -> return v                 _ : _ : _  -> fail "multiple matching variables in scope." -findIdMG :: TH.Name -> HermitC -> HermitM Id+findIdMG :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m) => TH.Name -> c -> m Id findIdMG nm c =-    case filter isValName $ findNameFromTH (mg_rdr_env $ hermitModGuts c) nm of+    case filter isValName $ findNamesFromTH (hermitGlobalRdrEnv c) nm of       []  -> findIdBuiltIn nm       [n] -> lookupId n       ns  -> do dynFlags <- getDynFlags                 fail $ "multiple matches found:\n" ++ intercalate ", " (map (showPpr dynFlags) ns) -findIdBuiltIn :: TH.Name -> HermitM Id-findIdBuiltIn = go . TH.nameBase+findIdBuiltIn :: forall m. Monad m => TH.Name -> m Id+findIdBuiltIn = go . showName     where go ":"     = dataConId consDataCon           go "[]"    = dataConId nilDataCon @@ -238,7 +251,7 @@           --       http://www.haskell.org/ghc/docs/latest/html/libraries/ghc/TysWiredIn.html           go _   = fail "variable not in scope." -          dataConId :: DataCon -> HermitM Id+          dataConId :: DataCon -> m Id           dataConId = return . dataConWorkId  ------------------------------------------------------------------------------@@ -259,3 +272,4 @@ mapAlts :: (CoreExpr -> CoreExpr) -> [CoreAlt] -> [CoreAlt] mapAlts f alts = [ (ac, vs, f e) | (ac, vs, e) <- alts ] +------------------------------------------------------------------------------

@@ -2,13 +2,15 @@ module Language.HERMIT.Primitive.Debug        ( -- * Debugging Primitives          externals-       , traceR+       , bracketR        , observeR        , observeFailureR+       , traceR        ) where -import Language.HERMIT.Core+import Control.Arrow+ import Language.HERMIT.Kure import Language.HERMIT.External import Language.HERMIT.Monad@@ -22,6 +24,8 @@                 [ "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" ]+         , external "bracket" (bracketR :: String -> RewriteH Core -> RewriteH Core)+                [ "if given rewrite succeeds, see its input and output" ]          ]  -- | If the 'Rewrite' fails, print out the 'Core', with a message.@@ -36,3 +40,14 @@ -- | Just say something, every time the rewrite is done. traceR :: String -> RewriteH a traceR msg = sideEffectR $ \ _ _ -> sendDebugMessage $ DebugTick msg++-- | Show before and after a rewrite.+bracketR :: Injection a Core => String -> RewriteH a -> RewriteH a+bracketR msg rr = do+    -- Be careful to only run the rr once, in case it has side effects.+    (e,r) <- idR &&& attemptM rr+    either fail (\ e' -> do _ <- return e >>> observeR before+                            return e' >>> observeR after) r+    where before = msg ++ " (before)"+          after  = msg ++ " (after)"+-- attemptM :: MonadCatch m => m a -> m (Either String a)

@@ -14,6 +14,8 @@ import Control.Applicative import Control.Arrow +import Data.Monoid (mempty)+ import Language.HERMIT.Core import Language.HERMIT.Monad import Language.HERMIT.Kure@@ -103,7 +105,7 @@ fixIntro = prefixFailMsg "fix introduction failed: " $            do Def f _ <- idR               f' <- constT $ cloneVarH id f-              Def f <$> (mkFix =<< (defT (extractR $ substR f $ varToCoreExpr f') (\ _ e' -> Lam f' e')))+              Def f <$> (mkFix =<< (defT mempty (extractR $ substR f $ varToCoreExpr f') (\ () e' -> Lam f' e')))  -------------------------------------------------------------------------------------------------- @@ -270,16 +272,16 @@       work = TH.mkName "work"       fx   = TH.mkName "fix"    in-      fixIntro >>> defR ( appAllR idR (letIntro f)-                           >>> letFloatArg-                           >>> letAllR idR ( forewardT (workerWrapperFacBR wrap unwrap)-                                               >>> appAllR idR (letIntro w)-                                               >>> letFloatArg-                                               >>> letNonRecAllR (unfoldNameR fx >>> alphaLetWith [work] >>> extractR simplifyR) idR-                                               >>> letSubstR-                                               >>> letFloatArg-                                           )-                       )+      fixIntro >>> defAllR idR ( appAllR idR (letIntro f)+                                  >>> letFloatArg+                                  >>> letAllR idR ( forewardT (workerWrapperFacBR wrap unwrap)+                                                     >>> appAllR idR (letIntro w)+                                                     >>> letFloatArg+                                                     >>> letNonRecAllR idR (unfoldNameR fx >>> alphaLetWith [work] >>> extractR simplifyR) idR+                                                     >>> letSubstR+                                                     >>> letFloatArg+                                                  )+                               )  -- | \\ wrap unwrap ->  (@g = expr@  ==>  @g = let f = \\ g -> expr in let work = unwrap (f (wrap work)) in wrap work)@ workerWrapperSplit :: CoreString -> CoreString -> RewriteH CoreDef@@ -357,10 +359,10 @@     assB = wwAssB wrap unwrap f      wwCL :: RewriteH CoreExpr-    wwCL = appAllR idR (lamR (forewardT assB) >>> etaReduce)+    wwCL = appAllR idR (lamAllR idR (forewardT assB) >>> etaReduce)      wwCR :: RewriteH CoreExpr-    wwCR = appAllR idR (etaExpand (TH.mkName "x") >>> lamR (backwardT assB))+    wwCR = appAllR idR (etaExpand "x" >>> lamAllR idR (backwardT assB))  -- | @fix t (\ x -> wrap (unwrap (f x)))@  \<==\>  @fix t f@ wwC :: CoreString -> CoreString -> CoreString -> BiRewriteH CoreExpr

@@ -34,7 +34,7 @@  externals :: [External] externals =-    [ external "fold" (promoteExprR . foldR)+    [ external "fold" (promoteExprR . foldR :: TH.Name -> RewriteH Core)         [ "fold a definition"         , ""         , "double :: Int -> Int"@@ -46,15 +46,15 @@         , ""         , "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)+    , external "fold" (promoteExprR . stashFoldR :: Label -> RewriteH Core)         [ "Fold a remembered definition." ]                      .+ Context .+ Deep-    , external "fold-any" (promoteExprR stashFoldAnyR)+    , external "fold-any" (promoteExprR stashFoldAnyR :: RewriteH Core)         [ "Attempt to fold any of the remembered definitions." ] .+ Context .+ Deep     ]  ------------------------------------------------------------------------ -stashFoldR :: Label -> RewriteH CoreExpr+stashFoldR :: ReadBindings c => Label -> Rewrite c HermitM CoreExpr stashFoldR label = prefixFailMsg "Fold failed: " $     translate $ \ c e -> do         Def i rhs <- lookupDef label@@ -63,14 +63,14 @@               return               (fold i rhs e) -stashFoldAnyR :: RewriteH CoreExpr+stashFoldAnyR :: ReadBindings c => Rewrite c HermitM CoreExpr stashFoldAnyR = setFailMsg "Fold failed: no definitions could be folded." $-    catchesM =<< map stashFoldR <$> (Map.keys <$> constT getStash)+                catchesM =<< map stashFoldR <$> (Map.keys <$> constT getStash) -foldR :: TH.Name -> RewriteH CoreExpr+foldR :: ReadBindings c => TH.Name -> Rewrite c HermitM CoreExpr foldR nm =  prefixFailMsg "Fold failed: " $     translate $ \ c e -> do-        i <- case filter (cmpTHName2Var nm) $ Map.keys (hermitBindings c) of+        i <- case findBoundVars nm c of                 []  -> fail "cannot find name."                 [i] -> return i                 is  -> fail $ "multiple names match: " ++ intercalate ", " (map var2String is)

@@ -1,13 +1,16 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables, LambdaCase #-} module Language.HERMIT.Primitive.GHC        ( -- * GHC-based Transformations          -- | This module contains transformations that are reflections of GHC functions, or derived from GHC functions.          externals+       , anyCallR          -- ** Free Variables        , coreExprFreeIds        , coreExprFreeVars+       , typeFreeVars        , freeIdsT        , freeVarsT+       , freeTyVarsT        , altFreeVarsT        , altFreeVarsExclWildT          -- ** Substitution@@ -25,10 +28,12 @@        , showVars        , rule        , rules+       , equivalent+         -- ** Lifted GHC capabilities        , lintExprT        , lintProgramT        , lintModuleT-       , equivalent+       , specConstrR        ) where @@ -37,12 +42,16 @@ import qualified CoreLint import qualified OccurAnal import IOEnv+import qualified SpecConstr  import Control.Arrow import Control.Monad-import Data.List (intercalate,mapAccumL,(\\))-import Data.Map (keys) +import Data.Function (on)+import Data.List (intercalate,mapAccumL,deleteFirstsBy)+import Data.Monoid (mempty)+import Data.Set (Set, fromList, toList, (\\))+ import Language.HERMIT.Core import Language.HERMIT.Context import Language.HERMIT.Monad@@ -50,6 +59,7 @@ import Language.HERMIT.External import Language.HERMIT.GHC +import Language.HERMIT.Primitive.Debug hiding (externals) import Language.HERMIT.Primitive.Navigation hiding (externals)  import qualified Language.Haskell.TH as TH@@ -59,7 +69,7 @@ -- | Externals that reflect GHC functions, or are derived from GHC functions. externals :: [External] externals =-         [ external "info" (info :: TranslateH Core String)+         [ external "info" (info :: TranslateH CoreTC String)                 [ "display information about the current node." ]          , external "let-subst" (promoteExprR letSubstR :: RewriteH Core)                 [ "Let substitution"@@ -84,9 +94,9 @@                 [ "list rules that can be used" ] .+ Query          , external "apply-rules" (promoteExprR . rules :: [String] -> RewriteH Core)                 [ "apply named GHC rules, succeeds if any of the rules succeed" ] .+ Shallow-         , external "compare-values" compareValues+         , external "compare-values" (compareValues ::  TH.Name -> TH.Name -> TranslateH Core ())                 ["compare the rhs of two values."] .+ Query .+ Predicate-         , external "add-rule" (\ rule_name id_name -> promoteModGutsR (addCoreBindAsRule rule_name id_name))+         , external "add-rule" ((\ rule_name id_name -> promoteModGutsR (addCoreBindAsRule rule_name id_name)) :: String -> TH.Name -> RewriteH Core)                 ["add-rule \"rule-name\" <id> -- adds a new rule that freezes the right hand side of the <id>"]                                         .+ Introduce          , external "occur-analysis" (promoteExprR occurAnalyseExprR :: RewriteH Core)@@ -102,17 +112,22 @@                 ["Runs GHC's Core Lint, which typechecks the top level list of bindings."] .+ Deep .+ Debug .+ Query          , external "lintModule" (promoteModGutsT lintModuleT :: TranslateH Core String)                 ["Runs GHC's Core Lint, which typechecks the current module."] .+ Deep .+ Debug .+ Query+         , external "specConstr" (promoteModGutsR specConstrR :: RewriteH Core)+                ["Run GHC's SpecConstr pass, which performs call pattern specialization."] .+ Deep+         , external "any-call" (anyCallR :: RewriteH Core -> RewriteH Core)+                [ "any-call (.. unfold command ..) applies an unfold commands to all applications"+                , "preference is given to applications with more arguments" ] .+ Deep          ]  ------------------------------------------------------------------------  -- | Substitute all occurrences of a variable with an expression, in either a program or an expression.-substR :: Var -> CoreExpr -> RewriteH Core+substR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Var -> CoreExpr -> Rewrite c m Core substR v e = setFailMsg "Can only perform substitution on expressions or programs." $-             promoteExprR (substExprR v e) <+ promoteProgR (substTopBindR v e)+             promoteExprR (substExprR v e) <+ promoteProgR (substTopBindR v e) <+ promoteAltR (substAltR v e)  -- | Substitute all occurrences of a variable with an expression, in an expression.-substExprR :: Var -> CoreExpr -> RewriteH CoreExpr+substExprR :: Monad m => Var -> CoreExpr -> Rewrite c m CoreExpr substExprR v e =  contextfreeT $ \ expr -> do     -- The InScopeSet needs to include any free variables appearing in the     -- expression to be substituted.  Constructing a NonRec Let expression@@ -122,15 +137,22 @@     return $ substExpr (text "substR") (extendSubst emptySub v e) expr  -- | Substitute all occurrences of a variable with an expression, in a program.-substTopBindR :: Var -> CoreExpr -> RewriteH CoreProg+substTopBindR :: Monad m => Var -> CoreExpr -> Rewrite c m CoreProg substTopBindR v e =  contextfreeT $ \ p -> do     -- TODO.  Do we need to initialize the emptySubst with bindFreeVars?     let emptySub =  emptySubst -- mkEmptySubst (mkInScopeSet (exprFreeVars exp))     return $ bindsToProg $ snd (mapAccumL substBind (extendSubst emptySub v e) (progToBinds p)) +-- | Substitute all occurrences of a variable with an expression, in a case alternative.+substAltR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Var -> CoreExpr -> Rewrite c m CoreAlt+substAltR v e = do (_, vs, _) <- idR+                   if v `elem` vs+                    then fail "variable is shadowed by a case-alternative constructor argument."+                    else altAllR idR (\ _ -> idR) (substExprR v e)+ -- | (let x = e1 in e2) ==> (e2[e1/x]), --   x must not be free in e1.-letSubstR :: RewriteH CoreExpr+letSubstR :: MonadCatch m => Rewrite c m CoreExpr letSubstR =  prefixFailMsg "Let substition failed: " $              rewrite $ \ c expr -> case occurAnalyseExpr expr of                                      Let (NonRec b be) e -> apply (substExprR b be) c e@@ -139,12 +161,12 @@  -- Neil: Commented this out as it's not (currently) used. --  Perform let-substitution the specified number of times.--- letSubstNR :: Int -> RewriteH Core+-- letSubstNR :: Int -> Rewrite c m 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 :: (ReadBindings c, MonadCatch m) => Rewrite c m CoreExpr safeLetSubstR =  prefixFailMsg "Safe let-substition failed: " $                  translate $ \ env expr ->     let   -- Lit?@@ -173,34 +195,39 @@  -- | 'safeLetSubstPlusR' tries to inline a stack of bindings, stopping when reaches -- the end of the stack of lets.-safeLetSubstPlusR :: RewriteH CoreExpr+safeLetSubstPlusR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m) => Rewrite c m CoreExpr safeLetSubstPlusR = tryR (letT idR safeLetSubstPlusR Let) >>> safeLetSubstR  ------------------------------------------------------------------------ -info :: TranslateH Core String-info = translate $ \ c core -> do-         dynFlags <- getDynFlags-         let pa       = "Path: " ++ show (absPath c)-             node     = "Node: " ++ coreNode core-             con      = "Constructor: " ++ coreConstructor core-             bds      = "Bindings in Scope: " ++ show (map unqualifiedVarName $ boundVars c)-             expExtra = case core of-                          ExprCore e -> ["Type or Kind: " ++ showExprTypeOrKind dynFlags e] ++-                                        ["Free Variables: " ++ showVars (coreExprFreeVars e)]-                                           --  ++-                                           -- case e of-                                           --   Var v -> ["Identifier Info: " ++ showIdInfo dynFlags v] -- TODO: what if this is a TyVar?-                                           --   _     -> []-                          _          -> []+info :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, HasDynFlags m, MonadCatch m) => Translate c m CoreTC String+info = do crumbs <- childrenT+          translate $ \ c coreTC -> do+            dynFlags <- getDynFlags+            let pa       = "Path: " ++ showCrumbs (snocPathToPath $ absPath c)+                node     = "Node: " ++ coreTCNode coreTC+                con      = "Constructor: " ++ coreTCConstructor coreTC+                children = "Children: " ++ showCrumbs crumbs+                bds      = "Bindings in Scope: " ++ show (map var2String $ toList $ boundVars c)+                extra    = case coreTC of+                             Core (ExprCore e)      -> ["Type or Kind: " ++ showPpr dynFlags (exprTypeOrKind e)] +++                                                       ["Free Variables: " ++ showVars (toList $ coreExprFreeVars e)] +++                                                       case e of+                                                         Var i -> ["Identifier Info: " ++ showIdInfo dynFlags i]+                                                         _     -> []+                             TyCo (TypeCore ty)     -> ["Kind: " ++ showPpr dynFlags (typeKind ty)]+                             TyCo (CoercionCore co) -> ["Kind: " ++ showPpr dynFlags (coercionType co) ] -- TODO: Revisit this, should we use coercionKind?+                             _                      -> [] -         return (intercalate "\n" $ [pa,node,con,bds] ++ expExtra)+            return (intercalate "\n" $ [pa,node,con,children,bds] ++ extra) -showExprTypeOrKind :: DynFlags -> CoreExpr -> String-showExprTypeOrKind dynFlags = showPpr dynFlags . exprTypeOrKind+showIdInfo :: DynFlags -> Id -> String+showIdInfo dynFlags v = showSDoc dynFlags $ ppIdInfo v $ idInfo v --- showIdInfo :: DynFlags -> Id -> String--- showIdInfo dynFlags v = showSDoc dynFlags $ ppIdInfo v $ idInfo v+coreTCNode :: CoreTC -> String+coreTCNode (Core core)           = coreNode core+coreTCNode (TyCo TypeCore{})     = "Type"+coreTCNode (TyCo CoercionCore{}) = "Coercion"  coreNode :: Core -> String coreNode (GutsCore _)  = "Module"@@ -210,6 +237,12 @@ coreNode (ExprCore _)  = "Expression" coreNode (AltCore _)   = "Case Alternative" +coreTCConstructor :: CoreTC -> String+coreTCConstructor = \case+                       Core core              -> coreConstructor core+                       TyCo (TypeCore ty)     -> typeConstructor ty+                       TyCo (CoercionCore co) -> coercionConstructor co+ coreConstructor :: Core -> String coreConstructor (GutsCore _)     = "ModGuts" coreConstructor (ProgCore prog)  = case prog of@@ -232,43 +265,77 @@                                      Tick _ _     -> "Tick"                                      Coercion _   -> "Coercion" +typeConstructor :: Type -> String+typeConstructor = \case+                     TyVarTy{}    -> "TyVarTy"+                     AppTy{}      -> "AppTy"+                     TyConApp{}   -> "TyConApp"+                     FunTy{}      -> "FunTy"+                     ForAllTy{}   -> "ForAllTy"+                     LitTy{}      -> "LitTy"++coercionConstructor :: Coercion -> String+coercionConstructor = \case+                         Refl{}        -> "Refl"+                         TyConAppCo{}  -> "TyConAppCo"+                         AppCo{}       -> "AppCo"+                         ForAllCo{}    -> "ForAllCo"+                         CoVarCo{}     -> "CoVarCo"+                         AxiomInstCo{} -> "AxiomInstCo"+                         UnsafeCo{}    -> "UnsafeCo"+                         SymCo{}       -> "SymCo"+                         TransCo{}     -> "TransCo"+                         NthCo{}       -> "NthCo"+                         InstCo{}      -> "InstCo"+#if __GLASGOW_HASKELL__ > 706+                         LRCo{}        -> "LRCo"+#endif+ ------------------------------------------------------------------------  -- | Output a list of all free variables in an expression.-freeIdsQuery :: TranslateH CoreExpr String+freeIdsQuery :: Monad m => Translate c m CoreExpr String freeIdsQuery = do frees <- freeIdsT-                  return $ "Free identifiers are: " ++ showVars frees+                  return $ "Free identifiers are: " ++ showVars (toList frees)  -- | Show a human-readable version of a list of 'Var's. showVars :: [Var] -> String showVars = show . map var2String  -- | Lifted version of 'coreExprFreeIds'.-freeIdsT :: TranslateH CoreExpr [Id]+freeIdsT :: Monad m => Translate c m CoreExpr (Set Id) freeIdsT = arr coreExprFreeIds  -- | Lifted version of 'coreExprFreeVars'.-freeVarsT :: TranslateH CoreExpr [Var]+freeVarsT :: Monad m => Translate c m CoreExpr (Set Var) freeVarsT = arr coreExprFreeVars +-- | Lifted version of 'typeFreeVars'.+freeTyVarsT :: Monad m => Translate c m Type (Set Var)+freeTyVarsT = arr typeFreeVars++-- | List all free variables in a type.+typeFreeVars :: Type -> Set Var+typeFreeVars = fromList . uniqSetToList . tyVarsOfType+ -- | List all free variables (including types) in the expression.-coreExprFreeVars :: CoreExpr -> [Var]-coreExprFreeVars  = uniqSetToList . exprFreeVars+coreExprFreeVars :: CoreExpr -> Set Var+coreExprFreeVars  = fromList . uniqSetToList . exprFreeVars  -- | List all free identifiers (value-level free variables) in the expression.-coreExprFreeIds :: CoreExpr -> [Id]-coreExprFreeIds  = uniqSetToList . exprFreeIds+coreExprFreeIds :: CoreExpr -> Set Id+coreExprFreeIds  = fromList . uniqSetToList . exprFreeIds  -- | The free variables in a case alternative, which excludes any identifiers bound in the alternative.-altFreeVarsT :: TranslateH CoreAlt [Var]-altFreeVarsT = altT freeVarsT (\ _ vs fvs -> fvs \\ vs)+altFreeVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreAlt (Set Var)+altFreeVarsT = altT mempty (\ _ -> idR) freeVarsT (\ () vs fvs -> fvs \\ fromList vs)  -- | A variant of 'altFreeVarsT' that returns a function that accepts the case wild-card binder before giving a result. --   This is so we can use this with congruence combinators, for example: -- --   caseT id (const altFreeVarsT) $ \ _ wild _ fvs -> [ f wild | f <- fvs ]-altFreeVarsExclWildT :: TranslateH CoreAlt (Id -> [Var])-altFreeVarsExclWildT = altT freeVarsT (\ _ vs fvs wild -> fvs \\ (wild : vs))+altFreeVarsExclWildT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreAlt (Id -> Set Var)+altFreeVarsExclWildT = altT mempty (\ _ -> idR) freeVarsT (\ () vs fvs wild -> fvs \\ fromList (wild : vs))  ------------------------------------------------------------------------ @@ -278,7 +345,7 @@ -- -- (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.)-deShadowProgR :: RewriteH CoreProg+deShadowProgR :: Monad m => Rewrite c m CoreProg deShadowProgR = arr (bindsToProg . deShadowBinds . progToBinds)  ------------------------------------------------------------------------@@ -288,22 +355,34 @@             -> InScopeSet 	    -> Id -> [CoreExpr] 	    -> [CoreRule] -> Maybe (CoreRule, CoreExpr)++GHC HEAD:+type InScopeEnv = (InScopeSet, IdUnfoldingFun)++lookupRule :: DynFlags -> InScopeEnv+           -> (Activation -> Bool)      -- When rule is active+           -> Id -> [CoreExpr]+           -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -}  -- Neil: Commented this out as its not (currently) used.--- rulesToEnv :: [CoreRule] -> Map.Map String (RewriteH CoreExpr)+-- rulesToEnv :: [CoreRule] -> Map.Map String (Rewrite c m CoreExpr) -- rulesToEnv rs = Map.fromList---         [ ( unpackFS (ruleName r), rulesToRewriteH [r] )+--         [ ( unpackFS (ruleName r), rulesToRewrite c m [r] ) --         | r <- rs --         ] -rulesToRewriteH :: [CoreRule] -> RewriteH CoreExpr+#if __GLASGOW_HASKELL__ > 706+rulesToRewriteH :: (ReadBindings c, HasDynFlags m, Monad m) => [CoreRule] -> Rewrite c m CoreExpr+#else+rulesToRewriteH :: (ReadBindings c, Monad m) => [CoreRule] -> Rewrite c m CoreExpr+#endif 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 ])+    let in_scope = mkInScopeSet (mkVarEnv [ (v,v) | v <- toList (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!@@ -311,20 +390,20 @@     -- trace (showSDoc (ppr fn GhcPlugins.<+> ppr args $$ ppr rs)) $ #if __GLASGOW_HASKELL__ > 706     dflags <- getDynFlags-    case lookupRule dflags (const True) (const NoUnfolding) in_scope fn args [r | r <- rs, ru_fn r == idName fn] of+    case lookupRule dflags (in_scope, const NoUnfolding) (const True) fn args [r | r <- rs, ru_fn r == idName fn] of #else     case lookupRule (const True) (const NoUnfolding) in_scope fn args [r | r <- rs, ru_fn r == idName fn] of #endif         Nothing         -> fail "rule not matched"         Just (r, expr)  -> do             let e' = mkApps expr (drop (ruleArity r) args)-            ifM (liftM (and . map (inScope c)) $ apply freeVarsT c e')+            ifM (liftM (and . map (inScope c) . toList) $ 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."])  -- | Determine whether an identifier is in scope.-inScope :: HermitC -> Id -> Bool+inScope :: ReadBindings c => c -> Id -> Bool inScope c v = (v `boundIn` c) ||                 -- defined in this module               case unfoldingInfo (idInfo v) of                 CoreUnfolding {} -> True         -- defined elsewhere@@ -332,33 +411,26 @@                 _                -> False  -- | Lookup a rule and attempt to construct a corresponding rewrite.-rule :: String -> RewriteH CoreExpr+rule :: (ReadBindings c, HasCoreRules c) => String -> Rewrite c HermitM CoreExpr rule r = do     theRules <- getHermitRules     case lookup r theRules of         Nothing -> fail $ "failed to find rule: " ++ show r         Just rr -> rulesToRewriteH rr -rules :: [String] -> RewriteH CoreExpr+rules :: (ReadBindings c, HasCoreRules c) => [String] -> Rewrite c HermitM CoreExpr rules = orR . map rule -getHermitRules :: TranslateH a [(String, [CoreRule])]-getHermitRules = translate $ \ env _ -> do-    rb <- liftCoreM getRuleBase+getHermitRules :: HasCoreRules c => Translate c HermitM a [(String, [CoreRule])]+getHermitRules = contextonlyT $ \ c -> do+    rb     <- liftCoreM getRuleBase     hscEnv <- liftCoreM getHscEnv-    rb' <- liftM eps_rule_base $ liftIO $ runIOEnv () $ readMutVar (hsc_EPS hscEnv)-    let other_rules = [ r-                        | top_bnds <- mg_binds (hermitModGuts env)-                        , bnd <- case top_bnds of-                                     Rec bnds -> map fst bnds-                                     NonRec b _ -> [b]-                        , r <- idCoreRules bnd-                        ]+    rb'    <- liftM eps_rule_base $ liftIO $ runIOEnv () $ readMutVar (hsc_EPS hscEnv)     return [ ( unpackFS (ruleName r), [r] )-           | r <- mg_rules (hermitModGuts env) ++ other_rules ++ concat (nameEnvElts rb) ++ concat (nameEnvElts rb')+           | r <- hermitCoreRules c ++ concat (nameEnvElts rb) ++ concat (nameEnvElts rb')            ] -rules_help :: TranslateH Core String+rules_help :: HasCoreRules c => Translate c HermitM Core String rules_help = do     rulesEnv <- getHermitRules     dynFlags <- constT getDynFlags@@ -375,7 +447,7 @@                                  []  -- TODO: check if a top-level binding-addCoreBindAsRule :: String -> TH.Name -> RewriteH ModGuts+addCoreBindAsRule :: Monad m => String -> TH.Name -> Rewrite c m ModGuts addCoreBindAsRule rule_name nm = contextfreeT $ \ modGuts ->         case [ (v,e)              | top_bnds <- mg_binds modGuts@@ -398,7 +470,7 @@ occurAnalyseExpr = OccurAnal.occurAnalyseExpr  -- | Lifted version of 'occurAnalyseExpr'-occurAnalyseExprR :: RewriteH CoreExpr+occurAnalyseExprR :: Monad m => Rewrite c m CoreExpr occurAnalyseExprR = arr occurAnalyseExpr  @@ -452,7 +524,7 @@ coreEqual (DefCore dc1) (DefCore dc2) = defsToRecBind [dc1] `bindEqual` defsToRecBind [dc2] coreEqual _             _             = Nothing -compareValues :: TH.Name -> TH.Name -> TranslateH Core ()+compareValues :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> TH.Name -> Translate c m Core () compareValues n1 n2 = do         p1 <- onePathToT (namedBinding n1)         p2 <- onePathToT (namedBinding n2)@@ -466,16 +538,16 @@ --------------------------------------------------------  -- | Try to figure out the arity of an identifier.-arityOf :: HermitC -> Id -> Int-arityOf env nm =-     case lookupHermitBinding nm env of-        Nothing       -> idArity nm-        Just (LAM {}) -> 0+arityOf :: ReadBindings c => c -> Id -> Int+arityOf env i =+     case lookupHermitBinding i env of+        Nothing       -> idArity i         -- 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) -> exprArity e-        Just (CASE _ e _) -> exprArity e+        Just b -> case hermitBindingExpr b of+                    Just e  -> exprArity e+                    Nothing -> 0 -- TODO: Why do we return 0 here?  ------------------------------------------- @@ -493,14 +565,47 @@         dumpSDocs endMsg = Bag.foldBag (\d r -> d ++ ('\n':r)) (showSDoc dflags) endMsg     if Bag.isEmptyBag errs         then return $ dumpSDocs "Core Lint Passed" warns-        else fail   $ dumpSDocs "Core Lint Failed" errs+        else observeR (dumpSDocs "" errs) >>> fail "Core Lint Failed"  -- | Note: this can miss several things that a whole-module core lint will find. -- For instance, running this on the RHS of a binding, the type of the RHS will -- not be checked against the type of the binding. Running on the whole let expression -- will catch that however.-lintExprT :: TranslateH CoreExpr String+lintExprT :: (BoundVars c, Monad m, HasDynFlags m) => Translate c m CoreExpr String lintExprT = translate $ \ c e -> do     dflags <- getDynFlags     maybe (return "Core Lint Passed") (fail . showSDoc dflags)-                 $ CoreLint.lintUnfolding noSrcLoc (keys $ hermitBindings c) e+                 $ CoreLint.lintUnfolding noSrcLoc (toList $ boundVars c) e++specConstrR :: RewriteH ModGuts+specConstrR = do+    rs  <- extractT specRules+    e'  <- contextfreeT $ liftCoreM . SpecConstr.specConstrProgram+    rs' <- return e' >>> extractT specRules+    let specRs = deleteFirstsBy ((==) `on` ru_name) rs' rs+    return e' >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewriteH specRs)))++-- | Get all the specialization rules on a binding.+--   These are created by SpecConstr and other GHC passes.+idSpecRules :: TranslateH Id [CoreRule]+idSpecRules = contextfreeT $ \ i -> let SpecInfo rs _ = specInfo (idInfo i) in return rs++-- | Promote 'idSpecRules' to CoreBind.+bindSpecRules :: TranslateH CoreBind [CoreRule]+bindSpecRules =    recT (\_ -> defT idSpecRules (return ()) const) concat+                <+ nonRecT idSpecRules (return ()) const++-- | Find all specialization rules in a Core fragment.+specRules :: TranslateH Core [CoreRule]+specRules = crushtdT $ promoteBindT bindSpecRules++-- | Top-down traversal tuned to matching function calls.+anyCallR :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m)+         => Rewrite c m Core -> Rewrite c m Core+anyCallR rr = prefixFailMsg "any-call failed: " $+              readerT $ \ e -> case e of+        ExprCore (App {}) -> childR App_Arg rec >+> (rr <+ childR App_Fun rec)+        ExprCore (Var {}) -> rr+        _                 -> anyR rec+    where rec :: Rewrite c m Core+          rec = anyCallR rr