hermit 0.6.0.0 → 0.7.0.0

raw patch · 80 files changed

+6247/−3483 lines, 80 filesdep +data-default-classdep +transformers-compatdep −data-defaultdep ~kuredep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default-class, transformers-compat

Dependencies removed: data-default

Dependency ranges changed: kure, transformers

API changes (from Hackage documentation)

Files

• README.md +6/−0
• dist/build/HERMIT/ParserCore.hs +15/−5
• examples/concatVanishes/ConcatVanishes.hss +1/−1
• examples/flatten/Flatten.hec +102/−0
• examples/flatten/Flatten.hss +0/−14
• examples/last/NewLast.hss +15/−0
• examples/new_reverse/HList.hs +30/−0
• examples/new_reverse/Reverse.hec +674/−0
• examples/new_reverse/Reverse.hs +22/−0
• examples/nub/Nub.hs +27/−0
• examples/nub/Nub.hss +37/−0
• examples/qsort/HList.hs +3/−0
• examples/qsort/QSort.hs +8/−0
• examples/qsort/QSort.hss +23/−13
• examples/reverse/Reverse.hss +1/−1
• hermit.cabal +38/−40
• src/HERMIT/Context.hs +6/−1
• src/HERMIT/Core.hs +158/−132
• src/HERMIT/Dictionary.hs +12/−0
• src/HERMIT/Dictionary/AlphaConversion.hs +18/−15
• src/HERMIT/Dictionary/Common.hs +3/−17
• src/HERMIT/Dictionary/Composite.hs +27/−21
• src/HERMIT/Dictionary/Debug.hs +7/−8
• src/HERMIT/Dictionary/FixPoint.hs +8/−9
• src/HERMIT/Dictionary/Fold.hs +553/−162
• src/HERMIT/Dictionary/Function.hs +15/−18
• src/HERMIT/Dictionary/GHC.hs +76/−50
• src/HERMIT/Dictionary/Induction.hs +1/−50
• src/HERMIT/Dictionary/Inline.hs +32/−18
• src/HERMIT/Dictionary/Kure.hs +81/−47
• src/HERMIT/Dictionary/Local.hs +12/−13
• src/HERMIT/Dictionary/Local/Bind.hs +2/−2
• src/HERMIT/Dictionary/Local/Case.hs +90/−64
• src/HERMIT/Dictionary/Local/Cast.hs +20/−8
• src/HERMIT/Dictionary/Local/Let.hs +29/−29
• src/HERMIT/Dictionary/Navigation.hs +63/−47
• src/HERMIT/Dictionary/Navigation/Crumbs.hs +104/−88
• src/HERMIT/Dictionary/New.hs +2/−2
• src/HERMIT/Dictionary/Query.hs +8/−6
• src/HERMIT/Dictionary/Reasoning.hs +457/−250
• src/HERMIT/Dictionary/Remembered.hs +87/−0
• src/HERMIT/Dictionary/Rules.hs +95/−52
• src/HERMIT/Dictionary/Undefined.hs +17/−15
• src/HERMIT/Dictionary/Unfold.hs +6/−65
• src/HERMIT/Dictionary/Unsafe.hs +1/−13
• src/HERMIT/Dictionary/WorkerWrapper/Common.hs +50/−48
• src/HERMIT/Dictionary/WorkerWrapper/Fix.hs +29/−29
• src/HERMIT/Dictionary/WorkerWrapper/FixResult.hs +36/−34
• src/HERMIT/External.hs +127/−122
• src/HERMIT/GHC.hs +4/−1
• src/HERMIT/Kernel.hs +183/−96
• src/HERMIT/Kernel/Scoped.hs +0/−167
• src/HERMIT/Kure.hs +203/−111
• src/HERMIT/Kure/SumTypes.hs +0/−453
• src/HERMIT/Kure/Universes.hs +813/−0
• src/HERMIT/Lemma.hs +303/−0
• src/HERMIT/Libraries/Int.hs +78/−0
• src/HERMIT/Monad.hs +57/−96
• src/HERMIT/Name.hs +24/−21
• src/HERMIT/ParserCore.y +15/−5
• src/HERMIT/Plugin.hs +49/−70
• src/HERMIT/Plugin/Builder.hs +38/−21
• src/HERMIT/Plugin/Display.hs +11/−15
• src/HERMIT/Plugin/Renderer.hs +4/−4
• src/HERMIT/Plugin/Types.hs +21/−36
• src/HERMIT/PrettyPrinter/AST.hs +10/−7
• src/HERMIT/PrettyPrinter/Clean.hs +22/−8
• src/HERMIT/PrettyPrinter/Common.hs +45/−16
• src/HERMIT/PrettyPrinter/GHC.hs +9/−3
• src/HERMIT/Shell/Command.hs +88/−61
• src/HERMIT/Shell/Completion.hs +31/−21
• src/HERMIT/Shell/Externals.hs +187/−184
• src/HERMIT/Shell/Interpreter.hs +14/−17
• src/HERMIT/Shell/KernelEffect.hs +76/−64
• src/HERMIT/Shell/Proof.hs +246/−275
• src/HERMIT/Shell/ScriptToRewrite.hs +98/−57
• src/HERMIT/Shell/ShellEffect.hs +41/−29
• src/HERMIT/Shell/Types.hs +336/−128
• src/HERMIT/Syntax.hs +7/−4
• src/HERMIT/Win32/IO.hsc +0/−4

@@ -0,0 +1,6 @@+# HERMIT [![Hackage version](https://img.shields.io/hackage/v/hermit.svg?style=flat)](http://hackage.haskell.org/package/hermit) [![Build Status](https://img.shields.io/travis/ku-fpg/hermit.svg?style=flat)](https://travis-ci.org/ku-fpg/hermit)++The Haskell Equational Reasoning Model-to-Implementation Tunnel.++## Links+* http://www.ittc.ku.edu/csdl/fpg/Tools/HERMIT

@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -w #-} {-# OPTIONS -fglasgow-exts -cpp #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-} module HERMIT.ParserCore     ( parseCore     , parseCoreExprT@@ -18,6 +19,7 @@ import Control.Arrow import Control.Monad.Reader import Data.Char (isSpace, isDigit)+import qualified Data.Map as M  import HERMIT.Context import HERMIT.External@@ -335,27 +337,35 @@  --------------------------------------------- -parseCore :: BoundVars c => CoreString -> c -> HermitM CoreExpr+parseCore :: ReadBindings c => CoreString -> c -> HermitM CoreExpr parseCore (CoreString s) c =     case lexer s of         Left msg -> fail msg-        Right tokens -> runReaderT (parser tokens) (boundVars c)+        Right tokens ->+            -- Since we are comparing occurrence names, only take the+            -- most recently defined (deepest) when variables shadow each other.+            let comb v1@(_,d1) v2@(_,d2) = if d1 > d2 then v1 else v2+                vars = mkVarSet . map fst . M.elems+                     $ M.mapKeysWith comb getOccString+                     $ M.mapWithKey (\k -> (k,) . hbDepth)+                     $ hermitBindings c+            in runReaderT (parser tokens) vars  ---------------------------------------------  -- These should probably go somewhere else.  -- | Parse a 'CoreString' to a 'CoreExpr', using the current context.-parseCoreExprT :: (BoundVars c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, HasStash m, LiftCoreM m)+parseCoreExprT :: (ReadBindings c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m)                => CoreString -> Transform c m a CoreExpr parseCoreExprT cs = contextonlyT $ embedHermitM . parseCore cs -parse2BeforeT :: (BoundVars c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, HasStash m, LiftCoreM m)+parse2BeforeT :: (ReadBindings c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m)               => (CoreExpr -> CoreExpr -> Translate c m a b)               -> CoreString -> CoreString -> Translate c m a b parse2BeforeT f s1 s2 = parseCoreExprT s1 &&& parseCoreExprT s2 >>= uncurry f -parse3BeforeT :: (BoundVars c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, HasStash m, LiftCoreM m)+parse3BeforeT :: (ReadBindings c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m)               => (CoreExpr -> CoreExpr -> CoreExpr -> Translate c m a b)               -> CoreString -> CoreString -> CoreString -> Translate c m a b parse3BeforeT f s1 s2 s3 = (parseCoreExprT s1 &&& parseCoreExprT s2) &&& parseCoreExprT s3 >>= (uncurry . uncurry $ f)

@@ -9,7 +9,7 @@   lam-body   eta-expand 'acc   lam-body-  bash-extended-with [ push 'repH StrictRepH, forward ww-result-fusion, apply-rules ["repH ++","repH (:)","repH []"] ]+  bash-extended-with [ push 'repH StrictRepH, forward ww-result-fusion, unfold-rules-unsafe ["repH ++","repH (:)","repH []"] ]   try (bash-extended-with [push-unsafe 'work]) } one-td (unfold 'absH)

@@ -0,0 +1,102 @@+load-as-rewrite "WWA" "WW-Ass-A.hss"+define-rewrite "WWC" "ww-result-AssA-to-AssC WWA"+load-as-rewrite "StrictRepH" "StrictRepH.hss"++-- module main:Main where+--   flatten :: forall a . Tree a -> [a]+--   $dShow :: Show [Char]+--   main :: IO ()+--   main :: IO ()++binding-of 'flatten++-- flatten = \ * ds ->+--   case ds of wild *+--     Node l r -> (++) * (flatten * l) (flatten * r)+--     Leaf a -> (:) * a ([] *)++ww-result-split-static-arg 1 [0] [| absH |] [| repH |] WWC++-- flatten = \ * ds ->+--   (let f = \ flatten' ds ->+--          case ds of wild *+--            Node l r -> (++) * (flatten' l) (flatten' r)+--            Leaf a -> (:) * a ([] *)+--        rec work = \ x1 -> repH * (f (\ x2 -> absH * (work x2)) x1)+--    in \ x0 -> absH * (work x0)) ds++bash+{++-- flatten = \ * ->+--   let rec work = \ x1 ->+--             repH *+--                  (case x1 of wild *+--                     Node l r -> (++) * (absH * (work l)) (absH * (work r))+--                     Leaf a -> (:) * a ([] *))+--   in \ x0 -> absH * (work x0)++rhs-of 'work++-- \ x1 ->+--   repH *+--        (case x1 of wild *+--           Node l r -> (++) * (absH * (work l)) (absH * (work r))+--           Leaf a -> (:) * a ([] *))++alpha-lam 'tree++-- \ tree ->+--   repH *+--        (case tree of wild *+--           Node l r -> (++) * (absH * (work l)) (absH * (work r))+--           Leaf a -> (:) * a ([] *))++lam-body++-- repH *+--      (case tree of wild *+--         Node l r -> (++) * (absH * (work l)) (absH * (work r))+--         Leaf a -> (:) * a ([] *))++eta-expand 'acc++-- \ acc ->+--   repH *+--        (case tree of wild *+--           Node l r -> (++) * (absH * (work l)) (absH * (work r))+--           Leaf a -> (:) * a ([] *))+--        acc++lam-body++-- repH *+--      (case tree of wild *+--         Node l r -> (++) * (absH * (work l)) (absH * (work r))+--         Leaf a -> (:) * a ([] *))+--      acc++bash-extended-with [push 'repH StrictRepH,forward ww-result-fusion,unfold-rules-unsafe ["repH ++","repH (:)","repH []"]]++-- case tree of wild *+--   Node l r -> work l (work r acc)+--   Leaf a -> (:) * a acc++ }++-- flatten = \ * ->+--   let rec work = \ tree acc ->+--             case tree of wild *+--               Node l r -> work l (work r acc)+--               Leaf a -> (:) * a acc+--   in \ x0 -> absH * (work x0)++one-td (unfold 'absH)++-- flatten = \ * ->+--   let rec work = \ tree acc ->+--             case tree of wild *+--               Node l r -> work l (work r acc)+--               Leaf a -> (:) * a acc+--   in \ x0 -> work x0 ([] *)+

@@ -1,14 +0,0 @@-load-as-rewrite "WWA" "WW-Ass-A.hss"-define-rewrite "WWC" "ww-result-AssA-to-AssC WWA"-load-as-rewrite "StrictRepH" "StrictRepH.hss"-binding-of 'flatten-ww-result-split-static-arg 1 [0] [| absH |] [| repH |] WWC-bash-{ rhs-of 'work-  alpha-lam 'tree-  lam-body-  eta-expand 'acc-  lam-body-  bash-extended-with [push 'repH StrictRepH, forward ww-result-fusion, apply-rules ["repH ++", "repH (:)", "repH []"] ]-}-one-td (unfold 'absH)

@@ -0,0 +1,15 @@+flatten-module+set-pp-type Show++binding-of 'last+fix-intro+{ application-of 'fix+  split-1-beta last [| wrap |] [| unwrap |]+  -- prove the assumption+  lhs (repeat (any-call (unfold ['., 'wrap, 'unwrap])))+  both smash+  end-proof++  repeat (any-call (unfold ['g, 'wrap, 'unwrap, 'fix]))+  bash+}

@@ -0,0 +1,30 @@+module HList+    ( H+    , repH+    , absH+    , myAppend+    ) where++type H a = [a] -> [a]++{-# INLINABLE repH #-}+repH :: [a] -> H a+repH xs = (xs ++)++{-# INLINABLE absH #-}+absH :: H a -> [a]+absH f = f []++-- Because we can't get unfolding for +++myAppend :: [a] -> [a] -> [a]+myAppend []     ys = ys+myAppend (x:xs) ys = x : myAppend xs ys+{-# RULES "appendFix" [~] (++) = myAppend #-}++-- Algebra for repH+{-# RULES "repH []"  [~]               repH [] = id #-}+{-# RULES "repH (:)" [~] forall x xs.  repH (x:xs) = (x:) . repH xs #-}+{-# RULES "repH ++"  [~] forall xs ys. repH (xs ++ ys) = repH xs . repH ys #-}++-- Needed because the fusion rule we generate isn't too useful yet.+{-# RULES "repH-absH-fusion" [~] forall h. repH (absH h) = h #-}

@@ -0,0 +1,674 @@+flatten-module+rule-to-lemma "++ []"++-- module main:Main where+--   absR :: forall a . ([a] -> H a) -> [a] -> [a]+--   repR :: forall a . ([a] -> [a]) -> [a] -> H a+--   rev :: forall a . [a] -> [a]+--   main :: IO ()+--   main :: IO ()++prove-lemma "++ []"++-- Goal:+-- forall * xs. (++) * xs ([] *) = xs++lhs (one-td (unfold-rule appendFix))++-- Goal:+-- forall *. (++) * = myAppend *++assume -- proven appendFix++-- Goal:+-- forall * xs. myAppend * xs ([] *) = xs++induction 'xs++-- Goal:+-- forall *. myAppend * (undefined *) ([] *) = undefined *++lhs unfold++-- Goal:+-- forall *.+-- case undefined * of wild *+--   [] -> [] *+--   (:) x xs -> (:) * x (myAppend * xs ([] *))+-- =+-- undefined *++lhs undefined-expr++-- Goal:+-- forall *. undefined * = undefined *++end-case -- proven "++ []-induction-case-undefined"++-- Goal:+-- forall *. myAppend * ([] *) ([] *) = [] *++lhs unfold++-- Goal:+-- forall *.+-- case [] * of wild *+--   [] -> [] *+--   (:) x xs -> (:) * x (myAppend * xs ([] *))+-- =+-- [] *++lhs simplify++-- Goal:+-- forall *. [] * = [] *++end-case -- proven "++ []-induction-case-[]"++-- Assumed lemmas:+-- ind-hyp-0 (Assumed)+--   myAppend * b ([] *) = b+-- Goal:+-- forall * a b. myAppend * ((:) * a b) ([] *) = (:) * a b++lhs unfold++-- Assumed lemmas:+-- ind-hyp-0 (Assumed)+--   myAppend * b ([] *) = b+-- Goal:+-- forall * a b.+-- case (:) * a b of wild *+--   [] -> [] *+--   (:) x xs -> (:) * x (myAppend * xs ([] *))+-- =+-- (:) * a b++lhs simplify++-- Assumed lemmas:+-- ind-hyp-0 (Assumed)+--   myAppend * b ([] *) = b+-- Goal:+-- forall * a b. (:) * a (myAppend * b ([] *)) = (:) * a b++lhs (one-td (lemma-forward ind-hyp-0))++-- Assumed lemmas:+-- ind-hyp-0 (Assumed)+--   myAppend * b ([] *) = b+-- Goal:+-- forall * a b. (:) * a b = (:) * a b++end-case -- proven "++ []-induction-case-:"+-- proven "++ []"+rule-to-lemma "repH []"++-- module main:Main where+--   absR :: forall a . ([a] -> H a) -> [a] -> [a]+--   repR :: forall a . ([a] -> [a]) -> [a] -> H a+--   rev :: forall a . [a] -> [a]+--   main :: IO ()+--   main :: IO ()++prove-lemma "repH []"++-- Goal:+-- forall *. repH * ([] *) = id *++lhs unfold++-- Goal:+-- forall *. (++) * ([] *) = id *++extensionality++-- Goal:+-- forall * x. (++) * ([] *) x = id * x++lhs (one-td (unfold-rule appendFix))++-- Goal:+-- forall * x. myAppend * ([] *) x = id * x++lhs unfold++-- Goal:+-- forall * x.+-- case [] * of wild *+--   [] -> x+--   (:) x xs -> (:) * x (myAppend * xs x)+-- =+-- id * x++both smash++-- Goal:+-- forall * x. x = x++end-proof -- proven "repH []"+rule-to-lemma "repH (:)"++-- module main:Main where+--   absR :: forall a . ([a] -> H a) -> [a] -> [a]+--   repR :: forall a . ([a] -> [a]) -> [a] -> H a+--   rev :: forall a . [a] -> [a]+--   main :: IO ()+--   main :: IO ()++prove-lemma "repH (:)"++-- Goal:+-- forall * x xs. repH * ((:) * x xs) = (.) * * * ((:) * x) (repH * xs)++both (any-call (unfold 'repH))++-- Goal:+-- forall * x xs. (++) * ((:) * x xs) = (.) * * * ((:) * x) ((++) * xs)++both (any-call (unfold-rule appendFix))++-- Goal:+-- forall * x xs. myAppend * ((:) * x xs) = (.) * * * ((:) * x) (myAppend * xs)++rhs unfold++-- Goal:+-- forall * x xs. myAppend * ((:) * x xs) = \ x -> (:) * x (myAppend * xs x)++lhs (unfold >>> smash)++-- Goal:+-- forall * x xs. \ ys -> (:) * x (myAppend * xs ys) = \ x -> (:) * x (myAppend * xs x)++end-proof -- proven "repH (:)"+rule-to-lemma "repH ++"++-- module main:Main where+--   absR :: forall a . ([a] -> H a) -> [a] -> [a]+--   repR :: forall a . ([a] -> [a]) -> [a] -> H a+--   rev :: forall a . [a] -> [a]+--   main :: IO ()+--   main :: IO ()++prove-lemma "repH ++"++-- Goal:+-- forall * xs ys. repH * ((++) * xs ys) = (.) * * * (repH * xs) (repH * ys)++both (any-call (unfold 'repH))++-- Goal:+-- forall * xs ys. (++) * ((++) * xs ys) = (.) * * * ((++) * xs) ((++) * ys)++both (any-call (unfold-rule appendFix))++-- Goal:+-- forall * xs ys. myAppend * (myAppend * xs ys) = (.) * * * (myAppend * xs) (myAppend * ys)++lhs (eta-expand 'x)++-- Goal:+-- forall * xs ys. \ x -> myAppend * (myAppend * xs ys) x = (.) * * * (myAppend * xs) (myAppend * ys)++rhs unfold++-- Goal:+-- forall * xs ys. \ x -> myAppend * (myAppend * xs ys) x = \ x -> myAppend * xs (myAppend * ys x)++induction 'xs++-- Goal:+-- forall * ys x. myAppend * (myAppend * (undefined *) ys) x = myAppend * (undefined *) (myAppend * ys x)++both (replicate 2 (any-call (unfold 'myAppend)))++-- Goal:+-- forall * ys x.+-- case case undefined * of wild *+--        [] -> ys+--        (:) x xs -> (:) * x (myAppend * xs ys)+--  of wild *+--   [] -> x+--   (:) x xs ->+--     (:) * x+--         (case xs of wild *+--            [] -> x+--            (:) x xs -> (:) * x (myAppend * xs x))+-- =+-- case undefined * of wild *+--   [] ->+--     case ys of wild *+--       [] -> x+--       (:) x xs ->+--         (:) * x+--             (case xs of wild *+--                [] -> x+--                (:) x xs -> (:) * x (myAppend * xs x))+--   (:) x xs ->+--     (:) * x+--         (case xs of wild *+--            [] ->+--              case ys of wild *+--                [] -> x+--                (:) x xs ->+--                  (:) * x+--                      (case xs of wild *+--                         [] -> x+--                         (:) x xs -> (:) * x (myAppend * xs x))+--            (:) x xs ->+--              (:) * x+--                  (myAppend * xs+--                            (case ys of wild *+--                               [] -> x+--                               (:) x xs ->+--                                 (:) * x+--                                     (case xs of wild *+--                                        [] -> x+--                                        (:) x xs -> (:) * x (myAppend * xs x)))))++both (innermost undefined-expr)++-- Goal:+-- forall * ys x. undefined * = undefined *++end-case -- proven "repH ++-induction-case-undefined"++-- Goal:+-- forall * ys x. myAppend * (myAppend * ([] *) ys) x = myAppend * ([] *) (myAppend * ys x)++both (replicate 2 (any-call (unfold 'myAppend)))++-- Goal:+-- forall * ys x.+-- case case [] * of wild *+--        [] -> ys+--        (:) x xs -> (:) * x (myAppend * xs ys)+--  of wild *+--   [] -> x+--   (:) x xs ->+--     (:) * x+--         (case xs of wild *+--            [] -> x+--            (:) x xs -> (:) * x (myAppend * xs x))+-- =+-- case [] * of wild *+--   [] ->+--     case ys of wild *+--       [] -> x+--       (:) x xs ->+--         (:) * x+--             (case xs of wild *+--                [] -> x+--                (:) x xs -> (:) * x (myAppend * xs x))+--   (:) x xs ->+--     (:) * x+--         (case xs of wild *+--            [] ->+--              case ys of wild *+--                [] -> x+--                (:) x xs ->+--                  (:) * x+--                      (case xs of wild *+--                         [] -> x+--                         (:) x xs -> (:) * x (myAppend * xs x))+--            (:) x xs ->+--              (:) * x+--                  (myAppend * xs+--                            (case ys of wild *+--                               [] -> x+--                               (:) x xs ->+--                                 (:) * x+--                                     (case xs of wild *+--                                        [] -> x+--                                        (:) x xs -> (:) * x (myAppend * xs x)))))++both smash++-- Goal:+-- forall * ys x.+-- case ys of wild *+--   [] -> x+--   (:) x xs ->+--     (:) * x+--         (case xs of wild *+--            [] -> x+--            (:) x xs -> (:) * x (myAppend * xs x))+-- =+-- case ys of wild *+--   [] -> x+--   (:) x xs ->+--     (:) * x+--         (case xs of wild *+--            [] -> x+--            (:) x xs -> (:) * x (myAppend * xs x))++end-case -- proven "repH ++-induction-case-[]"++-- Assumed lemmas:+-- ind-hyp-0 (Assumed)+--   \ x -> myAppend * (myAppend * b ys) x = \ x -> myAppend * b (myAppend * ys x)+-- Goal:+-- forall * ys a b x. myAppend * (myAppend * ((:) * a b) ys) x = myAppend * ((:) * a b) (myAppend * ys x)++both (one-td unfold)++-- Assumed lemmas:+-- ind-hyp-0 (Assumed)+--   \ x -> myAppend * (myAppend * b ys) x = \ x -> myAppend * b (myAppend * ys x)+-- Goal:+-- forall * ys a b x.+-- case myAppend * ((:) * a b) ys of wild *+--   [] -> x+--   (:) x xs -> (:) * x (myAppend * xs x)+-- =+-- case (:) * a b of wild *+--   [] -> myAppend * ys x+--   (:) x xs -> (:) * x (myAppend * xs (myAppend * ys x))++lhs (one-td unfold)++-- Assumed lemmas:+-- ind-hyp-0 (Assumed)+--   \ x -> myAppend * (myAppend * b ys) x = \ x -> myAppend * b (myAppend * ys x)+-- Goal:+-- forall * ys a b x.+-- case case (:) * a b of wild *+--        [] -> ys+--        (:) x xs -> (:) * x (myAppend * xs ys)+--  of wild *+--   [] -> x+--   (:) x xs -> (:) * x (myAppend * xs x)+-- =+-- case (:) * a b of wild *+--   [] -> myAppend * ys x+--   (:) x xs -> (:) * x (myAppend * xs (myAppend * ys x))++both smash++-- Assumed lemmas:+-- ind-hyp-0 (Assumed)+--   \ x -> myAppend * (myAppend * b ys) x = \ x -> myAppend * b (myAppend * ys x)+-- Goal:+-- forall * ys a b x. (:) * a (myAppend * (myAppend * b ys) x) = (:) * a (myAppend * b (myAppend * ys x))++rhs (one-td (lemma-backward ind-hyp-0))++-- Assumed lemmas:+-- ind-hyp-0 (Assumed)+--   \ x -> myAppend * (myAppend * b ys) x = \ x -> myAppend * b (myAppend * ys x)+-- Goal:+-- forall * ys a b x. (:) * a (myAppend * (myAppend * b ys) x) = (:) * a (myAppend * (myAppend * b ys) x)++end-case -- proven "repH ++-induction-case-:"+-- proven "repH ++"++-- module main:Main where+--   absR :: forall a . ([a] -> H a) -> [a] -> [a]+--   repR :: forall a . ([a] -> [a]) -> [a] -> H a+--   rev :: forall a . [a] -> [a]+--   main :: IO ()+--   main :: IO ()++binding-of 'rev++-- rev = \ * ds ->+--   case ds of wild *+--     [] -> [] *+--     (:) x xs -> (++) * (rev * xs) ((:) * x ([] *))++fix-intro++-- rev = \ * ->+--   fix *+--       (\ rev ds ->+--          case ds of wild *+--            [] -> [] *+--            (:) x xs -> (++) * (rev xs) ((:) * x ([] *)))++application-of 'fix++-- fix *+--     (\ rev ds ->+--        case ds of wild *+--          [] -> [] *+--          (:) x xs -> (++) * (rev xs) ((:) * x ([] *)))++split-1-beta rev [| absR |] [| repR |]++-- Goal:+-- fix *+--     ((.) * * * (absR *)+--          ((.) * * * (repR *)+--               (\ rev ds ->+--                  case ds of wild *+--                    [] -> [] *+--                    (:) x xs -> (++) * (rev xs) ((:) * x ([] *)))))+-- =+-- fix *+--     (\ rev ds ->+--        case ds of wild *+--          [] -> [] *+--          (:) x xs -> (++) * (rev xs) ((:) * x ([] *)))++both (unfold >>> smash)++-- Goal:+-- let rec x =+--           absR *+--                (repR *+--                      (\ ds ->+--                         case ds of wild *+--                           [] -> [] *+--                           (:) x xs -> (++) * (x xs) ((:) * x ([] *))))+-- in x+-- =+-- let rec x = \ ds ->+--           case ds of wild *+--             [] -> [] *+--             (:) x xs -> (++) * (x xs) ((:) * x ([] *))+-- in x++lhs (replicate 5 ((one-td unfold) >+> smash))++-- Goal:+-- let rec x = \ x ->+--           (++) *+--                (case x of wild *+--                   [] -> [] *+--                   (:) x xs -> (++) * (x xs) ((:) * x ([] *)))+--                ([] *)+-- in x+-- =+-- let rec x = \ ds ->+--           case ds of wild *+--             [] -> [] *+--             (:) x xs -> (++) * (x xs) ((:) * x ([] *))+-- in x++lhs (one-td (lemma-forward "++ []"))++-- Goal:+-- let rec x = \ x ->+--           case x of wild *+--             [] -> [] *+--             (:) x xs -> (++) * (x xs) ((:) * x ([] *))+-- in x+-- =+-- let rec x = \ ds ->+--           case ds of wild *+--             [] -> [] *+--             (:) x xs -> (++) * (x xs) ((:) * x ([] *))+-- in x++end-proof -- proven rev-assumption++-- let g =+--       (.) * * * (repR *)+--           ((.) * * *+--                (\ rev ds ->+--                   case ds of wild *+--                     [] -> [] *+--                     (:) x xs -> (++) * (rev xs) ((:) * x ([] *)))+--                (absR *))+--     worker = fix * g+-- in absR * worker++any-call (unfold ['absR,'repR])++-- let g =+--       (.) * * * (\ eta -> (\ f -> (.) * * * (repH *) f) eta)+--           ((.) * * *+--                (\ rev ds ->+--                   case ds of wild *+--                     [] -> [] *+--                     (:) x xs -> (++) * (rev xs) ((:) * x ([] *)))+--                (\ eta -> (\ g -> (.) * * * (absH *) g) eta))+--     worker = fix * g+-- in (\ g -> (.) * * * (absH *) g) worker++repeat (any-call (unfold '.)) ; smash++-- let worker =+--       fix *+--           (\ x x ->+--              repH *+--                   (case x of wild *+--                      [] -> [] *+--                      (:) x xs -> (++) * (absH * (x xs)) ((:) * x ([] *))))+-- in \ x -> absH * (worker x)++one-td (case-float-arg-lemma repHstrict)++-- Goal:+-- forall *. repH * (undefined *) = undefined *++lhs unfold++-- Goal:+-- forall *. (++) * (undefined *) = undefined *++lhs (one-td (unfold-rule appendFix))++-- Goal:+-- forall *. myAppend * (undefined *) = undefined *++lhs unfold++-- Goal:+-- forall *.+-- \ ys ->+--   case undefined * of wild *+--     [] -> ys+--     (:) x xs -> (:) * x (myAppend * xs ys)+-- =+-- undefined *++both (innermost undefined-expr)++-- Goal:+-- forall *. undefined * = undefined *++end-proof -- proven repHstrict++-- let worker =+--       fix *+--           (\ x x ->+--              case x of wild *+--                [] -> repH * ([] *)+--                (:) x xs -> repH * ((++) * (absH * (x xs)) ((:) * x ([] *))))+-- in \ x -> absH * (worker x)++one-td (lemma-forward "repH ++")++-- let worker =+--       fix *+--           (\ x x ->+--              case x of wild *+--                [] -> repH * ([] *)+--                (:) x xs -> (.) * * * (repH * (absH * (x xs))) (repH * ((:) * x ([] *))))+-- in \ x -> absH * (worker x)++repeat (any-call (unfold '.))++-- let worker =+--       fix *+--           (\ x x ->+--              case x of wild *+--                [] -> repH * ([] *)+--                (:) x xs -> \ x -> repH * (absH * (x xs)) (repH * ((:) * x ([] *)) x))+-- in \ x -> absH * (worker x)++one-td (unfold-rule repH-absH-fusion)++-- Goal:+-- forall * h. repH * (absH * h) = h++assume -- proven repH-absH-fusion++-- let worker =+--       fix *+--           (\ x x ->+--              case x of wild *+--                [] -> repH * ([] *)+--                (:) x xs -> \ x -> x xs (repH * ((:) * x ([] *)) x))+-- in \ x -> absH * (worker x)++one-td (lemma-forward "repH (:)")++-- let worker =+--       fix *+--           (\ x x ->+--              case x of wild *+--                [] -> repH * ([] *)+--                (:) x xs -> \ x -> x xs ((.) * * * ((:) * x) (repH * ([] *)) x))+-- in \ x -> absH * (worker x)++any-td (lemma-forward "repH []")++-- let worker =+--       fix *+--           (\ x x ->+--              case x of wild *+--                [] -> id *+--                (:) x xs -> \ x -> x xs ((.) * * * ((:) * x) (id *) x))+-- in \ x -> absH * (worker x)++any-call (unfold 'fix)++-- let worker =+--       let rec x =+--                 (\ x x ->+--                    case x of wild *+--                      [] -> id *+--                      (:) x xs -> \ x -> x xs ((.) * * * ((:) * x) (id *) x)) x+--       in x+-- in \ x -> absH * (worker x)++any-call (unfold 'absH)++-- let worker =+--       let rec x =+--                 (\ x x ->+--                    case x of wild *+--                      [] -> id *+--                      (:) x xs -> \ x -> x xs ((.) * * * ((:) * x) (id *) x)) x+--       in x+-- in \ x -> worker x ([] *)++bash++-- let rec x = \ x ->+--           case x of wild *+--             [] -> \ x -> x+--             (:) x xs -> \ x -> x xs ((:) * x x)+-- in \ x -> x x ([] *)++unshadow++-- let rec x = \ x0 ->+--           case x0 of wild *+--             [] -> \ x1 -> x1+--             (:) x1 xs -> \ x2 -> x xs ((:) * x1 x2)+-- in \ x0 -> x x0 ([] *)+

@@ -0,0 +1,22 @@+module Main where++import HList+import Data.Function (fix)++{-# INLINE repR #-}+repR :: ([a] -> [a]) -> ([a] -> H a)+repR f = repH . f++{-# INLINE absR #-}+absR :: ([a] -> H a) -> ([a] -> [a])+absR g = absH . g++rev :: [a] -> [a]+rev []     = []+rev (x:xs) = rev xs ++ [x]++main :: IO ()+main = print $ rev [1..10]++-- useful auxilliary lemma for proving the w/w assumption+{-# RULES "++ []" [~] forall xs. xs ++ [] = xs #-}

@@ -0,0 +1,27 @@+module Main where++import qualified Data.Set as Set+import Data.Set (Set)++import Prelude hiding (filter) -- because we can't get unfolding for filter++filter :: (a -> Bool) -> [a] -> [a]+filter _ [] = []+filter p (x:xs) = if p x then x : filter p xs else filter p xs++nub :: [Int] -> [Int]+nub [] = []+nub (x:xs) = x : nub (filter (/= x) xs)++absN :: ([Int] -> Set Int -> [Int]) -> [Int] -> [Int]+absN h [] = []+absN h (x:xs) = x : h xs (Set.singleton x)++repN :: ([Int] -> [Int]) -> [Int] -> Set Int -> [Int]+repN h xs s = h (filter (`Set.notMember` s) xs)++main :: IO ()+main = print (nub [ x | n <- [1..1000], x <- [1..n] ])++{-# RULES "filter-fusion" [~] forall p q ys. filter p (filter q ys) = filter (\y -> p y && q y) ys #-}+{-# RULES "member-fusion" [~] forall y x s. (y /= x) && (y `Set.notMember` s) = y `Set.notMember` (Set.insert x s) #-}

@@ -0,0 +1,37 @@+set-pp-type Show++flatten-module++binding-of 'nub+fix-intro ; def-rhs+split-2-beta nub [| absN |] [| repN |] ; assume++-- this bit to essentially undo the fix-intro+{ application-of 'repN ; app-arg ; let-intro 'nub ; one-td (unfold 'fix) ; simplify }+innermost let-float+alpha-let ['nub'] -- rename x to nub'++-- back to the derivation+binding-of 'worker+one-td (unfold 'repN)+remember origworker+one-td (unfold 'filter)+one-td (case-float-arg-lemma nubStrict)++-- prove strictness condition+lhs (unfold >>> undefined-expr)+end-proof++one-td (unfold 'nub')+simplify++one-td (case-float-arg-lemma nubStrict)+{ consider case ; consider case ; case-alt 1 ; alt-rhs+  unfold ; simplify+  one-td (unfold-rule "filter-fusion") ; assume+  simplify+  one-td (unfold-rule "member-fusion") ; assume+}+nonrec-to-rec+any-td (fold-remembered origworker)+

@@ -22,3 +22,6 @@ {-# RULES "repH ++" forall xs ys   . repH (xs ++ ys) = repH xs . repH ys #-} {-# RULES "repH []" 	             repH [] = id  	       	         #-} {-# RULES "repH (:)" forall x xs   . repH (x:xs) = ((:) x) . repH xs     #-}++-- Needed because the fusion rule we generate isn't too useful yet.+{-# RULES "repH-absH-fusion" [~] forall h. repH (absH h) = h #-}

@@ -7,6 +7,14 @@  data Tree a = Node (Tree a) (Tree a) | Leaf a +{-# INLINE repR #-}+repR :: ([a] -> [a]) -> ([a] -> H a)+repR f = repH . f++{-# INLINE absR #-}+absR :: ([a] -> H a) -> ([a] -> [a])+absR g = absH . g+ qsort :: Ord a => [a] -> [a] qsort []     = [] qsort (a:as) = qsort bs ++ [a] ++ qsort cs

@@ -1,15 +1,25 @@-load-as-rewrite "WWA" "WW-Ass-A.hss"-define-rewrite "WWC" "ww-result-AssA-to-AssC WWA"-load-as-rewrite "StrictRepH" "StrictRepH.hss"+flatten-module binding-of 'qsort-ww-result-split-static-arg 2 [0] [| absH |] [| repH |] WWC-bash-{ rhs-of 'work-  alpha-lam 'xs-  lam-body-  eta-expand 'acc-  lam-body-  bash-extended-with [push 'repH StrictRepH, forward ww-result-fusion, apply-rules ["repH ++", "repH (:)", "repH []"] ]-  bash-extended-with [push-unsafe 'work]+static-arg+{+    binding-of 'qsort'+    fix-intro+    def-rhs+    split-1-beta qsort [|absR|] [|repR|] ; assume+    rhs-of 'worker+    repeat (any-call (unfold ['.,'fix,'g,'repR,'absR]))+    simplify+    one-td (case-float-arg-lemma repHstrict) ; assume+    innermost let-float+    any-td (unfold-rule "repH ++") ; assume+    any-call (unfold-rule repH-absH-fusion) ; assume+    unshadow+    any-td (inline 'ds1)+    simplify+    alpha-let [worker]+    repeat (any-call (unfold-rules ["repH (:)","repH []"]))+    assume ; assume }-one-td (unfold 'absH)+repeat (any-call (unfold ['.,'absR, 'absH]))+innermost let-float+bash

@@ -9,6 +9,6 @@   lam-body   eta-expand 'acc   lam-body-  bash-extended-with [push 'repH StrictRepH, forward ww-result-fusion, apply-rules ["repH ++", "repH (:)", "repH []"] ]+  bash-extended-with [push 'repH StrictRepH, forward ww-result-fusion, unfold-rules-unsafe ["repH ++", "repH (:)", "repH []"] ] } one-td (unfold 'absH)

@@ -1,22 +1,9 @@ Name:                hermit-Version:             0.6.0.0+Version:             0.7.0.0 Synopsis:            Haskell Equational Reasoning Model-to-Implementation Tunnel Description:-  HERMIT uses Haskell to express semi-formal models,-  efficient implementations, and provide a bridging DSL-  to describe via stepwise refinement the connection between-  these models and implementations. The key transformation-  in the bridging DSL is the worker/wrapper transformation.-  .-  This is an alpha `please give feedback' release.-  Shortcomings/gotchas include:-  .-    * Command line completion is ad hoc at the moment.-  .-    * log command prints linearly, even if command history is a tree.-  .-    * A number of rewrites don't enforce preconditions. eg: cast elimination-      always works, even if the cast is necessary+  HERMIT is a Haskell-specific toolkit designed to mechanize+  equational reasoning and program transformation during compilation in GHC.   .   Examples can be found in the examples sub-directory.   .@@ -28,12 +15,12 @@   .   @    $ hermit Reverse.hs Reverse.hss resume-   [starting HERMIT v0.6.0.0 on Reverse.hs]+   [starting HERMIT v0.7.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.6.0.0 ... linking ... done.+   Loading package hermit-0.7.0.0 ... linking ... done.    [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )    Linking Reverse ...    $ ./Reverse@@ -44,12 +31,12 @@   .   @    $ hermit Reverse.hs-   [starting HERMIT v0.6.0.0 on Reverse.hs]+   [starting HERMIT v0.7.0.0 on Reverse.hs]    % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:*:    [1 of 2] Compiling HList            ( HList.hs, HList.o )    Loading package ghc-prim ... linking ... done.    ...-   Loading package hermit-0.6.0.0 ... linking ... done.+   Loading package hermit-0.7.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@@ -95,12 +82,13 @@ License:             BSD3 License-file:        LICENSE Author:              Andrew Farmer, Andy Gill, Ed Komp, Neil Sculthorpe-Maintainer:          Andy Gill <andygill@ku.edu>-Stability:           alpha+Maintainer:          Andrew Farmer <afarmer@ittc.ku.edu>+Stability:           beta build-type:          Simple Cabal-Version:       >= 1.14  extra-source-files:+    README.md     examples/concatVanishes/ConcatVanishes.hss     examples/concatVanishes/Flatten.hs     examples/concatVanishes/Flatten.hss@@ -121,38 +109,45 @@     examples/fib-tuple/Fib.hss     examples/flatten/HList.hs     examples/flatten/Flatten.hs-    examples/flatten/Flatten.hss+    examples/flatten/Flatten.hec     examples/hanoi/Hanoi.hs     examples/hanoi/Hanoi.hss     examples/last/Last.hs     examples/last/Last.hss+    examples/last/NewLast.hss     examples/mean/Mean.hs     examples/mean/Mean.hss+    examples/nub/Nub.hs+    examples/nub/Nub.hss     examples/qsort/HList.hs     examples/qsort/QSort.hs     examples/qsort/QSort.hss     examples/reverse/HList.hs     examples/reverse/Reverse.hs     examples/reverse/Reverse.hss+    examples/new_reverse/HList.hs+    examples/new_reverse/Reverse.hs+    examples/new_reverse/Reverse.hec  Library   ghc-options: -Wall -fno-warn-orphans-  Build-Depends: base >= 4 && < 5,-                 ansi-terminal >= 0.5.5,+  Build-Depends: base                >= 4 && < 5,+                 ansi-terminal       >= 0.5.5,                  array,-                 containers >= 0.5.0.0,-                 data-default >= 0.5.0,-                 directory >= 1.2.0.0,-                 ghc >= 7.8,-                 haskeline >= 0.7.0.3,-                 kure >= 2.16.4,-                 marked-pretty >= 0.1,-                 mtl >= 2.1.2,-                 operational >= 0.2.2.1,-                 process >= 1.1.0.2,-                 stm >= 2.4,-                 temporary >= 1.2.0.3,-                 transformers+                 containers          >= 0.5.0.0,+                 data-default-class  >= 0.0.1,+                 directory           >= 1.2.0.0,+                 ghc                 >= 7.8,+                 haskeline           >= 0.7.0.3,+                 kure                >= 2.16.8,+                 marked-pretty       >= 0.1,+                 mtl                 >= 2.1.2,+                 operational         >= 0.2.2.1,+                 process             >= 1.1.0.2,+                 stm                 >= 2.4,+                 temporary           >= 1.2.0.3,+                 transformers        >= 0.2,+                 transformers-compat >= 0.4    if os(windows)     build-depends: Win32@@ -193,6 +188,7 @@        HERMIT.Dictionary.New        HERMIT.Dictionary.Query        HERMIT.Dictionary.Reasoning+       HERMIT.Dictionary.Remembered        HERMIT.Dictionary.Rules        HERMIT.Dictionary.Undefined        HERMIT.Dictionary.Unfold@@ -205,9 +201,9 @@        HERMIT.GHC        HERMIT.GHC.Typechecker        HERMIT.Kernel-       HERMIT.Kernel.Scoped        HERMIT.Kure-       HERMIT.Kure.SumTypes+       HERMIT.Kure.Universes+       HERMIT.Lemma        HERMIT.Monad        HERMIT.Name        HERMIT.Parser@@ -237,6 +233,8 @@        HERMIT.Shell.Types         HERMIT.Utilities++       HERMIT.Libraries.Int    Other-modules:        HERMIT.Syntax

@@ -35,6 +35,7 @@        , lookupHermitBinding        , lookupHermitBindingDepth        , lookupHermitBindingSite+       , inScope          -- ** Accessing GHC rewrite rules from the context        , HasCoreRules(..)          -- ** An empty Context@@ -59,7 +60,6 @@ -- | The depth of a binding.  Used, for example, to detect shadowing when inlining. type BindingDepth = Int - -- | HERMIT\'s representation of variable bindings. --   Bound expressions cannot be inlined without checking for shadowing issues (using the depth information). data HermitBindingSite = LAM                                -- ^ A lambda-bound variable.@@ -190,6 +190,11 @@ -- | Determine if a variable is bound in a context. boundIn :: ReadBindings c => Var -> c -> Bool boundIn i c = i `member` hermitBindings c++-- | Determine whether a variable is in scope.+inScope :: BoundVars c => c -> Var -> Bool+inScope c v = not (isDeadBinder v || (isLocalVar v && (v `notElemVarSet` boundVars c)))+-- Used in Dictionary.Inline and Dictionary.Fold to check if variables are in scope.  -- | Lookup the binding for a variable in a context. lookupHermitBinding :: (ReadBindings c, Monad m) => Var -> c -> m HermitBinding

@@ -1,79 +1,81 @@ {-# LANGUAGE CPP, LambdaCase #-} module HERMIT.Core-          (-          -- * Generic Data Type-            CoreProg(..)-          , CoreDef(..)-          , CoreTickish-          -- * Equality-          -- | We define both syntactic equality and alpha equality.+    ( -- * Generic Data Type+      CoreProg(..)+    , CoreDef(..)+    , CoreTickish+      -- * Equality+      -- | We define both syntactic equality and alpha equality. -          -- ** Syntactic Equality-          , progSyntaxEq-          , bindSyntaxEq-          , defSyntaxEq-          , exprSyntaxEq-          , altSyntaxEq-          , typeSyntaxEq-          , coercionSyntaxEq+      -- ** Syntactic Equality+    , progSyntaxEq+    , bindSyntaxEq+    , defSyntaxEq+    , exprSyntaxEq+    , altSyntaxEq+    , typeSyntaxEq+    , coercionSyntaxEq -          -- ** Alpha Equality-          , progAlphaEq-          , bindAlphaEq-          , defAlphaEq-          , exprAlphaEq-          , altAlphaEq-          , typeAlphaEq-          , coercionAlphaEq+      -- ** Alpha Equality+    , progAlphaEq+    , bindAlphaEq+    , defAlphaEq+    , exprAlphaEq+    , altAlphaEq+    , typeAlphaEq+    , coercionAlphaEq -          -- * Conversions to/from 'Core'-          , defsToRecBind-          , defToIdExpr-          , progToBinds-          , bindsToProg-          , bindToVarExprs+      -- * Conversions to/from 'Core'+    , defsToRecBind+    , defToIdExpr+    , progToBinds+    , bindsToProg+    , bindToVarExprs -          -- * Collecting variable bindings-          , progIds-          , bindVars-          , defId-          , altVars+      -- * Collecting variable bindings+    , progIds+    , bindVars+    , defId+    , altVars -          -- * Collecting free variables-          -- $freeVarsNote-          , freeVarsProg-          , freeVarsBind-          , freeVarsDef-          , freeVarsExpr-          , freeVarsAlt-          , freeVarsVar-          , localFreeVarsAlt-          , freeVarsType-          , freeVarsCoercion-          , localFreeVarsExpr-          , freeIdsExpr-          , localFreeIdsExpr+      -- * Collecting free variables+      -- $freeVarsNote+    , freeVarsProg+    , freeVarsBind+    , freeVarsDef+    , freeVarsExpr+    , freeVarsAlt+    , freeVarsVar+    , localFreeVarsAlt+    , freeVarsType+    , freeVarsCoercion+    , localFreeVarsExpr+    , freeIdsExpr+    , localFreeIdsExpr -          -- * Utilities-          , isCoArg-          , exprKindOrType-          , exprTypeM-          , endoFunTypeM-          , splitTyConAppM-          , splitFunTypeM-          , endoFunExprTypeM-          , funExprArgResTypesM-          , funExprsWithInverseTypes-          , appCount-          , mapAlts+      -- * Utilities+    , isCoArg+    , exprKindOrType+    , exprTypeM+    , endoFunTypeM+    , splitTyConAppM+    , splitFunTypeM+    , endoFunExprTypeM+    , funExprArgResTypesM+    , funExprsWithInverseTypes+    , appCount+    , mapAlts+    , substCoreAlt+    , substCoreExpr+    , betaReduceAll+    , mkDataConApp -          -- * Crumbs-          , Crumb(..)-          , showCrumbs---          , crumbToDeprecatedInt-          , deprecatedLeftSibling-          , deprecatedRightSibling-) where+      -- * Crumbs+    , Crumb(..)+    , showCrumbs+    , leftSibling+    , rightSibling+    ) where  import Control.Monad ((>=>)) @@ -277,24 +279,39 @@ -- The GHC Function exprFreeVars defined in "CoreFVs" only returns *locally-defined* free variables. -- In HERMIT, this is typically not what we want, so we define our own functions. -- We reuse some of the functionality in "CoreFVs", but alas much of it is not exposed, so we have to reimplement some of it.---- | Find all free variables in an expression.-freeVarsExpr :: CoreExpr -> VarSet-freeVarsExpr = exprSomeFreeVars (const True)+-- We do not use GHC's exprSomeFreeVars because it does not return the full set of free vars for a Var.+-- It only returns the Var itself, rather than extendVarSet (freeVarsVar v) v like it should.  -- | Find all free identifiers in an expression. freeIdsExpr :: CoreExpr -> IdSet-freeIdsExpr = exprSomeFreeVars isId+freeIdsExpr = filterVarSet isId . freeVarsExpr  -- | Find all locally defined free variables in an expression. localFreeVarsExpr :: CoreExpr -> VarSet-localFreeVarsExpr = exprSomeFreeVars isLocalVar+localFreeVarsExpr = filterVarSet isLocalVar . freeVarsExpr  -- | Find all locally defined free identifiers in an expression. localFreeIdsExpr :: CoreExpr -> VarSet-localFreeIdsExpr = exprSomeFreeVars isLocalId+localFreeIdsExpr = filterVarSet isLocalId . freeVarsExpr +-- | Find all free variables in an expression.+freeVarsExpr :: CoreExpr -> VarSet+freeVarsExpr (Var v) = extendVarSet (freeVarsVar v) v+freeVarsExpr (Lit {}) = emptyVarSet+freeVarsExpr (App e1 e2) = freeVarsExpr e1 `unionVarSet` freeVarsExpr e2+freeVarsExpr (Lam b e) = delVarSet (freeVarsExpr e) b+freeVarsExpr (Let b e) = freeVarsBind b `unionVarSet` delVarSetList (freeVarsExpr e) (bindersOf b)+freeVarsExpr (Case s b ty alts) = let altFVs = delVarSet (unionVarSets $ map freeVarsAlt alts) b+                                  in unionVarSets [freeVarsExpr s, freeVarsType ty, altFVs]+freeVarsExpr (Cast e co) = freeVarsExpr e `unionVarSet` freeVarsCoercion co+freeVarsExpr (Tick t e) = freeVarsTick t `unionVarSet` freeVarsExpr e+freeVarsExpr (Type ty) = freeVarsType ty+freeVarsExpr (Coercion co) = freeVarsCoercion co +freeVarsTick :: Tickish Id -> VarSet+freeVarsTick (Breakpoint _ ids) = mkVarSet ids+freeVarsTick _ = emptyVarSet+ -- | Find all free identifiers in a binding group, which excludes any variables bound in the group. freeVarsBind :: CoreBind -> VarSet freeVarsBind (NonRec v e) = freeVarsExpr e `unionVarSet` freeVarsVar v@@ -448,10 +465,14 @@            | NthCo_Int | NthCo_Co            | InstCo_Co | InstCo_Type            | LRCo_LR | LRCo_Co+           -- Quantified+           | Forall_Body+           | Conj_Lhs | Conj_Rhs+           | Disj_Lhs | Disj_Rhs+           | Impl_Lhs | Impl_Rhs+           | Eq_Lhs | Eq_Rhs            deriving (Eq,Read,Show)-           -- TODO: Write a prettier Show instance - showCrumbs :: [Crumb] -> String showCrumbs crs = "[" ++ intercalate ", " (map showCrumb crs) ++ "]" @@ -501,65 +522,70 @@                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."+               -- Quantified+               Forall_Body -> "forall-body"+               Conj_Lhs    -> "conj-lhs"+               Conj_Rhs    -> "conj-rhs"+               Disj_Lhs    -> "disj-lhs"+               Disj_Rhs    -> "disj-rhs"+               Impl_Lhs    -> "antecedent"+               Impl_Rhs    -> "consequent"+               Eq_Lhs      -> "eq-lhs"+               Eq_Rhs      -> "eq-rhs"+               _ -> "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+--   This is used for moving 'left' in the shell.+leftSibling :: Crumb -> Maybe Crumb+leftSibling = \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-+--   This is used for moving 'right' in the shell.+rightSibling :: Crumb -> Maybe Crumb+rightSibling = \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  -----------------------------------------------------------------------++-- | Substitute all occurrences of a variable with an expression, in an expression.+substCoreExpr :: Var -> CoreExpr -> (CoreExpr -> CoreExpr)+substCoreExpr v e expr = substExpr (text "substCoreExpr") (extendSubst emptySub v e) expr+    where emptySub = mkEmptySubst (mkInScopeSet (localFreeVarsExpr (Let (NonRec v e) expr)))++-- | Substitute all occurrences of a variable with an expression, in a case alternative.+substCoreAlt :: Var -> CoreExpr -> CoreAlt -> CoreAlt+substCoreAlt v e alt = let (con, vs, rhs) = alt+                           inS            = (flip delVarSet v . unionVarSet (localFreeVarsExpr e) . localFreeVarsAlt) alt+                           subst          = extendSubst (mkEmptySubst (mkInScopeSet inS)) v e+                           (subst', vs')  = substBndrs subst vs+                        in (con, vs', substExpr (text "alt-rhs") subst' rhs)++-- | Beta-reduce as many lambda-binders as possible.+betaReduceAll :: CoreExpr -> [CoreExpr] -> (CoreExpr, [CoreExpr])+betaReduceAll (Lam v body) (a:as) = betaReduceAll (substCoreExpr v a body) as+betaReduceAll e            as     = (e,as)++-- | Build a constructor application.+--   Accepts a list of types to which the type constructor is instantiated. Ex.+--+-- > data T a b = C a b Int+--+-- Pseudocode:+--+-- > mkDataConApp [a',b'] C [x,y,z] ==> C a' b' (x::a') (y::b') (z::Int) :: T a' b'+--+mkDataConApp :: [Type] -> DataCon -> [Var] -> CoreExpr+mkDataConApp tys dc vs = mkCoreConApps dc (map Type tys ++ map (varToCoreExpr . zapVarOccInfo) vs)

@@ -16,6 +16,7 @@     , module HERMIT.Dictionary.New     , module HERMIT.Dictionary.Query     , module HERMIT.Dictionary.Reasoning+    , module HERMIT.Dictionary.Remembered     , module HERMIT.Dictionary.Rules     , module HERMIT.Dictionary.Undefined     , module HERMIT.Dictionary.Unfold@@ -57,6 +58,8 @@ import qualified HERMIT.Dictionary.Query as Query import           HERMIT.Dictionary.Reasoning hiding (externals) import qualified HERMIT.Dictionary.Reasoning as Reasoning+import           HERMIT.Dictionary.Remembered hiding (externals)+import qualified HERMIT.Dictionary.Remembered as Remembered import           HERMIT.Dictionary.Rules hiding (externals) import qualified HERMIT.Dictionary.Rules as Rules import           HERMIT.Dictionary.Undefined hiding (externals)@@ -71,7 +74,12 @@ import qualified HERMIT.Dictionary.WorkerWrapper.Fix as WorkerWrapperFix import           HERMIT.Dictionary.WorkerWrapper.FixResult hiding (externals) import qualified HERMIT.Dictionary.WorkerWrapper.FixResult as WorkerWrapperFixResult+-------------------------------------------------------------------------- +import qualified HERMIT.PrettyPrinter.AST as AST+import qualified HERMIT.PrettyPrinter.Clean as Clean+import qualified HERMIT.PrettyPrinter.GHC as GHCPP+ --------------------------------------------------------------------------  -- | List of all 'External's provided by HERMIT.@@ -91,6 +99,7 @@     ++ New.externals     ++ Query.externals     ++ Reasoning.externals+    ++ Remembered.externals     ++ Rules.externals     ++ Undefined.externals     ++ Unfold.externals@@ -98,5 +107,8 @@     ++ WorkerWrapperCommon.externals     ++ WorkerWrapperFix.externals     ++ WorkerWrapperFixResult.externals+    ++ AST.externals+    ++ Clean.externals+    ++ GHCPP.externals  --------------------------------------------------------------------------

@@ -54,33 +54,33 @@ -- | Externals for alpha-renaming. externals :: [External] externals = map (.+ Deep)-         [  external "alpha" (alphaR :: RewriteH Core)+         [  external "alpha" (promoteCoreR alphaR :: RewriteH LCore)                [ "Renames the bound variables at the current node."]-         ,  external "alpha-lam" (promoteExprR . alphaLamR . Just :: String -> RewriteH Core)+         ,  external "alpha-lam" (promoteExprR . alphaLamR . Just :: String -> RewriteH LCore)                [ "Renames the bound variable in a Lambda expression to the given name."]-         ,  external "alpha-lam" (promoteExprR  (alphaLamR Nothing) :: RewriteH Core)+         ,  external "alpha-lam" (promoteExprR  (alphaLamR Nothing) :: RewriteH LCore)                [ "Renames the bound variable in a Lambda expression."]-         ,  external "alpha-case-binder" (promoteExprR . alphaCaseBinderR . Just :: String -> RewriteH Core)+         ,  external "alpha-case-binder" (promoteExprR . alphaCaseBinderR . Just :: String -> RewriteH LCore)                [ "Renames the binder in a Case expression to the given name."]-         ,  external "alpha-case-binder" (promoteExprR (alphaCaseBinderR Nothing) :: RewriteH Core)+         ,  external "alpha-case-binder" (promoteExprR (alphaCaseBinderR Nothing) :: RewriteH LCore)                [ "Renames the binder in a Case expression."]-         ,  external "alpha-alt" (promoteAltR alphaAltR :: RewriteH Core)+         ,  external "alpha-alt" (promoteAltR alphaAltR :: RewriteH LCore)                [ "Renames all binders in a Case alternative."]-         ,  external "alpha-alt" (promoteAltR . alphaAltWithR :: [String] -> RewriteH Core)+         ,  external "alpha-alt" (promoteAltR . alphaAltWithR :: [String] -> RewriteH LCore)                [ "Renames all binders in a Case alternative using the user-provided list of new names."]-         ,  external "alpha-case" (promoteExprR alphaCaseR :: RewriteH Core)+         ,  external "alpha-case" (promoteExprR alphaCaseR :: RewriteH LCore)                [ "Renames all binders in a Case alternative."]-         ,  external "alpha-let" (promoteExprR . alphaLetWithR :: [String] -> RewriteH Core)+         ,  external "alpha-let" (promoteExprR . alphaLetWithR :: [String] -> RewriteH LCore)                [ "Renames the bound variables in a Let expression using a list of suggested names."]-         ,  external "alpha-let" (promoteExprR alphaLetR :: RewriteH Core)+         ,  external "alpha-let" (promoteExprR alphaLetR :: RewriteH LCore)                [ "Renames the bound variables in a Let expression."]-         ,  external "alpha-top" (promoteProgR . alphaProgConsWithR :: [String] -> RewriteH Core)+         ,  external "alpha-top" (promoteProgR . alphaProgConsWithR :: [String] -> RewriteH LCore)                [ "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 alphaProgConsR :: RewriteH Core)+         ,  external "alpha-top" (promoteProgR alphaProgConsR :: RewriteH LCore)                [ "Renames the bound identifiers in the top-level binding at the head of the program."]-         ,  external "alpha-prog" (promoteProgR alphaProgR :: RewriteH Core)+         ,  external "alpha-prog" (promoteProgR alphaProgR :: RewriteH LCore)                [ "Rename all top-level identifiers in the program."]-         ,  external "unshadow" (unshadowR :: RewriteH Core)+         ,  external "unshadow" (promoteCoreR unshadowR :: RewriteH LCore)                 [ "Rename local variables with manifestly unique names (x, x0, x1, ...)."]          ] @@ -99,7 +99,8 @@  -- | Collect all visible variables (in the expression or the context). visibleVarsT :: (BoundVars c, Monad m) => Transform c m CoreTC VarSet-visibleVarsT = liftM2 unionVarSet boundVarsT (arr freeVarsCoreTC)+visibleVarsT = -- TODO: implement freeVarsLCoreTC+               liftM2 unionVarSet boundVarsT (promoteT $ arr freeVarsCoreTC)  -- | If a name is provided, use that as the name of the new variable. --   Otherwise modify the variable name making sure to /not/ clash with the given variables or any visible variables.@@ -403,6 +404,8 @@ --       Though really, we first need to improve KURE to have a version of (<+) that maintains the existing error message in the case of non-matching constructors henceforth.  -- TODO 2: Also, we should be able to rename inside types and coercions.++-- TODO 3: Also, we should be able to rename lemma quantifiers  ----------------------------------------------------------------------- 

@@ -36,7 +36,6 @@     , varBindingDepthT     , varIsOccurrenceOfT     , exprIsOccurrenceOfT-    , inScope     , withVarsInScope       -- Miscellaneous     , wrongExprForm@@ -91,9 +90,9 @@  -- | Succeeds if we are looking at a fully saturated function call. callSaturatedT :: Monad m => Transform 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.+callSaturatedT = callPredT (\ i args -> let (tvs, ty) = splitForAllTys (varType i)+                                            (bs,_) = splitFunTys ty+                                        in (length tvs + length bs) == length args)  -- | Succeeds if we are looking at an application of given function callNameG :: MonadCatch m => HermitName -> Transform c m CoreExpr ()@@ -213,19 +212,6 @@ findTypeT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)           => HermitName -> Transform c m a Type findTypeT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findType nm)---- TODO: "inScope" was defined elsewhere, but I've moved it here.  Should it be combined with the above functions?--- Used in Dictionary.Inline to check if variables an in scope.--- Used in Dictionary.Fold---- | Determine whether a variable is in scope.-inScope :: ReadBindings c => c -> Var -> Bool-inScope c v = (v `boundIn` c) ||                 -- defined in this module-              (isId v &&                         -- idInfo panics on TyVars-               case unfoldingInfo (idInfo v) of-                CoreUnfolding {} -> True         -- defined elsewhere-                DFunUnfolding {} -> True-                _                -> False)  -- | Modify transformation to apply to current expression as if it were the body of a lambda binding the given variables. withVarsInScope :: (AddBindings c, ReadPath c Crumb) => [Var] -> Transform c m a b -> Transform c m a b

@@ -14,6 +14,7 @@     ) where  import Control.Arrow+import Control.Monad  import Data.String (fromString) @@ -25,6 +26,7 @@ import HERMIT.Monad import HERMIT.Name +import HERMIT.Dictionary.Common import HERMIT.Dictionary.Debug hiding (externals) import HERMIT.Dictionary.GHC hiding (externals) import HERMIT.Dictionary.Inline hiding (externals)@@ -35,24 +37,24 @@  externals ::  [External] externals =-    [ external "unfold-basic-combinator" (promoteExprR unfoldBasicCombinatorR :: RewriteH Core)+    [ external "unfold-basic-combinator" (promoteExprR unfoldBasicCombinatorR :: RewriteH LCore)         [ "Unfold the current expression if it is one of the basic combinators:"         , "($), (.), id, flip, const, fst, snd, curry, and uncurry." ]-    , external "simplify" (simplifyR :: RewriteH Core)+    , external "simplify" (simplifyR :: RewriteH LCore)         [ "innermost (unfold-basic-combinator <+ beta-reduce-plus <+ safe-let-subst <+ case-reduce <+ let-elim)" ]-    , external "bash" (bashR :: RewriteH Core)+    , external "bash" (bashR :: RewriteH LCore)         bashHelp .+ Eval .+ Deep .+ Loop-    , external "smash" (smashR :: RewriteH Core)+    , external "smash" (smashR :: RewriteH LCore)         smashHelp .+ Eval .+ Deep .+ Loop .+ Experiment-    , external "bash-extended-with" (bashExtendedWithR :: [RewriteH Core] -> RewriteH Core)+    , external "bash-extended-with" (bashExtendedWithR :: [RewriteH LCore] -> RewriteH LCore)         [ "Run \"bash\" extended with additional rewrites.",           "Note: be sure that the new rewrite either fails or makes progress, else this may loop."         ] .+ Eval .+ Deep .+ Loop-    , external "smash-extended-with" (smashExtendedWithR :: [RewriteH Core] -> RewriteH Core)+    , external "smash-extended-with" (smashExtendedWithR :: [RewriteH LCore] -> RewriteH LCore)         [ "Run \"smash\" extended with additional rewrites.",           "Note: be sure that the new rewrite either fails or makes progress, else this may loop."         ] .+ Eval .+ Deep .+ Loop-    , external "bash-debug" (bashDebugR :: RewriteH Core)+    , external "bash-debug" (bashDebugR :: RewriteH LCore)         [ "verbose bash - most useful with set-auto-corelint True" ] .+ Eval .+ Deep .+ Loop     ] @@ -67,11 +69,13 @@ unfoldBasicCombinatorR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb                           , MonadCatch m )                        => Rewrite c m CoreExpr-unfoldBasicCombinatorR = setFailMsg "unfold-basic-combinator failed." $ unfoldNamesR basicCombinators+unfoldBasicCombinatorR = setFailMsg "unfold-basic-combinator failed." $ orR (map f basicCombinators)+    where f nm = voidM (callNameT nm) >> voidM callSaturatedT >> unfoldR+          voidM = liftM (const ()) -- can't wait for AMP  simplifyR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb              , MonadCatch m, MonadUnique m )-          => Rewrite c m Core+          => Rewrite c m LCore simplifyR = setFailMsg "Simplify failed: nothing to simplify." $     innermostR (   promoteBindR recToNonrecR                 <+ promoteExprR ( unfoldBasicCombinatorR@@ -91,13 +95,13 @@ -- IdInfo attributes relied-upon by GHC. bashR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb          , MonadCatch m, MonadUnique m )-      => Rewrite c m Core+      => Rewrite c m LCore bashR = bashExtendedWithR []  -- | An extensible bash. Given rewrites are performed before normal bash rewrites. bashExtendedWithR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb                      , MonadCatch m, MonadUnique m )-                  => [Rewrite c m Core] -> Rewrite c m Core+                  => [Rewrite c m LCore] -> Rewrite c m LCore bashExtendedWithR rs = bashUsingR (rs ++ map fst bashComponents)  -- | Like 'bashR', but outputs name of each successful sub-rewrite, providing a log.@@ -107,13 +111,13 @@ -- Useful for debugging the bash command itself. bashDebugR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb               , HasDebugChan m, HasDynFlags m, MonadCatch m, MonadUnique m )-           => Rewrite c m Core+           => Rewrite c m LCore bashDebugR = bashUsingR [ bracketR nm r >>> catchM (promoteT lintExprT >> idR) traceR                         | (r,nm) <- bashComponents ]  -- | Perform the 'bash' algorithm with a given list of rewrites. bashUsingR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb, MonadCatch m)-           => [Rewrite c m Core] -> Rewrite c m Core+           => [Rewrite c m LCore] -> Rewrite c m LCore bashUsingR rs = setFailMsg "bash failed: nothing to do." $     repeatR (occurAnalyseR >>> onetdR (catchesT rs)) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR @@ -134,12 +138,12 @@  bashHelp :: [String] bashHelp = "Iteratively apply the following rewrites until nothing changes:"-         : map snd (bashComponents :: [(RewriteH Core,String)] -- to resolve ambiguity+         : map snd (bashComponents :: [(RewriteH LCore,String)] -- to resolve ambiguity                                                                                        ) -- TODO: Think about a good order for bash. bashComponents :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb                   , MonadCatch m, MonadUnique m )-               => [(Rewrite c m Core, String)]+               => [(Rewrite c m LCore, String)] bashComponents =   [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr")    -- ??     (promoteExprR betaReduceR, "beta-reduce")                        -- O(1)@@ -176,16 +180,16 @@ -- and is intended for use during proving tasks. smashR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb           , MonadCatch m, MonadUnique m )-       => Rewrite c m Core+       => Rewrite c m LCore smashR = smashExtendedWithR []  smashExtendedWithR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb                       , MonadCatch m, MonadUnique m )-                   => [Rewrite c m Core] -> Rewrite c m Core+                   => [Rewrite c m LCore] -> Rewrite c m LCore smashExtendedWithR rs = smashUsingR (rs ++ map fst smashComponents1) (map fst smashComponents2)  -smashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => [Rewrite c m Core] -> [Rewrite c m Core] -> Rewrite c m Core+smashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => [Rewrite c m LCore] -> [Rewrite c m LCore] -> Rewrite c m LCore smashUsingR rs1 rs2 =     setFailMsg "smash failed: nothing to do." $     repeatR (occurAnalyseR >>> (onetdR (catchesT rs1) <+ onetdR (catchesT rs2))) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR@@ -193,14 +197,14 @@  smashHelp :: [String] smashHelp = "A more powerful but less efficient version of \"bash\", intended for use while proving lemmas.  Iteratively apply the following rewrites until nothing changes:" : map snd (smashComponents1 ++ smashComponents2-                                                                                           :: [(RewriteH Core,String)] -- to resolve ambiguity+                                                                                           :: [(RewriteH LCore,String)] -- to resolve ambiguity                                                                                         )   -- | As bash, but with "let-nonrec-subst" instead of "let-nonrec-subst-safe". smashComponents1 :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb                     , MonadCatch m, MonadUnique m )-                 => [(Rewrite c m Core, String)]+                 => [(Rewrite c m LCore, String)] smashComponents1 =   [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr")    -- ??     (promoteExprR betaReduceR, "beta-reduce")                        -- O(1)@@ -226,12 +230,14 @@   , (promoteProgR letFloatTopR, "let-float-top")                     -- O(n)   , (promoteExprR castElimReflR, "cast-elim-refl")                   -- O(1)   , (promoteExprR castElimSymR, "cast-elim-sym")                     -- O(1)+  , (promoteExprR castFloatAppR, "cast-float-app")                   -- O(1)+  , (promoteExprR castFloatLamR, "cast-float-lam")                   -- O(1) --  , (promoteExprR dezombifyR, "dezombify")                           -- O(1) -- performed at the end   ]  smashComponents2 :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c                     , MonadCatch m, MonadUnique m )-                 => [(Rewrite c m Core, String)]+                 => [(Rewrite c m LCore, String)] smashComponents2 =     [ (promoteExprR caseElimMergeAltsR, "case-elim-merge-alts") -- do this last, lest it prevent other simplifications     ]

@@ -19,23 +19,23 @@ -- | Exposed debugging 'External's. externals :: [External] externals = map (.+ Debug)-    [ external "trace" (traceR :: String -> RewriteH Core)+    [ external "trace" (traceR :: String -> RewriteH LCoreTC)         [ "give a side-effect message as output when processing this command" ]-    , external "observe" (observeR :: String -> RewriteH Core)+    , external "observe" (observeR :: String -> RewriteH LCoreTC)         [ "give a side-effect message as output, and observe the value being processed" ]-    , external "observe-failure" (observeFailureR :: String -> RewriteH Core -> RewriteH Core)+    , external "observe-failure" (observeFailureR :: String -> RewriteH LCoreTC -> RewriteH LCoreTC)         [ "give a side-effect message if the rewrite fails, including the failing input" ]-    , external "bracket" (bracketR :: String -> RewriteH Core -> RewriteH Core)+    , external "bracket" (bracketR :: String -> RewriteH LCoreTC -> RewriteH LCoreTC)         [ "if given rewrite succeeds, see its input and output" ]     ]  -- | If the 'Rewrite' fails, print out the 'Core', with a message.-observeFailureR :: (Injection a CoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, MonadCatch m)+observeFailureR :: (Injection a LCoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, MonadCatch m)                 => String -> Rewrite c m a -> Rewrite c m a observeFailureR str m = m <+ observeR str  -- | Print out the 'Core', with a message.-observeR :: (Injection a CoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, Monad m)+observeR :: (Injection a LCoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, Monad m)          => String -> Rewrite c m a observeR msg = extractR $ sideEffectR $ \ cxt -> sendDebugMessage . DebugCore msg cxt @@ -44,7 +44,7 @@ traceR msg = sideEffectR $ \ _ _ -> sendDebugMessage $ DebugTick msg  -- | Show before and after a rewrite.-bracketR :: (Injection a CoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, MonadCatch m)+bracketR :: (Injection a LCoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, MonadCatch m)          => String -> Rewrite c m a -> Rewrite c m a bracketR msg rr = do     -- Be careful to only run the rr once, in case it has side effects.@@ -53,4 +53,3 @@                             return e' >>> observeR after) r     where before = msg ++ " (before)"           after  = msg ++ " (after)"--- attemptM :: MonadCatch m => m a -> m (Either String a)

@@ -14,7 +14,6 @@     , isFixExprT     ) where -import Control.Applicative import Control.Arrow import Control.Monad import Control.Monad.IO.Class@@ -43,21 +42,21 @@ -- | Externals for manipulating fixed points. externals ::  [External] externals =-    [ external "fix-intro" (fixIntroR :: RewriteH Core)+    [ external "fix-intro" (promoteCoreR fixIntroR :: RewriteH LCore)         [ "rewrite a function binding into a non-recursive binding using fix" ] .+ Introduce .+ Context-    , external "fix-computation-rule" (promoteExprBiR fixComputationRuleBR :: BiRewriteH Core)+    , external "fix-computation-rule" (promoteExprBiR fixComputationRuleBR :: BiRewriteH LCore)         [ "Fixed-Point Computation Rule",           "fix t f  <==>  f (fix t f)"         ] .+ Context-    , external "fix-rolling-rule" (promoteExprBiR fixRollingRuleBR :: BiRewriteH Core)+    , external "fix-rolling-rule" (promoteExprBiR fixRollingRuleBR :: BiRewriteH LCore)         [ "Rolling Rule",           "fix tyA (\\ a -> f (g a))  <==>  f (fix tyB (\\ b -> g (f b))"         ] .+ Context     , external "fix-fusion-rule" ((\ f g h r1 r2 strictf -> promoteExprBiR                                                                 (fixFusionRule (Just (r1,r2)) (Just strictf) f g h))                                                                 :: CoreString -> CoreString -> CoreString-                                                                    -> RewriteH Core -> RewriteH Core-                                                                    -> RewriteH Core -> BiRewriteH Core)+                                                                    -> RewriteH LCore -> RewriteH LCore+                                                                    -> RewriteH LCore -> BiRewriteH LCore)         [ "Fixed-point Fusion Rule"         , "Given f :: A -> B, g :: A -> A, h :: B -> B, and"         , "proofs that, for some x, (f (g a) ==> x) and (h (f a) ==> x) and that f is strict, then"@@ -65,7 +64,7 @@         ] .+ Context     , external "fix-fusion-rule-unsafe" ((\ f g h r1 r2 -> promoteExprBiR (fixFusionRule (Just (r1,r2)) Nothing f g h))                                                             :: CoreString -> CoreString -> CoreString-                                                                -> RewriteH Core -> RewriteH Core -> BiRewriteH Core)+                                                                -> RewriteH LCore -> RewriteH LCore -> BiRewriteH LCore)         [ "(Unsafe) Fixed-point Fusion Rule"         , "Given f :: A -> B, g :: A -> A, h :: B -> B, and"         , "a proof that, for some x, (f (g a) ==> x) and (h (f a) ==> x), then"@@ -73,7 +72,7 @@         , "Note that the precondition that f is strict is required to hold."         ] .+ Context .+ PreCondition     , external "fix-fusion-rule-unsafe" ((\ f g h -> promoteExprBiR (fixFusionRule Nothing Nothing f g h))-                                                        :: CoreString -> CoreString -> CoreString -> BiRewriteH Core)+                                                        :: CoreString -> CoreString -> CoreString -> BiRewriteH LCore)         [ "(Very Unsafe) Fixed-point Fusion Rule"         , "Given f :: A -> B, g :: A -> A, h :: B -> B, then"         , "f (fix g) <==> fix h"@@ -216,7 +215,7 @@                        App f <$> buildFixT g  -- | If @f@ is strict, then (@f (g a)@ == @h (f a)@)  ==>  (@f (fix g)@ == @fix h@)-fixFusionRule :: Maybe (RewriteH Core, RewriteH Core) -> Maybe (RewriteH Core) -> CoreString -> CoreString -> CoreString -> BiRewriteH CoreExpr+fixFusionRule :: Maybe (RewriteH LCore, RewriteH LCore) -> Maybe (RewriteH LCore) -> CoreString -> CoreString -> CoreString -> BiRewriteH CoreExpr fixFusionRule meq mfstrict = parse3beforeBiR $ fixFusionRuleBR ((extractR *** extractR) <$> meq) (extractR <$> mfstrict)  --------------------------------------------------------------------------------------------------

@@ -1,42 +1,61 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-} module HERMIT.Dictionary.Fold     ( -- * Fold/Unfold Transformation       externals     , foldR     , foldVarR-    , stashFoldR-    , stashFoldAnyR+    , foldVarConfigR+    , runFoldR       -- * Unlifted fold interface-    , fold-    , unifyTypes -- TODO: remove in favor of GHC's unification-    , tyMatchesToCoreExpr+    , fold, compileFold, runFold, runFoldMatches, CompiledFold+    , proves -- for now+    , lemmaMatch+      -- * Equality+    , Equality(..)+    , toEqualities+    , flipEquality+    , freeVarsEquality+    , ppEqualityT     ) where  import Control.Arrow-import Control.Applicative import Control.Monad import Control.Monad.IO.Class -import qualified Data.Map as Map+import Data.List (delete, (\\), intersect)+import qualified Data.Map as M+import Data.Maybe (catMaybes, fromMaybe, maybeToList)+import qualified Data.IntMap.Lazy as I+import Data.Typeable  import HERMIT.Core import HERMIT.Context import HERMIT.External import HERMIT.GHC import HERMIT.Kure+import HERMIT.Lemma import HERMIT.Monad import HERMIT.Name+import HERMIT.Utilities -import HERMIT.Dictionary.Common (varBindingDepthT,inScope,findIdT)+import HERMIT.Dictionary.Common (varBindingDepthT,findIdT) import HERMIT.Dictionary.Inline hiding (externals) +import HERMIT.PrettyPrinter.Common+import qualified Text.PrettyPrint.MarkedHughesPJ as PP+ import Prelude hiding (exp)  ------------------------------------------------------------------------  externals :: [External] externals =-    [ external "fold" (promoteExprR . foldR :: HermitName -> RewriteH Core)+    [ external "fold" (promoteExprR . foldR :: HermitName -> RewriteH LCore)         [ "fold a definition"         , ""         , "double :: Int -> Int"@@ -48,208 +67,580 @@         , ""         , "Note: due to associativity, if you wanted to fold 5 + 6 + 6, "         , "you first need to apply an associativity rewrite." ]  .+ Context .+ Deep-    , external "fold-remembered" (promoteExprR . stashFoldR :: RememberedName -> RewriteH Core)-        [ "Fold a remembered definition." ]                      .+ Context .+ Deep-    , external "fold-any" (promoteExprR stashFoldAnyR :: RewriteH Core)-        [ "Attempt to fold any of the remembered definitions." ] .+ Context .+ Deep     ]  ------------------------------------------------------------------------ -stashFoldR :: (ReadBindings c, HasStash m, MonadCatch m) => RememberedName -> Rewrite c m CoreExpr-stashFoldR label = prefixFailMsg "Fold failed: " $-    transform $ \ c e -> do-        Def i rhs <- lookupDef label-        guardMsg (inScope c i) $ unqualifiedName i ++ " is not in scope.\n(A common cause of this error is trying to fold a recursive call while being in the body of a non-recursive definition.  This can be resolved by calling \"nonrec-to-rec\" on the non-recursive binding group.)"-        maybe (fail "no match.")-              return-              (fold i rhs e)--stashFoldAnyR :: (ReadBindings c, HasStash m, MonadCatch m) => Rewrite c m CoreExpr-stashFoldAnyR = setFailMsg "Fold failed: no definitions could be folded." $-                catchesM =<< liftM (map stashFoldR) (liftM Map.keys (constT getStash))- foldR :: (ReadBindings c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m)       => HermitName -> Rewrite c m CoreExpr foldR nm = prefixFailMsg "Fold failed: " $ findIdT nm >>= foldVarR Nothing  foldVarR :: (ReadBindings c, MonadCatch m, MonadUnique m) => Maybe BindingDepth -> Var -> Rewrite c m CoreExpr-foldVarR md v = do+foldVarR = foldVarConfigR AllBinders++foldVarConfigR :: (ReadBindings c, MonadCatch m, MonadUnique m)+               => InlineConfig -> Maybe BindingDepth -> Var -> Rewrite c m CoreExpr+foldVarConfigR config md v = do     case md of         Nothing    -> return ()         Just depth -> do depth' <- varBindingDepthT v                          guardMsg (depth == depth') "Specified binding depth does not match that of variable binding, this is probably a shadowing occurrence."-    e <- idR-    (rhs,_) <- getUnfoldingT AllBinders <<< return v-    maybe (fail "no match.") return (fold v rhs e)+    rhss <- liftM (map fst) $ getUnfoldingsT config <<< return v+    transform $ \ c -> maybeM "no match." . fold [mkEquality [] rhs (varToCoreExpr v) | rhs <- rhss] c +-- | Rewrite using a compiled fold. Useful inside traversal strategies like+-- anytdR, because you can compile the fold once outside the traversal, then+-- apply it everywhere in the tree.+runFoldR :: (BoundVars c, Monad m) => CompiledFold -> Rewrite c m CoreExpr+runFoldR compiled = transform $ \c -> maybeM "no match." . runFold compiled c+ ------------------------------------------------------------------------ -countBinders :: CoreExpr -> Int-countBinders e = length vs-    where (vs,_) = collectBinders e+newtype CompiledFold = CompiledFold (EMap ([Var], CoreExpr)) -collectNBinders :: Int -> CoreExpr -> Maybe ([Var], CoreExpr)-collectNBinders = go []-  where-    go bs 0 e         = return (reverse bs, e)-    go bs i (Lam b e) = go (b:bs) (i-1) e-    go _ _  _         = Nothing+-- | Attempt to apply a list of Equalitys to the given expression, folding the+-- left-hand side into an application of the right-hand side. This+-- implementation depends on `Equality` being well-formed. That is, both the+-- LHS and RHS are NOT lambda expressions. Always use `mkEquality` to ensure+-- this is the case.+fold :: BoundVars c => [Equality] -> c -> CoreExpr -> Maybe CoreExpr+fold = runFold . compileFold -unifyHoles :: Ord k-           => [k]              -- keys we care about (TODO: figure out what else is getting in there)-           -> (a -> a -> Bool) -- notion of equality-           -> [(k,a)]          -- list of key/values-           -> Maybe [(k,a)]    -- list of unified key/values, or failure-unifyHoles vs eq kvs = do-    -- return Nothing if not equal, so sequence will fail below-    let checkEqual m1 m2 = ifM (eq <$> m1 <*> m2) m1 Nothing-        m = Map.fromListWith checkEqual [(k,Just v) | (k,v) <- kvs ]+-- | Compile a list of Equality's into a single fold matcher.+compileFold :: [Equality] -> CompiledFold+compileFold = CompiledFold . foldr addFold fEmpty+    where addFold (Equality vs lhs rhs) =+            let hs = vs `intersect` varSetElems (freeVarsExpr lhs)+            in insertFold emptyAlphaEnv vs lhs (hs, rhs) -    es <- sequence [ join (Map.lookup v m) | v <- vs ]-    return $ zip vs es+-- | Attempt to fold an expression using a matcher in a given context.+runFold :: BoundVars c => CompiledFold -> c -> CoreExpr -> Maybe CoreExpr+runFold f c e = fst <$> runFoldMatches f c e -fold :: Id -> CoreExpr -> CoreExpr -> Maybe CoreExpr-fold i lam exp = do-    (vs,body) <- collectNBinders (countBinders lam - countBinders exp) lam-    al <- foldMatch vs [] body exp+-- | Attempt to fold an expression using a matcher in a given context.+-- Return resulting expression and a map of what when in the holes in the pattern.+runFoldMatches :: BoundVars c => CompiledFold -> c -> CoreExpr -> Maybe (CoreExpr, VarEnv CoreExpr)+runFoldMatches (CompiledFold f) c exp = do+    (hs, (vs', rhs')) <- soleElement $ filterOutOfScope c $ findFold exp f+    args <- sequence [ lookupVarEnv hs v | v <- vs' ]+    return (uncurry mkCoreApps $ betaReduceAll (mkCoreLams vs' rhs') args, hs) -    es <- liftM (map snd) $ unifyHoles vs exprAlphaEq al+insertFold :: Fold m => AlphaEnv -> [Var] -> Key m -> a -> m a -> m a+insertFold env vs k x = fAlter env vs k (const (Just x)) -    return $ mkCoreApps (varToCoreExpr i) es+findFold :: Fold m => Key m -> m a -> [(VarEnv CoreExpr, a)]+findFold = fFold emptyVarEnv emptyAlphaEnv --- Note: Var in the concrete instance is first--- (not the Var found in the definition we are trying to fold).-addAlpha :: Var -> Var -> [(Var,Var)] -> [(Var,Var)]-addAlpha rId lId alphas | rId == lId = alphas-                        | otherwise  = (rId,lId) : alphas+filterOutOfScope :: BoundVars c => c -> [(VarEnv CoreExpr, ([Var], CoreExpr))] -> [(VarEnv CoreExpr, ([Var], CoreExpr))]+filterOutOfScope c = go+    where go [] = []+          go (x@(_,(vs,e)):r)+            | isEmptyVarSet (filterVarSet (not . inScope c) (delVarSetList (freeVarsExpr e) vs)) = x : go r+            | otherwise = go r -matchWithTypes :: [Var] -> [(Var,Var)] -> Id -> CoreExpr -> Maybe [(Var,CoreExpr)]-matchWithTypes vs as i e = do-    tys <- foldMatchType vs as (idType i) (exprType e)-    return $ (i,e) : tyMatchesToCoreExpr tys+------------------------------------------------------------------------ -tyMatchesToCoreExpr :: [(TyVar, Type)] -> [(Var, CoreExpr)]-tyMatchesToCoreExpr = map (\(v,t) -> (v, Type t))+data AlphaEnv = AE { _aeNext :: Int, _aeEnv :: VarEnv Int } +emptyAlphaEnv :: AlphaEnv+emptyAlphaEnv = AE 0 emptyVarEnv++extendAlphaEnv :: Var -> AlphaEnv -> AlphaEnv+extendAlphaEnv v (AE i env) = AE (i+1) (extendVarEnv env v i)++lookupAlphaEnv :: Var -> AlphaEnv -> Maybe Int+lookupAlphaEnv v (AE _ env) = lookupVarEnv env v+ ------------------------------------------------------------------------ --- Note: return list can have duplicate keys, caller is responsible--- for checking that dupes refer to same expression-foldMatch :: [Var]          -- ^ vars that can unify with anything-          -> [(Var,Var)]    -- ^ alpha equivalences, wherever there is binding-                            --   note: we depend on behavior of lookup here, so new entries-                            --         should always be added to the front of the list so-                            --         we don't have to explicity remove them when shadowing occurs-          -> CoreExpr       -- ^ pattern we are matching on-          -> CoreExpr       -- ^ expression we are checking-          -> Maybe [(Var,CoreExpr)] -- ^ mapping of vars to expressions, or failure+-- TODO: Maybe a -> a ??? -- we never need to delete+type A a = Maybe a -> Maybe a -foldMatch vs as (Var i) e | i `elem` vs = matchWithTypes vs as i e-                          | otherwise   = case e of-                                            Var i' | maybe False (==i) (lookup i' as) -> matchWithTypes vs as i e-                                                   | i == i' -> liftM tail $ matchWithTypes vs as i e-                                                                -- note we depend on (i,e) being at front here-                                                                -- this is not strictly necessary, but is faster-                                            _                -> Nothing-foldMatch _  _ (Lit l) (Lit l') | l == l' = return []+toA :: Fold m => (m a -> m a) -> Maybe (m a) -> Maybe (m a)+toA f = Just . f . fromMaybe fEmpty -foldMatch vs as (App e a) (App e' a') = do-    x <- foldMatch vs as e e'-    y <- foldMatch vs as a a'-    return (x ++ y)+type LMap a = M.Map Literal a+type BMap = TyMap -- Binders are de-bruijn indexed, so we only compare their types -foldMatch vs as (Lam v e) (Lam v' e') = foldMatch (filter (/=v) vs) (addAlpha v' v as) e e'+------------------------------------------------------------------------ -foldMatch vs as (Let (NonRec v rhs) e) (Let (NonRec v' rhs') e') = do-    x <- foldMatch vs as rhs rhs'-    y <- foldMatch (filter (/=v) vs) (addAlpha v' v as) e e'-    return (x ++ y)+class Fold m where+    type Key m :: *+    fEmpty :: m a+    fAlter :: AlphaEnv -> [Var] -> Key m -> A a -> m a -> m a+    fFold :: VarEnv CoreExpr -> AlphaEnv -> Key m -> m a -> [(VarEnv CoreExpr, a)] --- TODO: this depends on bindings being in the same order-foldMatch vs as (Let (Rec bnds) e) (Let (Rec bnds') e') | length bnds == length bnds' = do-    let vs' = filter (`notElem` map fst bnds) vs-        as' = foldr (uncurry addAlpha) as $ zip (map fst bnds) (map fst bnds')-        bmatch (_,rhs) (_,rhs') = foldMatch vs' as' rhs rhs'-    x <- zipWithM bmatch bnds bnds'-    y <- foldMatch vs' as' e e'-    return (concat x ++ y)+-- TODO: Idea ... Generalized Tries with Effects+--       Reader - De Bruijn indexing+--       State-ish - Folding with hole filling -foldMatch vs as (Tick t e) (Tick t' e') | t == t' = foldMatch vs as e e'+------------------------------------------------------------------------ -foldMatch vs as (Case s b ty alts) (Case s' b' ty' alts') = do-    guard (length alts == length alts')-    t <- foldMatchType vs as ty ty'-    x <- foldMatch vs as s s'-    let as' = addAlpha b' b as-        vs' = filter (/=b) vs-        altMatch (ac, is, e) (ac', is', e') | ac == ac' =-            foldMatch (filter (`notElem` is) vs') (foldr (uncurry addAlpha) as' $ zip is' is) e e'-        altMatch _ _ = Nothing-    y <- zipWithM altMatch alts alts'-    return (x ++ tyMatchesToCoreExpr t ++ concat y)+-- Note [Var Uniques]+-- Free variable occurrences can have the same unique at a different type!+-- The reason is that when GHC substitutes into the type of the Var, it DOES NOT+-- freshen the unique of the Var. This is not normally a problem for GHC, because+-- if two Vars with the same unique are bound within scope of each other, one gets+-- freshened at creation. However, with Lemmas, we have the possibility of applying+-- a fold from one subtree to a completely different subtree, so can cross scopes.+--+-- To solve this, we first look up the Var by unique, then check it's type with a TyMap.+-- This is unnecessary for bound vars, because their types are checked when we pass+-- the binding itself. -foldMatch vs as (Cast e c) (Cast e' c') = do-    guard (coreEqCoercion c c')-    foldMatch vs as e e'+data VMap a = VM { bvmap :: I.IntMap a, fvmap :: VarEnv (TyMap a) } -- See Note [Var Uniques]+            | VMEmpty -foldMatch vs as (Type t1) (Type t2) = liftM tyMatchesToCoreExpr $ foldMatchType vs as t1 t2+instance Fold VMap where+    type Key VMap = Var --- TODO: do we want to descend into these? There are Types in here.-foldMatch _ _ (Coercion c) (Coercion c') | coreEqCoercion c c' = return []+    fEmpty :: VMap a+    fEmpty = VMEmpty -foldMatch _ _ _ _ = Nothing+    fAlter :: AlphaEnv -> [Var] -> Key VMap -> A a -> VMap a -> VMap a+    fAlter env vs v f VMEmpty = fAlter env vs v f (VM I.empty emptyVarEnv)+    fAlter env vs v f m@VM{}+        | Just bv <- lookupAlphaEnv v env = m { bvmap = I.alter f bv (bvmap m) }+        | otherwise                       = m { fvmap = alterVarEnv (toA (fAlter env vs (varType v) f)) (fvmap m) v } +    fFold :: VarEnv CoreExpr -> AlphaEnv -> Key VMap -> VMap a -> [(VarEnv CoreExpr, a)]+    fFold _  _   _ VMEmpty = []+    fFold hs env v m@VM{}+        | Just bv <- lookupAlphaEnv v env = maybeToList $ (hs,) <$> I.lookup bv (bvmap m)+        | otherwise                       = do+            m' <- maybeToList $ lookupVarEnv (fvmap m) v+            fFold hs env (varType v) m'+ ------------------------------------------------------------------------ --- | Given list of TyVars which can match any type (the holes),--- a pattern, and a concrete type, return mapping from hole to type--- for successful unification.-unifyTypes :: [TyVar] -> Type -> Type -> Maybe [(TyVar, Type)]-unifyTypes holes pat ty = do-    al <- foldMatchType holes [] pat ty-    -- unlike folding itself, we don't care that every hole is assigned-    let found = [ v | (v,_) <- al, v `elem` holes ]-    unifyHoles found typeAlphaEq al+data TyMap a = TyMEmpty+             | TyM { tmHole   :: TyMap (M.Map Var a)+                   , tmVar    :: VMap a+                   , tmApp    :: TyMap (TyMap a)+                   , tmFun    :: TyMap (TyMap a)+                   , tmTcApp  :: NameEnv (ListMap TyMap a)+                   , tmForall :: TyMap (BMap a)+                   , tmTyLit  :: TyLitMap a+                   } -foldMatchType :: [TyVar]              -- ^ vars that can unify with anything-              -> [(TyVar,TyVar)]      -- ^ alpha equivalences, wherever there is binding-                                      --   note: we depend on behavior of lookup here, so new entries-                                      --         should always be added to the front of the list so-                                      --         we don't have to explicity remove them when shadowing occurs-              -> Type                 -- ^ pattern we are matching on-              -> Type                 -- ^ expression we are checking-              -> Maybe [(TyVar,Type)] -- ^ mapping of vars to types, or failure+instance Fold TyMap where+    type Key TyMap = Type --- look through type synonyms-foldMatchType vs as t1 t2 | Just t1' <- tcView t1 = foldMatchType vs as t1' t2-                          | Just t2' <- tcView t2 = foldMatchType vs as t1 t2'+    fEmpty :: TyMap a+    fEmpty = TyMEmpty -foldMatchType vs as (TyVarTy v) t | v `elem` vs = return [(v,t)]-                                  | otherwise = case t of-                                                  TyVarTy v' | maybe False (==v) (lookup v' as) -> return [(v,t)]-                                                             | v == v' {- compare kinds? -} -> return []-                                                  _ -> Nothing+    fAlter :: AlphaEnv -> [Var] -> Key TyMap -> A a -> TyMap a -> TyMap a+    fAlter env vs ty f TyMEmpty = fAlter env vs ty f (TyM fEmpty fEmpty fEmpty fEmpty emptyNameEnv fEmpty fEmpty)+    fAlter env vs ty f m@TyM{} = go ty+        where go (TyVarTy v)+                | v `elem` vs  = m { tmHole = fAlter env vs (varType v) (Just . M.alter f v . fromMaybe M.empty) (tmHole m) }+                | otherwise    = m { tmVar = fAlter env vs v f (tmVar m) }+              go (AppTy t1 t2) = m { tmApp = fAlter env vs t1 (toA (fAlter env vs t2 f)) (tmApp m) }+              go (FunTy t1 t2) = m { tmFun = fAlter env vs t1 (toA (fAlter env vs t2 f)) (tmFun m) }+              go (TyConApp tc tys) = m { tmTcApp = alterNameEnv (toA (fAlter env vs tys f)) (tmTcApp m) (getName tc) }+              go (ForAllTy tv t) = m { tmForall = fAlter (extendAlphaEnv tv env) (delete tv vs) t+                                                         (toA (fAlter env vs (varType tv) f)) (tmForall m) }+              go (LitTy l)     = m { tmTyLit = fAlter env vs l f (tmTyLit m) } -foldMatchType vs as (AppTy ty1 ty2) (AppTy ty1' ty2') = do-    x <- foldMatchType vs as ty1 ty1'-    y <- foldMatchType vs as ty2 ty2'-    return (x ++ y)+    fFold :: VarEnv CoreExpr -> AlphaEnv -> Key TyMap -> TyMap a -> [(VarEnv CoreExpr, a)]+    fFold _ _ _ TyMEmpty = []+    fFold hs env ty m@TyM{} = hss ++ go ty+        where hss = do+                (hs', m') <- fFold hs env (typeKind ty) (tmHole m)+                extendResult m' (Type ty) hs' -foldMatchType vs as (TyConApp tc1 kOrTys1) (TyConApp tc2 kOrTys2) = do-    guard ((tc1 == tc2) && (length kOrTys1 == length kOrTys2))-    let f ty1 ty2 | isKind ty1 && eqKind ty1 ty2 = return []-                  | otherwise = foldMatchType vs as ty1 ty2-    liftM concat $ zipWithM f kOrTys1 kOrTys2+              go (TyVarTy v) = fFold hs env v (tmVar m)+              go (AppTy t1 t2) = do+                (hs', m') <- fFold hs env t1 (tmApp m)+                fFold hs' env t2 m'+              go (FunTy t1 t2) = do+                (hs', m') <- fFold hs env t1 (tmFun m)+                fFold hs' env t2 m'+              go (TyConApp tc tys) = maybeToList (lookupNameEnv (tmTcApp m) (getName tc)) >>= fFold hs env tys+              go (ForAllTy tv t) = do+                (hs', m') <- fFold hs (extendAlphaEnv tv env) t (tmForall m)+                fFold hs' env (varType tv) m'+              go (LitTy l) = fFold hs env l (tmTyLit m) -foldMatchType vs as (FunTy ty1 ty2) (FunTy ty1' ty2') = do-    x <- foldMatchType vs as ty1 ty1'-    y <- foldMatchType vs as ty2 ty2'-    return (x ++ y)+------------------------------------------------------------------------ -foldMatchType vs as (ForAllTy v ty) (ForAllTy v' ty') = foldMatchType (filter (/=v) vs) (addAlpha v' v as) ty ty'+data TyLitMap a = TLM { tlmNumber :: M.Map Integer a+                      , tlmString :: M.Map FastString a+                      } -foldMatchType _ _ (LitTy l1) (LitTy l2) | l1 == l2 = return []+instance Fold TyLitMap where+    type Key TyLitMap = TyLit -foldMatchType _ _ _ _ = Nothing+    fEmpty :: TyLitMap a+    fEmpty = TLM M.empty M.empty +    fAlter :: AlphaEnv -> [Var] -> Key TyLitMap -> A a -> TyLitMap a -> TyLitMap a+    fAlter _ _ l f m = go l+        where go (NumTyLit n) = m { tlmNumber = M.alter f n (tlmNumber m) }+              go (StrTyLit s) = m { tlmString = M.alter f s (tlmString m) }++    fFold :: VarEnv CoreExpr -> AlphaEnv -> Key TyLitMap -> TyLitMap a -> [(VarEnv CoreExpr, a)]+    fFold hs _ l m = go l+        where go (NumTyLit n) = maybeToList $ (hs,) <$> M.lookup n (tlmNumber m)+              go (StrTyLit s) = maybeToList $ (hs,) <$> M.lookup s (tlmString m)++------------------------------------------------------------------------++-- Note [Coercions]+-- We don't actually care about the structure of the coercion evidence+-- itself when we are folding types and expressions. We merely care that+-- there are two coercions with the same type. Hence, we look up the type+-- of the coercion in a TyMap.++-- Note [Tick]+-- We completely look through Ticks, discarding them from pattern expressions+-- at insertion and from candidate expressions at folding/lookup. It is assumed+-- that the Tick is properly present in the RHS, which is the ultimate return+-- value of fFold, thus it will appear in the resulting code.++-- Note [Holes]+-- Holes are distinguished variables which can match any expression. (The universally+-- quantified variables in an Equality.) They are stored as a TyMap, so the type+-- of the expression can be checked against the type of the hole. This wraps a+-- map from Var to result. We use a regular map instead of a VarEnv so we can get+-- the Var back, which allows us to assign it to the expression when building+-- the fold result.++data EMap a = EMEmpty+            | EM { emHole  :: TyMap (M.Map Var a) -- See Note [Holes]+                 , emVar   :: VMap a+                 , emLit   :: LMap a+                 , emCo    :: TyMap a        -- See Note [Coercions]+                 , emType  :: TyMap a+                 , emCast  :: EMap (TyMap a) -- See Note [Coercions]+                 , emApp   :: EMap (EMap a)+                 , emLam   :: EMap (BMap a)+                 , emLetN  :: EMap (EMap (BMap a))+                   -- consider using set rather than list for order-independence+                 , emLetR  :: ListMap EMap (EMap (ListMap BMap a))+                 , emCase  :: EMap (ListMap AMap a)+                 , emECase :: EMap (TyMap a)+                 }++emptyEMapWrapper :: EMap a+emptyEMapWrapper = EM fEmpty fEmpty M.empty fEmpty fEmpty fEmpty+                      fEmpty fEmpty fEmpty fEmpty fEmpty fEmpty++instance Fold EMap where+    type Key EMap = CoreExpr+    fEmpty = EMEmpty++    fAlter :: AlphaEnv -> [Var] -> Key EMap -> A a -> EMap a -> EMap a+    fAlter env vs exp f EMEmpty = fAlter env vs exp f emptyEMapWrapper+    fAlter env vs exp f m@EM{} = go exp+        where go (Var v)+                | v `elem` vs = m { emHole = fAlter env vs (varType v) (Just . M.alter f v . fromMaybe M.empty) (emHole m) }+                | otherwise   = m { emVar  = fAlter env vs v f (emVar m) }+              go (Lit l)      = m { emLit  = M.alter f l (emLit m) }+              go (Coercion c) = m { emCo   = fAlter env vs (coercionType c) f (emCo m) }+              go (Type t)     = m { emType = fAlter env vs t f (emType m) }+              go (Cast e c)   = m { emCast = fAlter env vs e (toA (fAlter env vs (coercionType c) f)) (emCast m) }+              go (Tick _ e)   = fAlter env vs e f m -- See Note [Tick]+              go (App l r)    = m { emApp  = fAlter env vs l (toA (fAlter env vs r f)) (emApp m) }+              go (Lam b e)    = m { emLam  = fAlter (extendAlphaEnv b env) (delete b vs) e+                                                    (toA (fAlter env vs (varType b) f))+                                                    (emLam m) }+              go (Case s _ t []) = m { emECase = fAlter env vs s (toA (fAlter env vs t f)) (emECase m) }+              go (Case s b _ as) = m { emCase = fAlter env vs s+                                                       (toA (fAlter (extendAlphaEnv b env) (delete b vs) as f))+                                                       (emCase m) }+              go (Let (NonRec b r) e) = m { emLetN = fAlter (extendAlphaEnv b env) (delete b vs) e+                                                            (toA (fAlter env vs r (toA (fAlter env vs (varType b) f))))+                                                            (emLetN m) }+              go (Let (Rec ds) e) = let (bs, rhss) = unzip ds+                                        env' = foldr extendAlphaEnv env bs+                                        vs' = vs \\ bs+                                    in m { emLetR = fAlter env' vs' rhss+                                                           (toA (fAlter env' vs' e+                                                                        (toA (fAlter env vs (map varType bs) f))))+                                                           (emLetR m) }++    fFold :: VarEnv CoreExpr -> AlphaEnv -> Key EMap -> EMap a -> [(VarEnv CoreExpr, a)]+    fFold _  _   _ EMEmpty = []+    fFold hs env exp m@EM{} = hss ++ go exp+        where hss = do+                (hs', m') <- fFold hs env (exprKindOrType exp) (emHole m)+                extendResult m' exp hs'++              go (Var v)      = fFold hs env v (emVar m)+              go (Lit l)      = maybeToList $ (hs,) <$> M.lookup l (emLit m)+              go (Coercion c) = fFold hs env (coercionType c) (emCo m)+              go (Type t)     = fFold hs env t (emType m)+              go (Cast e c)   = do+                (hs', m') <- fFold hs env e (emCast m)+                fFold hs' env (coercionType c) m'+              go (Tick _ e)   = fFold hs env e m -- See Note [Tick]+              go (App l r)    = do+                (hs', m') <- fFold hs env l (emApp m)+                fFold hs' env r m'+              go (Lam b e)    = do+                (hs', m') <- fFold hs (extendAlphaEnv b env) e (emLam m)+                fFold hs' env (varType b) m'+              go (Case s _ t []) = do+                (hs', m') <- fFold hs env s (emECase m)+                fFold hs' env t m'+              go (Case s b _ as) = do+                (hs', m') <- fFold hs env s (emCase m)+                fFold hs' (extendAlphaEnv b env) as m'+              go (Let (NonRec b r) e) = do+                (hs' , m' ) <- fFold hs (extendAlphaEnv b env) e (emLetN m)+                (hs'', m'') <- fFold hs' env r m'+                fFold hs'' env (varType b) m''+              go (Let (Rec ds) e) = do+                let (bs, rhss) = unzip ds+                    env' = foldr extendAlphaEnv env bs+                (hs' , m' ) <- fFold hs env' rhss (emLetR m)+                (hs'', m'') <- fFold hs' env' e m'+                fFold hs'' env (map varType bs) m''++-- Add the matched expression to the holes map, fails if expression differs from one already in hole.+extendResult :: M.Map Var a -> CoreExpr -> VarEnv CoreExpr -> [(VarEnv CoreExpr, a)]+extendResult hm e m = catMaybes+    [ case lookupVarEnv m v of+        Nothing -> return (extendVarEnv m v e, x)+        Just e' -> sameExpr e e' >> return (m, x)+    | (v,x) <- M.assocs hm ]++-- | Determine if two expressions are alpha-equivalent.+sameExpr :: CoreExpr -> CoreExpr -> Maybe ()+sameExpr e1 e2 = snd <$> soleElement (findFold e2 m)+    where m = insertFold emptyAlphaEnv [] e1 () EMEmpty++-- | Determine if the left Quantified 'proves' the right one.+-- Here, 'proves' means that the right Quantified is a substitution+-- of the left one, where only the top-level binders of the left+-- Quantified can be substituted.+proves :: Quantified -> Quantified -> Bool+proves (Quantified bs cl1) (Quantified _ cl2) = maybe False (const True) $ soleElement (findFold cl2 m)+    where m = insertFold emptyAlphaEnv bs cl1 () CLMEmpty++-- | Determine if the right Quantified is a substitution+-- instance of the left Quantified (which is a pattern+-- with a given set of holes).+lemmaMatch :: [Var] -> Quantified -> Quantified -> Maybe (VarEnv CoreExpr)+lemmaMatch hs ql qr = fmap fst $ soleElement (findFold qr m)+    where m = insertFold emptyAlphaEnv hs ql () emptyQMapWrapper++------------------------------------------------------------------------++data ListMap m a+  = ListMap { lmNil  :: Maybe a+            , lmCons :: m (ListMap m a) }++instance Fold m => Fold (ListMap m) where+    type Key (ListMap m) = [Key m]++    fEmpty :: ListMap m a+    fEmpty = ListMap Nothing fEmpty++    fAlter :: AlphaEnv -> [Var] -> Key (ListMap m) -> A a -> ListMap m a -> ListMap m a+    fAlter _   _  []     f m = m { lmNil  = f (lmNil m) }+    fAlter env vs (x:xs) f m = m { lmCons = fAlter env vs x (toA (fAlter env vs xs f)) (lmCons m) }++    fFold :: VarEnv CoreExpr -> AlphaEnv -> Key (ListMap m) -> ListMap m a -> [(VarEnv CoreExpr, a)]+    fFold hs _   []     m = maybeToList $ (hs,) <$> lmNil m+    fFold hs env (x:xs) m = do+        (hs', m') <- fFold hs env x (lmCons m)+        fFold hs' env xs m'++------------------------------------------------------------------------++-- Note [Alt Binders]+-- We don't store the uniques/types of the alt-binders, because they are+-- completely determined by the scrutinee/datacon/rhs.++data AMap a = AMEmpty+            | AM { amDef  :: EMap a+                 , amData :: NameEnv (EMap a) -- See Note [Alt Binders]+                 , amLit  :: LMap (EMap a) }++instance Fold AMap where+    type Key AMap = Alt CoreBndr++    fEmpty :: AMap a+    fEmpty = AMEmpty++    fAlter :: AlphaEnv -> [Var] -> Key AMap -> A a -> AMap a -> AMap a+    fAlter env vs alt f AMEmpty = fAlter env vs alt f (AM fEmpty emptyNameEnv M.empty)+    fAlter env vs alt f m@AM{} = go alt+        where go (DEFAULT  , _ , rhs) = m { amDef  = fAlter env vs rhs f (amDef m) }+              go (DataAlt d, bs, rhs) = m { amData = alterNameEnv+                                                        (toA (fAlter (foldr extendAlphaEnv env bs) (vs \\ bs) rhs f))+                                                        (amData m) (getName d) }+              go (LitAlt l , _ , rhs) = m { amLit  = M.alter (toA (fAlter env vs rhs f)) l (amLit m) }++    fFold :: VarEnv CoreExpr -> AlphaEnv -> Key AMap -> AMap a -> [(VarEnv CoreExpr, a)]+    fFold _ _ _ AMEmpty = []+    fFold hs env alt m@AM{} = go alt+        where go (DEFAULT  , _ , rhs) = fFold hs env rhs (amDef m)+              go (DataAlt d, bs, rhs) = do+                m' <- maybeToList (lookupNameEnv (amData m) (getName d))+                fFold hs (foldr extendAlphaEnv env bs) rhs m'+              go (LitAlt l , _ , rhs) = maybeToList (M.lookup l (amLit m)) >>= fFold hs env rhs++----------------------------------------------------------------------------++data QMap a = QM { qmap :: CLMap (ListMap BMap a) }++emptyQMapWrapper :: QMap a+emptyQMapWrapper = QM fEmpty++instance Fold QMap where+    type Key QMap = Quantified++    fEmpty :: QMap a+    fEmpty = emptyQMapWrapper++    fAlter :: AlphaEnv -> [Var] -> Key QMap -> A a -> QMap a -> QMap a+    fAlter env vs (Quantified bs cl) f m =+        m { qmap = fAlter (foldr extendAlphaEnv env bs) (vs \\ bs) cl+                          (toA (fAlter env vs (map varType bs) f)) (qmap m) }++    fFold :: VarEnv CoreExpr -> AlphaEnv -> Key QMap -> QMap a -> [(VarEnv CoreExpr, a)]+    fFold hs env (Quantified bs cl) m = do+        (hs', m') <- fFold hs (foldr extendAlphaEnv env bs) cl (qmap m)+        fFold hs' env (map varType bs) m'++----------------------------------------------------------------------------++data CLMap a = CLMEmpty+             | CLM { clmConj  :: QMap (QMap a)+                   , clmDisj  :: QMap (QMap a)+                   , clmImpl  :: QMap (QMap a)+                   , clmEquiv :: EMap (EMap a)+                   }++emptyCLMapWrapper :: CLMap a+emptyCLMapWrapper = CLM fEmpty fEmpty fEmpty fEmpty++instance Fold CLMap where+    type Key CLMap = Clause++    fEmpty :: CLMap a+    fEmpty = CLMEmpty++    fAlter :: AlphaEnv -> [Var] -> Key CLMap -> A a -> CLMap a -> CLMap a+    fAlter env vs cl f CLMEmpty = fAlter env vs cl f emptyCLMapWrapper+    fAlter env vs cl f m@(CLM{}) = go cl+        where go (Conj  q1 q2) = m { clmConj  = fAlter env vs q1 (toA (fAlter env vs q2 f)) (clmConj  m) }+              go (Disj  q1 q2) = m { clmDisj  = fAlter env vs q1 (toA (fAlter env vs q2 f)) (clmDisj  m) }+              go (Impl  q1 q2) = m { clmImpl  = fAlter env vs q1 (toA (fAlter env vs q2 f)) (clmImpl  m) }+              go (Equiv e1 e2) = m { clmEquiv = fAlter env vs e1 (toA (fAlter env vs e2 f)) (clmEquiv m) }++    fFold :: VarEnv CoreExpr -> AlphaEnv -> Key CLMap -> CLMap a -> [(VarEnv CoreExpr, a)]+    fFold _  _   _  CLMEmpty = []+    fFold hs env cl m@CLM{}  = go cl+        where go (Conj q1 q2) = do+                (hs', m') <- fFold hs env q1 (clmConj m)+                fFold hs' env q2 m'+              go (Disj q1 q2) = do+                (hs', m') <- fFold hs env q1 (clmDisj m)+                fFold hs' env q2 m'+              go (Impl q1 q2) = do+                (hs', m') <- fFold hs env q1 (clmImpl m)+                fFold hs' env q2 m'+              go (Equiv e1 e2) = do+                (hs', m') <- fFold hs env e1 (clmEquiv m)+                fFold hs' env e2 m'++----------------------------------------------------------------------------++-- | An equality is represented as a set of universally quantified binders, and the LHS and RHS of the equality.+data Equality = Equality [CoreBndr] CoreExpr CoreExpr++-- | Build an equality from a list of universally quantified binders and two expressions.+-- If the head of either expression is a lambda expression, it's binder will become a universally quantified binder+-- over both sides. It is assumed the two expressions have the same type.+--+-- Ex.    mkEquality [] (\x. foo x) bar === forall x. foo x = bar x+--        mkEquality [] (baz y z) (\x. foo x x) === forall x. baz y z x = foo x x+--        mkEquality [] (\x. foo x) (\y. bar y) === forall x. foo x = bar x+mkEquality :: [CoreBndr] -> CoreExpr -> CoreExpr -> Equality+mkEquality vs lhs rhs = case mkQuantified vs lhs rhs of+                            Quantified vs' (Equiv lhs' rhs') -> Equality vs' lhs' rhs'++toEqualities :: Quantified -> [Equality]+toEqualities = go []+    where go qs (Quantified vs cl) = go2 (qs++vs) cl++          go2 qs (Equiv e1 e2) = [mkEquality qs e1 e2]+          go2 qs (Conj q1 q2)  = go qs q1 ++ go qs q2+          go2 _  _             = []++ppEqualityT :: PrettyPrinter -> PrettyH Equality+ppEqualityT pp = do+    Equality bs lhs rhs <- idR+    dfa <- return bs >>> pForall pp+    d1 <- return lhs >>> extractT (pCoreTC pp)+    d2 <- return rhs >>> extractT (pCoreTC pp)+    return $ PP.sep [dfa,d1,PP.text "=",d2]++------------------------------------------------------------------------------++-- | Flip the LHS and RHS of a 'Equality'.+flipEquality :: Equality -> Equality+flipEquality (Equality xs lhs rhs) = Equality xs rhs lhs++------------------------------------------------------------------------------++{-+-- Idea: use Haskell's functions to fill the holes automagically+--+-- plusId <- findIdT "+"+-- timesId <- findIdT "*"+-- mkEquality $ \ x -> ( mkCoreApps (Var plusId)  [x,x]+--                     , mkCoreApps (Var timesId) [Lit 2, x])+--+-- TODO: need to know type of 'x' to generate a variable.+class BuildEquality a where+    mkEquality :: a -> HermitM Equality++instance BuildEquality (CoreExpr,CoreExpr) where+    mkEquality :: (CoreExpr,CoreExpr) -> HermitM Equality+    mkEquality (lhs,rhs) = return $ Equality [] lhs rhs++instance BuildEquality a => BuildEquality (CoreExpr -> a) where+    mkEquality :: (CoreExpr -> a) -> HermitM Equality+    mkEquality f = do+        x <- newIdH "x" (error "need to create a type")+        Equality bnds lhs rhs <- mkEquality (f (varToCoreExpr x))+        return $ Equality (x:bnds) lhs rhs+-}++------------------------------------------------------------------------------++freeVarsEquality :: Equality -> VarSet+freeVarsEquality (Equality bs lhs rhs) =+    delVarSetList (unionVarSets (map freeVarsExpr [lhs,rhs])) bs++------------------------------------------------------------------------------++data RewriteEqualityBox = RewriteEqualityBox (RewriteH Equality) deriving Typeable++instance Extern (RewriteH Equality) where+    type Box (RewriteH Equality) = RewriteEqualityBox+    box = RewriteEqualityBox+    unbox (RewriteEqualityBox r) = r++-----------------------------------------------------------------++data TransformEqualityStringBox = TransformEqualityStringBox (TransformH Equality String) deriving Typeable++instance Extern (TransformH Equality String) where+    type Box (TransformH Equality String) = TransformEqualityStringBox+    box = TransformEqualityStringBox+    unbox (TransformEqualityStringBox t) = t++-----------------------------------------------------------------++data TransformEqualityUnitBox = TransformEqualityUnitBox (TransformH Equality ()) deriving Typeable++instance Extern (TransformH Equality ()) where+    type Box (TransformH Equality ()) = TransformEqualityUnitBox+    box = TransformEqualityUnitBox+    unbox (TransformEqualityUnitBox i) = i

@@ -2,7 +2,8 @@ module HERMIT.Dictionary.Function     ( externals     , appArgM-    , buildApplicationM+    , buildAppM+    , buildAppsM     , buildCompositionT     , buildFixT     , buildIdT@@ -13,6 +14,7 @@     ) where  import Control.Arrow+import Control.Monad import Control.Monad.IO.Class  import Data.List (nub, intercalate, intersect, partition, transpose)@@ -28,15 +30,14 @@ import HERMIT.Name  import HERMIT.Dictionary.Common-import HERMIT.Dictionary.GHC hiding (externals)  externals ::  [External] externals =-    [ external "static-arg" (promoteDefR staticArgR :: RewriteH Core)+    [ external "static-arg" (promoteDefR staticArgR :: RewriteH LCore)         [ "perform the static argument transformation on a recursive function." ]-    , external "static-arg-types" (promoteDefR staticArgTypesR :: RewriteH Core)+    , external "static-arg-types" (promoteDefR staticArgTypesR :: RewriteH LCore)         [ "perform the static argument transformation on a recursive function, only transforming type arguments." ]-    , external "static-arg-pos" (promoteDefR . staticArgPosR :: [Int] -> RewriteH Core)+    , external "static-arg-pos" (promoteDefR . staticArgPosR :: [Int] -> RewriteH LCore)         [ "perform the static argument transformation on a recursive function, only transforming the arguments specified (by index)." ]     ] @@ -131,29 +132,25 @@                              else return $ l !! n  -- | Build composition of two functions.-buildCompositionT :: (BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)+buildCompositionT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)                   => CoreExpr -> CoreExpr -> Transform c m x CoreExpr buildCompositionT f g = do     composeId <- findIdT $ fromString "Data.Function.."-    fDot <- buildApplicationM (varToCoreExpr composeId) f-    buildApplicationM fDot g+    fDot <- prefixFailMsg "building (.) f failed:" $ buildAppM (varToCoreExpr composeId) f+    prefixFailMsg "building f . g failed:" $ buildAppM fDot g +buildAppsM :: MonadCatch m => CoreExpr -> [CoreExpr] -> m CoreExpr+buildAppsM = foldM buildAppM+ -- | Given expression for f and for x, build f x, figuring out the type arguments.-buildApplicationM :: (HasDynFlags m, MonadCatch m, MonadIO m) => CoreExpr -> CoreExpr -> m CoreExpr-buildApplicationM f x = do+buildAppM :: MonadCatch m => CoreExpr -> CoreExpr -> m CoreExpr+buildAppM f x = do     (vsF, domF, _) <- splitFunTypeM (exprType f)     let (vsX, xTy) = splitForAllTys (exprType x)         allTvs = vsF ++ vsX         bindFn v = if v `elem` allTvs then BindMe else Skolem -    sub <- maybe (do d <- getDynFlags-                     liftIO $ putStrLn $ "f: " ++ showPpr d f-                     liftIO $ putStrLn $ "x: " ++ showPpr d x-                     liftIO $ putStrLn $ "vsF: " ++ showPpr d vsF-                     liftIO $ putStrLn $ "domF: " ++ showPpr d domF-                     liftIO $ putStrLn $ "vsX: " ++ showPpr d vsX-                     liftIO $ putStrLn $ "xTy: " ++ showPpr d xTy-                     fail "buildApplicationM - domain of f and type of x do not unify")+    sub <- maybe (fail "buildAppM - domain of f and type of x do not unify")                  return                  (tcUnifyTys bindFn [domF] [xTy]) 

@@ -1,18 +1,18 @@ {-# LANGUAGE CPP, FlexibleContexts #-} module HERMIT.Dictionary.GHC     ( -- * GHC-based Transformations-     -- | This module contains transformations that are reflections of GHC functions, or derived from GHC functions.-     externals-     -- ** Substitution+      -- | This module contains transformations that are reflections of GHC functions, or derived from GHC functions.+      externals+      -- ** Dynamic Loading+    , loadLemmaLibraryT+    , LemmaLibrary+      -- ** Substitution     , substR-    , substCoreAlt-    , substCoreExpr-     -- ** Utilities-    --      , inScope+      -- ** Utilities     , dynFlagsT     , arityOf-     -- ** Lifted GHC capabilities-     -- A zombie is an identifer that has 'OccInfo' 'IAmDead', but still has occurrences.+      -- ** Lifted GHC capabilities+      -- A zombie is an identifer that has 'OccInfo' 'IAmDead', but still has occurrences.     , lintExprT     , lintModuleT     , occurAnalyseR@@ -33,13 +33,15 @@  import           Data.Char (isSpace) import           Data.List (mapAccumL)+import qualified Data.Map as M+import           Data.String  import           HERMIT.Core import           HERMIT.Context-import           HERMIT.Dictionary.Debug hiding (externals) import           HERMIT.External import           HERMIT.GHC import           HERMIT.Kure+import           HERMIT.Lemma import           HERMIT.Monad import           HERMIT.Name @@ -48,21 +50,23 @@ -- | Externals that reflect GHC functions, or are derived from GHC functions. externals :: [External] externals =-         [ external "deshadow-prog" (promoteProgR deShadowProgR :: RewriteH Core)-                [ "Deshadow a program." ] .+ Deep-         , external "dezombify" (promoteExprR dezombifyR :: RewriteH Core)-                [ "Zap the occurrence information in the current identifer if it is a zombie."] .+ Shallow-         , external "occurrence-analysis" (occurrenceAnalysisR :: RewriteH Core)-                [ "Perform dependency analysis on all sub-expressions; simplifying and updating identifer info."] .+ Deep-         , external "lint-expr" (promoteExprT lintExprT :: TransformH CoreTC String)-                [ "Runs GHC's Core Lint, which typechecks the current expression."-                , "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."] .+ Deep .+ Debug .+ Query-         , external "lint-module" (promoteModGutsT lintModuleT :: TransformH CoreTC String)-                [ "Runs GHC's Core Lint, which typechecks the current module."] .+ Deep .+ Debug .+ Query-         ]+    [ external "deshadow-prog" (promoteProgR deShadowProgR :: RewriteH LCore)+        [ "Deshadow a program." ] .+ Deep+    , external "dezombify" (promoteExprR dezombifyR :: RewriteH LCore)+        [ "Zap the occurrence information in the current identifer if it is a zombie."] .+ Shallow+    , external "occurrence-analysis" (occurrenceAnalysisR :: RewriteH LCore)+        [ "Perform dependency analysis on all sub-expressions; simplifying and updating identifer info."] .+ Deep+    , external "lint-expr" (promoteExprT lintExprT :: TransformH LCoreTC String)+        [ "Runs GHC's Core Lint, which typechecks the current expression."+        , "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."] .+ Deep .+ Debug .+ Query+    , external "lint-module" (promoteModGutsT lintModuleT :: TransformH LCoreTC String)+        [ "Runs GHC's Core Lint, which typechecks the current module."] .+ Deep .+ Debug .+ Query+    , external "load-lemma-library" (loadLemmaLibraryT :: HermitName -> TransformH LCore ())+        [ "Dynamically load a library of lemmas." ]+    ]  ------------------------------------------------------------------------ @@ -71,16 +75,6 @@ substR v e = setFailMsg "Can only perform substitution on expressions, case alternatives or programs." $              promoteExprR (arr $ substCoreExpr v e) <+ promoteProgR (substTopBindR v e) <+ promoteAltR (arr $ substCoreAlt v e) --- | Substitute all occurrences of a variable with an expression, in an expression.-substCoreExpr :: Var -> CoreExpr -> (CoreExpr -> CoreExpr)-substCoreExpr v e expr =-    -- The InScopeSet needs to include any free variables appearing in the-    -- expression to be substituted.  Constructing a NonRec Let expression-    -- to pass on to exprFeeVars takes care of this, but ...-    -- TODO Is there a better way to do this ???-    let emptySub = mkEmptySubst (mkInScopeSet (localFreeVarsExpr (Let (NonRec v e) expr)))-     in substExpr (text "substCoreExpr") (extendSubst emptySub v e) expr- -- | Substitute all occurrences of a variable with an expression, in a program. substTopBindR :: Monad m => Var -> CoreExpr -> Rewrite c m CoreProg substTopBindR v e =  contextfreeT $ \ p -> do@@ -88,14 +82,6 @@     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.-substCoreAlt :: Var -> CoreExpr -> CoreAlt -> CoreAlt-substCoreAlt v e alt = let (con, vs, rhs) = alt-                           inS            = (flip delVarSet v . unionVarSet (localFreeVarsExpr e) . localFreeVarsAlt) alt-                           subst          = extendSubst (mkEmptySubst (mkInScopeSet inS)) v e-                           (subst', vs')  = substBndrs subst vs-                        in (con, vs', substExpr (text "alt-rhs") subst' rhs)- ------------------------------------------------------------------------  -- | [from GHC documentation] De-shadowing the program is sometimes a useful pre-pass.@@ -134,7 +120,7 @@          dumpSDocs endMsg = Bag.foldBag (\ d r -> d ++ ('\n':r)) (showSDoc dynFlags) endMsg      if Bag.isEmptyBag errs        then return $ dumpSDocs "Core Lint Passed" warns-       else observeR (dumpSDocs "" errs) >>> fail "Core Lint Failed"+       else fail $ "Core Lint Failed:\n" ++ dumpSDocs "" errs  -- | 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@@ -164,7 +150,7 @@ dezombifyR = varR (acceptR isDeadBinder >>^ zapVarOccInfo)  -- | Apply 'occurAnalyseExprR' to all sub-expressions.-occurAnalyseR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core+occurAnalyseR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m, Walker c u, Injection CoreExpr u) => Rewrite c m u occurAnalyseR = let r  = promoteExprR (arr occurAnalyseExpr_NoBinderSwap) -- See Note [No Binder Swap]                     go = r <+ anyR go                  in tryR go -- always succeed@@ -184,14 +170,14 @@ occurAnalyseExprChangedR = changedByR exprSyntaxEq (arr occurAnalyseExpr_NoBinderSwap) -- See Note [No Binder Swap]  -- | Occurrence analyse all sub-expressions, failing if the result is syntactically equal to the initial expression.-occurAnalyseChangedR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core-occurAnalyseChangedR = changedByR coreSyntaxEq occurAnalyseR+occurAnalyseChangedR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m LCore+occurAnalyseChangedR = changedByR lcoreSyntaxEq occurAnalyseR  -- | Run GHC's occurrence analyser, and also eliminate any zombies.-occurAnalyseAndDezombifyR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core+occurAnalyseAndDezombifyR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m, Walker c u, Injection CoreExpr u) => Rewrite c m u occurAnalyseAndDezombifyR = allbuR (tryR $ promoteExprR dezombifyR) >>> occurAnalyseR -occurrenceAnalysisR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core+occurrenceAnalysisR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m, Walker c LCore) => Rewrite c m LCore occurrenceAnalysisR = occurAnalyseAndDezombifyR  {- Does not work (no export)@@ -224,7 +210,8 @@             nonC = mkNonCanonical $ CtWanted { ctev_pred = predTy, ctev_evar = evar, ctev_loc = loc }             wCs = mkFlatWC [nonC]         (wCs', bnds) <- solveWantedsTcM wCs-        reportAllUnsolved wCs'+        -- reportAllUnsolved wCs' -- this is causing a panic with dictionary instantiation+                                  -- revist and fix!         return (evar, bnds)     bnds <- runDsM $ dsEvBinds bs     return (i,bnds)@@ -239,3 +226,42 @@     return $ case bnds of                 [NonRec v e] | i == v -> e -- the common case that we would have gotten a single non-recursive let                 _ -> mkCoreLets bnds (varToCoreExpr i)++-- | A LemmaLibrary is a transformation that produces a set of lemmas,+-- which are then added to the lemma store. It is not allowed to insert+-- its own lemmas directly (if it tries they are throw away), but can+-- certainly read the existing store.+type LemmaLibrary = TransformH () Lemmas++loadLemmaLibraryT :: HermitName -> TransformH x ()+loadLemmaLibraryT nm = contextonlyT $ \ c -> do+    hscEnv <- getHscEnv+    comp <- liftAndCatchIO $ loadLemmaLibrary hscEnv nm+    m' <- applyT comp c () -- TODO: discard side effects+    m <- getLemmas+    putLemmas $ m' `M.union` m++loadLemmaLibrary :: HscEnv -> HermitName -> IO LemmaLibrary+loadLemmaLibrary hscEnv hnm = do+    name <- lookupHermitNameForPlugins hscEnv varNS hnm+    lib_tycon_name <- lookupHermitNameForPlugins hscEnv tyConClassNS $ fromString "HERMIT.Dictionary.GHC.LemmaLibrary"+    lib_tycon <- forceLoadTyCon hscEnv lib_tycon_name+    mb_v <- getValueSafely hscEnv name $ mkTyConTy lib_tycon+    let dflags = hsc_dflags hscEnv+    maybe (fail $ showSDoc dflags $ hsep+                [ ptext (sLit "The value"), ppr name+                , ptext (sLit "did not have the type")+                , ppr lib_tycon, ptext (sLit "as required.")])+          return mb_v++lookupHermitNameForPlugins :: HscEnv -> NameSpace -> HermitName -> IO Name+lookupHermitNameForPlugins hscEnv ns hnm = do+    modName <- maybe (fail "name must be fully qualified with module name.") return (hnModuleName hnm)+    let dflags = hsc_dflags hscEnv+        rdrName = toRdrName ns hnm+    mbName <- lookupRdrNameInModuleForPlugins hscEnv modName rdrName+    maybe (fail $ showSDoc dflags $ hsep+            [ ptext (sLit "The module"), ppr modName+            , ptext (sLit "did not export the name")+            , ppr rdrName ])+          return mbName

@@ -3,26 +3,20 @@ module HERMIT.Dictionary.Induction   ( -- * Induction     inductionCaseSplit---  , inductionOnT---  , listInductionOnT   ) where  import Control.Arrow --- import Data.List (delete)- import HERMIT.Context import HERMIT.Core import HERMIT.GHC import HERMIT.Kure import HERMIT.Monad import HERMIT.Name--- import HERMIT.Utilities (soleElement)  import HERMIT.Dictionary.Common import HERMIT.Dictionary.Local.Case (caseSplitInlineR)--- import HERMIT.Dictionary.Reasoning import HERMIT.Dictionary.Undefined  ------------------------------------------------------------------------------@@ -44,7 +38,7 @@         -- then case split on the identifier, inlining the pattern        -- we consider the other universally quantified variables to be in scope while doing so-       Case _ _ _ alts <- withVarsInScope vs (caseSplitInlineR (==i)) <<< return contrivedExpr+       Case _ _ _ alts <- withVarsInScope vs (caseSplitInlineR (varToCoreExpr i)) <<< return contrivedExpr        let dataConCases = map compressAlts alts         lhsUndefined <- extractR (replaceIdWithUndefinedR i) <<< return lhsE@@ -60,46 +54,3 @@     compressAlts _ = error "Bug in inductionCaseSplit"  --- NOTE: Most of the Induction infrastructure has moved to HERMIT/Shell/Proof.hs----- -- | A general induction principle.  TODO: Is this valid for infinite data types?  Probably not.--- inductionOnT :: forall c. (AddBindings c, ReadBindings c, ReadPath c Crumb, ExtendPath c Crumb, Walker c Core)---                     => (Id -> Bool) -> (DataCon -> [BiRewrite c HermitM CoreExpr] -> CoreExprEqualityProof c HermitM) -> Transform c HermitM CoreExprEquality ()--- inductionOnT idPred genCaseAltProofs = prefixFailMsg "Induction failed: " $---     do eq@(CoreExprEquality bs lhs rhs) <- idR----        i <- setFailMsg "specified identifier is not universally quantified in this equality lemma." $ soleElement (filter idPred bs)----        cases <- inductionCaseSplit bs i lhs rhs----        -- TODO: will this work if vs contains TyVars or CoVars?  Maybe we need to sort the Vars in order: TyVars; CoVars; Ids.---        let verifyInductiveCaseT :: (DataCon,[Var],CoreExpr,CoreExpr) -> Transform c HermitM x ()---            verifyInductiveCaseT (con,vs,lhsE,rhsE) =---                 let vs_matching_i_type = filter (typeAlphaEq (varType i) . varType) vs---                     eqs = [ discardUniVars (instantiateCoreExprEq [(i,Var i')] eq) | i' <- vs_matching_i_type ]---                     brs = map birewrite eqs -- These eqs now have no universally quantified variables.---                                             -- Thus they can only be used on variables in the induction hypothesis.---                                             -- TODO: consider whether this is unneccassarily restrictive---                     caseEq = CoreExprEquality (delete i bs ++ vs) lhsE rhsE---                 in return caseEq >>> verifyCoreExprEqualityT (genCaseAltProofs con brs)----        mapM_ verifyInductiveCaseT cases---- -- | An induction principle for lists.--- listInductionOnT :: (AddBindings c, ReadBindings c, ReadPath c Crumb, ExtendPath c Crumb, Walker c Core)---                 => (Id -> Bool) -- Id to case split on---                 -> CoreExprEqualityProof c HermitM -- proof for [] case---                 -> (BiRewrite c HermitM CoreExpr -> CoreExprEqualityProof c HermitM) -- proof for (:) case, given smaller proof---                 -> Transform c HermitM CoreExprEquality ()--- listInductionOnT idPred nilCaseProof consCaseProof = inductionOnT idPred $ \ con brs ->---                                                                 if | con == nilDataCon   -> case brs of---                                                                                                   [] -> nilCaseProof---                                                                                                   _  -> error "Bug!"---                                                                    | con == consDataCon  -> case brs of---                                                                                                   [br] -> consCaseProof br---                                                                                                   _    -> error "Bug!"---                                                                    | otherwise           -> let msg = "Mystery constructor, this is a bug."---                                                                                              in (fail msg, fail msg)--------------------------------------------------------------------------------

@@ -5,6 +5,7 @@     , InlineConfig(..)     , CaseBinderInlineOption(..)     , getUnfoldingT+    , getUnfoldingsT     , ensureBoundT     , inlineR     , inlineNameR@@ -33,16 +34,16 @@ -- | 'External's for inlining variables. externals :: [External] externals =-    [ external "inline" (promoteExprR inlineR :: RewriteH Core)+    [ external "inline" (promoteExprR inlineR :: RewriteH LCore)         [ "(Var v) ==> <defn of v>" ].+ Eval .+ Deep-    , external "inline" (promoteExprR . inlineMatchingPredR . mkOccPred :: OccurrenceName -> RewriteH Core)+    , external "inline" (promoteExprR . inlineMatchingPredR . mkOccPred :: OccurrenceName -> RewriteH LCore)         [ "Given a specific v, (Var v) ==> <defn of v>" ] .+ Eval .+ Deep-    , external "inline" (promoteExprR . inlineNamesR :: [String] -> RewriteH Core)+    , external "inline" (promoteExprR . inlineNamesR :: [String] -> RewriteH LCore)         [ "If the current variable matches any of the given names, then inline it." ] .+ Eval .+ Deep-    , external "inline-case-scrutinee" (promoteExprR inlineCaseScrutineeR :: RewriteH Core)+    , external "inline-case-scrutinee" (promoteExprR inlineCaseScrutineeR :: RewriteH LCore)         [ "if v is a case binder, replace (Var v) with the bound case scrutinee." ] .+ Eval .+ Deep-    , external "inline-case-alternative" (promoteExprR inlineCaseAlternativeR :: RewriteH Core)-        [ "if v is a case binder, replace (Var v) with the bound case-alternative pattern." ] .+ Eval .+ Deep .+ Unsafe+    , external "inline-case-alternative" (promoteExprR inlineCaseAlternativeR :: RewriteH LCore)+        [ "if v is a case binder, replace (Var v) with the bound case-alternative pattern." ] .+ Eval .+ Deep     ]  ------------------------------------------------------------------------@@ -142,7 +143,16 @@ getUnfoldingT :: (ReadBindings c, MonadCatch m)               => InlineConfig               -> Transform c m Id (CoreExpr, BindingDepth -> Bool)-getUnfoldingT config = transform $ \ c i ->+getUnfoldingT config = do+    r <- getUnfoldingsT config+    case r of+        [] -> fail "no unfolding for variable."+        (u:_) -> return u++getUnfoldingsT :: (ReadBindings c, MonadCatch m)+               => InlineConfig+               -> Transform c m Id [(CoreExpr, BindingDepth -> Bool)]+getUnfoldingsT config = transform $ \ c i ->     case lookupHermitBinding i c of       Nothing -> do requireAllBinders config                     let uncaptured = (<= 0) -- i.e. is global@@ -151,34 +161,38 @@                     -- will give a reasonable error message if something goes wrong, instead of a GHC panic.                     guardMsg (isId i) "type variable is not in Env (this should not happen)."                     case unfoldingInfo (idInfo i) of-                      CoreUnfolding { uf_tmpl = uft } -> return (uft, uncaptured)-                      dunf@(DFunUnfolding {})         -> liftM (,uncaptured) $ dFunExpr dunf+                      CoreUnfolding { uf_tmpl = uft } -> single (uft, uncaptured)+                      dunf@(DFunUnfolding {})         -> single . (,uncaptured) =<< dFunExpr dunf                       _                               -> fail $ "cannot find unfolding in Env or IdInfo."       Just b -> let depth = hbDepth b                 in case hbSite b of                           CASEBINDER s alt -> let tys             = tyConAppArgs (idType i)-                                                  altExprDepthM   = liftM (, (<= depth+1)) $ alt2Exp tys alt-                                                  scrutExprDepthM = return (s, (< depth))+                                                  altExprDepthM   = single . (, (<= depth+1)) =<< alt2Exp tys alt+                                                  scrutExprDepthM = single (s, (< depth))                                                in case config of                                                     CaseBinderOnly Scrutinee   -> scrutExprDepthM                                                     CaseBinderOnly Alternative -> altExprDepthM-                                                    AllBinders                 -> altExprDepthM <+ scrutExprDepthM+                                                    AllBinders                 -> do+                                                        au <- altExprDepthM <+ return []+                                                        su <- scrutExprDepthM+                                                        return $ au ++ su                            NONREC e         -> do requireAllBinders config-                                                 return (e, (< depth))+                                                 single (e, (< depth))                            REC e            -> do requireAllBinders config-                                                 return (e, (<= depth))+                                                 single (e, (<= depth))                            MUTUALREC e      -> do requireAllBinders config-                                                 return (e, (<= depth+1))+                                                 single (e, (<= depth+1))                            TOPLEVEL e       -> do requireAllBinders config-                                                 return (e, (<= depth)) -- Depth should always be 0 for top-level bindings.+                                                 single (e, (<= depth)) -- Depth should always be 0 for top-level bindings.                                                                         -- Any inlined variables should only refer to top-level bindings or global things, else they've been captured.                            _                -> fail "variable is not bound to an expression."   where+    single = return . (:[])     requireAllBinders :: Monad m => InlineConfig -> m ()     requireAllBinders AllBinders         = return ()     requireAllBinders (CaseBinderOnly _) = fail "not a case binder."@@ -196,12 +210,12 @@ alt2Exp :: Monad m => [Type] -> (AltCon,[Var]) -> m CoreExpr alt2Exp _   (DEFAULT   , _ ) = fail "DEFAULT alternative cannot be converted to an expression." alt2Exp _   (LitAlt l  , _ ) = return $ Lit l-alt2Exp tys (DataAlt dc, vs) = return $ mkCoreConApps dc (map Type tys ++ map (varToCoreExpr . zapVarOccInfo) vs)+alt2Exp tys (DataAlt dc, vs) = return $ mkDataConApp tys dc vs  -- | Get list of possible inline targets. Used by shell for completion. inlineTargetsT :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c                   , ReadBindings c, HasEmptyContext c, MonadCatch m )-               => Transform c m Core [String]+               => Transform c m LCore [String] inlineTargetsT = collectT $ promoteT $ whenM (testM inlineR) (varT $ arr unqualifiedName)  -- | Build a CoreExpr for a DFunUnfolding

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, LambdaCase #-}  module HERMIT.Dictionary.Kure     ( -- * KURE Strategies@@ -21,95 +21,117 @@ -- | -- This list contains reflections of the KURE strategies as 'External's. externals :: [External] externals = map (.+ KURE)-   [ external "id"         (idR :: RewriteH Core)+   [ external "id"         (idR :: RewriteH LCore)        [ "Perform an identity rewrite."] .+ Shallow-   , external "success"    (successT :: TransformH Core ())+   , external "id"         (idR :: RewriteH LCoreTC)+       [ "Perform an identity rewrite."] .+ Shallow+   , external "success"    (successT :: TransformH LCore ())        [ "An always succeeding translation." ]-   , external "fail"       (fail :: String -> RewriteH Core)+   , external "fail"       (fail :: String -> RewriteH LCore)        [ "A failing rewrite."]-   , external "<+"         ((<+) :: RewriteH Core -> RewriteH Core -> RewriteH Core)+   , external "<+"         ((<+) :: RewriteH LCore -> RewriteH LCore -> RewriteH LCore)        [ "Perform the first rewrite, and then, if it fails, perform the second rewrite." ]-   , external "<+"         ((<+) :: TransformH Core () -> TransformH Core () -> TransformH Core ())+   , external "<+"         ((<+) :: TransformH LCore () -> TransformH LCore () -> TransformH LCore ())        [ "Perform the first check, and then, if it fails, perform the second check." ]-   , external ">>>"        ((>>>) :: RewriteH Core -> RewriteH Core -> RewriteH Core)+   , external ">>>"        ((>>>) :: RewriteH LCore -> RewriteH LCore -> RewriteH LCore)        [ "Compose rewrites, requiring both to succeed." ]-   , external ">>>"        ((>>>) :: BiRewriteH Core -> BiRewriteH Core -> BiRewriteH Core)+   , external ">>>"        ((>>>) :: BiRewriteH LCore -> BiRewriteH LCore -> BiRewriteH LCore)        [ "Compose bidirectional rewrites, requiring both to succeed." ]-   , external ">+>"        ((>+>) :: RewriteH Core -> RewriteH Core -> RewriteH Core)+   , external ">>>"        ((>>>) :: RewriteH LCoreTC -> RewriteH LCoreTC -> RewriteH LCoreTC)+       [ "Compose rewrites, requiring both to succeed." ]+   , external ">+>"        ((>+>) :: RewriteH LCore -> RewriteH LCore -> RewriteH LCore)        [ "Compose rewrites, allowing one to fail." ]-   , external "try"        (tryR :: RewriteH Core -> RewriteH Core)+   , external "try"        (tryR :: RewriteH LCore -> RewriteH LCore)        [ "Try a rewrite, and perform the identity if the rewrite fails." ]-   , external "repeat"     (repeatR :: RewriteH Core -> RewriteH Core)+   , external "repeat"     (repeatR :: RewriteH LCore -> RewriteH LCore)        [ "Repeat a rewrite until it would fail." ] .+ Loop-   , external "replicate"  ((\ n -> andR . replicate n)  :: Int -> RewriteH Core -> RewriteH Core)+   , external "replicate"  ((\ n -> andR . replicate n)  :: Int -> RewriteH LCore -> RewriteH LCore)        [ "Repeat a rewrite n times." ]-   , external "all"        (allR :: RewriteH Core -> RewriteH Core)+   , external "all"        (allR :: RewriteH LCore -> RewriteH LCore)        [ "Apply a rewrite to all children of the node, requiring success at every child." ] .+ Shallow-   , external "any"        (anyR :: RewriteH Core -> RewriteH Core)+   , external "any"        (anyR :: RewriteH LCore -> RewriteH LCore)        [ "Apply a rewrite to all children of the node, requiring success for at least one child." ] .+ Shallow-   , external "one"        (oneR :: RewriteH Core -> RewriteH Core)+   , external "one"        (oneR :: RewriteH LCore -> RewriteH LCore)        [ "Apply a rewrite to the first child of the node for which it can succeed." ] .+ Shallow-   , external "all-bu"     (allbuR :: RewriteH Core -> RewriteH Core)+   , external "all-bu"     (allbuR :: RewriteH LCore -> RewriteH LCore)        [ "Promote a rewrite to operate over an entire tree in bottom-up order, requiring success at every node." ] .+ Deep-   , external "all-td"     (alltdR :: RewriteH Core -> RewriteH Core)+   , external "all-td"     (alltdR :: RewriteH LCore -> RewriteH LCore)        [ "Promote a rewrite to operate over an entire tree in top-down order, requiring success at every node." ] .+ Deep-   , external "all-du"     (allduR :: RewriteH Core -> RewriteH Core)+   , external "all-du"     (allduR :: RewriteH LCore -> RewriteH LCore)        [ "Apply a rewrite twice, in a top-down and bottom-up way, using one single tree traversal,",          "succeeding if they all succeed."] .+ Deep-   , external "any-bu"     (anybuR :: RewriteH Core -> RewriteH Core)+   , external "any-bu"     (anybuR :: RewriteH LCore -> RewriteH LCore)        [ "Promote a rewrite to operate over an entire tree in bottom-up order, requiring success for at least one node." ] .+ Deep-   , external "any-td"     (anytdR :: RewriteH Core -> RewriteH Core)+   , external "any-td"     (anytdR :: RewriteH LCore -> RewriteH LCore)        [ "Promote a rewrite to operate over an entire tree in top-down order, requiring success for at least one node." ] .+ Deep-   , external "any-du"     (anyduR :: RewriteH Core -> RewriteH Core)+   , external "any-du"     (anyduR :: RewriteH LCore -> RewriteH LCore)        [ "Apply a rewrite twice, in a top-down and bottom-up way, using one single tree traversal,",          "succeeding if any succeed."] .+ Deep-   , external "one-td"     (onetdR :: RewriteH Core -> RewriteH Core)+   , external "one-td"     (onetdR :: RewriteH LCore -> RewriteH LCore)        [ "Apply a rewrite to the first node (in a top-down order) for which it can succeed." ] .+ Deep-   , external "one-bu"     (onebuR :: RewriteH Core -> RewriteH Core)+   , external "one-bu"     (onebuR :: RewriteH LCore -> RewriteH LCore)        [ "Apply a rewrite to the first node (in a bottom-up order) for which it can succeed." ] .+ Deep-   , external "prune-td"   (prunetdR :: RewriteH Core -> RewriteH Core)+   , external "prune-td"   (prunetdR :: RewriteH LCore -> RewriteH LCore)        [ "Attempt to apply a rewrite in a top-down manner, prunning at successful rewrites." ] .+ Deep-   , external "innermost"  (innermostR :: RewriteH Core -> RewriteH Core)+   , external "innermost"  (innermostR :: RewriteH LCore -> RewriteH LCore)        [ "A fixed-point traveral, starting with the innermost term." ] .+ Deep .+ Loop-   , external "focus"      (hfocusR :: TransformH CoreTC LocalPathH -> RewriteH CoreTC -> RewriteH CoreTC)+   , external "focus"      (hfocusR :: TransformH LCoreTC LocalPathH -> RewriteH LCoreTC -> RewriteH LCoreTC)        [ "Apply a rewrite to a focal point."] .+ Navigation .+ Deep-   , external "focus"      (hfocusT :: TransformH CoreTC LocalPathH -> TransformH CoreTC String -> TransformH CoreTC String)+   , external "focus"      (hfocusT :: TransformH LCoreTC LocalPathH -> TransformH LCoreTC String -> TransformH LCoreTC String)        [ "Apply a query at a focal point."] .+ Navigation .+ Deep-   , external "focus"      (hfocusR . return :: LocalPathH -> RewriteH CoreTC -> RewriteH CoreTC)+   , external "focus"      ((\p -> hfocusR (return p)) :: LocalPathH -> RewriteH LCoreTC -> RewriteH LCoreTC)        [ "Apply a rewrite to a focal point."] .+ Navigation .+ Deep-   , external "focus"      (hfocusT . return :: LocalPathH -> TransformH CoreTC String -> TransformH CoreTC String)+   , external "focus"      ((\p -> hfocusT (return p)) :: LocalPathH -> TransformH LCoreTC String -> TransformH LCoreTC String)        [ "Apply a query at a focal point."] .+ Navigation .+ Deep-   , external "when"       ((>>) :: TransformH Core () -> RewriteH Core -> RewriteH Core)+   , external "focus"      (hfocusR :: TransformH LCore LocalPathH -> RewriteH LCore -> RewriteH LCore)+       [ "Apply a rewrite to a focal point."] .+ Navigation .+ Deep+   , external "focus"      (hfocusT :: TransformH LCore LocalPathH -> TransformH LCore String -> TransformH LCore String)+       [ "Apply a query at a focal point."] .+ Navigation .+ Deep+   , external "focus"      ((\p -> hfocusR (return p)) :: LocalPathH -> RewriteH LCore -> RewriteH LCore)+       [ "Apply a rewrite to a focal point."] .+ Navigation .+ Deep+   , external "focus"      ((\p -> hfocusT (return p)) :: LocalPathH -> TransformH LCore String -> TransformH LCore String)+       [ "Apply a query at a focal point."] .+ Navigation .+ Deep+   , external "when"       ((>>) :: TransformH LCore () -> RewriteH LCore -> RewriteH LCore)        [ "Apply a rewrite only if the check succeeds." ] .+ Predicate-   , external "not"        (notM :: TransformH Core () -> TransformH Core ())+   , external "not"        (notM :: TransformH LCore () -> TransformH LCore ())        [ "Cause a failing check to succeed, a succeeding check to fail." ] .+ Predicate-   , external "invert"     (invertBiT :: BiRewriteH Core -> BiRewriteH Core)+   , external "invert"     (invertBiT :: BiRewriteH LCore -> BiRewriteH LCore)        [ "Reverse a bidirectional rewrite." ]-   , external "forward"    (forwardT :: BiRewriteH Core -> RewriteH Core)+   , external "forward"    (forwardT :: BiRewriteH LCore -> RewriteH LCore)        [ "Apply a bidirectional rewrite forewards." ]-   , external "backward"   (backwardT :: BiRewriteH Core -> RewriteH Core)+   , external "backward"   (backwardT :: BiRewriteH LCore -> RewriteH LCore)        [ "Apply a bidirectional rewrite backwards." ]-   , external "test"       (testQuery :: RewriteH Core -> TransformH Core String)+   , external "test"       (testQuery :: RewriteH LCore -> TransformH LCore String)        [ "Determine if a rewrite could be successfully applied." ]-   , external "any-call"   (anyCallR :: RewriteH Core -> RewriteH Core)+   , external "any-call"   (anyCallR_LCore :: RewriteH LCore -> RewriteH LCore)        [ "any-call (.. unfold command ..) applies an unfold command to all applications."        , "Preference is given to applications with more arguments." ] .+ Deep-   , external "promote"    (promoteR :: RewriteH Core -> RewriteH CoreTC)+   , external "promote"    (promoteR :: RewriteH LCore -> RewriteH LCoreTC)        [ "Promote a RewriteCore to a RewriteCoreTC" ]-   , external "extract"    (extractR :: RewriteH CoreTC -> RewriteH Core)+   , external "extract"    (extractR :: RewriteH LCoreTC -> RewriteH LCore)        [ "Extract a RewriteCore from a RewriteCoreTC" ]-   , external "between"    (betweenR :: Int -> Int -> RewriteH CoreTC -> RewriteH CoreTC)+   , external "extract"    (extractT :: TransformH LCoreTC String -> TransformH LCore String)+       [ "Extract a TransformLCoreString from a TransformLCoreTCString" ]+   , external "between"    (betweenR :: Int -> Int -> RewriteH LCoreTC -> RewriteH LCoreTC)        [ "between x y rr -> perform rr at least x times and at most y times." ]+   , external "atPath"     (flip hfocusT idR :: TransformH LCore LocalPathH -> TransformH LCore LCore)+       [ "return the expression found at the given path" ]+   , external "atPath"     (flip hfocusT idR :: TransformH LCoreTC LocalPathH -> TransformH LCoreTC LCoreTC)+       [ "return the expression found at the given path" ]+   , external "atPath"     (extractT . flip hfocusT projectT :: TransformH LCoreTC LocalPathH -> TransformH LCore LCore)+       [ "return the expression found at the given path" ]    ]  ------------------------------------------------------------------------------------ -hfocusR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m CoreTC LocalPathH -> Rewrite c m CoreTC -> Rewrite c m CoreTC+hfocusR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, Walker c u, MonadCatch m)+        => Transform c m u LocalPathH -> Rewrite c m u -> Rewrite c m u hfocusR tp r = do lp <- tp                   localPathR lp r {-# INLINE hfocusR #-} -hfocusT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m CoreTC LocalPathH -> Transform c m CoreTC String -> Transform c m CoreTC String+hfocusT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, Walker c u, MonadCatch m)+        => Transform c m u LocalPathH -> Transform c m u b -> Transform c m u b hfocusT tp t = do lp <- tp                   localPathT lp t {-# INLINE hfocusT #-}@@ -131,13 +153,24 @@ anyCallR :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext 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+              readerT $ \case+                           ExprCore (App {}) -> childR App_Arg (anyCallR rr)+                                                >+> (rr <+ childR App_Fun (anyCallR rr))+                           ExprCore (Var {}) -> rr+                           _                 -> anyR (anyCallR rr) +-- | Top-down traversal tuned to matching function calls.+anyCallR_LCore :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m)+         => Rewrite c m LCore -> Rewrite c m LCore+anyCallR_LCore rr = prefixFailMsg "any-call failed: " $+              readerT $ \case+                           LCore (ExprCore (App {})) ->     childR App_Arg (anyCallR_LCore rr)+                                                        >+> (rr <+ childR App_Fun (anyCallR_LCore rr))+                           LCore (ExprCore (Var {})) -> rr+                           _                         -> anyR (anyCallR_LCore rr)++-- TODO: sort out this duplication+ ------------------------------------------------------------------------------------  -- | betweenR x y rr -> perform rr at least x times and at most y times.@@ -150,3 +183,4 @@                | c < l  = rr >>> go (c+1)   -- haven't hit lower bound yet                | otherwise = tryR (rr >>> go (c+1))  -- met lower bound +------------------------------------------------------------------------------------

@@ -34,7 +34,6 @@ import HERMIT.Utilities  import HERMIT.Dictionary.Common-import HERMIT.Dictionary.GHC (substCoreExpr) import HERMIT.Dictionary.Local.Bind hiding (externals) import qualified HERMIT.Dictionary.Local.Bind as Bind import HERMIT.Dictionary.Local.Case hiding (externals)@@ -52,31 +51,31 @@ --   (Many taken from Chapter 3 of Andre Santos' dissertation.) externals :: [External] externals =-    [ external "beta-reduce" (promoteExprR betaReduceR :: RewriteH Core)+    [ external "beta-reduce" (promoteExprR betaReduceR :: RewriteH LCore)         [ "((\\ v -> E1) E2) ==> let v = E2 in E1"         , "This form of beta-reduction is safe if E2 is an arbitrary expression"         , "(won't duplicate work)." ]                                 .+ Eval .+ Shallow-    , external "beta-expand" (promoteExprR betaExpandR :: RewriteH Core)+    , external "beta-expand" (promoteExprR betaExpandR :: RewriteH LCore)         [ "(let v = e1 in e2) ==> (\\ v -> e2) e1" ]                            .+ Shallow-    , external "eta-reduce" (promoteExprR etaReduceR :: RewriteH Core)+    , external "eta-reduce" (promoteExprR etaReduceR :: RewriteH LCore)         [ "(\\ v -> e1 v) ==> e1" ]                                             .+ Eval .+ Shallow-    , external "eta-expand" (promoteExprR . etaExpandR :: String -> RewriteH Core)+    , external "eta-expand" (promoteExprR . etaExpandR :: String -> RewriteH LCore)         [ "\"eta-expand 'v\" performs e1 ==> (\\ v -> e1 v)" ]                  .+ Shallow .+ Introduce-    , external "flatten-module" (promoteModGutsR flattenModuleR :: RewriteH Core)+    , external "flatten-module" (promoteModGutsR flattenModuleR :: RewriteH LCore)         [ "Flatten all the top-level binding groups in the module to a single recursive binding group."         , "This can be useful if you intend to appply GHC RULES." ]-    , external "flatten-program" (promoteProgR flattenProgramR :: RewriteH Core)+    , external "flatten-program" (promoteProgR flattenProgramR :: RewriteH LCore)         [ "Flatten all the top-level binding groups in a program (list of binding groups) to a single"         , "recursive binding group.  This can be useful if you intend to apply GHC RULES." ]-    , external "abstract" (promoteExprR . abstractR . mkOccPred :: OccurrenceName -> RewriteH Core)+    , external "abstract" (promoteExprR . abstractR . mkOccPred :: OccurrenceName -> RewriteH LCore)         [ "Abstract over a variable using a lambda."         , "e  ==>  (\\ x -> e) x" ]                                             .+ Shallow .+ Introduce .+ Context-    , external "push" ((\ nm strictf -> push (Just strictf) (cmpString2Var nm)) :: String -> RewriteH Core -> RewriteH Core)+    , external "push" ((\ nm strictf -> push (Just strictf) (cmpString2Var nm)) :: String -> RewriteH LCore -> RewriteH LCore)         [ "Push a function 'f into a case-expression or let-expression argument,"         , "given a proof that f (fully saturated with type arguments) is strict." ] .+ Shallow .+ Commute-    , external "push-unsafe" (push Nothing . cmpString2Var :: String -> RewriteH Core)+    , external "push-unsafe" (push Nothing . cmpString2Var :: String -> RewriteH LCore)         [ "Push a function 'f into a case-expression or let-expression argument."-        , "Requires 'f to be strict." ] .+ Shallow .+ Commute .+ PreCondition+        , "Requires 'f to be strict." ] .+ Shallow .+ Commute .+ PreCondition .+ Unsafe     ]     ++ Bind.externals     ++ Case.externals@@ -163,9 +162,9 @@  ------------------------------------------------------------------------------------------------------ -push :: Maybe (RewriteH Core) -- ^ a proof that the function (after being applied to its type arguments) is strict+push :: Maybe (RewriteH LCore) -- ^ a proof that the function (after being applied to its type arguments) is strict      -> (Id -> Bool)          -- ^ a predicate to identify the function-     -> RewriteH Core+     -> RewriteH LCore push mstrict p = promoteExprR (pushR (extractR `fmap` mstrict) p)  -- | Push a function through a Case or Let expression.

@@ -17,10 +17,10 @@ -- | Externals for manipulating binding groups. externals :: [External] externals =-    [ external "nonrec-to-rec" (promoteBindR nonrecToRecR :: RewriteH Core)+    [ external "nonrec-to-rec" (promoteBindR nonrecToRecR :: RewriteH LCore)         [ "Convert a non-recursive binding into a recursive binding group with a single definition."         , "NonRec v e ==> Rec [Def v e]" ]                           .+ Shallow-    , external "rec-to-nonrec" (promoteBindR recToNonrecR :: RewriteH Core)+    , external "rec-to-nonrec" (promoteBindR recToNonrecR :: RewriteH LCore)         [ "Convert a singleton recursive binding into a non-recursive binding group."         , "Rec [Def v e] ==> NonRec v e,  (v not free in e)" ]     ]

@@ -16,8 +16,9 @@     , caseReduceR     , caseReduceDataconR     , caseReduceLiteralR-    -- , caseReduceIdR     , caseReduceUnfoldR+    , casesForM+    , caseExprsForM     , caseSplitR     , caseSplitInlineR     , caseInlineScrutineeR@@ -32,7 +33,6 @@     ) where  import Control.Arrow-import Control.Applicative import Control.Monad import Control.Monad.IO.Class @@ -44,96 +44,101 @@ import HERMIT.External import HERMIT.GHC import HERMIT.Kure+import HERMIT.Lemma import HERMIT.Monad import HERMIT.Name import HERMIT.ParserCore import HERMIT.Utilities +import HERMIT.Dictionary.AlphaConversion hiding (externals) import HERMIT.Dictionary.Common+import HERMIT.Dictionary.Fold hiding (externals) import HERMIT.Dictionary.Inline hiding (externals)-import HERMIT.Dictionary.AlphaConversion hiding (externals)-import HERMIT.Dictionary.Fold (foldVarR)-import HERMIT.Dictionary.GHC (substCoreExpr) import HERMIT.Dictionary.Undefined (verifyStrictT, buildStrictnessLemmaT) import HERMIT.Dictionary.Unfold (unfoldR) --- NOTE: these are hard to test in small examples, as GHC does them for us, so use with caution ------------------------------------------------------------------------------  -- | Externals relating to Case expressions. externals :: [External] externals =-    [ external "case-float-app" (promoteExprR caseFloatAppR :: RewriteH Core)+    [ external "case-float-app" (promoteExprR caseFloatAppR :: RewriteH LCore)         [ "(case ec of alt -> e) v ==> case ec of alt -> e v" ] .+ Commute .+ Shallow-    , external "case-float-arg" ((\ strict -> promoteExprR (caseFloatArg Nothing (Just strict))) :: RewriteH Core -> RewriteH Core)+    , external "case-float-arg" ((\ strict -> promoteExprR (caseFloatArg Nothing (Just strict))) :: RewriteH LCore -> RewriteH LCore)         [ "Given a proof that f is strict, then"         , "f (case s of alt -> e) ==> case s of alt -> f e" ]   .+ Commute .+ Shallow-    , external "case-float-arg" ((\ f strict -> promoteExprR (caseFloatArg (Just f) (Just strict))) :: CoreString -> RewriteH Core -> RewriteH Core)+    , external "case-float-arg" ((\ f strict -> promoteExprR (caseFloatArg (Just f) (Just strict))) :: CoreString -> RewriteH LCore -> RewriteH LCore)         [ "For a specified f, given a proof that f is strict, then"         , "f (case s of alt -> e) ==> case s of alt -> f e" ]   .+ Commute .+ Shallow-    , external "case-float-arg-unsafe" ((\ f -> promoteExprR (caseFloatArg (Just f) Nothing)) :: CoreString -> RewriteH Core)+    , external "case-float-arg-unsafe" ((\ f -> promoteExprR (caseFloatArg (Just f) Nothing)) :: CoreString -> RewriteH LCore)         [ "For a specified f,"         , "f (case s of alt -> e) ==> case s of alt -> f e" ]   .+ Commute .+ Shallow .+ PreCondition .+ Strictness-    , external "case-float-arg-unsafe" (promoteExprR (caseFloatArg Nothing Nothing) :: RewriteH Core)-        [ "f (case s of alt -> e) ==> case s of alt -> f e" ]   .+ Commute .+ Shallow .+ PreCondition .+ Strictness-    , external "case-float-arg-lemma" (promoteExprR . caseFloatArgLemmaR :: LemmaName -> RewriteH Core)+    , external "case-float-arg-unsafe" (promoteExprR . caseFloatArgLemmaR UnsafeUsed :: LemmaName -> RewriteH LCore)+        [ "f (case s of alt -> e) ==> case s of alt -> f e" ]   .+ Commute .+ Shallow .+ PreCondition .+ Strictness .+ Unsafe+    , external "case-float-arg-lemma" (promoteExprR . caseFloatArgLemmaR Obligation :: LemmaName -> RewriteH LCore)         [ "f (case s of alt -> e) ==> case s of alt -> f e"         , "Generates a lemma with given name for strictness side condition on f." ] .+ Commute .+ Shallow .+ PreCondition .+ Strictness-    , external "case-float-case" (promoteExprR caseFloatCaseR :: RewriteH Core)+    , external "case-float-case" (promoteExprR caseFloatCaseR :: RewriteH LCore)         [ "case (case ec of alt1 -> e1) of alta -> ea ==> case ec of alt1 -> case e1 of alta -> ea" ] .+ Commute .+ Eval-    , external "case-float-cast" (promoteExprR caseFloatCastR :: RewriteH Core)+    , external "case-float-cast" (promoteExprR caseFloatCastR :: RewriteH LCore)         [ "cast (case s of p -> e) co ==> case s of p -> cast e co" ]        .+ Shallow .+ Commute-    , external "case-float-let" (promoteExprR caseFloatLetR :: RewriteH Core)+    , external "case-float-let" (promoteExprR caseFloatLetR :: RewriteH LCore)         [ "let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e" ] .+ Commute .+ Shallow .+ Strictness-    , external "case-float" (promoteExprR caseFloatR :: RewriteH Core)+    , external "case-float" (promoteExprR caseFloatR :: RewriteH LCore)         [ "case-float = case-float-app <+ case-float-case <+ case-float-let <+ case-float-cast" ] .+ Commute .+ Shallow .+ Strictness-    , external "case-float-in" (promoteExprR caseFloatInR :: RewriteH Core)+    , external "case-float-in" (promoteExprR caseFloatInR :: RewriteH LCore)         [ "Float in a Case whatever the context." ]                             .+ Commute .+ Shallow .+ PreCondition-    , external "case-float-in-args" (promoteExprR caseFloatInArgsR :: RewriteH Core)+    , external "case-float-in-args" (promoteExprR caseFloatInArgsR :: RewriteH LCore)         [ "Float in a Case whose alternatives are parallel applications of the same function." ] .+ Commute .+ Shallow .+ PreCondition .+ Strictness-    -- , external "case-float-in-app" (promoteExprR caseFloatInApp :: RewriteH Core)+    -- , external "case-float-in-app" (promoteExprR caseFloatInApp :: RewriteH LCore)     --     [ "Float in a Case whose alternatives are applications of different functions with the same arguments." ] .+ Commute .+ Shallow .+ PreCondition-    , external "case-reduce" (promoteExprR (caseReduceR True) :: RewriteH Core)+    , external "case-reduce" (promoteExprR (caseReduceR True) :: RewriteH LCore)         [ "Case of Known Constructor"         , "case-reduce-datacon <+ case-reduce-literal" ]                     .+ Shallow .+ Eval-    , external "case-reduce-datacon" (promoteExprR (caseReduceDataconR True) :: RewriteH Core)+    , external "case-reduce-datacon" (promoteExprR (caseReduceDataconR True) :: RewriteH LCore)         [ "Case of Known Constructor"         , "case C v1..vn of C w1..wn -> e ==> let { w1 = v1 ; .. ; wn = vn } in e" ]    .+ Shallow .+ Eval-    , external "case-reduce-literal" (promoteExprR (caseReduceLiteralR True) :: RewriteH Core)+    , external "case-reduce-literal" (promoteExprR (caseReduceLiteralR True) :: RewriteH LCore)         [ "Case of Known Constructor"         , "case L of L -> e ==> e" ]                                         .+ Shallow .+ Eval-    , external "case-reduce-unfold" (promoteExprR (caseReduceUnfoldR True) :: RewriteH Core)+    , external "case-reduce-unfold" (promoteExprR (caseReduceUnfoldR True) :: RewriteH LCore)         [ "Unfold the case scrutinee and then case-reduce." ] .+ Shallow .+ Eval .+ Context-    , external "case-split" (promoteExprR . caseSplitR . cmpString2Var :: String -> RewriteH Core)+    , external "case-split" ((\nm -> findVarT (unOccurrenceName nm) >>= promoteExprR . caseSplitR . varToCoreExpr) :: OccurrenceName -> RewriteH LCore)         [ "case-split 'x"-        , "e ==> case x of C1 vs -> e; C2 vs -> e, where x is free in e" ] .+ Shallow .+ Strictness-    , external "case-split-inline" (promoteExprR . caseSplitInlineR . cmpString2Var :: String -> RewriteH Core)+        , "e ==> case x of C1 vs -> e; C2 vs -> e, where x is free in e" ] .+ Deep .+ Strictness+    , external "case-split" (parseCoreExprT >=> promoteR . caseSplitR :: CoreString -> RewriteH LCore)+        [ "case-split [| expr |]"+        , "e ==> case expr of C1 vs -> e; C2 vs -> e"] .+ Deep .+ Strictness+    , external "case-split-inline" ((\nm -> findVarT (unOccurrenceName nm) >>= promoteExprR . caseSplitInlineR . varToCoreExpr) :: OccurrenceName -> RewriteH LCore)         [ "Like case-split, but additionally inlines the matched constructor "         , "applications for all occurances of the named variable." ] .+ Deep .+ Strictness-    , external "case-intro-seq" (promoteExprR . caseIntroSeqR . cmpString2Var :: String -> RewriteH Core)+    , external "case-split-inline" (parseCoreExprT >=> promoteExprR . caseSplitInlineR :: CoreString -> RewriteH LCore)+        [ "Like case-split, but additionally inlines the matched constructor "+        , "applications for all occurances of the case binder." ] .+ Deep .+ Strictness+    , external "case-intro-seq" (promoteExprR . caseIntroSeqR . cmpString2Var :: String -> RewriteH LCore)         [ "Force evaluation of a variable by introducing a case."         , "case-intro-seq 'v is is equivalent to adding @(seq v)@ in the source code." ] .+ Shallow .+ Introduce .+ Strictness-    , external "case-elim-seq" (promoteExprR caseElimSeqR :: RewriteH Core)+    , external "case-elim-seq" (promoteExprR caseElimSeqR :: RewriteH LCore)         [ "Eliminate a case that corresponds to a pointless seq."  ] .+ Deep .+ Eval .+ Strictness-    , external "case-inline-alternative" (promoteExprR caseInlineAlternativeR :: RewriteH Core)+    , external "case-inline-alternative" (promoteExprR caseInlineAlternativeR :: RewriteH LCore)         [ "Inline the case binder as the case-alternative pattern everywhere in the case alternatives." ] .+ Deep-    , external "case-inline-scrutinee" (promoteExprR caseInlineScrutineeR :: RewriteH Core)+    , external "case-inline-scrutinee" (promoteExprR caseInlineScrutineeR :: RewriteH LCore)         [ "Inline the case binder as the case scrutinee everywhere in the case alternatives." ] .+ Deep-    , external "case-merge-alts" (promoteExprR caseMergeAltsR :: RewriteH Core)+    , external "case-merge-alts" (promoteExprR caseMergeAltsR :: RewriteH LCore)         [ "Merge all case alternatives into a single default case."         , "The RHS of each alternative must be the same."         , "case s of {pat1 -> e ; pat2 -> e ; ... ; patn -> e} ==> case s of {_ -> e}" ]-    , external "case-merge-alts-with-binder" (promoteExprR caseMergeAltsWithBinderR :: RewriteH Core)+    , external "case-merge-alts-with-binder" (promoteExprR caseMergeAltsWithBinderR :: RewriteH LCore)         [ "A cleverer version of 'mergeCaseAlts' that first attempts to"         , "abstract out any occurrences of the alternative pattern using the case binder." ] .+ Deep-    , external "case-elim" (promoteExprR caseElimR :: RewriteH Core)+    , external "case-elim" (promoteExprR caseElimR :: RewriteH LCore)         [ "case s of w; C vs -> e ==> e if w and vs are not free in e" ]     .+ Shallow .+ Strictness-    , external "case-elim-inline-scrutinee" (promoteExprR caseElimInlineScrutineeR :: RewriteH Core)+    , external "case-elim-inline-scrutinee" (promoteExprR caseElimInlineScrutineeR :: RewriteH LCore)         [ "Eliminate a case, inlining any occurrences of the case binder as the scrutinee." ] .+ Deep-    , external "case-elim-merge-alts" (promoteExprR caseElimMergeAltsR :: RewriteH Core)+    , external "case-elim-merge-alts" (promoteExprR caseElimMergeAltsR :: RewriteH LCore)         [ "Eliminate a case, merging the case alternatives into a single default alternative",           "and inlining the case binder as the scrutinee (if possible)." ] .+ Deep-    , external "case-fold-binder" (promoteExprR caseFoldBinderR :: RewriteH Core)+    , external "case-fold-binder" (promoteExprR caseFoldBinderR :: RewriteH LCore)         [ "In the case alternatives, fold any occurrences of the case alt patterns to the case binder." ]     ] @@ -166,7 +171,7 @@           (\(Case s b _ alts) v -> let newAlts = mapAlts (`App` v) alts                                     in Case s b (coreAltsType newAlts) newAlts) -caseFloatArg :: Maybe CoreString -> Maybe (RewriteH Core) -> RewriteH CoreExpr+caseFloatArg :: Maybe CoreString -> Maybe (RewriteH LCore) -> RewriteH CoreExpr caseFloatArg mfstr mstrictCore = let mstrict = extractR <$> mstrictCore                                   in case mfstr of                                        Nothing    -> caseFloatArgR Nothing mstrict@@ -202,9 +207,9 @@ --   Only safe if @f@ is strict, so introduces a lemma to prove. caseFloatArgLemmaR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasHermitMEnv m                       , HasHscEnv m, HasDynFlags m, HasLemmas m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )-                   => LemmaName -> Rewrite c m CoreExpr-caseFloatArgLemmaR nm = prefixFailMsg "Case floating from application argument failed: " $-                        withPatFailMsg "App f (Case s w ty alts)" $ do+                   => Used -> LemmaName -> Rewrite c m CoreExpr+caseFloatArgLemmaR u nm = prefixFailMsg "Case floating from application argument failed: " $+                          withPatFailMsg "App f (Case s w ty alts)" $ do     App f (Case s w _ alts) <- idR      let fvs         = freeVarsExpr f@@ -215,7 +220,7 @@             appAllR idR (alphaCaseBinderR Nothing) >>> caseFloatArgR Nothing Nothing        | all isEmptyVarSet altCaptures -> do             let new_alts = mapAlts (App f) alts-            buildStrictnessLemmaT nm f+            buildStrictnessLemmaT u nm f             return $ Case s w (coreAltsType new_alts) new_alts        | otherwise ->             appAllR idR (caseAllR idR idR idR (\ n -> let vs = varSetElems (altCaptures !! n)@@ -363,25 +368,44 @@                               | otherwise                  -> caseOneR (fail "scrutinee") (fail "binder") (fail "type") (\ _ -> acceptR (\ (dc'',_,_) -> dc'' == dc') >>> alphaAltVarsR shadows) >>> go -- WARNING: The alpha-renaming to avoid variable capture has not been tested.  We need testing infrastructure! --- | Case split a free identifier in an expression:+-- | Case split on an arbitrary scrutinee s. All free variables in s should be in scope. ----- E.g. Assume expression e which mentions i :: [a]+-- E.g. If s has type [a], then case-split s: ----- e ==> case i of i---         []     -> e---         (a:as) -> e-caseSplitR :: (MonadCatch m, MonadUnique m) => (Id -> Bool) -> Rewrite c m CoreExpr-caseSplitR idPred = prefixFailMsg "caseSplit failed: " $-               do i            <- matchingFreeIdT idPred-                  (tycon, tys) <- splitTyConAppM (idType i)-                  let aNms     = map (:[]) $ cycle ['a'..'z']-                  contextfreeT $ \ e -> do dcsAndVars <- mapM (\ dc -> liftM (dc,) (sequence [ newIdH a ty | (a,ty) <- zip aNms $ dataConInstArgTys dc tys ]))-                                                              (tyConDataCons tycon)-                                           w <- cloneVarH (++ "'") i-                                           let e' = substCoreExpr i (Var w) e-                                               alts = [ (DataAlt dc, as, e') | (dc,as) <- dcsAndVars ]-                                           return $ Case (Var i) w (coreAltsType alts) alts+-- e ==> case s of w+--         []     -> e[w/s]+--         (a:as) -> e[w/s]+--+-- Note that occurrences of s in e are replaced with the case binder.+caseSplitR :: forall c m. ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb+                          , MonadCatch m, MonadUnique m )+           => CoreExpr -> Rewrite c m CoreExpr+caseSplitR s = prefixFailMsg "case-split failed: " $ do+    c <- contextT+    guardMsg (all (inScope c) $ varSetElems $ freeVarsExpr s) "variables in desired scrutinee are unbound."+    w <- constT $ newVarH "w" (exprType s)+    let f = compileFold [Equality [] s (varToCoreExpr w)]+    e' <- tryR $ withVarsInScope [w] $ extractR (anytdR (promoteR $ runFoldR f) :: Rewrite c m Core)+    constT $ do+        dcsAndBss <- casesForM s+        let alts = [ (DataAlt dc, bs, e') | (dc,bs) <- dcsAndBss ]+        guardMsg (not (null alts)) "no constructors for scrutinee of that type."+        return $ Case s w (exprType e') alts +casesForM :: MonadUnique m => CoreExpr -> m [(DataCon, [Id])]+casesForM e = do+    (tyCon, tys) <- splitTyConAppM (exprType e)+    let aNms = map (:[]) $ cycle ['a'..'z']+    forM (tyConDataCons tyCon) $ \ dc -> do+        bs <- sequence [ newIdH a ty | (a,ty) <- zip aNms $ dataConInstArgTys dc tys ]+        return (dc,bs)++caseExprsForM :: MonadUnique m => CoreExpr -> m [CoreExpr]+caseExprsForM e = do+    (_, tys) <- splitTyConAppM (exprType e)+    cases <- casesForM e+    return [ mkDataConApp tys dc vs | (dc,vs) <- cases ]+ -- | Force evaluation of an identifier by introducing a case. --   This is equivalent to adding @(seq v)@ in the source code. --@@ -411,8 +435,8 @@ -- > caseSplitInline idPred = caseSplit idPred >>> caseInlineAlternativeR caseSplitInlineR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c                     , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )-                 => (Id -> Bool) -> Rewrite c m CoreExpr-caseSplitInlineR idPred = caseSplitR idPred >>> caseInlineAlternativeR+                 => CoreExpr -> Rewrite c m CoreExpr+caseSplitInlineR s = caseSplitR s >>> caseInlineAlternativeR  ------------------------------------------------------------------------------ @@ -458,10 +482,12 @@ caseFoldBinderR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c                                , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )                 => Rewrite c m CoreExpr-caseFoldBinderR = prefixFailMsg "case-fold-binder failed: " $ do-    w <- caseBinderIdT-    caseAllR idR idR idR $ \ _ -> do depth <- varBindingDepthT w-                                     extractR $ anybuR (promoteExprR (foldVarR (Just depth) w) :: Rewrite c m Core)+caseFoldBinderR = prefixFailMsg "case-fold-binder failed: " $+    -- ensure the case binder is not dead, or else fold will fail+    caseAllR idR (arr (flip setIdOccInfo NoOccInfo)) idR (const idR) >>> (do+        w <- caseBinderIdT+        caseAllR idR idR idR $ \ _ -> do depth <- varBindingDepthT w+                                         extractR $ anybuR (promoteExprR (foldVarR (Just depth) w) :: Rewrite c m Core))  -- | A cleverer version of 'mergeCaseAlts' that first attempts to abstract out any occurrences of the alternative pattern using the case binder. caseMergeAltsWithBinderR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c

@@ -6,6 +6,7 @@     , castElimReflR     , castElimSymR     , castFloatAppR+    , castFloatLamR     , castElimSymPlusR -- TODO: revisit     ) where@@ -17,9 +18,9 @@  import HERMIT.Core import HERMIT.Context-import HERMIT.Kure import HERMIT.External import HERMIT.GHC+import HERMIT.Kure  import HERMIT.Dictionary.Common @@ -28,17 +29,19 @@ -- | Externals relating to Case expressions. externals :: [External] externals =-    [ external "cast-elim" (promoteExprR castElimR :: RewriteH Core)+    [ external "cast-elim" (promoteExprR castElimR :: RewriteH LCore)         [ "cast-elim-refl <+ cast-elim-sym" ] .+ Shallow -- don't include in "Bash", as sub-rewrites are tagged "Bash" already.-    , external "cast-elim-refl" (promoteExprR castElimReflR :: RewriteH Core)+    , external "cast-elim-refl" (promoteExprR castElimReflR :: RewriteH LCore)         [ "cast e co ==> e ; if co is a reflexive coercion" ] .+ Shallow-    , external "cast-elim-sym" (promoteExprR castElimSymR :: RewriteH Core)+    , external "cast-elim-sym" (promoteExprR castElimSymR :: RewriteH LCore)         [ "removes pairs of symmetric casts" ]                .+ Shallow-    , external "cast-elim-sym-plus" (promoteExprR castElimSymPlusR :: RewriteH Core)+    , external "cast-elim-sym-plus" (promoteExprR castElimSymPlusR :: RewriteH LCore)         [ "removes pairs of symmetric casts possibly separated by let or case forms" ] .+ Deep .+ TODO-    , external "cast-float-app" (promoteExprR castFloatAppR :: RewriteH Core)+    , external "cast-float-app" (promoteExprR castFloatAppR :: RewriteH LCore)         [ "(cast e (c1 -> c2)) x ==> cast (e (cast x (sym c1))) c2" ] .+ Shallow-    , external "cast-elim-unsafe" (promoteExprR castElimUnsafeR :: RewriteH Core)+    , external "cast-float-lam" (promoteExprR castFloatLamR :: RewriteH LCore)+        [ "\\ x::a -> cast x (a -> b) ==> cast (\\x::a -> x) ((a -> a) -> (a -> b))" ] .+ Shallow+    , external "cast-elim-unsafe" (promoteExprR castElimUnsafeR :: RewriteH LCore)         [ "removes casts regardless of whether it is safe to do so" ] .+ Shallow .+ Experiment .+ Unsafe .+ TODO     ] @@ -78,6 +81,16 @@                 return (Cast (App e1 e2) (Coercion.substCo (Coercion.extendTvSubst emptyCvSubst t x') c2))             _ -> fail "castFloatApp" +-- (\ x::a -> cast e (b -> c)) :: a -> c+-- cast (\x::a -> e) ((a -> b) -> (a -> c))+castFloatLamR :: MonadCatch m => Rewrite c m CoreExpr+castFloatLamR = prefixFailMsg "Cast float from lambda failed: " $+                withPatFailMsg (wrongExprForm "Lam b (Cast e co)") $ do+    Lam b (Cast e co) <- idR+    let r = coercionRole co+        aTy = varType b+    return (Cast (Lam b e) (mkFunCo r (mkReflCo r aTy) co))+ -- | Attempts to tease a coercion apart into a type constructor and the application -- of a number of coercion arguments to that constructor splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])@@ -124,4 +137,3 @@  castElimUnsafeR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreExpr castElimUnsafeR = castT idR idR const-

@@ -69,81 +69,81 @@ -- | Externals relating to 'Let' expressions. externals :: [External] externals =-    [ external "let-subst" (promoteExprR letSubstR :: RewriteH Core)+    [ external "let-subst" (promoteExprR letSubstR :: RewriteH LCore)         [ "Let substitution: (let x = e1 in e2) ==> (e2[e1/x])"         , "x must not be free in e1." ]                                         .+ Deep .+ Eval-    , external "let-subst-safe" (promoteExprR letSubstSafeR :: RewriteH Core)+    , external "let-subst-safe" (promoteExprR letSubstSafeR :: RewriteH LCore)         [ "Safe let substitution"         , "let x = e1 in e2, safe to inline without duplicating work ==> e2[e1/x],"         , "x must not be free in e1." ]                                         .+ Deep .+ Eval-    , external "let-nonrec-subst-safe" (promoteExprR letNonRecSubstSafeR :: RewriteH Core)+    , external "let-nonrec-subst-safe" (promoteExprR letNonRecSubstSafeR :: RewriteH LCore)         [ "As let-subst-safe, but does not try to convert a recursive let into a non-recursive let first." ] .+ Deep .+ Eval-    -- , external "safe-let-subst-plus" (promoteExprR safeLetSubstPlusR :: RewriteH Core)+    -- , external "safe-let-subst-plus" (promoteExprR safeLetSubstPlusR :: RewriteH LCore)     --     [ "Safe let substitution"     --     , "let { x = e1, ... } in e2, "     --     , "  where safe to inline without duplicating work ==> e2[e1/x,...],"     --     , "only matches non-recursive lets" ]  .+ Deep .+ Eval-    , external "let-intro" (promoteExprR . letIntroR :: String -> RewriteH Core)+    , external "let-intro" (promoteExprR . letIntroR :: String -> RewriteH LCore)         [ "e => (let v = e in v), name of v is provided" ]                      .+ Shallow .+ Introduce-    , external "let-intro-unfolding" (promoteExprR . letIntroUnfoldingR :: HermitName -> RewriteH Core)+    , external "let-intro-unfolding" (promoteExprR . letIntroUnfoldingR :: HermitName -> RewriteH LCore)         [ "e => let f' = defn[f'/f] in e[f'/f], name of f is provided" ]-    , external "let-elim" (promoteExprR letElimR :: RewriteH Core)+    , external "let-elim" (promoteExprR letElimR :: RewriteH LCore)         [ "Remove an unused let binding."         , "(let v = e1 in e2) ==> e2, if v is not free in e1 or e2." ]          .+ Eval .+ Shallow---    , external "let-constructor-reuse" (promoteR $ not_defined "constructor-reuse" :: RewriteH Core)+--    , external "let-constructor-reuse" (promoteR $ not_defined "constructor-reuse" :: RewriteH LCore) --        [ "let v = C v1..vn in ... C v1..vn ... ==> let v = C v1..vn in ... v ..., fails otherwise" ] .+ Eval-    , external "let-float-app" (promoteExprR letFloatAppR :: RewriteH Core)+    , external "let-float-app" (promoteExprR letFloatAppR :: RewriteH LCore)         [ "(let v = ev in e) x ==> let v = ev in e x" ]                         .+ Commute .+ Shallow-    , external "let-float-arg" (promoteExprR letFloatArgR :: RewriteH Core)+    , external "let-float-arg" (promoteExprR letFloatArgR :: RewriteH LCore)         [ "f (let v = ev in e) ==> let v = ev in f e" ]                         .+ Commute .+ Shallow-    , external "let-float-lam" (promoteExprR letFloatLamR :: RewriteH Core)+    , external "let-float-lam" (promoteExprR letFloatLamR :: RewriteH LCore)         [ "The Full Laziness Transformation"         , "(\\ v1 -> let v2 = e1 in e2)  ==>  let v2 = e1 in (\\ v1 -> e2), if v1 is not free in e2."         , "If v1 = v2 then v1 will be alpha-renamed." ]                         .+ Commute .+ Shallow-    , external "let-float-let" (promoteExprR letFloatLetR :: RewriteH Core)+    , external "let-float-let" (promoteExprR letFloatLetR :: RewriteH LCore)         [ "let v = (let w = ew in ev) in e ==> let w = ew in let v = ev in e" ] .+ Commute .+ Shallow-    , external "let-float-case" (promoteExprR letFloatCaseR :: RewriteH Core)+    , external "let-float-case" (promoteExprR letFloatCaseR :: RewriteH LCore)         [ "case (let v = ev in e) of ... ==> let v = ev in case e of ..." ]     .+ Commute .+ Shallow .+ Eval-    , external "let-float-case-alt" (promoteExprR (letFloatCaseAltR Nothing) :: RewriteH Core)+    , external "let-float-case-alt" (promoteExprR (letFloatCaseAltR Nothing) :: RewriteH LCore)         [ "case s of { ... ; p -> let v = ev in e ; ... } "         , "==> let v = ev in case s of { ... ; p -> e ; ... } " ]               .+ Commute .+ Shallow .+ Eval-    , external "let-float-case-alt" (promoteExprR . letFloatCaseAltR . Just :: Int -> RewriteH Core)+    , external "let-float-case-alt" (promoteExprR . letFloatCaseAltR . Just :: Int -> RewriteH LCore)         [ "Float a let binding from specified alternative."         , "case s of { ... ; p -> let v = ev in e ; ... } "         , "==> let v = ev in case s of { ... ; p -> e ; ... } " ]               .+ Commute .+ Shallow .+ Eval-    , external "let-float-cast" (promoteExprR letFloatCastR :: RewriteH Core)+    , external "let-float-cast" (promoteExprR letFloatCastR :: RewriteH LCore)         [ "cast (let bnds in e) co ==> let bnds in cast e co" ]                 .+ Commute .+ Shallow-    , external "let-float-top" (promoteProgR letFloatTopR :: RewriteH Core)+    , external "let-float-top" (promoteProgR letFloatTopR :: RewriteH LCore)         [ "v = (let bds in e) : prog ==> bds : v = e : prog" ]                  .+ Commute .+ Shallow-    , external "let-float" (promoteProgR letFloatTopR <+ promoteExprR letFloatExprR :: RewriteH Core)+    , external "let-float" (promoteProgR letFloatTopR <+ promoteExprR letFloatExprR :: RewriteH LCore)         [ "Float a Let whatever the context." ]                                 .+ Commute .+ Shallow  -- Don't include in bash, as each sub-rewrite is tagged "Bash" already.-    , external "let-to-case" (promoteExprR letToCaseR :: RewriteH Core)+    , external "let-to-case" (promoteExprR letToCaseR :: RewriteH LCore)         [ "let v = ev in e ==> case ev of v -> e" ]                             .+ Commute .+ Shallow .+ PreCondition---    , external "let-to-case-unbox" (promoteR $ not_defined "let-to-case-unbox" :: RewriteH Core)+--    , external "let-to-case-unbox" (promoteR $ not_defined "let-to-case-unbox" :: RewriteH LCore) --        [ "let v = ev in e ==> case ev of C v1..vn -> let v = C v1..vn in e" ]-    , external "let-float-in" (promoteExprR letFloatInR :: RewriteH Core)+    , external "let-float-in" (promoteExprR letFloatInR :: RewriteH LCore)         [ "Float-in a let if possible." ]                                        .+ Commute .+ Shallow-    , external "let-float-in-app" ((promoteExprR letFloatInAppR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core)+    , external "let-float-in-app" ((promoteExprR letFloatInAppR >+> anybuR (promoteExprR letElimR)) :: RewriteH LCore)         [ "let v = ev in f a ==> (let v = ev in f) (let v = ev in a)" ]         .+ Commute .+ Shallow-    , external "let-float-in-case" ((promoteExprR letFloatInCaseR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core)+    , external "let-float-in-case" ((promoteExprR letFloatInCaseR >+> anybuR (promoteExprR letElimR)) :: RewriteH LCore)         [ "let v = ev in case s of p -> e ==> case (let v = ev in s) of p -> let v = ev in e"         , "if v does not shadow a pattern binder in p" ]                        .+ Commute .+ Shallow-    , external "let-float-in-lam" ((promoteExprR letFloatInLamR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core)+    , external "let-float-in-lam" ((promoteExprR letFloatInLamR >+> anybuR (promoteExprR letElimR)) :: RewriteH LCore)         [ "let v = ev in \\ x -> e ==> \\ x -> let v = ev in e"         , "if v does not shadow x" ]                                            .+ Commute .+ Shallow-    , external "reorder-lets" (promoteExprR . reorderNonRecLetsR :: [String] -> RewriteH Core)+    , external "reorder-lets" (promoteExprR . reorderNonRecLetsR :: [String] -> RewriteH LCore)         [ "Re-order a sequence of nested non-recursive let bindings."         , "The argument list should contain the let-bound variables, in the desired order." ]-    , external "let-tuple" (promoteExprR . letTupleR :: String -> RewriteH Core)+    , external "let-tuple" (promoteExprR . letTupleR :: String -> RewriteH LCore)         [ "Combine nested non-recursive lets into case of a tuple."         , "E.g. let {v1 = e1 ; v2 = e2 ; v3 = e3} in body ==> case (e1,e2,e3) of {(v1,v2,v3) -> body}" ] .+ Commute-    , external "prog-bind-elim" (promoteProgR progBindElimR :: RewriteH Core)+    , external "prog-bind-elim" (promoteProgR progBindElimR :: RewriteH LCore)         [ "Remove unused top-level binding(s)."         , "prog-bind-nonrec-elim <+ prog-bind-rec-elim" ]                       .+ Eval .+ Shallow-    , external "prog-bind-nonrec-elim" (promoteProgR progBindNonRecElimR :: RewriteH Core)+    , external "prog-bind-nonrec-elim" (promoteProgR progBindNonRecElimR :: RewriteH LCore)         [ "Remove unused top-level binding(s)."         , "v = e : prog ==> prog, if v is not free in prog and not exported." ] .+ Eval .+ Shallow-    , external "prog-bind-rec-elim" (promoteProgR progBindRecElimR :: RewriteH Core)+    , external "prog-bind-rec-elim" (promoteProgR progBindRecElimR :: RewriteH LCore)         [ "Remove unused top-level binding(s)."         , "v+ = e+ : prog ==> v* = e* : prog, where v* is a subset of v+ consisting"         , "of vs that are free in prog or e+, or exported." ]                   .+ Eval .+ Shallow

@@ -1,4 +1,10 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, InstanceSigs, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}  module HERMIT.Dictionary.Navigation     ( -- * Navigation@@ -19,16 +25,18 @@     , string2considerable     ) where +import Control.Arrow+import Control.Monad+ import Data.Dynamic (Typeable) import Data.Monoid -import Control.Arrow- import HERMIT.Core import HERMIT.Context import HERMIT.External import HERMIT.GHC hiding ((<>)) import HERMIT.Kure+import HERMIT.Lemma(Quantified(..)) import HERMIT.Name  import HERMIT.Dictionary.Navigation.Crumbs@@ -39,29 +47,29 @@ externals :: [External] externals = crumbExternals     ++ map (.+ Navigation)-        [ external "rhs-of" (rhsOfT . mkRhsOfPred :: RhsOfName -> TransformH Core LocalPathH)+        [ external "rhs-of" (rhsOfT . mkRhsOfPred :: RhsOfName -> TransformH LCoreTC LocalPathH)             [ "Find the path to the RHS of the binding of the named variable." ]-        , external "binding-group-of" (bindingGroupOfT . cmpString2Var :: String -> TransformH CoreTC LocalPathH)+        , external "binding-group-of" (bindingGroupOfT . cmpString2Var :: String -> TransformH LCoreTC LocalPathH)             [ "Find the path to the binding group of the named variable." ]-        , external "binding-of" (bindingOfT . mkBindingPred :: BindingName -> TransformH CoreTC LocalPathH)+        , external "binding-of" (bindingOfT . mkBindingPred :: BindingName -> TransformH LCoreTC LocalPathH)             [ "Find the path to the binding of the named variable." ]-        , external "occurrence-of" (occurrenceOfT . mkOccPred :: OccurrenceName -> TransformH CoreTC LocalPathH)+        , external "occurrence-of" (occurrenceOfT . mkOccPred :: OccurrenceName -> TransformH LCoreTC LocalPathH)             [ "Find the path to the first occurrence of the named variable." ]-        , external "application-of" (applicationOfT . mkOccPred :: OccurrenceName -> TransformH CoreTC LocalPathH)+        , external "application-of" (applicationOfT . mkOccPred :: OccurrenceName -> TransformH LCoreTC LocalPathH)             [ "Find the path to the first application of the named variable." ]-        , external "consider" (considerConstructT :: Considerable -> TransformH Core LocalPathH)+        , external "consider" (considerConstructT :: Considerable -> TransformH LCore LocalPathH)             [ "consider <c> focuses on the first construct <c>.", recognizedConsiderables ]-        , external "arg" (promoteExprT . nthArgPath :: Int -> TransformH Core LocalPathH)+        , external "arg" (promoteExprT . nthArgPath :: Int -> TransformH LCore LocalPathH)             [ "arg n focuses on the (n-1)th argument of a nested application." ]-        , external "lams-body" (promoteExprT lamsBodyT :: TransformH Core LocalPathH)+        , external "lams-body" (promoteExprT lamsBodyT :: TransformH LCore LocalPathH)             [ "Descend into the body after a sequence of lambdas." ]-        , external "lets-body" (promoteExprT letsBodyT :: TransformH Core LocalPathH)+        , external "lets-body" (promoteExprT letsBodyT :: TransformH LCore LocalPathH)             [ "Descend into the body after a sequence of let bindings." ]-        , external "prog-end" (promoteModGutsT gutsProgEndT <+ promoteProgT progEndT :: TransformH Core LocalPathH)+        , external "prog-end" (promoteModGutsT gutsProgEndT <+ promoteProgT progEndT :: TransformH LCore LocalPathH)             [ "Descend to the end of a program." ]-        , external "parent-of" (parentOfT :: TransformH Core LocalPathH -> TransformH Core LocalPathH)+        , external "parent-of" (parentOfT :: TransformH LCore LocalPathH -> TransformH LCore LocalPathH)             [ "Focus on the parent of another focal point." ]-        , external "parent-of" (parentOfT :: TransformH CoreTC LocalPathH -> TransformH CoreTC LocalPathH)+        , external "parent-of" (parentOfT :: TransformH LCoreTC LocalPathH -> TransformH LCoreTC LocalPathH)             [ "Focus on the parent of another focal point." ]         ] @@ -76,7 +84,7 @@ -----------------------------------------------------------------------  -- | Find the path to the RHS of a binding.-rhsOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m Core LocalPathH+rhsOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m LCoreTC LocalPathH rhsOfT p = prefixFailMsg ("rhs-of failed: ") $            do lp <- onePathToT (arr $ bindingOf p . inject)               case lastCrumb lp of@@ -85,26 +93,27 @@                                 Let_Bind      -> return (lp @@ NonRec_RHS)                                 ProgCons_Head -> return (lp @@ NonRec_RHS)                                 _             -> fail "does not have a RHS."-                Nothing -> defOrNonRecT successT lastCrumbT (\ () cr -> mempty @@ cr)+                Nothing -> promoteCoreT (defOrNonRecT successT lastCrumbT (\ () cr -> mempty @@ cr))  -- | Find the path to the binding group of a variable.-bindingGroupOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m CoreTC LocalPathH+bindingGroupOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m LCoreTC LocalPathH bindingGroupOfT p = prefixFailMsg ("binding-group-of failed: ") $                     oneNonEmptyPathToT (promoteBindT $ arr $ bindingGroupOf p)  -- | Find the path to the binding of a variable.-bindingOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m CoreTC LocalPathH+bindingOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m LCoreTC LocalPathH bindingOfT p = prefixFailMsg ("binding-of failed: ") $                oneNonEmptyPathToT (arr $ bindingOf p)  -- | Find the path to the first occurrence of a variable.-occurrenceOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m CoreTC LocalPathH+occurrenceOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m)+              => (Var -> Bool) -> Transform c m LCoreTC LocalPathH occurrenceOfT p = prefixFailMsg ("occurrence-of failed: ") $                   oneNonEmptyPathToT (arr $ occurrenceOf p)  -- | Find the path to an application of a given function. applicationOfT :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, MonadCatch m, ReadPath c Crumb)-               => (Var -> Bool) -> Transform c m CoreTC LocalPathH+               => (Var -> Bool) -> Transform c m LCoreTC LocalPathH applicationOfT p = prefixFailMsg "application-of failed:" $ oneNonEmptyPathToT go     where go = promoteExprT (appT (extractT go) successT const) <+ arr (occurrenceOf p) @@ -115,13 +124,16 @@  ----------------------------------------------------------------------- -bindingOf :: (Var -> Bool) -> CoreTC -> Bool+bindingOf :: (Var -> Bool) -> LCoreTC -> Bool bindingOf p = any p . varSetElems . binders -binders :: CoreTC -> VarSet-binders (Core core)              = bindersCore core-binders (TyCo (TypeCore ty))     = binderType ty-binders (TyCo (CoercionCore co)) = binderCoercion co+-- TODO: check this is correct, written in a hurry+binders :: LCoreTC -> VarSet+binders (LTCCore (LQuantified (Quantified bs _)))  = mkVarSet bs+binders (LTCCore (LClause _))                      = emptyVarSet+binders (LTCCore (LCore core))                     = bindersCore core+binders (LTCTyCo (TypeCore ty))                    = binderType ty+binders (LTCTyCo (CoercionCore co))                = binderCoercion co  bindersCore :: Core -> VarSet bindersCore (BindCore bnd)  = binderBind bnd@@ -152,14 +164,14 @@  ----------------------------------------------------------------------- -occurrenceOf :: (Var -> Bool) -> CoreTC -> Bool-occurrenceOf p = maybe False p . varOccurrence+occurrenceOf :: (Var -> Bool) -> LCoreTC -> Bool+occurrenceOf p = maybe False p . (projectM >=> varOccurrence) -varOccurrence :: CoreTC -> Maybe Var-varOccurrence (Core (ExprCore e))      = varOccurrenceExpr e-varOccurrence (TyCo (TypeCore ty))     = varOccurrenceType ty-varOccurrence (TyCo (CoercionCore co)) = varOccurrenceCoercion co-varOccurrence _                        = Nothing+varOccurrence :: LCoreTC -> Maybe Var+varOccurrence (LTCCore (LCore (ExprCore e))) = varOccurrenceExpr e+varOccurrence (LTCTyCo (TypeCore ty))        = varOccurrenceType ty+varOccurrence (LTCTyCo (CoercionCore co))    = varOccurrenceCoercion co+varOccurrence _                              = Nothing  varOccurrenceExpr :: CoreExpr -> Maybe Var varOccurrenceExpr (Var v)       = Just v@@ -176,19 +188,19 @@ -----------------------------------------------------------------------  -- | Find all possible targets of 'occurrenceOfT'.-occurrenceOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m CoreTC VarSet+occurrenceOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m LCoreTC VarSet occurrenceOfTargetsT = allT $ crushbuT (arr varOccurrence >>> projectT >>^ unitVarSet)  -- | Find all possible targets of 'bindingOfT'.-bindingOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m CoreTC VarSet+bindingOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m LCoreTC VarSet bindingOfTargetsT = allT $ crushbuT (arr binders)  -- | Find all possible targets of 'bindingGroupOfT'.-bindingGroupOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m CoreTC VarSet+bindingGroupOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m LCoreTC VarSet bindingGroupOfTargetsT = allT $ crushbuT (promoteBindT $ arr (mkVarSet . bindVars))  -- | Find all possible targets of 'rhsOfT'.-rhsOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m CoreTC VarSet+rhsOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m LCoreTC VarSet rhsOfTargetsT = crushbuT (promoteBindT (arr binderBind) <+ promoteDefT (arr binderDef))  -----------------------------------------------------------------------@@ -223,12 +235,18 @@                   ]  -- | Find the path to the first matching construct.-considerConstructT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Considerable -> Transform c m Core LocalPathH-considerConstructT con = oneNonEmptyPathToT (arr $ underConsideration con)+considerConstructT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Considerable -> Transform c m LCore LocalPathH+considerConstructT con = oneNonEmptyPathToT (arr $ underConsiderationLCore con)  string2considerable :: String -> Maybe Considerable string2considerable = flip lookup considerables +-- TODO: cleanup this code++underConsiderationLCore :: Considerable -> LCore -> Bool+underConsiderationLCore con (LCore c) = underConsideration con c+underConsiderationLCore _   _         = False+ underConsideration :: Considerable -> Core -> Bool underConsideration Binding      (BindCore _)               = True underConsideration Definition   (BindCore (NonRec _ _))    = True@@ -262,24 +280,22 @@   setEmptyContext ec = ec { baseContext = setEmptyContext (baseContext ec)                           , extraContext = mempty } -exhaustRepeatCrumbT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c CoreTC, MonadCatch m) => Crumb -> Transform c m CoreTC LocalPathH+exhaustRepeatCrumbT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c LCoreTC, MonadCatch m) => Crumb -> Transform c m LCoreTC LocalPathH exhaustRepeatCrumbT cr = let l = exhaustPathL (repeat cr)                           in withLocalPathT (focusT l exposeLocalPathT)  -- | Construct a path to the body of a sequence of lambdas.-lamsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c CoreTC, MonadCatch m) => Transform c m CoreExpr LocalPathH+lamsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c LCoreTC, MonadCatch m) => Transform c m CoreExpr LocalPathH lamsBodyT = extractT (exhaustRepeatCrumbT Lam_Body)  -- | Construct a path to the body of a sequence of let bindings.-letsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c CoreTC, MonadCatch m) => Transform c m CoreExpr LocalPathH+letsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c LCoreTC, MonadCatch m) => Transform c m CoreExpr LocalPathH letsBodyT = extractT (exhaustRepeatCrumbT Let_Body)  -- | Construct a path to end of a program.-progEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c CoreTC, MonadCatch m) => Transform c m CoreProg LocalPathH+progEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c LCoreTC, MonadCatch m) => Transform c m CoreProg LocalPathH progEndT = extractT (exhaustRepeatCrumbT ProgCons_Tail) --- | Construct a path to teh end of a program, starting at the 'ModGuts'.-gutsProgEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c CoreTC, MonadCatch m) => Transform c m ModGuts LocalPathH+-- | Construct a path to the end of a program, starting at the 'ModGuts'.+gutsProgEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c LCoreTC, MonadCatch m) => Transform c m ModGuts LocalPathH gutsProgEndT = modGutsT progEndT (\ _ p -> (mempty @@ ModGuts_Prog) <> p)-----------------------------------------------------------------------------------------

@@ -1,8 +1,7 @@ module HERMIT.Dictionary.Navigation.Crumbs-       ( -- * Navigating Using Crumbs-         crumbExternals-       )-where+    ( -- * Navigating Using Crumbs+      crumbExternals+    ) where  import HERMIT.Core import HERMIT.External@@ -12,89 +11,106 @@ -- | 'External's for individual 'Crumb's. crumbExternals :: [External] crumbExternals = map (.+ Navigation)-            [-              external "prog" ModGuts_Prog-                [ "Descend into the program within a module." ]-            , external "prog-head" ProgCons_Head-                [ "Descend into the first binding group in a program." ]-            , external "prog-tail" ProgCons_Tail-                [ "Descend into the tail of the program." ]-            , external "nonrec-rhs" NonRec_RHS-                [ "Descend into the right-hand side of a non-recursive binding." ]-            , external "rec-def" Rec_Def-                [ "Descend into the (n-1)th definition in a recursive binding group." ]-            , external "def-rhs" Def_RHS-                [ "Descend into the right-hand side of a recursive definition." ]-            , external "app-fun" App_Fun-                [ "Descend into the function in an application." ]-            , external "app-arg" App_Arg-                [ "Descend into the argument in an application." ]-            , external "lam-body" Lam_Body-                [ "Descend into the body of a lambda." ]-            , external "let-bind" Let_Bind-                [ "Descend into the binding group of a let expression." ]-            , external "let-body" Let_Body-                [ "Descend into the body of a let expression." ]-            , external "case-expr" Case_Scrutinee-                [ "Descend into the scrutinised expression in a case expression." ]-            , external "case-type" Case_Type-                [ "Descend into the type of a case expression." ]-            , external "case-alt" Case_Alt-                [ "Descend into the (n-1)th alternative in a case expression." ]-            , external "cast-expr" Cast_Expr-                [ "Descend into the expression in a cast." ]-            , external "cast-co" Cast_Co-                [ "Descend into the coercion in a cast." ]-            , external "tick-expr" Tick_Expr-                [ "Descend into the expression in a tick." ]-            , external "alt-rhs" Alt_RHS-                [ "Descend into the right-hand side of a case alternative." ]-            , external "type" Type_Type-                [ "Descend into the type within a type expression." ]-            , external "coercion" Co_Co-                [ "Descend into the coercion within a coercion expression." ]-            , external "appTy-fun" AppTy_Fun-                [ "Descend into the type function in a type application." ]-            , external "appTy-arg" AppTy_Fun-                [ "Descend into the type argument in a type application." ]-            , external "tyCon-arg" TyConApp_Arg-                [ "Descend into the (n-1)th argument of a type constructor application." ]-            , external "fun-dom" FunTy_Dom-                [ "Descend into the domain of a function type." ]-            , external "fun-cod" FunTy_CoDom-                [ "Descend into the codomain of a function type." ]-            , external "forall-body" ForAllTy_Body-                [ "Descend into the body of a forall type." ]-            , external "refl-type" Refl_Type-                [ "Descend into the (n-1)th argument of a type constructor coercion." ]-            , external "coCon-arg" TyConAppCo_Arg-                [ "Descend into the function of a coercion application." ]-            , external "appCo-fun" AppCo_Fun-                [ "Descend into the coercion function in a coercion application." ]-            , external "appCo-arg" AppCo_Arg-                [ "Descend into the coercion argument in a coercion application." ]-            , external "coForall-body" ForAllCo_Body-                [ "Descend into the body of a forall coercion." ]-            , external "axiom-inst" AxiomInstCo_Arg-                [ "Descend into the (n-1)th argument of a coercion axiom instantiation." ]-            , external "unsafe-left" UnsafeCo_Left-                [ "Descend into the left-hand type of an unsafe coercion." ]-            , external "unsafe-right" UnsafeCo_Right-                [ "Descend into the right-hand type of an unsafe coercion." ]-            , external "sym-co" SymCo_Co-                [ "Descend into the coercion within a symmetric coercion." ]-            , external "trans-left" TransCo_Left-                [ "Descend into the left-hand type of a transitive coercion." ]-            , external "trans-right" TransCo_Right-                [ "Descend into the right-hand type of a transitive coercion." ]-            , external "nth-co" NthCo_Co-                [ "Descend into the coercion within an nth projection coercion." ]-            , external "inst-co" InstCo_Co-                [ "Descend into the coercion within a coercion instantiation." ]-            , external "inst-type" InstCo_Type-                [ "Descend into the type within a coercion instantiation." ]-            , external "lr-co" LRCo_Co-                [ "Descend into the coercion within a left/right projection coercion." ]-            ]+    [ external "prog" ModGuts_Prog+        [ "Descend into the program within a module." ]+    , external "prog-head" ProgCons_Head+        [ "Descend into the first binding group in a program." ]+    , external "prog-tail" ProgCons_Tail+        [ "Descend into the tail of the program." ]+    , external "nonrec-rhs" NonRec_RHS+        [ "Descend into the right-hand side of a non-recursive binding." ]+    , external "rec-def" Rec_Def+        [ "Descend into the (n-1)th definition in a recursive binding group." ]+    , external "def-rhs" Def_RHS+        [ "Descend into the right-hand side of a recursive definition." ]+    , external "app-fun" App_Fun+        [ "Descend into the function in an application." ]+    , external "app-arg" App_Arg+        [ "Descend into the argument in an application." ]+    , external "lam-body" Lam_Body+        [ "Descend into the body of a lambda." ]+    , external "let-bind" Let_Bind+        [ "Descend into the binding group of a let expression." ]+    , external "let-body" Let_Body+        [ "Descend into the body of a let expression." ]+    , external "case-expr" Case_Scrutinee+        [ "Descend into the scrutinised expression in a case expression." ]+    , external "case-type" Case_Type+        [ "Descend into the type of a case expression." ]+    , external "case-alt" Case_Alt+        [ "Descend into the (n-1)th alternative in a case expression." ]+    , external "cast-expr" Cast_Expr+        [ "Descend into the expression in a cast." ]+    , external "cast-co" Cast_Co+        [ "Descend into the coercion in a cast." ]+    , external "tick-expr" Tick_Expr+        [ "Descend into the expression in a tick." ]+    , external "alt-rhs" Alt_RHS+        [ "Descend into the right-hand side of a case alternative." ]+    , external "type" Type_Type+        [ "Descend into the type within a type expression." ]+    , external "coercion" Co_Co+        [ "Descend into the coercion within a coercion expression." ]+    , external "appTy-fun" AppTy_Fun+        [ "Descend into the type function in a type application." ]+    , external "appTy-arg" AppTy_Fun+        [ "Descend into the type argument in a type application." ]+    , external "tyCon-arg" TyConApp_Arg+        [ "Descend into the (n-1)th argument of a type constructor application." ]+    , external "fun-dom" FunTy_Dom+        [ "Descend into the domain of a function type." ]+    , external "fun-cod" FunTy_CoDom+        [ "Descend into the codomain of a function type." ]+    , external "forall-body" ForAllTy_Body+        [ "Descend into the body of a forall type." ]+    , external "refl-type" Refl_Type+        [ "Descend into the (n-1)th argument of a type constructor coercion." ]+    , external "coCon-arg" TyConAppCo_Arg+        [ "Descend into the function of a coercion application." ]+    , external "appCo-fun" AppCo_Fun+        [ "Descend into the coercion function in a coercion application." ]+    , external "appCo-arg" AppCo_Arg+        [ "Descend into the coercion argument in a coercion application." ]+    , external "coForall-body" ForAllCo_Body+        [ "Descend into the body of a forall coercion." ]+    , external "axiom-inst" AxiomInstCo_Arg+        [ "Descend into the (n-1)th argument of a coercion axiom instantiation." ]+    , external "unsafe-left" UnsafeCo_Left+        [ "Descend into the left-hand type of an unsafe coercion." ]+    , external "unsafe-right" UnsafeCo_Right+        [ "Descend into the right-hand type of an unsafe coercion." ]+    , external "sym-co" SymCo_Co+        [ "Descend into the coercion within a symmetric coercion." ]+    , external "trans-left" TransCo_Left+        [ "Descend into the left-hand type of a transitive coercion." ]+    , external "trans-right" TransCo_Right+        [ "Descend into the right-hand type of a transitive coercion." ]+    , external "nth-co" NthCo_Co+        [ "Descend into the coercion within an nth projection coercion." ]+    , external "inst-co" InstCo_Co+        [ "Descend into the coercion within a coercion instantiation." ]+    , external "inst-type" InstCo_Type+        [ "Descend into the type within a coercion instantiation." ]+    , external "lr-co" LRCo_Co+        [ "Descend into the coercion within a left/right projection coercion." ]+    , external "forall-body" Forall_Body+        [ "Descend into the clause of a quantified clause." ]+    , external "conj-lhs" Conj_Lhs+        [ "Descend into left-hand side of a conjunction." ]+    , external "conj-rhs" Conj_Rhs+        [ "Descend into right-hand side of a conjunction." ]+    , external "disj-lhs" Disj_Lhs+        [ "Descend into left-hand side of a disjunction." ]+    , external "disj-rhs" Disj_Rhs+        [ "Descend into right-hand side of a disjunction." ]+    , external "antecedent" Impl_Lhs+        [ "Descend into antecedent of an implication." ]+    , external "consequent" Impl_Rhs+        [ "Descend into consequent of an implication." ]+    , external "eq-lhs" Eq_Lhs+        [ "Descend into left-hand side of an equivalence." ]+    , external "eq-rhs" Eq_Rhs+        [ "Descend into right-hand side of an equivalence." ]+    ]  ---------------------------------------------------------------------------------------

@@ -14,11 +14,11 @@  externals ::  [External] externals = map ((.+ Experiment) . (.+ TODO))-         [ external "var" (promoteExprT . isVar :: String -> TransformH Core ())+         [ external "var" (promoteExprT . isVar :: String -> TransformH LCore ())                 [ "var '<v> returns successfully for variable v, and fails otherwise."                 , "Useful in combination with \"when\", as in: when (var v) r"                 ] .+ Predicate-         , external "nonrec-intro" (nonRecIntro :: String -> CoreString -> RewriteH Core)+         , external "nonrec-intro" ((\ s str -> promoteCoreR (nonRecIntro s str)) :: String -> CoreString -> RewriteH LCore)                 [ "Introduce a new non-recursive binding.  Only works at Expression or Program nodes."                 , "nonrec-into 'v [| e |]"                 , "body ==> let v = e in body"

@@ -31,16 +31,17 @@ -- | Externals that reflect GHC functions, or are derived from GHC functions. externals :: [External] externals =-    [ external "info" (infoT :: TransformH CoreTC String)+    [ external "info" (promoteCoreTCT infoT :: TransformH LCoreTC String)         [ "Display information about the current node." ] .+ Query-    , external "compare-bound-ids" (compareBoundIds :: HermitName -> HermitName -> TransformH CoreTC ())+    , external "compare-bound-ids" (compareBoundIds :: HermitName -> HermitName -> TransformH LCoreTC ())         [ "Compare the definitions of two in-scope identifiers for alpha equality."] .+ Query .+ Predicate-    , external "compare-core-at" (compareCoreAtT ::  TransformH Core LocalPathH -> TransformH Core LocalPathH -> TransformH Core ())+    , external "compare-core-at" (compareCoreAtT ::  TransformH LCoreTC LocalPathH -> TransformH LCoreTC LocalPathH -> TransformH LCoreTC ())         [ "Compare the core fragments at the end of the given paths for alpha-equality."] .+ Query .+ Predicate     ]  -------------------------------------------------------- +-- TODO: update this to cope with lemmas infoT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, BoundVars c, HasEmptyContext c, HasDynFlags m, MonadCatch m) => Transform c m CoreTC String infoT =   do crumbs <- childrenT@@ -162,12 +163,13 @@ --------------------------------------------------------  -- | Compare the core fragments at the end of the specified 'LocalPathH's.-compareCoreAtT :: (ExtendPath c Crumb, AddBindings c, ReadBindings c, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Transform c m Core LocalPathH -> Transform c m Core LocalPathH -> Transform c m Core ()+compareCoreAtT :: (ExtendPath c Crumb, AddBindings c, ReadBindings c, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Transform c m LCoreTC LocalPathH -> Transform c m LCoreTC LocalPathH -> Transform c m LCoreTC () compareCoreAtT p1T p2T =   do p1 <- p1T      p2 <- p2T-     core1 <- localPathT p1 idR-     core2 <- localPathT p2 idR+     -- TODO: temproary hack.  Need to properly check whether the paths point to COre or not, and report a decent error message+     LTCCore (LCore core1) <- localPathT p1 idR+     LTCCore (LCore core2) <- localPathT p2 idR      guardMsg (core1 `coreAlphaEq` core2) "core fragments are not alpha-equivalent."  -- | Compare the definitions of two identifiers for alpha-equality.

@@ -1,74 +1,89 @@-{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, InstanceSigs,-             ScopedTypeVariables, TupleSections, TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}  module HERMIT.Dictionary.Reasoning     ( -- * Equational Reasoning       externals     , EqualityProof-    , flipEquality     , eqLhsIntroR     , eqRhsIntroR     , birewrite     , extensionalityR     , getLemmasT     , getLemmaByNameT-    , insertLemmaR-    , lemmaR-    , markLemmaUsedR-    , modifyLemmaR-    -- ** Lifting transformations over 'Equality'+    , getObligationNotProvenT+    , insertLemmaT+    , insertLemmasT+    , lemmaBiR+    , lemmaConsequentR+    , markLemmaUsedT+    , markLemmaProvedT+    , markLemmaAssumedT+    , modifyLemmaT+    , showLemmaT+    , showLemmasT+    , ppLemmaT+    , ppQuantifiedT+    , ppLCoreTCT+      -- ** Lifting transformations over 'Quantified'     , lhsT     , rhsT     , bothT-    , forallVarsT     , lhsR     , rhsR     , bothR-    , ppEqualityT-    , proveEqualityT-    , verifyEqualityT+    , forallVarsT+    , verifyQuantifiedT+    , verifyEquivalentT+    , verifyOrCreateT+    , lintQuantifiedT     , verifyEqualityLeftToRightT     , verifyEqualityCommonTargetT     , verifyIsomorphismT     , verifyRetractionT     , retractionBR-    , alphaEqualityR-    , unshadowEqualityR+    , unshadowQuantifiedR     , instantiateDictsR-    , instantiateEquality-    , instantiateEqualityVar-    , instantiateEqualityVarR+    , instantiateQuantifiedVarR+    , abstractQuantifiedR     , discardUniVars     ) where -import           Control.Applicative-import           Control.Arrow+import           Control.Arrow hiding ((<+>)) import           Control.Monad-import           Control.Monad.IO.Class +import           Data.Either (partitionEithers)+import           Data.List (isInfixOf, nubBy) import qualified Data.Map as Map-import           Data.List (nubBy) import           Data.Maybe (fromMaybe) import           Data.Monoid  import           HERMIT.Context import           HERMIT.Core import           HERMIT.External-import           HERMIT.GHC+import           HERMIT.GHC hiding ((<>), (<+>), nest, ($+$)) import           HERMIT.Kure+import           HERMIT.Lemma import           HERMIT.Monad import           HERMIT.Name import           HERMIT.ParserCore import           HERMIT.ParserType import           HERMIT.PrettyPrinter.Common+import           HERMIT.PrettyPrinter.Clean (symbol) -- this should be in Common import           HERMIT.Utilities-                -import           HERMIT.Dictionary.AlphaConversion hiding (externals)+ import           HERMIT.Dictionary.Common import           HERMIT.Dictionary.Fold hiding (externals) import           HERMIT.Dictionary.GHC hiding (externals) import           HERMIT.Dictionary.Local.Let (nonRecIntroR)-import           HERMIT.Dictionary.Unfold hiding (externals)  import qualified Text.PrettyPrint.MarkedHughesPJ as PP @@ -76,71 +91,103 @@  externals :: [External] externals =-    [ external "retraction" ((\ f g r -> promoteExprBiR $ retraction (Just r) f g) :: CoreString -> CoreString -> RewriteH Core -> BiRewriteH Core)+    [ external "retraction" ((\ f g r -> promoteExprBiR $ retraction (Just r) f g) :: CoreString -> CoreString -> RewriteH LCore -> BiRewriteH LCore)         [ "Given f :: X -> Y and g :: Y -> X, and a proof that f (g y) ==> y, then"         , "f (g y) <==> y."         ] .+ Shallow-    , external "retraction-unsafe" ((\ f g -> promoteExprBiR $ retraction Nothing f g) :: CoreString -> CoreString -> BiRewriteH Core)+    , external "retraction-unsafe" ((\ f g -> promoteExprBiR $ retraction Nothing f g) :: CoreString -> CoreString -> BiRewriteH LCore)         [ "Given f :: X -> Y and g :: Y -> X, then"         , "f (g y) <==> y."         , "Note that the precondition (f (g y) == y) is expected to hold."         ] .+ Shallow .+ PreCondition-    , external "alpha-equality" ((\ nm newName -> alphaEqualityR (cmpString2Var nm) (const newName)))-        [ "Alpha-rename a universally quantified variable." ]-    , external "unshadow-equality" unshadowEqualityR-        [ "Unshadow an equality." ]-    , external "lemma" (promoteExprBiR . lemmaR :: LemmaName -> BiRewriteH Core)+    , external "unshadow-quantified" (promoteQuantifiedR unshadowQuantifiedR :: RewriteH LCoreTC)+        [ "Unshadow a quantified clause." ]+    , external "merge-quantifiers" (\n1 n2 -> promoteR (mergeQuantifiersR (cmpHN2Var n1) (cmpHN2Var n2)) :: RewriteH LCore)+        [ "Merge quantifiers from two clauses if they have the same type."+        , "Example:"+        , "(forall (x::Int). foo x = x) ^ (forall (y::Int). bar y y = 5)"+        , "merge-quantifiers 'x 'y"+        , "forall (x::Int). (foo x = x) ^ (bar x x = 5)"+        , "Note: if only one quantifier matches, it will be floated if possible." ]+    , external "float-left" (\n1 -> promoteR (mergeQuantifiersR (cmpHN2Var n1) (const False)) :: RewriteH LCore)+        [ "Float quantifier out of left-hand side." ]+    , external "float-right" (\n1 -> promoteR (mergeQuantifiersR (const False) (cmpHN2Var n1)) :: RewriteH LCore)+        [ "Float quantifier out of right-hand side." ]+    , external "conjunct" (\n1 n2 n3 -> conjunctLemmasT n1 n2 n3 :: TransformH LCore ())+        [ "conjunt new-name lhs-name rhs-name" ]+    , external "disjunct" (\n1 n2 n3 -> disjunctLemmasT n1 n2 n3 :: TransformH LCore ())+        [ "disjunt new-name lhs-name rhs-name" ]+    , external "imply" (\n1 n2 n3 -> implyLemmasT n1 n2 n3 :: TransformH LCore ())+        [ "imply new-name antecedent-name consequent-name" ]+    , external "lint" (promoteT lintQuantifiedT :: TransformH LCoreTC String)+        [ "Lint check a quantified clause." ]+    , external "lemma-birewrite" (promoteExprBiR . lemmaBiR Obligation :: LemmaName -> BiRewriteH LCore)         [ "Generate a bi-directional rewrite from a lemma." ]-    , external "lemma-lhs-intro" (lemmaLhsIntroR :: LemmaName -> RewriteH Core)+    , external "lemma-forward" (forwardT . promoteExprBiR . lemmaBiR Obligation :: LemmaName -> RewriteH LCore)+        [ "Generate a rewrite from a lemma, left-to-right." ]+    , external "lemma-backward" (backwardT . promoteExprBiR . lemmaBiR Obligation :: LemmaName -> RewriteH LCore)+        [ "Generate a rewrite from a lemma, right-to-left." ]+    , external "lemma-consequent" (promoteQuantifiedR . lemmaConsequentR Obligation :: LemmaName -> RewriteH LCore)+        [ "Match the current lemma with the consequent of an implication lemma."+        , "Upon success, replaces with antecedent of the implication, properly instantiated." ]+    , external "lemma-consequent-birewrite" (promoteExprBiR . lemmaConsequentBiR Obligation :: LemmaName -> BiRewriteH LCore)+        [ "Generate a bi-directional rewrite from the consequent of an implication lemma."+        , "The antecedent is instantiated and introduced as an unproven obligation." ]+    , external "lemma-lhs-intro" (promoteCoreR . lemmaLhsIntroR :: LemmaName -> RewriteH LCore)         [ "Introduce the LHS of a lemma as a non-recursive binding, in either an expression or a program."         , "body ==> let v = lhs in body" ] .+ Introduce .+ Shallow-    , external "lemma-rhs-intro" (lemmaRhsIntroR :: LemmaName -> RewriteH Core)+    , external "lemma-rhs-intro" (promoteCoreR . lemmaRhsIntroR :: LemmaName -> RewriteH LCore)         [ "Introduce the RHS of a lemma as a non-recursive binding, in either an expression or a program."         , "body ==> let v = rhs in body" ] .+ Introduce .+ Shallow-    , external "inst-lemma" (\ nm v cs -> modifyLemmaR nm id (instantiateEqualityVarR (cmpString2Var v) cs) id id :: RewriteH Core)+    , external "inst-lemma" (\ nm v cs -> modifyLemmaT nm id (instantiateQuantifiedVarR (cmpHN2Var v) cs) id id :: TransformH LCore ())         [ "Instantiate one of the universally quantified variables of the given lemma,"         , "with the given Core expression, creating a new lemma. Instantiating an"         , "already proven lemma will result in the new lemma being considered proven." ]-    , external "inst-lemma-dictionaries" (\ nm -> modifyLemmaR nm id instantiateDictsR id id :: RewriteH Core)-        [ "Instantiate all of the universally quantified dictionaries of the given lemma."-        , "Only works on dictionaries whose types are monomorphic (no free type variables)." ]-    , external "copy-lemma" (\ nm newName -> modifyLemmaR nm (const newName) idR id id :: RewriteH Core)+    , external "inst-dictionaries" (promoteQuantifiedR instantiateDictsR :: RewriteH LCore)+        [ "Instantiate all of the universally quantified dictionaries of the given lemma." ]+    , external "abstract" ((\nm -> promoteQuantifiedR . abstractQuantifiedR nm . csInQBodyT) :: String -> CoreString -> RewriteH LCore)+        [ "Weaken a lemma by abstracting an expression to a new quantifier." ]+    , external "abstract" ((\nm rr -> promoteQuantifiedR $ abstractQuantifiedR nm $ extractT rr >>> setFailMsg "path must focus on an expression" projectT) :: String -> RewriteH LCore -> RewriteH LCore)+        [ "Weaken a lemma by abstracting an expression to a new quantifier." ]+    , external "copy-lemma" (\ nm newName -> modifyLemmaT nm (const newName) idR id id :: TransformH LCore ())         [ "Copy a given lemma, with a new name." ]-    , external "modify-lemma" (\ nm rr -> modifyLemmaR nm id rr (const False) (const False) :: RewriteH Core)-        [ "Modify a given lemma. Resets the proven status to Not Proven and used status to Not Used." ]-    , external "query-lemma" ((\ nm t -> getLemmaByNameT nm >>> arr lemmaEq >>> t) :: LemmaName -> TransformH Equality String -> TransformH Core String)+    , external "modify-lemma" ((\ nm rr -> modifyLemmaT nm id (extractR rr) (const NotProven) (const NotUsed)) :: LemmaName -> RewriteH LCore -> TransformH LCore ())+        [ "Modify a given lemma. Resets proven status to Not Proven and used status to Not Used." ]+    , external "query-lemma" ((\ nm t -> getLemmaByNameT nm >>> arr lemmaQ >>> extractT t) :: LemmaName -> TransformH LCore String -> TransformH LCore String)         [ "Apply a transformation to a lemma, returning the result." ]-    , external "extensionality" (extensionalityR . Just :: String -> RewriteH Equality)+    , external "show-lemma" ((\pp n -> showLemmaT n pp) :: PrettyPrinter -> LemmaName -> PrettyH LCore)+        [ "Display a lemma." ]+    , external "show-lemmas" ((\pp n -> showLemmasT (Just n) pp) :: PrettyPrinter -> LemmaName -> PrettyH LCore)+        [ "List lemmas whose names match search string." ]+    , external "show-lemmas" (showLemmasT Nothing :: PrettyPrinter -> PrettyH LCore)+        [ "List lemmas." ]+    , external "extensionality" (promoteR . extensionalityR . Just :: String -> RewriteH LCore)         [ "Given a name 'x, then"         , "f == g  ==>  forall x.  f x == g x" ]-    , external "extensionality" (extensionalityR Nothing :: RewriteH Equality)+    , external "extensionality" (promoteR (extensionalityR Nothing) :: RewriteH LCore)         [ "f == g  ==>  forall x.  f x == g x" ]-    , external "lhs" (lhsR . extractR :: RewriteH Core -> RewriteH Equality)-        [ "Apply a rewrite to the LHS of an equality." ]-    , external "lhs" (lhsT . extractT :: TransformH CoreTC String -> TransformH Equality String)-        [ "Apply a transformation to the LHS of an equality." ]-    , external "rhs" (rhsR . extractR :: RewriteH Core -> RewriteH Equality)-        [ "Apply a rewrite to the RHS of an equality." ]-    , external "rhs" (rhsT . extractT :: TransformH CoreTC String -> TransformH Equality String)-        [ "Apply a transformation to the RHS of an equality." ]-    , external "both" (bothR . extractR :: RewriteH Core -> RewriteH Equality)+    , external "lhs" (promoteQuantifiedR . lhsR :: RewriteH LCore -> RewriteH LCore)+        [ "Apply a rewrite to the LHS of a quantified clause." ]+    , external "lhs" (promoteQuantifiedT . lhsT :: TransformH LCore String -> TransformH LCore String)+        [ "Apply a transformation to the LHS of a quantified clause." ]+    , external "rhs" (promoteQuantifiedR . rhsR :: RewriteH LCore -> RewriteH LCore)+        [ "Apply a rewrite to the RHS of a quantified clause." ]+    , external "rhs" (promoteQuantifiedT . rhsT :: TransformH LCore String -> TransformH LCore String)+        [ "Apply a transformation to the RHS of a quantified clause." ]+    , external "both" (promoteQuantifiedR . bothR :: RewriteH LCore -> RewriteH LCore)         [ "Apply a rewrite to both sides of an equality, succeeding if either succeed." ]-    , external "both" ((\t -> liftM (\(r,s) -> unlines [r,s]) (bothT (extractT t))) :: TransformH CoreTC String -> TransformH Equality String)-        [ "Apply a transformation to the RHS of an equality." ]+    , external "both" ((\t -> do (r,s) <- promoteQuantifiedT (bothT t); return (unlines [r,s])) :: TransformH LCore String -> TransformH LCore String)+        [ "Apply a transformation to both sides of a quantified clause." ]     ]  ------------------------------------------------------------------------------  type EqualityProof c m = (Rewrite c m CoreExpr, Rewrite c m CoreExpr) --- | Flip the LHS and RHS of a 'Equality'.-flipEquality :: Equality -> Equality-flipEquality (Equality xs lhs rhs) = Equality xs rhs lhs- -- | f == g  ==>  forall x.  f x == g x-extensionalityR :: Maybe String -> Rewrite c HermitM Equality+extensionalityR :: Maybe String -> Rewrite c HermitM Quantified extensionalityR mn = prefixFailMsg "extensionality failed: " $-  do Equality vs lhs rhs <- idR+  do Quantified vs (Equiv lhs rhs) <- idR       let tyL = exprKindOrType lhs          tyR = exprKindOrType rhs@@ -152,123 +199,179 @@       let x = varToCoreExpr v -     return $ Equality (vs ++ [v]) (mkCoreApp lhs x) (mkCoreApp rhs x)+     return $ Quantified (vs ++ [v]) $ Equiv (mkCoreApp lhs x) (mkCoreApp rhs x)  ------------------------------------------------------------------------------  -- | @e@ ==> @let v = lhs in e@-eqLhsIntroR :: Equality -> Rewrite c HermitM Core-eqLhsIntroR (Equality bs lhs _) = nonRecIntroR "lhs" (mkCoreLams bs lhs)+eqLhsIntroR :: Quantified -> Rewrite c HermitM Core+eqLhsIntroR (Quantified bs (Equiv lhs _)) = nonRecIntroR "lhs" (mkCoreLams bs lhs)+eqLhsIntroR _                             = fail "compound lemmas not supported."  -- | @e@ ==> @let v = rhs in e@-eqRhsIntroR :: Equality -> Rewrite c HermitM Core-eqRhsIntroR (Equality bs _ rhs) = nonRecIntroR "rhs" (mkCoreLams bs rhs)+eqRhsIntroR :: Quantified -> Rewrite c HermitM Core+eqRhsIntroR (Quantified bs (Equiv _ rhs)) = nonRecIntroR "rhs" (mkCoreLams bs rhs)+eqRhsIntroR _                             = fail "compound lemmas not supported."  ------------------------------------------------------------------------------ --- | Create a 'BiRewrite' from a 'Equality'.------ The high level idea: create a temporary function with two definitions.--- Fold one of the defintions, then immediately unfold the other.+-- | Create a 'BiRewrite' from a 'Quantified'. birewrite :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c              , ReadPath c Crumb, MonadCatch m, MonadUnique m )-          => Equality -> BiRewrite c m CoreExpr-birewrite (Equality bnds l r) = bidirectional (foldUnfold l r) (foldUnfold r l)-    where foldUnfold lhs rhs = transform $ \ c e -> do-            let lhsLam = mkCoreLams bnds lhs-            -- we use a unique, transitory variable for the 'function' we are folding-            v <- newIdH "biTemp" (exprType lhsLam)-            e' <- maybe (fail "folding LHS failed") return (fold v lhsLam e)-            let rhsLam = mkCoreLams bnds rhs-                -- create a temporary context with an unfolding for the-                -- transitory function so we can reuse unfoldR.-                c' = addHermitBindings [(v, NONREC rhsLam, mempty)] c-            applyT unfoldR c' e'+          => Quantified -> BiRewrite c m CoreExpr+birewrite q = bidirectional (foldUnfold "left" id) (foldUnfold "right" flipEquality)+    where foldUnfold side f = transform $ \ c ->+                                maybeM ("expression did not match "++side++"-hand side")+                                . fold (map f (toEqualities q)) c --- | Lift a transformation over 'CoreExpr' into a transformation over the left-hand side of a 'Equality'.-lhsT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m Equality b-lhsT t = idR >>= \ (Equality vs lhs _) -> return lhs >>> withVarsInScope vs t+------------------------------------------------------------------------------+-- TODO: deprecate these?+-- Yes, but later.  They're in the paper now.+-- We should be using "childR crumb", really. --- | Lift a transformation over 'CoreExpr' into a transformation over the right-hand side of a 'Equality'.-rhsT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m Equality b-rhsT t = idR >>= \ (Equality vs _ rhs) -> return rhs >>> withVarsInScope vs t+-- | Lift a transformation over 'LCoreTC' into a transformation over the left-hand side of a 'Quantified'.+lhsT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Monad m)+     => Transform c m LCore a -> Transform c m Quantified a+lhsT t = quantifiedT successT (clauseT t successT (\_ l _ -> l)) (flip const) --- | Lift a transformation over 'CoreExpr' into a transformation over both sides of a 'Equality'.-bothT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m Equality (b,b)-bothT t = liftM2 (,) (lhsT t) (rhsT t) -- Can't wait for Applicative to be a superclass of Monad+-- | Lift a transformation over 'LCoreTC' into a transformation over the right-hand side of a 'Quantified'.+rhsT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Monad m)+     => Transform c m LCore a -> Transform c m Quantified a+rhsT t = quantifiedT successT (clauseT successT t (\_ _ r -> r)) (flip const) --- | Lift a transformation over '[Var]' into a transformation over the universally quantified variables of a 'Equality'.-forallVarsT :: Monad m => Transform c m [Var] b -> Transform c m Equality b-forallVarsT t = idR >>= \ (Equality vs _ _) -> return vs >>> t+-- | Lift a transformation over 'LCoreTC' into a transformation over both sides of a 'Quantified'.+bothT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Monad m)+      => Transform c m LCore a -> Transform c m Quantified (a, a)+bothT t = quantifiedT successT (clauseT t t (const (,))) (flip const) --- | Lift a rewrite over 'CoreExpr' into a rewrite over the left-hand side of a 'Equality'.-lhsR :: (AddBindings c, Monad m, ReadPath c Crumb) => Rewrite c m CoreExpr -> Rewrite c m Equality-lhsR r = do-    Equality vs lhs rhs <- idR-    lhs' <- withVarsInScope vs r <<< return lhs-    return $ Equality vs lhs' rhs+-- | Lift a rewrite over 'LCoreTC' into a rewrite over the left-hand side of a 'Quantified'.+lhsR :: (AddBindings c, Monad m, ReadPath c Crumb, ExtendPath c Crumb)+     => Rewrite c m LCore -> Rewrite c m Quantified+lhsR r = quantifiedR idR (clauseR r idR) --- | Lift a rewrite over 'CoreExpr' into a rewrite over the right-hand side of a 'Equality'.-rhsR :: (AddBindings c, Monad m, ReadPath c Crumb) => Rewrite c m CoreExpr -> Rewrite c m Equality-rhsR r = do-    Equality vs lhs rhs <- idR-    rhs' <- withVarsInScope vs r <<< return rhs-    return $ Equality vs lhs rhs'+-- | Lift a rewrite over 'LCoreTC' into a rewrite over the right-hand side of a 'Quantified'.+rhsR :: (AddBindings c, Monad m, ReadPath c Crumb, ExtendPath c Crumb)+     => Rewrite c m LCore -> Rewrite c m Quantified+rhsR r = quantifiedR idR (clauseR idR r) --- | Lift a rewrite over 'CoreExpr' into a rewrite over both sides of a 'Equality'.-bothR :: (AddBindings c, MonadCatch m, ReadPath c Crumb) => Rewrite c m CoreExpr -> Rewrite c m Equality+-- | Lift a rewrite over 'LCoreTC' into a rewrite over both sides of a 'Quantified'.+bothR :: (AddBindings c, MonadCatch m, ReadPath c Crumb, ExtendPath c Crumb)+      => Rewrite c m LCore -> Rewrite c m Quantified bothR r = lhsR r >+> rhsR r  ------------------------------------------------------------------------------ -ppEqualityT :: PrettyPrinter -> TransformH Equality DocH-ppEqualityT pp = do-    let pos = pOptions pp-    d1 <- forallVarsT (liftPrettyH pos $ pForall pp)-    (d2,d3) <- bothT (liftPrettyH pos $ extractT $ pCoreTC pp)-    return $ PP.sep [d1,d2,syntaxColor (PP.text "="),d3]+-- | Original clause passed to function so it can decide how to handle connective.+clauseT :: (Monad m, ExtendPath c Crumb) => Transform c m LCore a -> Transform c m LCore b -> (Clause -> a -> b -> d) -> Transform c m Clause d+clauseT t1 t2 f = readerT $ \ cl -> case cl of+                                      Conj{}  -> conjT  (extractT t1) (extractT t2) (f cl)+                                      Disj{}  -> disjT  (extractT t1) (extractT t2) (f cl)+                                      Impl{}  -> implT  (extractT t1) (extractT t2) (f cl)+                                      Equiv{} -> equivT (extractT t1) (extractT t2) (f cl) +clauseR :: (Monad m, ExtendPath c Crumb) => Rewrite c m LCore -> Rewrite c m LCore -> Rewrite c m Clause+clauseR r1 r2 = readerT $ \case+                             Conj{}  -> conjAllR (extractR r1) (extractR r2)+                             Disj{}  -> disjAllR (extractR r1) (extractR r2)+                             Impl{}  -> implAllR (extractR r1) (extractR r2)+                             Equiv{} -> equivAllR (extractR r1) (extractR r2)++-- | Lift a transformation over '[Var]' into a transformation over the universally quantified variables of a 'Quantified'.+forallVarsT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Monad m) => Transform c m [Var] b -> Transform c m Quantified b+forallVarsT t = quantifiedT t successT const+ ------------------------------------------------------------------------------ --- Idea: use Haskell's functions to fill the holes automagically------ plusId <- findIdT "+"--- timesId <- findIdT "*"--- mkEquality $ \ x -> ( mkCoreApps (Var plusId)  [x,x]---                     , mkCoreApps (Var timesId) [Lit 2, x])------ TODO: need to know type of 'x' to generate a variable.-class BuildEquality a where-    mkEquality :: a -> HermitM Equality+showLemmasT :: Maybe LemmaName -> PrettyPrinter -> PrettyH a+showLemmasT mnm pp = do+    ls <- getLemmasT+    let ls' = Map.toList $ Map.filterWithKey (maybe (\ _ _ -> True) (\ nm n _ -> show nm `isInfixOf` show n) mnm) ls+    ds <- forM ls' $ \(nm,l) -> return l >>> ppLemmaT pp nm+    return $ PP.vcat ds -instance BuildEquality (CoreExpr,CoreExpr) where-    mkEquality :: (CoreExpr,CoreExpr) -> HermitM Equality-    mkEquality (lhs,rhs) = return $ Equality [] lhs rhs+showLemmaT :: LemmaName -> PrettyPrinter -> PrettyH a+showLemmaT nm pp = getLemmaByNameT nm >>> ppLemmaT pp nm -instance BuildEquality a => BuildEquality (CoreExpr -> a) where-    mkEquality :: (CoreExpr -> a) -> HermitM Equality-    mkEquality f = do-        x <- newIdH "x" (error "need to create a type")-        Equality bnds lhs rhs <- mkEquality (f (varToCoreExpr x))-        return $ Equality (x:bnds) lhs rhs+ppLemmaT :: PrettyPrinter -> LemmaName -> PrettyH Lemma+ppLemmaT pp nm = do+    Lemma q p _u _t <- idR+    qDoc <- return q >>> ppQuantifiedT pp+    let hDoc = PP.text (show nm) PP.<+> PP.text ("(" ++ show p ++ ")")+    return $ hDoc PP.$+$ PP.nest 2 qDoc +ppLCoreTCT :: PrettyPrinter -> PrettyH LCoreTC+ppLCoreTCT pp = promoteT (ppQuantifiedT pp) <+ promoteT (ppClauseT pp) <+ promoteT (pCoreTC pp)++ppQuantifiedT :: PrettyPrinter -> PrettyH Quantified+ppQuantifiedT pp = do+    (d1,d2) <- quantifiedT (pForall pp) (ppClauseT pp) (,)+    return $ PP.sep [d1,d2]++ppClauseT :: PrettyPrinter -> PrettyH Clause+ppClauseT pp = do+    let t = absPathT &&& (promoteT (ppQuantifiedT pp) <+ promoteT (extractT (pCoreTC pp) :: PrettyH Core)) -- TODO: temporary hack, need to think about what's going on here and fix it+        parenify (p1,d1) (p2,d2) o = ( symbol p1 '(' PP.<> d1 PP.<> symbol p1 ')'+                                     , symbol p2 '(' PP.<> d2 PP.<> symbol p2 ')'+                                     , syntaxColor (PP.text o)+                                     )+    (d1,d2,oper) <- clauseT t t (\ cl r1 r2 ->+                                    case cl of+                                        Conj {} -> parenify r1 r2 "^"+                                        Disj {} -> parenify r1 r2 "v"+                                        Impl {} -> parenify r1 r2 "=>"+                                        Equiv {} -> (snd r1, snd r2, syntaxColor $ PP.text "="))+    return $ PP.sep [d1,oper,d2]+ ------------------------------------------------------------------------------ --- | Verify that a 'Equality' holds, by applying a rewrite to each side, and checking that the results are equal.-proveEqualityT :: forall c m. (AddBindings c, Monad m, ReadPath c Crumb)-                        => EqualityProof c m -> Transform c m Equality ()-proveEqualityT (l,r) = lhsR l >>> rhsR r >>> verifyEqualityT+verifyQuantifiedT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, MonadCatch m) => Transform c m Quantified ()+verifyQuantifiedT = quantifiedT successT verifyClauseT (flip const) --- | Verify that the left- and right-hand sides of a 'Equality' are alpha equivalent.-verifyEqualityT :: Monad m => Transform c m Equality ()-verifyEqualityT = do-    Equality _ lhs rhs <- idR-    guardMsg (exprAlphaEq lhs rhs) "the two sides of the equality do not match."+verifyClauseT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, MonadCatch m) => Transform c m Clause ()+verifyClauseT =+    readerT (\case Conj  q1 q2 -> (return q1 >>> verifyQuantifiedT) >> (return q2 >>> verifyQuantifiedT)+                   Disj  q1 q2 -> (return q1 >>> verifyQuantifiedT) <+ (return q2 >>> verifyQuantifiedT)+                   Impl  _  _  -> fail "verifyClauseT: Impl TODO"+                   Equiv e1 e2 -> guardMsg (exprAlphaEq e1 e2) "the two sides of the equality do not match.") +verifyEquivalentT :: (HasLemmas m, MonadCatch m) => Used -> LemmaName -> Transform c m Quantified ()+verifyEquivalentT used nm = prefixFailMsg "verification failed: " $ do+    Lemma q _ _ _ <- getLemmaByNameT nm+    eq <- arr (q `proves`)+    guardMsg eq "lemmas are not equivalent."+    markLemmaUsedT nm used++verifyOrCreateT :: (HasLemmas m, MonadCatch m) => Used -> LemmaName -> Lemma -> Transform c m a ()+verifyOrCreateT u nm l = do+    exists <- testM $ getLemmaByNameT nm+    if exists+    then return (lemmaQ l) >>> verifyEquivalentT u nm+    else insertLemmaT nm l+ ------------------------------------------------------------------------------ --- TODO: are these other functions used? If so, can they be rewritten in terms of lhsR and rhsR as above?+lintQuantifiedT :: (AddBindings c, BoundVars c, ReadPath c Crumb, ExtendPath c Crumb, HasDynFlags m, MonadCatch m)+                => Transform c m Quantified String+lintQuantifiedT = lintQuantifiedWorkT [] +lintQuantifiedWorkT :: (AddBindings c, BoundVars c, ReadPath c Crumb, ExtendPath c Crumb, HasDynFlags m, MonadCatch m)+                    => [Var] -> Transform c m Quantified String+lintQuantifiedWorkT bs = readerT $ \ (Quantified bs' _) -> quantifiedT successT (lintClauseT (bs++bs')) (flip const)++lintClauseT :: (AddBindings c, BoundVars c, ReadPath c Crumb, ExtendPath c Crumb, HasDynFlags m, MonadCatch m)+            => [Var] -> Transform c m Clause String+lintClauseT bs = do+    t <- readerT $ \case Equiv {} -> return $ promoteT ({- arr (mkCoreLams bs) >>> -} lintExprT) -- TODO: why does this break core lint?!+                         _        -> return $ promoteT (lintQuantifiedWorkT bs)+    (w1,w2) <- clauseT t t (const (,))+    return $ unlines [w1,w2]++------------------------------------------------------------------------------++-- TODO: everything between here and instantiateDictsR needs to be rethought/removed++-- TODO: this is used in century plugin, but otherwise should be removed+ -- | Given two expressions, and a rewrite from the former to the latter, verify that rewrite. verifyEqualityLeftToRightT :: MonadCatch m => CoreExpr -> CoreExpr -> Rewrite c m CoreExpr -> Transform c m a () verifyEqualityLeftToRightT sourceExpr targetExpr r =@@ -331,13 +434,13 @@          return y  -- | Given @f :: X -> Y@ and @g :: Y -> X@, and a proof that @f (g y)@ ==> @y@, then @f (g y)@ <==> @y@.-retraction :: Maybe (RewriteH Core) -> CoreString -> CoreString -> BiRewriteH CoreExpr+retraction :: Maybe (RewriteH LCore) -> CoreString -> CoreString -> BiRewriteH CoreExpr retraction mr = parse2beforeBiR (retractionBR (extractR <$> mr))  ------------------------------------------------------------------------------  -- TODO: revisit this for binder re-ordering issue-instantiateDictsR :: RewriteH Equality+instantiateDictsR :: RewriteH Quantified instantiateDictsR = prefixFailMsg "Dictionary instantiation failed: " $ do     bs <- forallVarsT idR     let dArgs = filter (\b -> isId b && isDictTy (varType b)) bs@@ -346,160 +449,264 @@     ds <- forM uniqDs $ \ b -> constT $ do             (i,bnds) <- buildDictionary b             let dExpr = case bnds of-                            [NonRec v e] | i == v -> e -- the common case that we would have gotten a single non-recursive let+                            -- the common case that we would have gotten a single non-recursive let+                            [NonRec v e] | i == v -> e                             _ -> mkCoreLets bnds (varToCoreExpr i)-                new = varSetElems $ delVarSetList (localFreeVarsExpr dExpr) bs-            return (b,dExpr,new)-    let buildSubst :: Monad m => Var -> m (Var, CoreExpr, [Var])-        buildSubst b = case [ (b,e,[]) | (b',e,_) <- ds, eqType (varType b) (varType b') ] of+            return (b,dExpr)+    let buildSubst :: Monad m => Var -> m (Var, CoreExpr)+        buildSubst b = case [ (b,e) | (b',e) <- ds, eqType (varType b) (varType b') ] of                         [] -> fail "cannot find equivalent dictionary expression (impossible!)"                         [t] -> return t                         _   -> fail "multiple dictionary expressions found (impossible!)"-        lookup3 :: Var -> [(Var,CoreExpr,[Var])] -> (Var,CoreExpr,[Var])-        lookup3 v l = head [ t | t@(v',_,_) <- l, v == v' ]+        lookup2 :: Var -> [(Var,CoreExpr)] -> (Var,CoreExpr)+        lookup2 v l = head [ t | t@(v',_) <- l, v == v' ]     allDs <- forM dArgs $ \ b -> constT $ do                 if b `elem` uniqDs-                then return $ lookup3 b ds+                then return $ lookup2 b ds                 else buildSubst b-    contextfreeT $ instantiateEquality allDs+    transform (\ c -> instsQuantified (boundVars c) allDs) >>> arr redundantDicts  ------------------------------------------------------------------------------ -alphaEqualityR :: (Var -> Bool) -> (String -> String) -> RewriteH Equality-alphaEqualityR p f = prefixFailMsg "Alpha-renaming binder in equality failed: " $ do-    Equality bs lhs rhs <- idR-    guardMsg (any p bs) "specified variable is not universally quantified."+conjunctLemmasT :: (HasLemmas m, Monad m) => LemmaName -> LemmaName -> LemmaName -> Transform c m a ()+conjunctLemmasT new lhs rhs = do+    Lemma ql pl _ tl <- getLemmaByNameT lhs+    Lemma qr pr _ tr <- getLemmaByNameT rhs+    insertLemmaT new $ Lemma (Quantified [] (Conj ql qr)) (pl `andP` pr) NotUsed (tl || tr) -    let (bs',i:vs) = break p bs -- this is safe because we know i is in bs-    i' <- constT $ cloneVarH f i+disjunctLemmasT :: (HasLemmas m, Monad m) => LemmaName -> LemmaName -> LemmaName -> Transform c m a ()+disjunctLemmasT new lhs rhs = do+    Lemma ql pl _ tl <- getLemmaByNameT lhs+    Lemma qr pr _ tr <- getLemmaByNameT rhs+    insertLemmaT new $ Lemma (Quantified [] (Disj ql qr)) (pl `orP` pr) NotUsed (tl || tr) -    let inS           = delVarSetList (unionVarSets (map localFreeVarsExpr [lhs, rhs] ++ map freeVarsVar vs)) (i:i':vs)-        subst         = extendSubst (mkEmptySubst (mkInScopeSet inS)) i (varToCoreExpr i')-        (subst', vs') = substBndrs subst vs-        lhs'          = substExpr (text "coreExprEquality-lhs") subst' lhs-        rhs'          = substExpr (text "coreExprEquality-rhs") subst' rhs-    return $ Equality (bs'++(i':vs')) lhs' rhs'+implyLemmasT :: (HasLemmas m, Monad m) => LemmaName -> LemmaName -> LemmaName -> Transform c m a ()+implyLemmasT new lhs rhs = do+    Lemma ql _  _ tl <- getLemmaByNameT lhs+    Lemma qr pr _ tr <- getLemmaByNameT rhs+    insertLemmaT new $ Lemma (Quantified [] (Impl ql qr)) pr NotUsed (tl || tr) -unshadowEqualityR :: RewriteH Equality-unshadowEqualityR = prefixFailMsg "Unshadowing equality failed: " $ do-    c@(Equality bs _ _) <- idR-    bvs <- boundVarsT-    let visible = unionVarSets [bvs , freeVarsEquality c]-    ss <- varSetElems <$> detectShadowsM bs visible-    guardMsg (not (null ss)) "no shadows to eliminate."-    let f = freshNameGenAvoiding Nothing . extendVarSet visible-    andR [ alphaEqualityR (==s) (f s) | s <- reverse ss ] >>> bothR (tryR unshadowExprR)+------------------------------------------------------------------------------ -freeVarsEquality :: Equality -> VarSet-freeVarsEquality (Equality bs lhs rhs) =-    delVarSetList (unionVarSets (map freeVarsExpr [lhs,rhs])) bs+mergeQuantifiersR :: MonadCatch m => (Var -> Bool) -> (Var -> Bool) -> Rewrite c m Quantified+mergeQuantifiersR pl pr = contextfreeT $ mergeQuantifiers pl pr +mergeQuantifiers :: MonadCatch m => (Var -> Bool) -> (Var -> Bool) -> Quantified -> m Quantified+mergeQuantifiers pl pr (Quantified bs cl) = prefixFailMsg "merge-quantifiers failed: " $ do+    (con,lq@(Quantified bsl cll),rq@(Quantified bsr clr)) <- case cl of+        Conj q1 q2 -> return (Conj,q1,q2)+        Disj q1 q2 -> return (Disj,q1,q2)+        Impl q1 q2 -> return (Impl,q1,q2)+        _ -> fail "no quantifiers on either side."++    let (lBefore,lbs) = break pl bsl+        (rBefore,rbs) = break pr bsr+        check b q l r = guardMsg (not (b `elemVarSet` freeVarsQuantified q)) $+                                 "specified "++l++" binder would capture in "++r++"-hand clause."+        checkUB v vs = let fvs = freeVarsVar v+                       in guardMsg (not (any (`elemVarSet` fvs) vs)) $ "binder " ++ getOccString v +++                            " cannot be floated because it depends on binders not being floated."++    case (lbs,rbs) of+        ([],[])        -> fail "no quantifiers match."+        ([],rb:rAfter) -> do+            check rb lq "right" "left"+            checkUB rb rBefore+            return $ Quantified (bs++[rb]) $ con lq (Quantified (rBefore++rAfter) clr)+        (lb:lAfter,[]) -> do+            check lb rq "left" "right"+            checkUB lb lBefore+            return $ Quantified (bs++[lb]) $ con (Quantified (lBefore++lAfter) cll) rq+        (lb:lAfter,rb:rAfter) -> do+            guardMsg (eqType (varType lb) (varType rb)) "specified quantifiers have differing types."+            check lb rq "left" "right"+            check rb lq "right" "left"+            checkUB lb lBefore+            checkUB rb rBefore++            let Quantified partial clr' = substQuantified rb (varToCoreExpr lb) $ Quantified rAfter clr+                rq' = Quantified (rBefore ++ partial) clr'+                lq' = Quantified (lBefore ++ lAfter) cll++            return $ Quantified (bs++[lb]) (con lq' rq')+ ------------------------------------------------------------------------------ -instantiateEqualityVarR :: (Var -> Bool) -> CoreString -> RewriteH Equality-instantiateEqualityVarR p cs = prefixFailMsg "instantiation failed: " $ do-    bs <- forallVarsT idR-    (e,new) <- case filter p bs of-                [] -> fail "no universally quantified variables match predicate."-                (b:_) | isId b    -> let (before,_) = break (==b) bs-                                     in liftM (,[]) $ withVarsInScope before $ parseCoreExprT cs-                      | otherwise -> do let (before,_) = break (==b) bs-                                        (ty, tvs) <- withVarsInScope before $ parseTypeWithHolesT cs-                                        return (Type ty, tvs)-    eq <- contextfreeT $ instantiateEqualityVar p e new-    (_,_) <- return eq >>> bothT lintExprT -- sanity check-    return eq+unshadowQuantifiedR :: MonadUnique m => Rewrite c m Quantified+unshadowQuantifiedR = contextfreeT unshadowQuantified --- | Instantiate one of the universally quantified variables in a 'Equality'.--- Note: assumes implicit ordering of variables, such that substitution happens to the right--- as it does in case alternatives. Only first variable that matches predicate is--- instantiated.-instantiateEqualityVar :: MonadIO m => (Var -> Bool) -- predicate to select var-                                    -> CoreExpr      -- expression to instantiate with-                                    -> [Var]         -- new binders to add in place of var-                                    -> Equality -> m Equality-instantiateEqualityVar p e new (Equality bs lhs rhs)-    | not (any p bs) = fail "specified variable is not universally quantified."-    | otherwise = do-        let (bs',i:vs) = break p bs -- this is safe because we know i is in bs-            tyVars    = filter isTyVar bs'-            failMsg   = fail "type of provided expression differs from selected binder."+unshadowQuantified :: MonadUnique m => Quantified -> m Quantified+unshadowQuantified q = go emptySubst (mapUniqSet fs (freeVarsQuantified q)) q+    where fs = occNameFS . getOccName -            -- unifyTypes will give back mappings from a TyVar to itself-            -- we don't want to do these instantiations, or else variables-            -- become unbound-            dropSelfSubst :: [(TyVar, Type)] -> [(TyVar,Type)]-            dropSelfSubst ps = [ (v,t) | (v,t) <- ps, case t of-                                                        TyVarTy v' | v' == v -> False-                                                        _ -> True ]-        tvs <- maybe failMsg (return . tyMatchesToCoreExpr . dropSelfSubst)-                $ unifyTypes tyVars (varType i) (exprKindOrType e)+          go subst seen (Quantified bs cl) = go1 subst seen bs [] cl -        let inS           = delVarSetList (unionVarSets (map localFreeVarsExpr [lhs, rhs, e] ++ map freeVarsVar vs)) (i:vs)-            subst         = extendSubst (mkEmptySubst (mkInScopeSet inS)) i e-            (subst', vs') = substBndrs subst vs-            lhs'          = substExpr (text "equality-lhs") subst' lhs-            rhs'          = substExpr (text "equality-rhs") subst' rhs-        instantiateEquality (noAdds tvs) $ Equality (bs'++new++vs') lhs' rhs'+          go1 subst seen []     bs' cl = do+            cl' <- go2 subst seen cl+            return $ Quantified (reverse bs') cl'+          go1 subst seen (b:bs) bs' cl+            | fsb `elementOfUniqSet` seen = do+                b'' <- cloneVarFSH (inventNames seen) b'+                go1 (extendSubst subst' b' (varToCoreExpr b'')) (addOneToUniqSet seen (fs b'')) bs (b'':bs') cl+            | otherwise = go1 subst' (addOneToUniqSet seen fsb) bs (b':bs') cl+                where fsb = fs b'+                      (subst', b') = substBndr subst b -noAdds :: [(Var,CoreExpr)] -> [(Var,CoreExpr,[Var])]-noAdds ps = [ (v,e,[]) | (v,e) <- ps ]+          go2 subst seen (Conj q1 q2) = do+            q1' <- go subst seen q1+            q2' <- go subst seen q2+            return $ Conj q1' q2'+          go2 subst seen (Disj q1 q2) = do+            q1' <- go subst seen q1+            q2' <- go subst seen q2+            return $ Disj q1' q2'+          go2 subst seen (Impl q1 q2) = do+            q1' <- go subst seen q1+            q2' <- go subst seen q2+            return $ Impl q1' q2'+          go2 subst _ (Equiv e1 e2) =+            let e1' = substExpr (text "unshadowQuantified e1") subst e1+                e2' = substExpr (text "unshadowQuantified e2") subst e2+            in return $ Equiv e1' e2' --- | Instantiate a set of universally quantified variables in a 'Equality'.--- It is important that all type variables appear before any value-level variables in the first argument.-instantiateEquality :: MonadIO m => [(Var,CoreExpr,[Var])] -> Equality -> m Equality-instantiateEquality = flip (foldM (\ eq (v,e,vs) -> instantiateEqualityVar (==v) e vs eq)) . reverse--- foldM is a left-to-right fold, so the reverse is important to do substitutions in reverse order--- which is what we want (all value variables should be instantiated before type variables).+inventNames :: UniqSet FastString -> FastString -> FastString+inventNames s nm = head [ nm' | i :: Int <- [0..]+                              , let nm' = nm `appendFS` (mkFastString (show i))+                              , not (nm' `elementOfUniqSet` s) ]  ------------------------------------------------------------------------------ -discardUniVars :: Equality -> Equality-discardUniVars (Equality _ lhs rhs) = Equality [] lhs rhs+instantiateQuantifiedVarR :: (Var -> Bool) -> CoreString -> RewriteH Quantified+instantiateQuantifiedVarR p cs = prefixFailMsg "instantiation failed: " $ do+    bs <- forallVarsT idR+    e <- case filter p bs of+                [] -> fail "no universally quantified variables match predicate."+                (b:_) | isId b    -> let (before,_) = break (==b) bs+                                     in withVarsInScope before $ parseCoreExprT cs+                      | otherwise -> let (before,_) = break (==b) bs+                                     in liftM (Type . fst) $ withVarsInScope before $ parseTypeWithHolesT cs+    transform (\ c -> instQuantified (boundVars c) p e) >>> (lintQuantifiedT >> idR) -- lint for sanity  ------------------------------------------------------------------------------ +-- | Replace all occurrences of the given expression with a new quantified variable.+abstractQuantifiedR :: forall c m.+                       ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+                       , HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadUnique m )+                    => String -> Transform c m Quantified CoreExpr -> Rewrite c m Quantified+abstractQuantifiedR nm tr = prefixFailMsg "abstraction failed: " $ do+    e <- tr+    Quantified bs cl <- idR+    b <- constT $ newVarH nm (exprKindOrType e)+    let f = compileFold [Equality [] e (varToCoreExpr b)] -- we don't use mkEquality on purpose, so we can abstract lambdas+    liftM dropBinders $ return (Quantified (bs++[b]) cl) >>>+                            extractR (anytdR $ promoteExprR $ runFoldR f :: Rewrite c m LCoreTC)++csInQBodyT :: ( AddBindings c, ReadBindings c, ReadPath c Crumb, HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m ) => CoreString -> Transform c m Quantified CoreExpr+csInQBodyT cs = do+    Quantified bs _ <- idR+    withVarsInScope bs $ parseCoreExprT cs++------------------------------------------------------------------------------+ getLemmasT :: HasLemmas m => Transform c m x Lemmas getLemmasT = constT getLemmas  getLemmaByNameT :: (HasLemmas m, Monad m) => LemmaName -> Transform c m x Lemma getLemmaByNameT nm = getLemmasT >>= maybe (fail $ "No lemma named: " ++ show nm) return . Map.lookup nm -lemmaR :: LemmaName -> BiRewriteH CoreExpr-lemmaR nm = afterBiR (beforeBiR (getLemmaByNameT nm) (birewrite . lemmaEq)) (markLemmaUsedR nm)+getObligationNotProvenT :: (HasLemmas m, Monad m) => Transform c m x [NamedLemma]+getObligationNotProvenT = do+    ls <- getLemmasT+    return [ (nm,l) | (nm, l@(Lemma _ NotProven Obligation _)) <- Map.toList ls ]  ------------------------------------------------------------------------------ --- We use sideEffectR because only rewrites generate new state in the Kernel.+lemmaBiR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+            , HasLemmas m, MonadCatch m, MonadUnique m)+         => Used -> LemmaName -> BiRewrite c m CoreExpr+lemmaBiR u nm = afterBiR (beforeBiR (getLemmaByNameT nm) (birewrite . lemmaQ)) (markLemmaUsedT nm u >> idR) -insertLemmaR :: (HasLemmas m, Monad m) => LemmaName -> Lemma -> Rewrite c m a-insertLemmaR nm l = sideEffectR $ \ _ _ -> insertLemma nm l+lemmaConsequentR :: forall c m. ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c+                                , ReadPath c Crumb, HasLemmas m, MonadCatch m, MonadUnique m)+                 => Used -> LemmaName -> Rewrite c m Quantified+lemmaConsequentR u nm = prefixFailMsg "lemma-consequent failed:" $+                        withPatFailMsg "lemma is not an implication." $ do+    Quantified hs (Impl ante con) <- lemmaQ <$> getLemmaByNameT nm+    q' <- transform $ \ c q -> do+        m <- maybeM ("consequent did not match.") $ lemmaMatch hs con q+        subs <- maybeM ("some quantifiers not instantiated.") $+                mapM (\h -> (h,) <$> lookupVarEnv m h) hs+        let q' = substQuantifieds subs ante+        guardMsg (all (inScope c) $ varSetElems (freeVarsQuantified q'))+                 "some variables in result would be out of scope."+        return q'+    markLemmaUsedT nm u+    return q' -modifyLemmaR :: (HasLemmas m, Monad m)+lemmaConsequentBiR :: forall c m. ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c+                                  , ReadPath c Crumb, HasLemmas m, MonadCatch m, MonadUnique m)+                   => Used -> LemmaName -> BiRewrite c m CoreExpr+lemmaConsequentBiR u nm = afterBiR (beforeBiR (getLemmaByNameT nm) (go . lemmaQ)) (markLemmaUsedT nm u >> idR)+    where go :: Quantified -> BiRewrite c m CoreExpr+          go (Quantified bs (Impl ante (Quantified bs' cl))) = do+            let eqs = toEqualities $ Quantified (bs++bs') cl -- consequent+                foldUnfold side f =+                    transform $ \ c e -> do+                        let cf = compileFold $ map f eqs+                        (e',hs) <- maybeM ("expression did not match "++side++"-hand side") $ runFoldMatches cf c e+                        let matches = [ case lookupVarEnv hs b of+                                            Nothing -> Left b+                                            Just arg -> Right (b,arg)+                                      | b <- bs ]+                            (unmatched, subs) = partitionEithers matches+                            Quantified aBs acl = substQuantifieds subs ante+                            q = Quantified (unmatched++aBs) acl+                        insertLemma (nm <> "-antecedent") $ Lemma q NotProven u True+                        return e'+            bidirectional (foldUnfold "left" id) (foldUnfold "right" flipEquality)+          go _ = let t = fail $ show nm ++ " is not an implication."+                 in bidirectional t t++------------------------------------------------------------------------------++insertLemmaT :: (HasLemmas m, Monad m) => LemmaName -> Lemma -> Transform c m a ()+insertLemmaT nm l = constT $ insertLemma nm l++insertLemmasT :: (HasLemmas m, Monad m) => [NamedLemma] -> Transform c m a ()+insertLemmasT = constT . mapM_ (uncurry insertLemma)++modifyLemmaT :: (HasLemmas m, Monad m)              => LemmaName              -> (LemmaName -> LemmaName) -- ^ modify lemma name-             -> Rewrite c m Equality     -- ^ rewrite the equality-             -> (Bool -> Bool)           -- ^ modify proven status-             -> (Bool -> Bool)           -- ^ modify used status-             -> Rewrite c m a-modifyLemmaR nm nFn rr pFn uFn = do-    Lemma eq p u <- getLemmaByNameT nm-    eq' <- rr <<< return eq-    sideEffectR $ \ _ _ -> insertLemma (nFn nm) $ Lemma eq' (pFn p) (uFn u)+             -> Rewrite c m Quantified   -- ^ rewrite the quantified clause+             -> (Proven -> Proven)       -- ^ modify proven status+             -> (Used -> Used)           -- ^ modify used status+             -> Transform c m a ()+modifyLemmaT nm nFn rr pFn uFn = do+    Lemma q p u t <- getLemmaByNameT nm+    q' <- rr <<< return q+    constT $ insertLemma (nFn nm) $ Lemma q' (pFn p) (uFn u) t -markLemmaUsedR :: (HasLemmas m, Monad m) => LemmaName -> Rewrite c m a-markLemmaUsedR nm = modifyLemmaR nm id idR id (const True)+markLemmaUsedT :: (HasLemmas m, Monad m) => LemmaName -> Used -> Transform c m a ()+markLemmaUsedT nm u = modifyLemmaT nm id idR id (const u) +markLemmaProvedT :: (HasLemmas m, Monad m) => LemmaName -> Transform c m a ()+markLemmaProvedT nm = modifyLemmaT nm id idR (const Proven) id++markLemmaAssumedT :: (HasLemmas m, Monad m) => Bool -> LemmaName -> Transform c m a ()+markLemmaAssumedT user nm = modifyLemmaT nm id idR (const (Assumed user)) id ------------------------------------------------------------------------------ -lemmaNameToEqualityT :: (HasLemmas m, Monad m) => LemmaName -> Transform c m x Equality-lemmaNameToEqualityT nm = liftM lemmaEq $ getLemmaByNameT nm+lemmaNameToQuantifiedT :: (HasLemmas m, Monad m) => LemmaName -> Transform c m x Quantified+lemmaNameToQuantifiedT nm = liftM lemmaQ $ getLemmaByNameT nm  -- | @e@ ==> @let v = lhs in e@  (also works in a similar manner at Program nodes) lemmaLhsIntroR :: LemmaName -> RewriteH Core-lemmaLhsIntroR = lemmaNameToEqualityT >=> eqLhsIntroR+lemmaLhsIntroR = lemmaNameToQuantifiedT >=> eqLhsIntroR  -- | @e@ ==> @let v = rhs in e@  (also works in a similar manner at Program nodes) lemmaRhsIntroR :: LemmaName -> RewriteH Core-lemmaRhsIntroR = lemmaNameToEqualityT >=> eqRhsIntroR+lemmaRhsIntroR = lemmaNameToQuantifiedT >=> eqRhsIntroR +------------------------------------------------------------------------------

@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module HERMIT.Dictionary.Remembered+    ( -- * Remembering definitions.+      externals+    , prefixRemembered+    , rememberR+    , unfoldRememberedR+    , foldRememberedR+    , foldAnyRememberedR+    , compileRememberedT+    ) where++import           Control.Monad++import qualified Data.Map as Map+import           Data.List (isPrefixOf)+import           Data.Monoid++import           HERMIT.Context+import           HERMIT.Core+import           HERMIT.External+import           HERMIT.GHC hiding ((<>), (<+>), nest, ($+$))+import           HERMIT.Kure+import           HERMIT.Lemma+import           HERMIT.Monad+import           HERMIT.PrettyPrinter.Common++import           HERMIT.Dictionary.Fold hiding (externals)+import           HERMIT.Dictionary.Reasoning hiding (externals)++------------------------------------------------------------------------------++externals :: [External]+externals =+    [ external "remember" (promoteCoreT . rememberR :: LemmaName -> TransformH LCore ())+        [ "Remember the current binding, allowing it to be folded/unfolded in the future." ] .+ Context+    , external "unfold-remembered" (promoteExprR . unfoldRememberedR Obligation :: LemmaName -> RewriteH LCore)+        [ "Unfold a remembered definition." ] .+ Deep .+ Context+    , external "fold-remembered" (promoteExprR . foldRememberedR Obligation :: LemmaName -> RewriteH LCore)+        [ "Fold a remembered definition." ]                      .+ Context .+ Deep+    , external "fold-any-remembered" (promoteExprR foldAnyRememberedR :: RewriteH LCore)+        [ "Attempt to fold any of the remembered definitions." ] .+ Context .+ Deep+    , external "show-remembered" (promoteCoreT . showLemmasT (Just "remembered-") :: PrettyPrinter -> PrettyH LCore)+        [ "Display all remembered definitions." ]+    ]++------------------------------------------------------------------------------++prefixRemembered :: LemmaName -> LemmaName+prefixRemembered = ("remembered-" <>)++-- | Remember a binding with a name for later use. Allows us to look at past definitions.+rememberR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasLemmas m, MonadCatch m)+          => LemmaName -> Transform c m Core ()+rememberR nm = prefixFailMsg "remember failed: " $ do+    Def v e <- setFailMsg "not applied to a binding." $ defOrNonRecT idR idR Def+    insertLemmaT (prefixRemembered nm) $ Lemma (mkQuantified [] (varToCoreExpr v) e) Proven NotUsed False++-- | Unfold a remembered definition (like unfoldR, but looks in stash instead of context).+unfoldRememberedR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+                     , HasLemmas m, MonadCatch m, MonadUnique m)+                  => Used -> LemmaName -> Rewrite c m CoreExpr+unfoldRememberedR u = prefixFailMsg "Unfolding remembered definition failed: " . forwardT . lemmaBiR u . prefixRemembered++-- | Fold a remembered definition (like foldR, but looks in stash instead of context).+foldRememberedR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+                   , HasLemmas m, MonadCatch m, MonadUnique m)+                => Used -> LemmaName -> Rewrite c m CoreExpr+foldRememberedR u = prefixFailMsg "Folding remembered definition failed: " . backwardT . lemmaBiR u . prefixRemembered++-- | Fold any of the remembered definitions.+foldAnyRememberedR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+                      , HasLemmas m, MonadCatch m, MonadUnique m)+                   => Rewrite c m CoreExpr+foldAnyRememberedR = setFailMsg "Fold failed: no definitions could be folded."+                   $ compileRememberedT >>= runFoldR++-- | Compile all remembered definitions into something that can be run with `runFoldR`+compileRememberedT :: (HasLemmas m, Monad m) => Transform c m x CompiledFold+compileRememberedT = do+    qs <- liftM (map lemmaQ . Map.elems . Map.filterWithKey (\ k _ -> "remembered-" `isPrefixOf` show k)) getLemmasT+    return $ compileFold $ concatMap (map flipEquality . toEqualities) qs -- fold rhs to lhs

@@ -5,10 +5,13 @@       -- ** Rules     , RuleName(..)     , RuleNameListBox(..)-    , ruleR-    , rulesR-    , ruleToEqualityT-    , ruleNameToEqualityT+    , foldRuleR+    , foldRulesR+    , unfoldRuleR+    , unfoldRulesR+    , compileRulesT+    , ruleToQuantifiedT+    , ruleNameToQuantifiedT     , getHermitRuleT     , getHermitRulesT       -- ** Specialisation@@ -27,18 +30,20 @@ import Data.List (deleteFirstsBy,intercalate) import Data.String (IsString(..)) -import HERMIT.Core import HERMIT.Context-import HERMIT.Monad-import HERMIT.Kure+import HERMIT.Core import HERMIT.External import HERMIT.GHC+import HERMIT.Kure+import HERMIT.Lemma+import HERMIT.Monad -import HERMIT.Dictionary.GHC (dynFlagsT)+import HERMIT.Dictionary.Fold (compileFold, CompiledFold, toEqualities) import HERMIT.Dictionary.Kure (anyCallR) import HERMIT.Dictionary.Reasoning hiding (externals)-import HERMIT.Dictionary.Unfold (betaReducePlusR) +import HERMIT.PrettyPrinter.Common+ import IOEnv hiding (liftIO)  ------------------------------------------------------------------------@@ -46,22 +51,27 @@ -- | Externals dealing with GHC rewrite rules. externals :: [External] externals =-    [ external "rule-help" (rulesHelpListT :: TransformH CoreTC String)+    [ external "show-rules" (rulesHelpListT :: TransformH LCoreTC String)         [ "List all the rules in scope." ] .+ Query-    , external "rule-help" (ruleHelpT :: RuleName -> TransformH CoreTC String)+    , external "show-rule" (ruleHelpT :: PrettyPrinter -> RuleName -> TransformH LCoreTC DocH)         [ "Display details on the named rule." ] .+ Query-    , external "apply-rule" (promoteExprR . ruleR :: RuleName -> RewriteH Core)-        [ "Apply a named GHC rule" ] .+ Shallow-    , external "apply-rules" (promoteExprR . rulesR :: [RuleName] -> RewriteH Core)-        [ "Apply named GHC rules, succeed if any of the rules succeed" ] .+ Shallow-    , external "unfold-rule" ((\ nm -> promoteExprR (ruleR nm >>> tryR betaReducePlusR)) :: RuleName -> RewriteH Core)-        [ "Unfold a named GHC rule" ] .+ Deep .+ Context .+ TODO -- TODO: does not work with rules with no arguments-    , external "rule-to-lemma" (\nm -> do eq <- ruleNameToEqualityT nm-                                          insertLemmaR (fromString (show nm)) $ Lemma eq False False :: RewriteH Core)+    , external "fold-rule" (promoteExprR . foldRuleR Obligation :: RuleName -> RewriteH LCore)+        [ "Apply a named GHC rule right-to-left." ] .+ Shallow+    , external "fold-rules" (promoteExprR . foldRulesR Obligation :: [RuleName] -> RewriteH LCore)+        [ "Apply named GHC rules right-to-left, succeed if any of the rules succeed." ] .+ Shallow+    , external "unfold-rule" (promoteExprR . unfoldRuleR Obligation :: RuleName -> RewriteH LCore)+        [ "Apply a named GHC rule left-to-right." ] .+ Shallow+    , external "unfold-rule-unsafe" (promoteExprR . unfoldRuleR UnsafeUsed :: RuleName -> RewriteH LCore)+        [ "Apply a named GHC rule left-to-right." ] .+ Shallow .+ Unsafe+    , external "unfold-rules" (promoteExprR . unfoldRulesR Obligation :: [RuleName] -> RewriteH LCore)+        [ "Apply named GHC rules left-to-right, succeed if any of the rules succeed" ] .+ Shallow+    , external "unfold-rules-unsafe" (promoteExprR . unfoldRulesR UnsafeUsed :: [RuleName] -> RewriteH LCore)+        [ "Apply named GHC rules left-to-right, succeed if any of the rules succeed" ] .+ Shallow .+ Unsafe+    , external "rule-to-lemma" ((\pp nm -> ruleToLemmaT nm >> liftPrettyH (pOptions pp) (showLemmaT (fromString (show nm)) pp)) :: PrettyPrinter -> RuleName -> TransformH LCore DocH)         [ "Create a lemma from a GHC RULE." ]-    , external "spec-constr" (promoteModGutsR specConstrR :: RewriteH Core)+    , external "spec-constr" (promoteModGutsR specConstrR :: RewriteH LCore)         [ "Run GHC's SpecConstr pass, which performs call pattern specialization."] .+ Deep-    , external "specialise" (promoteModGutsR specialiseR :: RewriteH Core)+    , external "specialise" (promoteModGutsR specialiseR :: RewriteH LCore)         [ "Run GHC's specialisation pass, which performs type and dictionary specialisation."] .+ Deep     ] @@ -84,19 +94,49 @@     box = RuleNameListBox     unbox (RuleNameListBox l) = l --- | Lookup a rule by name, attempt to apply it. If successful, record it as an unproven lemma.-ruleR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, ReadBindings c, ReadPath c Crumb-         , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )-      => RuleName -> Rewrite c m CoreExpr-ruleR nm = do-    eq <- ruleNameToEqualityT nm-    forwardT (birewrite eq) >>> sideEffectR (\ _ _ -> addLemma (fromString (show nm)) $ Lemma eq False True)+-- | Lookup a rule by name, attempt to apply it left-to-right. If successful, record it as an unproven lemma.+foldRuleR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+               , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+            => Used -> RuleName -> Rewrite c m CoreExpr+foldRuleR u nm = do+    q <- ruleNameToQuantifiedT nm+    backwardT (birewrite q) >>> (verifyOrCreateT u (fromString (show nm)) (Lemma q NotProven u False) >> idR) -rulesR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, ReadBindings c, ReadPath c Crumb-          , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )-       => [RuleName] -> Rewrite c m CoreExpr-rulesR = orR . map ruleR+-- | Lookup a set of rules by name, attempt to apply them left-to-right. Record an unproven lemma for the one that succeeds.+foldRulesR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+              , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+           => Used -> [RuleName] -> Rewrite c m CoreExpr+foldRulesR u = orR . map (foldRuleR u) +-- | Lookup a rule by name, attempt to apply it left-to-right. If successful, record it as an unproven lemma.+unfoldRuleR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+               , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+            => Used -> RuleName -> Rewrite c m CoreExpr+unfoldRuleR u nm = do+    q <- ruleNameToQuantifiedT nm+    forwardT (birewrite q) >>> (verifyOrCreateT u (fromString (show nm)) (Lemma q NotProven u False) >> idR)++-- | Lookup a set of rules by name, attempt to apply them left-to-right. Record an unproven lemma for the one that succeeds.+unfoldRulesR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+                , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+             => Used -> [RuleName] -> Rewrite c m CoreExpr+unfoldRulesR u = orR . map (unfoldRuleR u)++-- | Can be used with runFoldR. Note: currently doesn't create a lemma for the rule used.+compileRulesT :: (BoundVars c, HasCoreRules c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m)+              => [RuleName] -> Transform c m a CompiledFold+compileRulesT nms = do+    let suggestion = "If you think the rule exists, try running the flatten-module command at the top level."+    let failMsg []   = "no rule names supplied."+        failMsg [nm] = "failed to find rule: " ++ show nm ++ ". " ++ suggestion+        failMsg _    = "failed to find any rules named " ++ intercalate ", " (map show nms) ++ ". " ++ suggestion+    allRules <- getHermitRulesT+    case filter ((`elem` nms) . fst) allRules of+        [] -> fail (failMsg nms)+        rs -> liftM (compileFold . concatMap toEqualities)+                $ forM (map snd rs) $ \ r -> return r >>> ruleToQuantifiedT++ -- | Return all in-scope CoreRules (including specialization RULES on binders), with their names. getHermitRulesT :: (HasCoreRules c, HasHermitMEnv m, LiftCoreM m, MonadIO m) => Transform c m a [(RuleName, CoreRule)] getHermitRulesT = contextonlyT $ \ c -> do@@ -123,29 +163,32 @@     rulesEnv <- getHermitRulesT     return (intercalate "\n" $ reverse $ map (show.fst) rulesEnv) --- | Print a named CoreRule using GHC's pretty printer for rewrite rules.--- TODO: use our own Equality pretty printer.-ruleHelpT :: (HasCoreRules c, HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadIO m)-          => RuleName -> Transform c m a String-ruleHelpT nm = do-    r <- getHermitRuleT nm-    dflags <- dynFlagsT-    return $ showSDoc dflags $ pprRulesForUser [r]+-- | Print a named CoreRule using the quantified printer.+ruleHelpT :: (HasCoreRules c, ReadBindings c, ReadPath c Crumb) => PrettyPrinter -> RuleName -> Transform c HermitM a DocH+ruleHelpT pp nm = ruleNameToQuantifiedT nm >>> liftPrettyH (pOptions pp) (ppQuantifiedT pp) --- | Build an Equality from a named GHC rewrite rule.-ruleNameToEqualityT :: ( BoundVars c, HasCoreRules c, HasDynFlags m, HasHermitMEnv m+-- | Build an Quantified from a named GHC rewrite rule.+ruleNameToQuantifiedT :: ( BoundVars c, HasCoreRules c, HasDynFlags m, HasHermitMEnv m                        , LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m )-                    => RuleName -> Transform c m a Equality-ruleNameToEqualityT name = getHermitRuleT name >>> ruleToEqualityT+                    => RuleName -> Transform c m a Quantified+ruleNameToQuantifiedT name = getHermitRuleT name >>> ruleToQuantifiedT --- | Transform GHC's CoreRule into an Equality.-ruleToEqualityT :: (BoundVars c, HasDynFlags m, HasHermitMEnv m, MonadThings m, MonadCatch m)-                => Transform c m CoreRule Equality-ruleToEqualityT = withPatFailMsg "HERMIT cannot handle built-in rules yet." $-  do r@Rule{} <- idR -- other possibility is "BuiltinRule"-     f <- lookupId $ ru_fn r-     return $ Equality (ru_bndrs r) (mkCoreApps (Var f) (ru_args r)) (ru_rhs r)+-- | Transform GHC's CoreRule into an Quantified.+ruleToQuantifiedT :: (BoundVars c, HasHermitMEnv m, MonadThings m, MonadCatch m)+                => Transform c m CoreRule Quantified+ruleToQuantifiedT = withPatFailMsg "HERMIT cannot handle built-in rules yet." $ do+    r@Rule{} <- idR -- other possibility is "BuiltinRule"+    f <- lookupId $ ru_fn r+    let lhs = mkCoreApps (varToCoreExpr f) (ru_args r)+    return $ mkQuantified (ru_bndrs r) lhs (ru_rhs r) +ruleToLemmaT :: ( BoundVars c, HasCoreRules c, HasDynFlags m, HasHermitMEnv m, HasLemmas m+                , LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m)+             => RuleName -> Transform c m a ()+ruleToLemmaT nm = do+    q <- ruleNameToQuantifiedT nm+    insertLemmaT (fromString (show nm)) $ Lemma q NotProven NotUsed False+ ------------------------------------------------------------------------  -- | Run GHC's specConstr pass, and apply any rules generated.@@ -202,6 +245,6 @@ rulesToRewrite :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb                   , HasDynFlags m, HasHermitMEnv m, MonadCatch m, MonadThings m, MonadUnique m )                => [CoreRule] -> Rewrite c m CoreExpr-rulesToRewrite rs = catchesM [ (return r >>> ruleToEqualityT) >>= forwardT . birewrite | r <- rs ]+rulesToRewrite rs = catchesM [ (return r >>> ruleToQuantifiedT) >>= forwardT . birewrite | r <- rs ]  ------------------------------------------------------------------------

@@ -5,6 +5,7 @@       externals     , buildStrictnessLemmaT     , verifyStrictT+    , applyToUndefinedT     , mkUndefinedValT     , isUndefinedValT     , replaceCurrentExprWithUndefinedR@@ -31,6 +32,7 @@ import HERMIT.External import HERMIT.GHC hiding ((<>)) import HERMIT.Kure+import HERMIT.Lemma import HERMIT.Monad import HERMIT.Name @@ -41,40 +43,40 @@ ------------------------------------------------------------------------  externals :: [External]-externals = map (.+ Unsafe)-    [ external "replace-current-expr-with-undefined" (promoteExprR replaceCurrentExprWithUndefinedR :: RewriteH Core)+externals = map (.+ Strictness)+    [ external "replace-current-expr-with-undefined" (promoteExprR replaceCurrentExprWithUndefinedR :: RewriteH LCore)         [ "Set the current expression to \"undefined\"."         ] .+ Shallow .+ Context .+ Unsafe-    , external "replace-id-with-undefined" (replaceIdWithUndefined :: HermitName -> RewriteH Core)+    , external "replace-id-with-undefined" (promoteCoreR . replaceIdWithUndefined :: HermitName -> RewriteH LCore)         [ "Replace the specified identifier with \"undefined\"."         ] .+ Deep .+ Context .+ Unsafe-    , external "error-to-undefined" (promoteExprR errorToUndefinedR :: RewriteH Core)+    , external "error-to-undefined" (promoteExprR errorToUndefinedR :: RewriteH LCore)         [ "error ty string  ==>  undefined ty"         ] .+ Shallow .+ Context-    , external "is-undefined-val" (promoteExprT isUndefinedValT :: TransformH Core ())+    , external "is-undefined-val" (promoteExprT isUndefinedValT :: TransformH LCore ())         [ "Succeed if the current expression is an undefined value."         ] .+ Shallow .+ Context .+ Predicate-    , external "undefined-expr" (promoteExprR undefinedExprR :: RewriteH Core)+    , external "undefined-expr" (promoteExprR undefinedExprR :: RewriteH LCore)         [ "undefined-app <+ undefined-lam <+ undefined-let <+ undefined-cast <+ undefined-tick <+ undefined-case"         ] .+ Eval .+ Shallow .+ Context-    , external "undefined-app" (promoteExprR undefinedAppR :: RewriteH Core)+    , external "undefined-app" (promoteExprR undefinedAppR :: RewriteH LCore)         [ "(undefined ty1) e  ==>  undefined ty2"         ] .+ Eval .+ Shallow .+ Context-    , external "undefined-lam" (promoteExprR undefinedLamR :: RewriteH Core)+    , external "undefined-lam" (promoteExprR undefinedLamR :: RewriteH LCore)         [ "(\\ v -> undefined ty1)  ==>  undefined ty2   (where v is not a 'TyVar')"         ] .+ Eval .+ Shallow .+ Context-    , external "undefined-let" (promoteExprR undefinedLetR :: RewriteH Core)+    , external "undefined-let" (promoteExprR undefinedLetR :: RewriteH LCore)         [ "let bds in (undefined ty)  ==>  undefined ty"         ] .+ Eval .+ Shallow .+ Context-    , external "undefined-case" (promoteExprR undefinedCaseR :: RewriteH Core)+    , external "undefined-case" (promoteExprR undefinedCaseR :: RewriteH LCore)         [ "case (undefined ty) of alts  ==>  undefined ty"         , "OR"         , "case e of {pat_1 -> undefined ty ; pat_2 -> undefined ty ; ... ; pat_n -> undefined ty} ==> undefined ty"         ] .+ Eval .+ Shallow .+ Context-    , external "undefined-cast" (promoteExprR undefinedCastR :: RewriteH Core)+    , external "undefined-cast" (promoteExprR undefinedCastR :: RewriteH LCore)         [ "Cast (undefined ty1) co  ==>  undefined ty2"         ] .+ Eval .+ Shallow .+ Context-    , external "undefined-tick" (promoteExprR undefinedTickR :: RewriteH Core)+    , external "undefined-tick" (promoteExprR undefinedTickR :: RewriteH LCore)         [ "Tick tick (undefined ty1)  ==>  undefined ty1"         ] .+ Eval .+ Shallow .+ Context     ]@@ -216,10 +218,10 @@ -- | Add a lemma for the strictness of a function. -- Note: assumes added lemma has been used buildStrictnessLemmaT :: (BoundVars c, HasDynFlags m, HasHscEnv m, HasHermitMEnv m, HasLemmas m, MonadCatch m, MonadIO m, MonadThings m)-                      => LemmaName -> CoreExpr -> Transform c m x ()-buildStrictnessLemmaT nm f = do+                      => Used -> LemmaName -> CoreExpr -> Transform c m x ()+buildStrictnessLemmaT u nm f = do     (tvs, lhs) <- liftM collectTyBinders $ applyToUndefinedT f     rhs <- mkUndefinedValT (exprType lhs)-    constT $ insertLemma nm $ Lemma (Equality tvs lhs rhs) False True+    verifyOrCreateT u nm $ Lemma (mkQuantified tvs lhs rhs) NotProven u False  ------------------------------------------------------------------------

@@ -2,27 +2,18 @@ module HERMIT.Dictionary.Unfold     ( externals     , betaReducePlusR-    , rememberR-    , showStashT     , unfoldR     , unfoldPredR     , unfoldNameR     , unfoldNamesR     , unfoldSaturatedR-    , unfoldStashR     , specializeR     ) where  import Control.Arrow import Control.Monad -import Data.List (intercalate)-import qualified Data.Map as Map--import HERMIT.PrettyPrinter.Common (DocH, PrettyH, TransformDocH(..), PrettyC)- import HERMIT.Dictionary.Common-import HERMIT.Dictionary.GHC (substCoreExpr) import HERMIT.Dictionary.Inline (inlineR)  import HERMIT.Core@@ -35,30 +26,22 @@  import Prelude hiding (exp) -import qualified Text.PrettyPrint.MarkedHughesPJ as PP- ------------------------------------------------------------------------  externals :: [External] externals =-    [ external "beta-reduce-plus" (promoteExprR betaReducePlusR :: RewriteH Core)+    [ external "beta-reduce-plus" (promoteExprR betaReducePlusR :: RewriteH LCore)         [ "Perform one or more beta-reductions."]                               .+ Eval .+ Shallow-    , external "remember" (rememberR :: RememberedName -> RewriteH Core)-        [ "Remember the current binding, allowing it to be folded/unfolded in the future." ] .+ Context-    , external "unfold-remembered" (promoteExprR . unfoldStashR :: RememberedName -> RewriteH Core)-        [ "Unfold a remembered definition." ] .+ Deep .+ Context-    , external "unfold" (promoteExprR unfoldR :: RewriteH Core)+    , external "unfold" (promoteExprR unfoldR :: RewriteH LCore)         [ "In application f x y z, unfold f." ] .+ Deep .+ Context-    , external "unfold" (promoteExprR . unfoldNameR . unOccurrenceName :: OccurrenceName -> RewriteH Core)+    , external "unfold" (promoteExprR . unfoldNameR . unOccurrenceName :: OccurrenceName -> RewriteH LCore)         [ "Inline a definition, and apply the arguments; traditional unfold." ] .+ Deep .+ Context-    , external "unfold" (promoteExprR . unfoldNamesR . map unOccurrenceName:: [OccurrenceName] -> RewriteH Core)+    , external "unfold" (promoteExprR . unfoldNamesR . map unOccurrenceName:: [OccurrenceName] -> RewriteH LCore)         [ "Unfold a definition if it is named in the list." ] .+ Deep .+ Context-    , external "unfold-saturated" (promoteExprR unfoldSaturatedR :: RewriteH Core)+    , external "unfold-saturated" (promoteExprR unfoldSaturatedR :: RewriteH LCore)         [ "Unfold a definition only if the function is fully applied." ] .+ Deep .+ Context-    , external "specialize" (promoteExprR specializeR :: RewriteH Core)+    , external "specialize" (promoteExprR specializeR :: RewriteH LCore)         [ "Specialize an application to its type and coercion arguments." ] .+ Deep .+ Context-    , external "show-remembered" (TransformDocH showStashT :: TransformDocH CoreTC)-        [ "Display all remembered definitions." ]     ]  ------------------------------------------------------------------------@@ -104,45 +87,3 @@  specializeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr specializeR = unfoldPredR (const $ all isTyCoArg)---- NOTE: Using a Rewrite because of the way the Kernel is set up.---       This is a temporary hack until we work out the best way to structure the Kernel.---- | Stash a binding with a name for later use.--- Allows us to look at past definitions.-rememberR :: RememberedName -> Rewrite c HermitM Core-rememberR label = sideEffectR $ \ _ -> \case-                                          DefCore def           -> saveDef label def-                                          BindCore (NonRec i e) -> saveDef label (Def i e)-                                          _                     -> fail "remember failed: not applied to a binding."---- | Stash a binding with a name for later use.--- Allows us to look at past definitions.--- rememberR :: String -> Transform c m Core ()--- rememberR label = contextfreeT $ \ core ->---     case core of---         DefCore def -> saveDef label def---         BindCore (NonRec i e) -> saveDef label (Def i e)---         _           -> fail "remember: not a binding"---- | Apply a stashed definition (like inline, but looks in stash instead of context).-unfoldStashR :: ReadBindings c => RememberedName -> Rewrite c HermitM CoreExpr-unfoldStashR label = prefixFailMsg "Inlining stashed definition failed: " $-                     withPatFailMsg (wrongExprForm "Var v") $-    do (c, Var v) <- exposeT-       constT $ do Def i rhs <- lookupDef label-                   dflags <- getDynFlags-                   if idName i == idName v -- TODO: Is there a reason we're not just using equality on Id?-                   then let fvars = varSetElems $ localFreeVarsExpr rhs-                        in if all (inScope c) fvars-                           then return rhs-                           else fail $ "free variables " ++ intercalate "," (map (showPpr dflags) (filter (not . inScope c) fvars)) ++ " in stashed definition are no longer in scope."-                   else fail $ "stashed definition applies to " ++ unqualifiedName i ++ " not " ++ unqualifiedName v--showStashT :: Injection CoreDef a => PrettyC -> PrettyH a -> Transform c HermitM a DocH-showStashT pctx pp = do-    stash <- constT getStash-    docs <- forM (Map.toList stash) $ \ (l,d) -> do-                dfn <- constT $ applyT (extractT pp) pctx d-                return $ PP.text ("[ " ++ show l ++ " ]") PP.$+$ dfn PP.$+$ PP.space-    return $ PP.vcat docs

@@ -1,7 +1,6 @@ module HERMIT.Dictionary.Unsafe     ( externals     , unsafeReplaceR-    , unsafeReplaceStashR     ) where  import Control.Monad@@ -9,7 +8,6 @@ import HERMIT.Core import HERMIT.Kure import HERMIT.GHC-import HERMIT.Monad import HERMIT.External import HERMIT.ParserCore @@ -19,12 +17,9 @@  externals :: [External] externals = map (.+ Unsafe)-    [ external "unsafe-replace" (promoteExprR . unsafeReplaceR :: CoreString -> RewriteH Core)+    [ external "unsafe-replace" (promoteExprR . unsafeReplaceR :: CoreString -> RewriteH LCore)         [ "replace the currently focused expression with a new expression"         , "DOES NOT ensure that free variables in the replacement expression are in scope" ]-    , external "unsafe-replace" (promoteExprR . unsafeReplaceStashR :: RememberedName -> RewriteH Core)-        [ "replace the currently focused expression with a remembered expression"-        , "DOES NOT ensure that free variables in the replacement expression are in scope" ]     ]  ------------------------------------------------------------------------@@ -35,12 +30,5 @@         e' <- parseCore core c         guardMsg (eqType (exprKindOrType e) (exprKindOrType e')) "expression types differ."         return e'--unsafeReplaceStashR :: RememberedName -> RewriteH CoreExpr-unsafeReplaceStashR label = prefixFailMsg "unsafe-replace failed: " $-    contextfreeT $ \ e -> do-        Def _ rhs <- lookupDef label-        guardMsg (eqType (exprKindOrType e) (exprKindOrType rhs)) "expression types differ."-        return rhs  ------------------------------------------------------------------------

@@ -3,9 +3,9 @@     ( externals     , WWAssumptionTag(..)     , WWAssumption(..)-    , assumptionAEqualityT-    , assumptionBEqualityT-    , assumptionCEqualityT+    , assumptionAQuantifiedT+    , assumptionBQuantifiedT+    , assumptionCQuantifiedT     , split1BetaR     , split2BetaR     , workLabel@@ -21,6 +21,7 @@ import HERMIT.External import HERMIT.GHC import HERMIT.Kure+import HERMIT.Lemma import HERMIT.Monad import HERMIT.ParserCore @@ -36,30 +37,30 @@ externals = map (.+ Proof)     [ external "intro-ww-assumption-A"         (\nm absC repC -> do-            eq <- parse2BeforeT assumptionAEqualityT absC repC-            insertLemmaR nm $ Lemma eq False False :: RewriteH Core)+            q <- parse2BeforeT assumptionAQuantifiedT absC repC+            insertLemmaT nm $ Lemma q NotProven NotUsed False :: TransformH LCore ())         [ "Introduce a lemma for worker/wrapper assumption A"         , "using given abs and rep functions." ]     , external "intro-ww-assumption-B"         (\nm absC repC bodyC -> do-            eq <- parse3BeforeT assumptionBEqualityT absC repC bodyC-            insertLemmaR nm $ Lemma eq False False :: RewriteH Core)+            q <- parse3BeforeT assumptionBQuantifiedT absC repC bodyC+            insertLemmaT nm $ Lemma q NotProven NotUsed False :: TransformH LCore ())         [ "Introduce a lemma for worker/wrapper assumption B"         , "using given abs, rep, and body functions." ]     , external "intro-ww-assumption-C"         (\nm absC repC bodyC -> do-            eq <- parse3BeforeT assumptionCEqualityT absC repC bodyC-            insertLemmaR nm $ Lemma eq False False :: RewriteH Core)+            q <- parse3BeforeT assumptionCQuantifiedT absC repC bodyC+            insertLemmaT nm $ Lemma q NotProven NotUsed False :: TransformH LCore ())         [ "Introduce a lemma for worker/wrapper assumption C"         , "using given abs, rep, and body functions." ]-    , external "split-1-beta" (\ nm absC -> promoteExprR . parse2BeforeT (split1BetaR nm) absC :: CoreString -> RewriteH Core)+    , external "split-1-beta" (\ nm absC -> promoteExprR . parse2BeforeT (split1BetaR Obligation nm) absC :: CoreString -> RewriteH LCore)         [ "split-1-beta <name> <abs expression> <rep expression>"         , "Perform worker/wrapper split with condition 1-beta."         , "Given lemma name argument is used as prefix to two introduced lemmas."         , "  <name>-assumption: unproven lemma for w/w assumption C."         , "  <name>-fusion: assumed lemma for w/w fusion."         ]-    , external "split-2-beta" (\ nm absC -> promoteExprR . parse2BeforeT (split2BetaR nm) absC :: CoreString -> RewriteH Core)+    , external "split-2-beta" (\ nm absC -> promoteExprR . parse2BeforeT (split2BetaR Obligation nm) absC :: CoreString -> RewriteH LCore)         [ "split-2-beta <name> <abs expression> <rep expression>"         , "Perform worker/wrapper split with condition 2-beta."         , "Given lemma name argument is used as prefix to two introduced lemmas."@@ -87,94 +88,95 @@ -- That would have to exist at the Shell level though.  -- This isn't entirely safe, as a malicious the user could define a label with this name.-workLabel :: RememberedName+workLabel :: LemmaName workLabel = fromString "recursive-definition-of-work-for-use-by-ww-fusion"  --------------------------------------------------------------------------------------------------  -- Given abs and rep expressions, build "abs . rep = id"-assumptionAEqualityT :: ( BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m+assumptionAQuantifiedT :: ( BoundVars c, HasHermitMEnv m, HasHscEnv m                         , MonadCatch m, MonadIO m, MonadThings m )-                     => CoreExpr -> CoreExpr -> Transform c m x Equality-assumptionAEqualityT absE repE = prefixFailMsg "Building assumption A failed: " $ do+                     => CoreExpr -> CoreExpr -> Transform c m x Quantified+assumptionAQuantifiedT absE repE = prefixFailMsg "Building assumption A failed: " $ do     comp <- buildCompositionT absE repE     let (_,compBody) = collectTyBinders comp     (tvs, xTy, _) <- splitFunTypeM (exprType comp)     idE <- buildIdT xTy-    return $ Equality tvs compBody idE+    return $ Quantified tvs (Equiv compBody idE)  -- Given abs, rep, and f expressions, build "abs . rep . f = f"-assumptionBEqualityT :: ( BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m+assumptionBQuantifiedT :: ( BoundVars c, HasHermitMEnv m, HasHscEnv m                         , MonadCatch m, MonadIO m, MonadThings m)-                     => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Equality-assumptionBEqualityT absE repE fE = prefixFailMsg "Building assumption B failed: " $ do+                     => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Quantified+assumptionBQuantifiedT absE repE fE = prefixFailMsg "Building assumption B failed: " $ do     repAfterF <- buildCompositionT repE fE     comp <- buildCompositionT absE repAfterF     let (tvs,lhs) = collectTyBinders comp     rhs <- appArgM 5 lhs >>= appArgM 5 -- get f with proper tvs applied-    return $ Equality tvs lhs rhs+    return $ Quantified tvs (Equiv lhs rhs)  -- Given abs, rep, and f expressions, build "fix (abs . rep . f) = fix f"-assumptionCEqualityT :: (BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)-                     => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Equality-assumptionCEqualityT absE repE fE = prefixFailMsg "Building assumption C failed: " $ do-    Equality vs lhs rhs <- assumptionBEqualityT absE repE fE+assumptionCQuantifiedT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)+                     => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Quantified+assumptionCQuantifiedT absE repE fE = prefixFailMsg "Building assumption C failed: " $ do+    Quantified vs (Equiv lhs rhs) <- assumptionBQuantifiedT absE repE fE     lhs' <- buildFixT lhs     rhs' <- buildFixT rhs-    return $ Equality vs lhs' rhs'+    return $ Quantified vs (Equiv lhs' rhs')  -- Given abs, rep, and 'fix g' expressions, build "rep (abs (fix g)) = fix g"-wwFusionEqualityT :: (HasDynFlags m, MonadCatch m, MonadIO m)-                  => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Equality-wwFusionEqualityT absE repE fixgE = prefixFailMsg "Building worker/wrapper fusion lemma failed: " $ do-    protoLhs <- buildApplicationM repE =<< buildApplicationM absE fixgE+wwFusionQuantifiedT :: MonadCatch m => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Quantified+wwFusionQuantifiedT absE repE fixgE = prefixFailMsg "Building worker/wrapper fusion lemma failed: " $ do+    protoLhs <- buildAppM repE =<< buildAppM absE fixgE     let (tvs, lhs) = collectTyBinders protoLhs     -- This way, the rhs is applied to the proper type variables.     rhs <- case lhs of             (App _ (App _ rhs)) -> return rhs             _                   -> fail "lhs malformed"-    return $ Equality tvs lhs rhs+    return $ Quantified tvs (Equiv lhs rhs)  -- Perform the worker/wrapper split using condition 1-beta, introducing -- an unproven lemma for assumption C, and an appropriate w/w fusion lemma.-split1BetaR :: ( BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m, HasLemmas m+split1BetaR :: ( BoundVars c, HasHermitMEnv m, HasHscEnv m, HasLemmas m                , MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )-            => LemmaName -> CoreExpr -> CoreExpr -> Rewrite c m CoreExpr-split1BetaR nm absE repE = do+            => Used -> LemmaName -> CoreExpr -> CoreExpr -> Rewrite c m CoreExpr+split1BetaR u nm absE repE = do     (_fixId, [_tyA, f]) <- callNameT $ fromString "Data.Function.fix" -    g <- buildCompositionT repE =<< buildCompositionT f absE+    g <- prefixFailMsg "building (rep . f . abs) failed: "+       $ buildCompositionT repE =<< buildCompositionT f absE     gId <- constT $ newIdH "g" $ exprType g      workRhs <- buildFixT $ varToCoreExpr gId     workId <- constT $ newIdH "worker" $ exprType workRhs -    newRhs <- buildApplicationM absE (varToCoreExpr workId)+    newRhs <- prefixFailMsg "building (abs work) failed: "+            $ buildAppM absE (varToCoreExpr workId) -    assumptionEq <- assumptionCEqualityT absE repE f-    _ <- insertLemmaR (fromString (show nm ++ "-assumption")) $ Lemma assumptionEq False True -- unproven, used+    assumptionQ <- assumptionCQuantifiedT absE repE f+    verifyOrCreateT u (fromString (show nm ++ "-assumption")) $ Lemma assumptionQ NotProven u False -- unproven, used, permanent -    wwFusionEq <- wwFusionEqualityT absE repE workRhs-    _ <- insertLemmaR (fromString (show nm ++ "-fusion")) $ Lemma wwFusionEq True False -- proven (assumed), unused+    wwFusionQ <- wwFusionQuantifiedT absE repE workRhs+    insertLemmaT (fromString (show nm ++ "-fusion")) $ Lemma wwFusionQ (Assumed False) NotUsed False -- assumed, unused, permanent      return $ mkCoreLets [NonRec gId g, NonRec workId workRhs] newRhs -split2BetaR :: ( BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m, HasLemmas m+split2BetaR :: ( BoundVars c, HasHermitMEnv m, HasHscEnv m, HasLemmas m                , MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )-            => LemmaName -> CoreExpr -> CoreExpr -> Rewrite c m CoreExpr-split2BetaR nm absE repE = do+            => Used -> LemmaName -> CoreExpr -> CoreExpr -> Rewrite c m CoreExpr+split2BetaR u nm absE repE = do     (_fixId, [_tyA, f]) <- callNameT $ fromString "Data.Function.fix"     fixfE <- idR -    repFixFE <- buildApplicationM repE fixfE+    repFixFE <- buildAppM repE fixfE     workId <- constT $ newIdH "worker" $ exprType repFixFE -    newRhs <- buildApplicationM absE (varToCoreExpr workId)+    newRhs <- buildAppM absE (varToCoreExpr workId) -    assumptionEq <- assumptionCEqualityT absE repE f-    _ <- insertLemmaR (fromString (show nm ++ "-assumption")) $ Lemma assumptionEq False True -- unproven, used+    assumptionQ <- assumptionCQuantifiedT absE repE f+    verifyOrCreateT u (fromString (show nm ++ "-assumption")) $ Lemma assumptionQ NotProven u False -- unproven, used, permanent -    wwFusionEq <- wwFusionEqualityT absE repE (varToCoreExpr workId)-    _ <- insertLemmaR (fromString (show nm ++ "-fusion")) $ Lemma wwFusionEq True False -- proven (assumed), unused+    wwFusionQ <- wwFusionQuantifiedT absE repE (varToCoreExpr workId)+    insertLemmaT (fromString (show nm ++ "-fusion")) $ Lemma wwFusionQ (Assumed False) NotUsed False -- assumed, unused, permanent      return $ mkCoreLets [NonRec workId repFixFE] newRhs

@@ -5,14 +5,13 @@     , wwFacBR     , wwSplitR     , wwSplitStaticArg-    , wwGenerateFusionR+    , wwGenerateFusionT     , wwFusionBR     , wwAssA     , wwAssB     , wwAssC     ) where -import Control.Applicative import Control.Arrow  import Data.String (fromString)@@ -21,6 +20,7 @@ import HERMIT.External import HERMIT.GHC import HERMIT.Kure+import HERMIT.Lemma import HERMIT.Monad import HERMIT.Name import HERMIT.ParserCore@@ -44,21 +44,21 @@ externals =          [            external "ww-factorisation" ((\ wrap unwrap assC -> promoteExprBiR $ wwFac (mkWWAssC assC) wrap unwrap)-                                          :: CoreString -> CoreString -> RewriteH Core -> BiRewriteH Core)+                                          :: CoreString -> CoreString -> RewriteH LCore -> BiRewriteH LCore)                 [ "Worker/Wrapper Factorisation",                   "For any \"f :: A -> A\", and given \"wrap :: B -> A\" and \"unwrap :: A -> B\" as arguments,",                   "and a proof of Assumption C (fix A (\\ a -> wrap (unwrap (f a))) ==> fix A f), then",                   "fix A f  ==>  wrap (fix B (\\ b -> unwrap (f (wrap b))))"                 ] .+ Introduce .+ Context          , external "ww-factorisation-unsafe" ((\ wrap unwrap -> promoteExprBiR $ wwFac Nothing wrap unwrap)-                                               :: CoreString -> CoreString -> BiRewriteH Core)+                                               :: CoreString -> CoreString -> BiRewriteH LCore)                 [ "Unsafe Worker/Wrapper Factorisation",                   "For any \"f :: A -> A\", and given \"wrap :: B -> A\" and \"unwrap :: A -> B\" as arguments, then",                   "fix A f  <==>  wrap (fix B (\\ b -> unwrap (f (wrap b))))",                   "Note: the pre-condition \"fix A (\\ a -> wrap (unwrap (f a))) == fix A f\" is expected to hold."                 ] .+ Introduce .+ Context .+ PreCondition          , external "ww-split" ((\ wrap unwrap assC -> promoteDefR $ wwSplit (mkWWAssC assC) wrap unwrap)-                                  :: CoreString -> CoreString -> RewriteH Core -> RewriteH Core)+                                  :: CoreString -> CoreString -> RewriteH LCore -> RewriteH LCore)                 [ "Worker/Wrapper Split",                   "For any \"prog :: A\", and given \"wrap :: B -> A\" and \"unwrap :: A -> B\" as arguments,",                   "and a proof of Assumption C (fix A (\\ a -> wrap (unwrap (f a))) ==> fix A f), then",@@ -67,7 +67,7 @@                   "                              in wrap work"                 ] .+ Introduce .+ Context          , external "ww-split-unsafe" ((\ wrap unwrap -> promoteDefR $ wwSplit Nothing wrap unwrap)-                                       :: CoreString -> CoreString -> RewriteH Core)+                                       :: CoreString -> CoreString -> RewriteH LCore)                 [ "Unsafe Worker/Wrapper Split",                   "For any \"prog :: A\", and given \"wrap :: B -> A\" and \"unwrap :: A -> B\" as arguments, then",                   "prog = expr  ==>  prog = let f = \\ prog -> expr",@@ -76,79 +76,79 @@                   "Note: the pre-condition \"fix A (wrap . unwrap . f) == fix A f\" is expected to hold."                 ] .+ Introduce .+ Context .+ PreCondition          , external "ww-split-static-arg" ((\ n is wrap unwrap assC -> promoteDefR $ wwSplitStaticArg n is (mkWWAssC assC) wrap unwrap)-                                      :: Int -> [Int] -> CoreString -> CoreString -> RewriteH Core -> RewriteH Core)+                                      :: Int -> [Int] -> CoreString -> CoreString -> RewriteH LCore -> RewriteH LCore)                 [ "Worker/Wrapper Split - Static Argument Variant",                   "Perform the static argument transformation on the first n arguments, then perform the worker/wrapper split,",                   "applying the given wrap and unwrap functions to the specified (by index) static arguments before use."                 ] .+ Introduce .+ Context          , external "ww-split-static-arg-unsafe" ((\ n is wrap unwrap -> promoteDefR $ wwSplitStaticArg n is Nothing wrap unwrap)-                                      :: Int -> [Int] -> CoreString -> CoreString -> RewriteH Core)+                                      :: Int -> [Int] -> CoreString -> CoreString -> RewriteH LCore)                 [ "Unsafe Worker/Wrapper Split - Static Argument Variant",                   "Perform the static argument transformation on the first n arguments, then perform the (unsafe) worker/wrapper split,",                   "applying the given wrap and unwrap functions to the specified (by index) static arguments before use."                 ] .+ Introduce .+ Context .+ PreCondition          , external "ww-assumption-A" ((\ wrap unwrap assA -> promoteExprBiR $ wwA (Just $ extractR assA) wrap unwrap)-                                       :: CoreString -> CoreString -> RewriteH Core -> BiRewriteH Core)+                                       :: CoreString -> CoreString -> RewriteH LCore -> BiRewriteH LCore)                 [ "Worker/Wrapper Assumption A",                   "For a \"wrap :: B -> A\" and an \"unwrap :: A -> B\",",                   "and given a proof of \"wrap (unwrap a) ==> a\", then",                   "wrap (unwrap a)  <==>  a"                 ] .+ Introduce .+ Context          , external "ww-assumption-B" ((\ wrap unwrap f assB -> promoteExprBiR $ wwB (Just $ extractR assB) wrap unwrap f)-                                       :: CoreString -> CoreString -> CoreString -> RewriteH Core -> BiRewriteH Core)+                                       :: CoreString -> CoreString -> CoreString -> RewriteH LCore -> BiRewriteH LCore)                 [ "Worker/Wrapper Assumption B",                   "For a \"wrap :: B -> A\", an \"unwrap :: A -> B\", and an \"f :: A -> A\",",                   "and given a proof of \"wrap (unwrap (f a)) ==> f a\", then",                   "wrap (unwrap (f a))  <==>  f a"                 ] .+ Introduce .+ Context          , external "ww-assumption-C" ((\ wrap unwrap f assC -> promoteExprBiR $ wwC (Just $ extractR assC) wrap unwrap f)-                                       :: CoreString -> CoreString -> CoreString -> RewriteH Core -> BiRewriteH Core)+                                       :: CoreString -> CoreString -> CoreString -> RewriteH LCore -> BiRewriteH LCore)                 [ "Worker/Wrapper Assumption C",                   "For a \"wrap :: B -> A\", an \"unwrap :: A -> B\", and an \"f :: A -> A\",",                   "and given a proof of \"fix A (\\ a -> wrap (unwrap (f a))) ==> fix A f\", then",                   "fix A (\\ a -> wrap (unwrap (f a)))  <==>  fix A f"                 ] .+ Introduce .+ Context          , external "ww-assumption-A-unsafe" ((\ wrap unwrap -> promoteExprBiR $ wwA Nothing wrap unwrap)-                                              :: CoreString -> CoreString -> BiRewriteH Core)+                                              :: CoreString -> CoreString -> BiRewriteH LCore)                 [ "Unsafe Worker/Wrapper Assumption A",                   "For a \"wrap :: B -> A\" and an \"unwrap :: A -> B\", then",                   "wrap (unwrap a)  <==>  a",                   "Note: only use this if it's true!"                 ] .+ Introduce .+ Context .+ PreCondition          , external "ww-assumption-B-unsafe" ((\ wrap unwrap f -> promoteExprBiR $ wwB Nothing wrap unwrap f)-                                              :: CoreString -> CoreString -> CoreString -> BiRewriteH Core)+                                              :: CoreString -> CoreString -> CoreString -> BiRewriteH LCore)                 [ "Unsafe Worker/Wrapper Assumption B",                   "For a \"wrap :: B -> A\", an \"unwrap :: A -> B\", and an \"f :: A -> A\", then",                   "wrap (unwrap (f a))  <==>  f a",                   "Note: only use this if it's true!"                 ] .+ Introduce .+ Context .+ PreCondition          , external "ww-assumption-C-unsafe" ((\ wrap unwrap f -> promoteExprBiR $ wwC Nothing wrap unwrap f)-                                              :: CoreString -> CoreString -> CoreString -> BiRewriteH Core)+                                              :: CoreString -> CoreString -> CoreString -> BiRewriteH LCore)                 [ "Unsafe Worker/Wrapper Assumption C",                   "For a \"wrap :: B -> A\", an \"unwrap :: A -> B\", and an \"f :: A -> A\", then",                   "fix A (\\ a -> wrap (unwrap (f a)))  <==>  fix A f",                   "Note: only use this if it's true!"                 ] .+ Introduce .+ Context .+ PreCondition-         , external "ww-AssA-to-AssB" (promoteExprR . wwAssAimpliesAssB . extractR :: RewriteH Core -> RewriteH Core)+         , external "ww-AssA-to-AssB" (promoteExprR . wwAssAimpliesAssB . extractR :: RewriteH LCore -> RewriteH LCore)                    [ "Convert a proof of worker/wrapper Assumption A into a proof of worker/wrapper Assumption B."                    ]-         , external "ww-AssB-to-AssC" (promoteExprR . wwAssBimpliesAssC . extractR :: RewriteH Core -> RewriteH Core)+         , external "ww-AssB-to-AssC" (promoteExprR . wwAssBimpliesAssC . extractR :: RewriteH LCore -> RewriteH LCore)                    [ "Convert a proof of worker/wrapper Assumption B into a proof of worker/wrapper Assumption C."                    ]-         , external "ww-AssA-to-AssC" (promoteExprR . wwAssAimpliesAssC . extractR :: RewriteH Core -> RewriteH Core)+         , external "ww-AssA-to-AssC" (promoteExprR . wwAssAimpliesAssC . extractR :: RewriteH LCore -> RewriteH LCore)                    [ "Convert a proof of worker/wrapper Assumption A into a proof of worker/wrapper Assumption C."                    ]-         , external "ww-generate-fusion" (wwGenerateFusionR . mkWWAssC :: RewriteH Core -> RewriteH Core)+         , external "ww-generate-fusion" (wwGenerateFusionT . mkWWAssC :: RewriteH LCore -> TransformH LCore ())                    [ "Given a proof of Assumption C (fix A (\\ a -> wrap (unwrap (f a))) ==> fix A f), then",                      "execute this command on \"work = unwrap (f (wrap work))\" to enable the \"ww-fusion\" rule thereafter.",                      "Note that this is performed automatically as part of \"ww-split\"."                    ] .+ Experiment .+ TODO-         , external "ww-generate-fusion-unsafe" (wwGenerateFusionR Nothing :: RewriteH Core)+         , external "ww-generate-fusion-unsafe" (wwGenerateFusionT Nothing :: TransformH LCore ())                    [ "Execute this command on \"work = unwrap (f (wrap work))\" to enable the \"ww-fusion\" rule thereafter.",                      "The precondition \"fix A (wrap . unwrap . f) == fix A f\" is expected to hold.",                      "Note that this is performed automatically as part of \"ww-split\"."                    ] .+ Experiment .+ TODO-         , external "ww-fusion" (promoteExprBiR wwFusion :: BiRewriteH Core)+         , external "ww-fusion" (promoteExprBiR wwFusion :: BiRewriteH LCore)                 [ "Worker/Wrapper Fusion",                   "unwrap (wrap work)  <==>  work",                   "Note: you are required to have previously executed the command \"ww-generate-fusion\" on the definition",@@ -156,7 +156,7 @@                 ] .+ Introduce .+ Context .+ PreCondition .+ TODO          ]   where-    mkWWAssC :: RewriteH Core -> Maybe WWAssumption+    mkWWAssC :: RewriteH LCore -> Maybe WWAssumption     mkWWAssC r = Just (WWAssumption C (extractR r))  --------------------------------------------------------------------------------------------------@@ -203,9 +203,9 @@ wwFusionBR =     beforeBiR (prefixFailMsg "worker/wrapper fusion failed: " $                withPatFailMsg "malformed WW Fusion rule." $-               do Def w (App unwrap (App _f (App wrap (Var w')))) <- constT (lookupDef workLabel)-                  guardMsg (w == w') "malformed WW Fusion rule."-                  return (wrap,unwrap,Var w)+               do Quantified _ (Equiv w (App unwrap (App _f (App wrap w')))) <- constT (lemmaQ <$> findLemma workLabel)+                  guardMsg (exprSyntaxEq w w') "malformed WW Fusion rule."+                  return (wrap,unwrap,w)               )               (\ (wrap,unwrap,work) -> bidirectional (fusL wrap unwrap work) (fusR wrap unwrap work))   where@@ -237,14 +237,14 @@ -- | Save the recursive definition of work in the stash, so that we can later verify uses of 'wwFusionBR'. --   Must be applied to a definition of the form: @work = unwrap (f (wrap work))@ --   Note that this is performed automatically as part of 'wwSplitR'.-wwGenerateFusionR :: Maybe WWAssumption -> RewriteH Core-wwGenerateFusionR mAss =+wwGenerateFusionT :: Maybe WWAssumption -> TransformH LCore ()+wwGenerateFusionT mAss =     prefixFailMsg "generate WW fusion failed: " $     withPatFailMsg wrongForm $-    do Def w (App unwrap (App f (App wrap (Var w')))) <- projectT+    do Def w e@(App unwrap (App f (App wrap (Var w')))) <- projectT        guardMsg (w == w') wrongForm        whenJust (verifyWWAss wrap unwrap f) mAss-       rememberR workLabel+       insertLemmaT workLabel $ Lemma (Quantified [] (Equiv (varToCoreExpr w) e)) Proven NotUsed False   where     wrongForm = "definition does not have the form: work = unwrap (f (wrap work))" @@ -260,7 +260,7 @@                                           >>> appAllR idR ( unfoldNameR (fromString "Data.Function.fix")                                                             >>> alphaLetWithR ["work"]                                                             >>> letRecAllR (\ _ -> defAllR idR (betaReduceR >>> letNonRecSubstR)-                                                                                   >>> extractR (wwGenerateFusionR mAss)+                                                                                   >>> (extractT (wwGenerateFusionT mAss) >> idR)                                                                            )                                                                            idR                                                           )

@@ -7,7 +7,7 @@     , wwResultFacBR     , wwResultSplitR     , wwResultSplitStaticArg-    , wwResultGenerateFusionR+    , wwResultGenerateFusionT     , wwResultFusionBR     , wwResultAssA     , wwResultAssB@@ -24,6 +24,7 @@ import HERMIT.External import HERMIT.GHC import HERMIT.Kure+import HERMIT.Lemma import HERMIT.Monad import HERMIT.Name import HERMIT.ParserCore@@ -47,21 +48,21 @@ externals =          [            external "ww-result-factorisation" ((\ abs rep assC -> promoteExprBiR $ wwFac (mkWWAssC assC) abs rep)-                                          :: CoreString -> CoreString -> RewriteH Core -> BiRewriteH Core)+                                          :: CoreString -> CoreString -> RewriteH LCore -> BiRewriteH LCore)                 [ "Worker/Wrapper Factorisation (Result Variant)",                   "For any \"f :: (X -> A) -> (X -> A)\", and given \"abs :: B -> A\" and \"rep :: A -> B\" as arguments,",                   "and a proof of Assumption C (fix (X -> A) (\\ h x -> abs (rep (f h x))) ==> fix (X->A) f), then",                   "fix (X->A) f  ==>  \\ x1 -> abs (fix (X->B) (\\ h x2 -> rep (f (\\ x3 -> abs (h x3)) x2)) x1"                 ] .+ Introduce .+ Context          , external "ww-result-factorisation-unsafe" ((\ abs rep -> promoteExprBiR $ wwFac Nothing abs rep)-                                               :: CoreString -> CoreString -> BiRewriteH Core)+                                               :: CoreString -> CoreString -> BiRewriteH LCore)                 [ "Unsafe Worker/Wrapper Factorisation (Result Variant)",                   "For any \"f :: (X -> A) -> (X -> A)\", and given \"abs :: B -> A\" and \"rep :: A -> B\" as arguments, then",                   "fix (X->A) f  ==>  \\ x1 -> abs (fix (X->B) (\\ h x2 -> rep (f (\\ x3 -> abs (h x3)) x2)) x1",                   "Note: the pre-condition \"fix (X -> A) (\\ h x -> abs (rep (f h x))) == fix (X->A) f\" is expected to hold."                 ] .+ Introduce .+ Context .+ PreCondition          , external "ww-result-split" ((\ abs rep assC -> promoteDefR $ wwSplit (mkWWAssC assC) abs rep)-                                  :: CoreString -> CoreString -> RewriteH Core -> RewriteH Core)+                                  :: CoreString -> CoreString -> RewriteH LCore -> RewriteH LCore)                 [ "Worker/Wrapper Split (Result Variant)",                   "For any \"prog :: X -> A\", and given \"abs :: B -> A\" and \"rep :: A -> B\" as arguments,",                   "and a proof of Assumption C (fix (X->A) (\\ h x -> abs (rep (f h x))) ==> fix (X->A) f), then",@@ -70,88 +71,88 @@                   "                              in \\ x0 -> abs (work x0)"                 ] .+ Introduce .+ Context          , external "ww-result-split-unsafe" ((\ abs rep -> promoteDefR $ wwSplit Nothing abs rep)-                                       :: CoreString -> CoreString -> RewriteH Core)+                                       :: CoreString -> CoreString -> RewriteH LCore)                 [ "Unsafe Worker/Wrapper Split (Result Variant)",                   "For any \"prog :: X -> A\", and given \"abs :: B -> A\" and \"rep :: A -> B\" as arguments, then",                   "prog = expr  ==>  prog = let f = \\ prog -> expr",                   "                          in let work = \\ x1 -> rep (f (\\ x2 -> abs (work x2)) x1)",                   "                              in \\ x0 -> abs (work x0)",                   "Note: the pre-condition \"fix (X->A) (\\ h x -> abs (rep (f h x))) == fix (X->A) f\" is expected to hold."-                ] .+ Introduce .+ Context .+ PreCondition+                ] .+ Introduce .+ Context .+ PreCondition .+ Unsafe          , external "ww-result-split-static-arg" ((\ n is abs rep assC -> promoteDefR $ wwResultSplitStaticArg n is (mkWWAssC assC) abs rep)-                                      :: Int -> [Int] -> CoreString -> CoreString -> RewriteH Core -> RewriteH Core)+                                      :: Int -> [Int] -> CoreString -> CoreString -> RewriteH LCore -> RewriteH LCore)                 [ "Worker/Wrapper Split - Static Argument Variant (Result Variant)",                   "Perform the static argument transformation on the first n arguments, then perform the worker/wrapper split,",                   "applying the given abs and rep functions to the specified (by index) static arguments before use."                 ] .+ Introduce .+ Context          , external "ww-result-split-static-arg-unsafe" ((\ n is abs rep -> promoteDefR $ wwResultSplitStaticArg n is Nothing abs rep)-                                      :: Int -> [Int] -> CoreString -> CoreString -> RewriteH Core)+                                      :: Int -> [Int] -> CoreString -> CoreString -> RewriteH LCore)                 [ "Unsafe Worker/Wrapper Split - Static Argument Variant (Result Variant)",                   "Perform the static argument transformation on the first n arguments, then perform the (unsafe) worker/wrapper split,",                   "applying the given abs and rep functions to the specified (by index) static arguments before use."-                ] .+ Introduce .+ Context .+ PreCondition+                ] .+ Introduce .+ Context .+ PreCondition .+ Unsafe          , external "ww-result-assumption-A" ((\ abs rep assA -> promoteExprBiR $ wwA (Just $ extractR assA) abs rep)-                                       :: CoreString -> CoreString -> RewriteH Core -> BiRewriteH Core)+                                       :: CoreString -> CoreString -> RewriteH LCore -> BiRewriteH LCore)                 [ "Worker/Wrapper Assumption A (Result Variant)",                   "For a \"abs :: B -> A\" and a \"rep :: A -> B\",",                   "and given a proof of \"abs (rep a)  ==>  a\", then",                   "abs (rep a)  <==>  a"                 ] .+ Introduce .+ Context          , external "ww-result-assumption-B" ((\ abs rep f assB -> promoteExprBiR $ wwB (Just $ extractR assB) abs rep f)-                                       :: CoreString -> CoreString -> CoreString -> RewriteH Core -> BiRewriteH Core)+                                       :: CoreString -> CoreString -> CoreString -> RewriteH LCore -> BiRewriteH LCore)                 [ "Worker/Wrapper Assumption B (Result Variant)",                   "For a \"abs :: B -> A\", an \"rep :: A -> B\", and an \"f :: (X -> A) -> X -> A\",",                   "and given a proof of \"abs (rep (f h x))  ==>  f h x\", then",                   "abs (rep (f h x))  <==>  f h x"                 ] .+ Introduce .+ Context          , external "ww-result-assumption-C" ((\ abs rep f assC -> promoteExprBiR $ wwC (Just $ extractR assC) abs rep f)-                                       :: CoreString -> CoreString -> CoreString -> RewriteH Core -> BiRewriteH Core)+                                       :: CoreString -> CoreString -> CoreString -> RewriteH LCore -> BiRewriteH LCore)                 [ "Worker/Wrapper Assumption C (Result Variant)",                   "For a \"abs :: B -> A\", an \"rep :: A -> B\", and an \"f :: (X -> A) -> X -> A\",",                   "and given a proof of \"fix (X->A) (\\ h x -> abs (rep (f h x))) ==> fix (X->A) f\", then",                   "fix (X->A) (\\ h x -> abs (rep (f h x)))  <==>  fix (X->A) f"                 ] .+ Introduce .+ Context          , external "ww-result-assumption-A-unsafe" ((\ abs rep -> promoteExprBiR $ wwA Nothing abs rep)-                                              :: CoreString -> CoreString -> BiRewriteH Core)+                                              :: CoreString -> CoreString -> BiRewriteH LCore)                 [ "Unsafe Worker/Wrapper Assumption A (Result Variant)",                   "For a \"abs :: B -> A\" and a \"rep :: A -> B\", then",                   "abs (rep a)  <==>  a",                   "Note: only use this if it's true!"                 ] .+ Introduce .+ Context .+ PreCondition          , external "ww-result-assumption-B-unsafe" ((\ abs rep f -> promoteExprBiR $ wwB Nothing abs rep f)-                                              :: CoreString -> CoreString -> CoreString -> BiRewriteH Core)+                                              :: CoreString -> CoreString -> CoreString -> BiRewriteH LCore)                 [ "Unsafe Worker/Wrapper Assumption B (Result Variant)",                   "For a \"abs :: B -> A\", an \"rep :: A -> B\", and an \"f :: (X -> A) -> X -> A\", then",                   "abs (rep (f h x))  <==>  f h x",                   "Note: only use this if it's true!"                 ] .+ Introduce .+ Context .+ PreCondition          , external "ww-result-assumption-C-unsafe" ((\ abs rep f -> promoteExprBiR $ wwC Nothing abs rep f)-                                              :: CoreString -> CoreString -> CoreString -> BiRewriteH Core)+                                              :: CoreString -> CoreString -> CoreString -> BiRewriteH LCore)                 [ "Unsafe Worker/Wrapper Assumption C (Result Variant)",                   "For a \"abs :: B -> A\", an \"rep :: A -> B\", and an \"f :: (X -> A) -> X -> A\", then",                   "fix (X->A) (\\ h x -> abs (rep (f h x)))  <==>  fix (X->A) f",                   "Note: only use this if it's true!"                 ] .+ Introduce .+ Context .+ PreCondition-         , external "ww-result-AssA-to-AssB" (promoteExprR . wwResultAssAimpliesAssB . extractR :: RewriteH Core -> RewriteH Core)+         , external "ww-result-AssA-to-AssB" (promoteExprR . wwResultAssAimpliesAssB . extractR :: RewriteH LCore -> RewriteH LCore)                    [ "Convert a proof of worker/wrapper Assumption A into a proof of worker/wrapper Assumption B."                    ]-         , external "ww-result-AssB-to-AssC" (promoteExprR . wwResultAssBimpliesAssC . extractR :: RewriteH Core -> RewriteH Core)+         , external "ww-result-AssB-to-AssC" (promoteExprR . wwResultAssBimpliesAssC . extractR :: RewriteH LCore -> RewriteH LCore)                    [ "Convert a proof of worker/wrapper Assumption B into a proof of worker/wrapper Assumption C."                    ]-         , external "ww-result-AssA-to-AssC" (promoteExprR . wwResultAssAimpliesAssC . extractR :: RewriteH Core -> RewriteH Core)+         , external "ww-result-AssA-to-AssC" (promoteExprR . wwResultAssAimpliesAssC . extractR :: RewriteH LCore -> RewriteH LCore)                    [ "Convert a proof of worker/wrapper Assumption A into a proof of worker/wrapper Assumption C."                    ]-         , external "ww-result-generate-fusion" (wwResultGenerateFusionR . mkWWAssC :: RewriteH Core -> RewriteH Core)+         , external "ww-result-generate-fusion" (wwResultGenerateFusionT . mkWWAssC :: RewriteH LCore -> TransformH LCore ())                    [ "Given a proof of Assumption C (fix (X->A) (\\ h x -> abs (rep (f h x))) ==> fix (X->A) f), then",                      "execute this command on \"work = \\ x1 -> rep (f (\\ x2 -> abs (work x2)) x1)\" to enable the \"ww-result-fusion\" rule thereafter.",                      "Note that this is performed automatically as part of \"ww-result-split\"."                    ] .+ Experiment .+ TODO-         , external "ww-result-generate-fusion-unsafe" (wwResultGenerateFusionR Nothing :: RewriteH Core)+         , external "ww-result-generate-fusion-unsafe" (wwResultGenerateFusionT Nothing :: TransformH LCore ())                    [ "Execute this command on \"work = \\ x1 -> rep (f (\\ x2 -> abs (work x2)) x1)\" to enable the \"ww-fusion\" rule thereafter.",                      "The precondition \"fix (X->A) (\\ h x -> abs (rep (f h x))) == fix (X->A) f\" is expected to hold.",                      "Note that this is performed automatically as part of \"ww-result-split\"."                    ] .+ Experiment .+ TODO-         , external "ww-result-fusion" (promoteExprBiR wwFusion :: BiRewriteH Core)+         , external "ww-result-fusion" (promoteExprBiR wwFusion :: BiRewriteH LCore)                 [ "Worker/Wrapper Fusion (Result Variant)",                   "rep (abs (work x))  <==>  work x",                   "Note: you are required to have previously executed the command \"ww-generate-fusion\" on the definition",@@ -159,7 +160,7 @@                 ] .+ Introduce .+ Context .+ PreCondition .+ TODO          ]   where-    mkWWAssC :: RewriteH Core -> Maybe WWAssumption+    mkWWAssC :: RewriteH LCore -> Maybe WWAssumption     mkWWAssC r = Just (WWAssumption C (extractR r))  --------------------------------------------------------------------------------------------------@@ -223,14 +224,15 @@ wwResultFusionBR =     beforeBiR (prefixFailMsg "worker/wrapper fusion failed: " $                withPatFailMsg "malformed WW Fusion rule." $-               do Def w (Lam x1 (App rep-                                     (App (App _ (Lam x2 (App abs (App (Var w') (Var x2')))))+               do Quantified _ (Equiv w+                        (Lam x1 (App rep+                                     (App (App _ (Lam x2 (App abs (App w' (Var x2')))))                                           (Var x1')                                      )                                 )-                        ) <- constT (lookupDef workLabel)-                  guardMsg (w == w' && x1 == x1' && x2 == x2') "malformed WW Fusion rule."-                  return (abs,rep,Var w)+                        )) <- constT (lemmaQ <$> findLemma workLabel)+                  guardMsg (exprSyntaxEq w w' && x1 == x1' && x2 == x2') "malformed WW Fusion rule."+                  return (abs,rep,w)               )               (\ (abs,rep,work) -> bidirectional (fusL abs rep work) (fusR abs rep work))   where@@ -262,19 +264,19 @@ -- | Save the recursive definition of work in the stash, so that we can later verify uses of 'wwResultFusionBR'. --   Must be applied to a definition of the form: @work = \\ x1 -> rep (f (\\ x2 -> abs (work x2)) x1)@ --   Note that this is performed automatically as part of 'wwResultSplitR'.-wwResultGenerateFusionR :: Maybe WWAssumption -> RewriteH Core-wwResultGenerateFusionR mAss =+wwResultGenerateFusionT :: Maybe WWAssumption -> TransformH LCore ()+wwResultGenerateFusionT mAss =     prefixFailMsg "generate WW fusion failed: " $     withPatFailMsg wrongForm $-    do Def w (Lam x1 (App rep+    do Def w e@(Lam x1 (App rep                           (App (App f (Lam x2 (App abs (App (Var w') (Var x2')))))                                (Var x1')                           )-                     )-             ) <- projectT+                       )+               ) <- projectT        guardMsg (w == w' && x1 == x1' && x2 == x2') wrongForm        whenJust (verifyWWAss abs rep f) mAss-       rememberR workLabel+       insertLemmaT workLabel $ Lemma (Quantified [] (Equiv (varToCoreExpr w) e)) Proven NotUsed False   where     wrongForm = "definition does not have the form: work = \\ x1 -> rep (f (\\ x2 -> abs (work x2)) x1)" @@ -291,7 +293,7 @@                                           >>> lamAllR idR (appAllR idR (appAllR ( unfoldNameR (fromString "Data.Function.fix")                                                                                   >>> alphaLetWithR ["work"]                                                                                   >>> letRecAllR (\ _ -> defAllR idR (betaReduceR >>> letNonRecSubstR)-                                                                                                         >>> extractR (wwResultGenerateFusionR mAss)+                                                                                                         >>> (extractT (wwResultGenerateFusionT mAss) >> idR)                                                                                                  )                                                                                                  idR                                                                                 )

@@ -26,26 +26,29 @@     , dictionaryOfTags       -- * Boxes       -- | Boxes are used by the 'Extern' class.-    , BiRewriteCoreBox(..)     , CoreString(..)     , CrumbBox(..)     , IntBox(..)     , IntListBox(..)     , PathBox(..)-    , RewriteCoreBox(..)-    , RewriteCoreListBox(..)-    , RewriteCoreTCBox(..)-    , RewriteEqualityBox(..)     , StringBox(..)     , StringListBox(..)     , TagBox(..)-    , TransformCoreCheckBox(..)-    , TransformCorePathBox(..)-    , TransformCoreStringBox(..)-    , TransformCoreTCCheckBox(..)-    , TransformCoreTCPathBox(..)-    , TransformCoreTCStringBox(..)-    , TransformEqualityStringBox(..)+      -- ** LCore Boxes+    , TransformLCoreStringBox(..)+    , TransformLCoreUnitBox(..)+    , TransformLCorePathBox(..)+    , RewriteLCoreBox(..)+    , BiRewriteLCoreBox(..)+    , RewriteLCoreListBox(..)+      -- ** LCoreTC Boxes+    , TransformLCoreTCStringBox(..)+    , TransformLCoreTCUnitBox(..)+    , TransformLCoreTCLCoreBox(..)+    , TransformLCoreTCPathBox(..)+    , RewriteLCoreTCBox(..)+    , BiRewriteLCoreTCBox(..)+    , RewriteLCoreTCListBox(..)     ) where  import Data.Map hiding (map)@@ -56,7 +59,7 @@ import HERMIT.Core import HERMIT.Context (LocalPathH) import HERMIT.Kure-import HERMIT.Monad+import HERMIT.Lemma  ----------------------------------------------------------------- @@ -90,6 +93,8 @@             | 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.+                             --   Only available in unsafe mode!+            | Safe           -- ^ Include in Strict Safety mode (currently unused)             | Proof          -- ^ Commands related to proving lemmas.              | TODO           -- ^ An incomplete or potentially buggy command.@@ -235,12 +240,13 @@  -- | Remove the word 'Box' from a string. deBoxify :: String -> String-deBoxify xs-    | "CLSBox -> " `isPrefixOf` xs = deBoxify (drop 10 xs)-deBoxify xs-    | "Box" `isPrefixOf` xs        = deBoxify (drop 3 xs)-deBoxify (x:xs)                    = x : deBoxify xs-deBoxify []                        = []+deBoxify s | "CLSBox -> "        `isPrefixOf` s = go (drop 10 s)+           | "PrettyPrinter -> " `isPrefixOf` s = go (drop 17 s)+           | otherwise = go s+    where go xs+            | "Box" `isPrefixOf` xs = go (drop 3 xs)+          go (x:xs)                 = x : go xs+          go []                     = []  externTypeArgResString :: External -> ([String], String) externTypeArgResString e = (map (deBoxify . show) aTys, deBoxify (show rTy))@@ -301,182 +307,181 @@  ----------------------------------------------------------------- -data RewriteCoreBox = RewriteCoreBox (RewriteH Core) deriving Typeable+-- TODO: Considering unifying CrumbBox and PathBox under TransformLCoreTCPathBox.+data CrumbBox = CrumbBox Crumb deriving Typeable -instance Extern (RewriteH Core) where-    type Box (RewriteH Core) = RewriteCoreBox-    box = RewriteCoreBox-    unbox (RewriteCoreBox r) = r+instance Extern Crumb where+    type Box Crumb = CrumbBox+    box = CrumbBox+    unbox (CrumbBox cr) = cr  ----------------------------------------------------------------- -data RewriteCoreTCBox = RewriteCoreTCBox (RewriteH CoreTC) deriving Typeable+data PathBox = PathBox LocalPathH deriving Typeable -instance Extern (RewriteH CoreTC) where-    type Box (RewriteH CoreTC) = RewriteCoreTCBox-    box = RewriteCoreTCBox-    unbox (RewriteCoreTCBox r) = r+instance Extern LocalPathH where+    type Box LocalPathH = PathBox+    box = PathBox+    unbox (PathBox p) = p  ----------------------------------------------------------------- -data BiRewriteCoreBox = BiRewriteCoreBox (BiRewriteH Core) deriving Typeable+newtype CoreString = CoreString { unCoreString :: String } deriving Typeable -instance Extern (BiRewriteH Core) where-    type Box (BiRewriteH Core) = BiRewriteCoreBox-    box = BiRewriteCoreBox-    unbox (BiRewriteCoreBox b) = b+instance Extern CoreString where+    type Box CoreString = CoreString+    box = id+    unbox = id  ----------------------------------------------------------------- -data TransformCoreTCStringBox = TransformCoreTCStringBox (TransformH CoreTC String) deriving Typeable+data StringBox = StringBox String deriving Typeable -instance Extern (TransformH CoreTC String) where-    type Box (TransformH CoreTC String) = TransformCoreTCStringBox-    box = TransformCoreTCStringBox-    unbox (TransformCoreTCStringBox t) = t+instance Extern String where+    type Box String = StringBox+    box = StringBox+    unbox (StringBox s) = s  ----------------------------------------------------------------- -data TransformCoreStringBox = TransformCoreStringBox (TransformH Core String) deriving Typeable+data StringListBox = StringListBox [String] deriving Typeable -instance Extern (TransformH Core String) where-    type Box (TransformH Core String) = TransformCoreStringBox-    box = TransformCoreStringBox-    unbox (TransformCoreStringBox t) = t+instance Extern [String] where+    type Box [String] = StringListBox+    box = StringListBox+    unbox (StringListBox l) = l  ----------------------------------------------------------------- -data TransformCoreTCCheckBox = TransformCoreTCCheckBox (TransformH CoreTC ()) deriving Typeable+data IntListBox = IntListBox [Int] deriving Typeable -instance Extern (TransformH CoreTC ()) where-    type Box (TransformH CoreTC ()) = TransformCoreTCCheckBox-    box = TransformCoreTCCheckBox-    unbox (TransformCoreTCCheckBox t) = t+instance Extern [Int] where+    type Box [Int] = IntListBox+    box = IntListBox+    unbox (IntListBox l) = l  ----------------------------------------------------------------- -data TransformCoreCheckBox = TransformCoreCheckBox (TransformH Core ()) deriving Typeable--instance Extern (TransformH Core ()) where-    type Box (TransformH Core ()) = TransformCoreCheckBox-    box = TransformCoreCheckBox-    unbox (TransformCoreCheckBox t) = t+instance Extern LemmaName where+    type Box LemmaName = LemmaName+    box = id+    unbox = id  ----------------------------------------------------------------- --- TODO: We now have CrumbBoc, PathBox and TransformCorePathBox.---       Ints are interpreted as a TransformCorePathBox.---       This all needs cleaning up.--data CrumbBox = CrumbBox Crumb deriving Typeable+data RewriteLCoreBox = RewriteLCoreBox (RewriteH LCore) deriving Typeable -instance Extern Crumb where-    type Box Crumb = CrumbBox-    box = CrumbBox-    unbox (CrumbBox cr) = cr+instance Extern (RewriteH LCore) where+    type Box (RewriteH LCore) = RewriteLCoreBox+    box = RewriteLCoreBox+    unbox (RewriteLCoreBox r) = r  ----------------------------------------------------------------- -data PathBox = PathBox LocalPathH deriving Typeable+data TransformLCoreStringBox = TransformLCoreStringBox (TransformH LCore String) deriving Typeable -instance Extern LocalPathH where-    type Box LocalPathH = PathBox-    box = PathBox-    unbox (PathBox p) = p+instance Extern (TransformH LCore String) where+    type Box (TransformH LCore String) = TransformLCoreStringBox+    box = TransformLCoreStringBox+    unbox (TransformLCoreStringBox t) = t  ----------------------------------------------------------------- -data TransformCorePathBox = TransformCorePathBox (TransformH Core LocalPathH) deriving Typeable+data TransformLCoreUnitBox = TransformLCoreUnitBox (TransformH LCore ()) deriving Typeable -instance Extern (TransformH Core LocalPathH) where-    type Box (TransformH Core LocalPathH) = TransformCorePathBox-    box = TransformCorePathBox-    unbox (TransformCorePathBox t) = t+instance Extern (TransformH LCore ()) where+    type Box (TransformH LCore ()) = TransformLCoreUnitBox+    box = TransformLCoreUnitBox+    unbox (TransformLCoreUnitBox t) = t  ----------------------------------------------------------------- -data TransformCoreTCPathBox = TransformCoreTCPathBox (TransformH CoreTC LocalPathH) deriving Typeable+data TransformLCorePathBox = TransformLCorePathBox (TransformH LCore LocalPathH) deriving Typeable -instance Extern (TransformH CoreTC LocalPathH) where-    type Box (TransformH CoreTC LocalPathH) = TransformCoreTCPathBox-    box = TransformCoreTCPathBox-    unbox (TransformCoreTCPathBox t) = t+instance Extern (TransformH LCore LocalPathH) where+    type Box (TransformH LCore LocalPathH) = TransformLCorePathBox+    box = TransformLCorePathBox+    unbox (TransformLCorePathBox t) = t  ----------------------------------------------------------------- -newtype CoreString = CoreString { unCoreString :: String } deriving Typeable+data BiRewriteLCoreBox = BiRewriteLCoreBox (BiRewriteH LCore) deriving Typeable -instance Extern CoreString where-    type Box CoreString = CoreString-    box = id-    unbox = id+instance Extern (BiRewriteH LCore) where+    type Box (BiRewriteH LCore) = BiRewriteLCoreBox+    box = BiRewriteLCoreBox+    unbox (BiRewriteLCoreBox b) = b  ----------------------------------------------------------------- -data StringBox = StringBox String deriving Typeable+data RewriteLCoreListBox = RewriteLCoreListBox [RewriteH LCore] deriving Typeable -instance Extern String where-    type Box String = StringBox-    box = StringBox-    unbox (StringBox s) = s+instance Extern [RewriteH LCore] where+    type Box [RewriteH LCore] = RewriteLCoreListBox+    box = RewriteLCoreListBox+    unbox (RewriteLCoreListBox l) = l  ----------------------------------------------------------------- -data StringListBox = StringListBox [String] deriving Typeable+data RewriteLCoreTCBox = RewriteLCoreTCBox (RewriteH LCoreTC) deriving Typeable -instance Extern [String] where-    type Box [String] = StringListBox-    box = StringListBox-    unbox (StringListBox l) = l+instance Extern (RewriteH LCoreTC) where+    type Box (RewriteH LCoreTC) = RewriteLCoreTCBox+    box = RewriteLCoreTCBox+    unbox (RewriteLCoreTCBox r) = r  ----------------------------------------------------------------- -data IntListBox = IntListBox [Int] deriving Typeable+data TransformLCoreTCStringBox = TransformLCoreTCStringBox (TransformH LCoreTC String) deriving Typeable -instance Extern [Int] where-    type Box [Int] = IntListBox-    box = IntListBox-    unbox (IntListBox l) = l+instance Extern (TransformH LCoreTC String) where+    type Box (TransformH LCoreTC String) = TransformLCoreTCStringBox+    box = TransformLCoreTCStringBox+    unbox (TransformLCoreTCStringBox t) = t  ----------------------------------------------------------------- -data RewriteCoreListBox = RewriteCoreListBox [RewriteH Core] deriving Typeable+data TransformLCoreTCUnitBox = TransformLCoreTCUnitBox (TransformH LCoreTC ()) deriving Typeable -instance Extern [RewriteH Core] where-    type Box [RewriteH Core] = RewriteCoreListBox-    box = RewriteCoreListBox-    unbox (RewriteCoreListBox l) = l+instance Extern (TransformH LCoreTC ()) where+    type Box (TransformH LCoreTC ()) = TransformLCoreTCUnitBox+    box = TransformLCoreTCUnitBox+    unbox (TransformLCoreTCUnitBox t) = t  ----------------------------------------------------------------- -instance Extern RememberedName where-    type Box RememberedName = RememberedName-    box = id-    unbox = id+data TransformLCoreTCLCoreBox = TransformLCoreTCLCoreBox (TransformH LCoreTC LCore) deriving Typeable +instance Extern (TransformH LCoreTC LCore) where+    type Box (TransformH LCoreTC LCore) = TransformLCoreTCLCoreBox+    box = TransformLCoreTCLCoreBox+    unbox (TransformLCoreTCLCoreBox t) = t+ ----------------------------------------------------------------- -instance Extern LemmaName where-    type Box LemmaName = LemmaName-    box = id-    unbox = id+data TransformLCoreTCPathBox = TransformLCoreTCPathBox (TransformH LCoreTC LocalPathH) deriving Typeable +instance Extern (TransformH LCoreTC LocalPathH) where+    type Box (TransformH LCoreTC LocalPathH) = TransformLCoreTCPathBox+    box = TransformLCoreTCPathBox+    unbox (TransformLCoreTCPathBox t) = t+ ----------------------------------------------------------------- -data RewriteEqualityBox = RewriteEqualityBox (RewriteH Equality) deriving Typeable+data BiRewriteLCoreTCBox = BiRewriteLCoreTCBox (BiRewriteH LCoreTC) deriving Typeable -instance Extern (RewriteH Equality) where-    type Box (RewriteH Equality) = RewriteEqualityBox-    box = RewriteEqualityBox-    unbox (RewriteEqualityBox r) = r+instance Extern (BiRewriteH LCoreTC) where+    type Box (BiRewriteH LCoreTC) = BiRewriteLCoreTCBox+    box = BiRewriteLCoreTCBox+    unbox (BiRewriteLCoreTCBox b) = b  ----------------------------------------------------------------- -data TransformEqualityStringBox = TransformEqualityStringBox (TransformH Equality String) deriving Typeable+data RewriteLCoreTCListBox = RewriteLCoreTCListBox [RewriteH LCoreTC] deriving Typeable -instance Extern (TransformH Equality String) where-    type Box (TransformH Equality String) = TransformEqualityStringBox-    box = TransformEqualityStringBox-    unbox (TransformEqualityStringBox t) = t+instance Extern [RewriteH LCoreTC] where+    type Box [RewriteH LCoreTC] = RewriteLCoreTCListBox+    box = RewriteLCoreTCListBox+    unbox (RewriteLCoreTCListBox l) = l  -----------------------------------------------------------------