hermit 0.5.0.0 → 0.6.0.0

raw patch · 78 files changed

+3708/−2857 lines, 78 filesdep +Win32dep ~ghcdep ~kurePVP ok

version bump matches the API change (PVP)

Dependencies added: Win32

Dependency ranges changed: ghc, kure

API changes (from Hackage documentation)

Files

• dist/build/HERMIT/Parser.hs +134/−127
• dist/build/HERMIT/ParserCore.hs +20/−11
• dist/build/HERMIT/ParserType.hs +2/−10
• examples/concatVanishes/Flatten.hs +0/−4
• examples/concatVanishes/QSort.hs +0/−4
• examples/concatVanishes/Rev.hs +0/−4
• examples/evaluation/Eval.hs +0/−4
• examples/factorial/Fac.hs +0/−4
• examples/fib-stream/Fib.hs +0/−4
• examples/fib-tuple/Fib.hs +0/−5
• examples/flatten/Flatten.hs +0/−4
• examples/hanoi/Hanoi.hs +0/−4
• examples/last/Last.hs +0/−4
• examples/qsort/QSort.hs +0/−4
• examples/reverse/Reverse.hs +0/−4
• hermit.cabal +18/−12
• src/HERMIT.hs +3/−3
• src/HERMIT/Context.hs +3/−3
• src/HERMIT/Core.hs +21/−28
• src/HERMIT/Dictionary.hs +4/−0
• src/HERMIT/Dictionary/AlphaConversion.hs +126/−93
• src/HERMIT/Dictionary/Common.hs +32/−44
• src/HERMIT/Dictionary/Composite.hs +86/−69
• src/HERMIT/Dictionary/Debug.hs +27/−24
• src/HERMIT/Dictionary/FixPoint.hs +104/−74
• src/HERMIT/Dictionary/Fold.hs +25/−21
• src/HERMIT/Dictionary/Function.hs +106/−17
• src/HERMIT/Dictionary/GHC.hs +82/−41
• src/HERMIT/Dictionary/Induction.hs +2/−1
• src/HERMIT/Dictionary/Inline.hs +65/−96
• src/HERMIT/Dictionary/Kure.hs +18/−5
• src/HERMIT/Dictionary/Local.hs +33/−78
• src/HERMIT/Dictionary/Local/Bind.hs +6/−7
• src/HERMIT/Dictionary/Local/Case.hs +112/−90
• src/HERMIT/Dictionary/Local/Cast.hs +0/−6
• src/HERMIT/Dictionary/Local/Let.hs +158/−64
• src/HERMIT/Dictionary/Navigation.hs +60/−51
• src/HERMIT/Dictionary/Query.hs +21/−21
• src/HERMIT/Dictionary/Reasoning.hs +199/−141
• src/HERMIT/Dictionary/Rules.hs +109/−152
• src/HERMIT/Dictionary/Undefined.hs +50/−32
• src/HERMIT/Dictionary/Unfold.hs +41/−43
• src/HERMIT/Dictionary/Unsafe.hs +4/−4
• src/HERMIT/Dictionary/WorkerWrapper/Common.hs +163/−6
• src/HERMIT/Dictionary/WorkerWrapper/Fix.hs +24/−22
• src/HERMIT/Dictionary/WorkerWrapper/FixResult.hs +31/−29
• src/HERMIT/Driver.hs +11/−8
• src/HERMIT/External.hs +109/−110
• src/HERMIT/GHC.hs +80/−180
• src/HERMIT/GHC/Typechecker.hs +3/−9
• src/HERMIT/Kernel.hs +69/−40
• src/HERMIT/Kernel/Scoped.hs +16/−16
• src/HERMIT/Kure.hs +56/−145
• src/HERMIT/Monad.hs +212/−135
• src/HERMIT/Name.hs +182/−101
• src/HERMIT/Parser.y +6/−1
• src/HERMIT/ParserCore.y +20/−11
• src/HERMIT/ParserType.y +2/−10
• src/HERMIT/Plugin.hs +44/−38
• src/HERMIT/Plugin/Builder.hs +35/−32
• src/HERMIT/Plugin/Renderer.hs +8/−1
• src/HERMIT/Plugin/Types.hs +23/−8
• src/HERMIT/PrettyPrinter/AST.hs +0/−7
• src/HERMIT/PrettyPrinter/Clean.hs +57/−54
• src/HERMIT/PrettyPrinter/Common.hs +12/−9
• src/HERMIT/Shell/Command.hs +67/−30
• src/HERMIT/Shell/Completion.hs +127/−0
• src/HERMIT/Shell/Dictionary.hs +21/−4
• src/HERMIT/Shell/Externals.hs +5/−32
• src/HERMIT/Shell/Interpreter.hs +66/−48
• src/HERMIT/Shell/KernelEffect.hs +33/−26
• src/HERMIT/Shell/Proof.hs +122/−198
• src/HERMIT/Shell/ScriptToRewrite.hs +13/−8
• src/HERMIT/Shell/ShellEffect.hs +7/−8
• src/HERMIT/Shell/Types.hs +59/−103
• src/HERMIT/Utilities.hs +10/−11
• src/HERMIT/Win32/Console.hsc +105/−0
• src/HERMIT/Win32/IO.hsc +239/−0

@@ -6,6 +6,7 @@     , unparseScript     , unparseExprH     , ExprH(..)+    , parseExprH     ) where  import Data.Char (isSpace)@@ -19,85 +20,84 @@  -- parser produced by Happy Version 1.19.3 -newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11 = HappyAbsSyn HappyAny+newtype HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 type HappyAny = Happy_GHC_Exts.Any #else type HappyAny = forall a . a #endif-happyIn4 :: t4 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn4 #-}-happyOut4 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t4-happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut4 #-}-happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn5 :: t5 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t5+happyOut5 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t5 happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut5 #-}-happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn6 :: t6 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t6+happyOut6 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t6 happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut6 #-}-happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn7 :: t7 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t7+happyOut7 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t7 happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut7 #-}-happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn8 :: t8 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn8 #-}-happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t8+happyOut8 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t8 happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut8 #-}-happyIn9 :: t9 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn9 :: t9 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t9+happyOut9 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t9 happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut9 #-}-happyIn10 :: t10 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn10 :: t10 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn10 #-}-happyOut10 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t10+happyOut10 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t10 happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut10 #-}-happyIn11 :: t11 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn11 :: t11 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn11 #-}-happyOut11 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t11+happyOut11 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t11 happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut11 #-}-happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn12 :: t12 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12)+happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn12 #-}+happyOut12 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t12+happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut12 #-}+happyInTok :: (Token) -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyInTok x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> (Token)+happyOutTok :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> (Token) happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOutTok #-}   happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\x0e\x00\x1e\x00\x0e\x00\x06\x00\x00\x00\x00\x00\xfd\xff\x01\x00\x00\x00\x1a\x00\x0e\x00\x1a\x00\x0e\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x09\x00\x00\x00\x00\x00\x02\x00\x00\x00\x1a\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00"#+happyActOffsets = HappyA# "\x0e\x00\x1a\x00\x1e\x00\x0e\x00\x06\x00\x01\x00\x00\x00\x1a\x00\x1a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\xfd\xff\x0e\x00\x0e\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x09\x00\x00\x00\x02\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00"#  happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\x45\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x4d\x00\x39\x00\x48\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x2d\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00"#+happyGotoOffsets = HappyA# "\x45\x00\x50\x00\x00\x00\x3f\x00\x00\x00\xfe\xff\x00\x00\x4d\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x33\x00\x00\x00\x00\x00\x2d\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00"#  happyDefActions :: HappyAddr-happyDefActions = HappyA# "\xfa\xff\x00\x00\xfa\xff\x00\x00\xfc\xff\xfb\xff\xf9\xff\xf4\xff\xf2\xff\x00\x00\xfa\xff\xe8\xff\xfa\xff\x00\x00\xed\xff\xee\xff\xea\xff\xef\xff\xf1\xff\xf0\xff\xf6\xff\xe7\xff\x00\x00\xe9\xff\xfd\xff\x00\x00\xf3\xff\x00\x00\xfa\xff\xfa\xff\xfe\xff\xf7\xff\xf8\xff\xf5\xff\xeb\xff\xec\xff\x00\x00\xe6\xff"#+happyDefActions = HappyA# "\xf9\xff\x00\x00\x00\x00\xf9\xff\x00\x00\xf3\xff\xf1\xff\x00\x00\xe7\xff\x00\x00\xec\xff\xed\xff\xe9\xff\x00\x00\xfb\xff\xfa\xff\xf8\xff\xf9\xff\xf9\xff\xf5\xff\xfc\xff\xf9\xff\xf9\xff\xee\xff\xf0\xff\xef\xff\xe6\xff\x00\x00\xe8\xff\x00\x00\xf2\xff\x00\x00\xfd\xff\xf4\xff\xea\xff\xeb\xff\x00\x00\xf6\xff\xf7\xff\xe5\xff"#  happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x04\x00\x01\x00\x05\x00\x02\x00\x08\x00\x05\x00\x03\x00\x04\x00\x05\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x01\x00\x07\x00\x03\x00\x04\x00\x05\x00\x0e\x00\x06\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x01\x00\x03\x00\x04\x00\x05\x00\x05\x00\x07\x00\x03\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x03\x00\x04\x00\x05\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#+happyCheck = HappyA# "\xff\xff\x04\x00\x01\x00\x05\x00\x02\x00\x08\x00\x05\x00\x03\x00\x04\x00\x05\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x01\x00\x07\x00\x03\x00\x04\x00\x05\x00\x0e\x00\x06\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x01\x00\x03\x00\x04\x00\x05\x00\x05\x00\x07\x00\x03\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#  happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\x1d\x00\x0a\x00\x1a\x00\x23\x00\x1e\x00\x0c\x00\x21\x00\x07\x00\x08\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x1c\x00\x0a\x00\x24\x00\x03\x00\x0b\x00\x0c\x00\xff\xff\x25\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0a\x00\x15\x00\x07\x00\x08\x00\x0c\x00\x25\x00\x03\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x1f\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x20\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x14\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x18\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x1e\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x15\x00\x07\x00\x08\x00\x16\x00\x17\x00\x19\x00\x07\x00\x08\x00\x00\x00\x12\x00\x13\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#+happyTable = HappyA# "\x00\x00\x16\x00\x08\x00\x1e\x00\x23\x00\x17\x00\x09\x00\x21\x00\x05\x00\x06\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x08\x00\x24\x00\x04\x00\x12\x00\x09\x00\xff\xff\x25\x00\x13\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x08\x00\x1a\x00\x05\x00\x06\x00\x09\x00\x27\x00\x04\x00\x00\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x25\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x26\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x13\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x14\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x20\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x1a\x00\x05\x00\x06\x00\x1b\x00\x1c\x00\x1d\x00\x05\x00\x06\x00\x04\x00\x05\x00\x06\x00\x18\x00\x19\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# -happyReduceArr = Happy_Data_Array.array (1, 25) [-	(1 , happyReduce_1),+happyReduceArr = Happy_Data_Array.array (2, 26) [ 	(2 , happyReduce_2), 	(3 , happyReduce_3), 	(4 , happyReduce_4),@@ -121,205 +121,206 @@ 	(22 , happyReduce_22), 	(23 , happyReduce_23), 	(24 , happyReduce_24),-	(25 , happyReduce_25)+	(25 , happyReduce_25),+	(26 , happyReduce_26) 	]  happy_n_terms = 15 :: Int happy_n_nonterms = 8 :: Int -happyReduce_1 = happySpecReduce_2  0# happyReduction_1-happyReduction_1 happy_x_2+happyReduce_2 = happySpecReduce_2  0# happyReduction_2+happyReduction_2 happy_x_2 	happy_x_1-	 =  case happyOut4 happy_x_2 of { happy_var_2 -> -	happyIn4+	 =  case happyOut5 happy_x_2 of { happy_var_2 -> +	happyIn5 		 (CmdName "{" : happy_var_2 	)} -happyReduce_2 = happySpecReduce_2  0# happyReduction_2-happyReduction_2 happy_x_2+happyReduce_3 = happySpecReduce_2  0# happyReduction_3+happyReduction_3 happy_x_2 	happy_x_1-	 =  case happyOut4 happy_x_2 of { happy_var_2 -> -	happyIn4+	 =  case happyOut5 happy_x_2 of { happy_var_2 -> +	happyIn5 		 (CmdName "}" : happy_var_2 	)} -happyReduce_3 = happySpecReduce_1  0# happyReduction_3-happyReduction_3 happy_x_1-	 =  case happyOut5 happy_x_1 of { happy_var_1 -> -	happyIn4-		 (happy_var_1-	)}--happyReduce_4 = happySpecReduce_1  1# happyReduction_4+happyReduce_4 = happySpecReduce_1  0# happyReduction_4 happyReduction_4 happy_x_1 	 =  case happyOut6 happy_x_1 of { happy_var_1 ->  	happyIn5 		 (happy_var_1 	)} -happyReduce_5 = happySpecReduce_0  1# happyReduction_5-happyReduction_5  =  happyIn5+happyReduce_5 = happySpecReduce_1  1# happyReduction_5+happyReduction_5 happy_x_1+	 =  case happyOut7 happy_x_1 of { happy_var_1 -> +	happyIn6+		 (happy_var_1+	)}++happyReduce_6 = happySpecReduce_0  1# happyReduction_6+happyReduction_6  =  happyIn6 		 ([] 	) -happyReduce_6 = happySpecReduce_1  2# happyReduction_6-happyReduction_6 happy_x_1-	 =  case happyOut7 happy_x_1 of { happy_var_1 -> -	happyIn6+happyReduce_7 = happySpecReduce_1  2# happyReduction_7+happyReduction_7 happy_x_1+	 =  case happyOut8 happy_x_1 of { happy_var_1 -> +	happyIn7 		 ([happy_var_1] 	)} -happyReduce_7 = happySpecReduce_3  2# happyReduction_7-happyReduction_7 happy_x_3+happyReduce_8 = happySpecReduce_3  2# happyReduction_8+happyReduction_8 happy_x_3 	happy_x_2 	happy_x_1-	 =  case happyOut7 happy_x_1 of { happy_var_1 -> -	case happyOut4 happy_x_3 of { happy_var_3 -> -	happyIn6+	 =  case happyOut8 happy_x_1 of { happy_var_1 -> +	case happyOut5 happy_x_3 of { happy_var_3 -> +	happyIn7 		 ([happy_var_1, CmdName "}"] ++ happy_var_3 	)}} -happyReduce_8 = happySpecReduce_3  2# happyReduction_8-happyReduction_8 happy_x_3+happyReduce_9 = happySpecReduce_3  2# happyReduction_9+happyReduction_9 happy_x_3 	happy_x_2 	happy_x_1-	 =  case happyOut7 happy_x_1 of { happy_var_1 -> -	case happyOut4 happy_x_3 of { happy_var_3 -> -	happyIn6+	 =  case happyOut8 happy_x_1 of { happy_var_1 -> +	case happyOut5 happy_x_3 of { happy_var_3 -> +	happyIn7 		 (happy_var_1 : happy_var_3 	)}} -happyReduce_9 = happySpecReduce_2  2# happyReduction_9-happyReduction_9 happy_x_2+happyReduce_10 = happySpecReduce_2  2# happyReduction_10+happyReduction_10 happy_x_2 	happy_x_1-	 =  case happyOut4 happy_x_2 of { happy_var_2 -> -	happyIn6+	 =  case happyOut5 happy_x_2 of { happy_var_2 -> +	happyIn7 		 (happy_var_2 	)} -happyReduce_10 = happySpecReduce_3  3# happyReduction_10-happyReduction_10 happy_x_3+happyReduce_11 = happySpecReduce_3  3# happyReduction_11+happyReduction_11 happy_x_3 	happy_x_2 	happy_x_1-	 =  case happyOut8 happy_x_1 of { happy_var_1 -> +	 =  case happyOut9 happy_x_1 of { happy_var_1 ->  	case happyOutTok happy_x_2 of { (InfixOp happy_var_2) -> -	case happyOut7 happy_x_3 of { happy_var_3 -> -	happyIn7+	case happyOut8 happy_x_3 of { happy_var_3 -> +	happyIn8 		 (AppH (AppH (CmdName happy_var_2) happy_var_1) happy_var_3 	)}}} -happyReduce_11 = happySpecReduce_1  3# happyReduction_11-happyReduction_11 happy_x_1-	 =  case happyOut8 happy_x_1 of { happy_var_1 -> -	happyIn7+happyReduce_12 = happySpecReduce_1  3# happyReduction_12+happyReduction_12 happy_x_1+	 =  case happyOut9 happy_x_1 of { happy_var_1 -> +	happyIn8 		 (happy_var_1 	)} -happyReduce_12 = happySpecReduce_2  4# happyReduction_12-happyReduction_12 happy_x_2+happyReduce_13 = happySpecReduce_2  4# happyReduction_13+happyReduction_13 happy_x_2 	happy_x_1-	 =  case happyOut8 happy_x_1 of { happy_var_1 -> -	case happyOut9 happy_x_2 of { happy_var_2 -> -	happyIn8+	 =  case happyOut9 happy_x_1 of { happy_var_1 -> +	case happyOut10 happy_x_2 of { happy_var_2 -> +	happyIn9 		 (AppH happy_var_1 happy_var_2 	)}} -happyReduce_13 = happySpecReduce_1  4# happyReduction_13-happyReduction_13 happy_x_1-	 =  case happyOut9 happy_x_1 of { happy_var_1 -> -	happyIn8+happyReduce_14 = happySpecReduce_1  4# happyReduction_14+happyReduction_14 happy_x_1+	 =  case happyOut10 happy_x_1 of { happy_var_1 -> +	happyIn9 		 (happy_var_1 	)} -happyReduce_14 = happySpecReduce_2  5# happyReduction_14-happyReduction_14 happy_x_2+happyReduce_15 = happySpecReduce_2  5# happyReduction_15+happyReduction_15 happy_x_2 	happy_x_1 	 =  case happyOutTok happy_x_2 of { (Ident happy_var_2) -> -	happyIn9+	happyIn10 		 (SrcName happy_var_2 	)} -happyReduce_15 = happySpecReduce_2  5# happyReduction_15-happyReduction_15 happy_x_2+happyReduce_16 = happySpecReduce_2  5# happyReduction_16+happyReduction_16 happy_x_2 	happy_x_1 	 =  case happyOutTok happy_x_2 of { (InfixOp happy_var_2) -> -	happyIn9+	happyIn10 		 (SrcName happy_var_2 	)} -happyReduce_16 = happySpecReduce_2  5# happyReduction_16-happyReduction_16 happy_x_2+happyReduce_17 = happySpecReduce_2  5# happyReduction_17+happyReduction_17 happy_x_2 	happy_x_1 	 =  case happyOutTok happy_x_2 of { (Quote happy_var_2) -> -	happyIn9+	happyIn10 		 (SrcName happy_var_2 	)} -happyReduce_17 = happySpecReduce_1  5# happyReduction_17-happyReduction_17 happy_x_1+happyReduce_18 = happySpecReduce_1  5# happyReduction_18+happyReduction_18 happy_x_1 	 =  case happyOutTok happy_x_1 of { (Quote happy_var_1) -> -	happyIn9+	happyIn10 		 (CmdName happy_var_1 	)} -happyReduce_18 = happySpecReduce_1  5# happyReduction_18-happyReduction_18 happy_x_1+happyReduce_19 = happySpecReduce_1  5# happyReduction_19+happyReduction_19 happy_x_1 	 =  case happyOutTok happy_x_1 of { (CoreString happy_var_1) -> -	happyIn9+	happyIn10 		 (CoreH happy_var_1 	)} -happyReduce_19 = happySpecReduce_3  5# happyReduction_19-happyReduction_19 happy_x_3+happyReduce_20 = happySpecReduce_3  5# happyReduction_20+happyReduction_20 happy_x_3 	happy_x_2 	happy_x_1-	 =  case happyOut10 happy_x_2 of { happy_var_2 -> -	happyIn9+	 =  case happyOut11 happy_x_2 of { happy_var_2 -> +	happyIn10 		 (ListH happy_var_2 	)} -happyReduce_20 = happySpecReduce_3  5# happyReduction_20-happyReduction_20 happy_x_3+happyReduce_21 = happySpecReduce_3  5# happyReduction_21+happyReduction_21 happy_x_3 	happy_x_2 	happy_x_1-	 =  case happyOut7 happy_x_2 of { happy_var_2 -> -	happyIn9+	 =  case happyOut8 happy_x_2 of { happy_var_2 -> +	happyIn10 		 (happy_var_2 	)} -happyReduce_21 = happySpecReduce_1  5# happyReduction_21-happyReduction_21 happy_x_1+happyReduce_22 = happySpecReduce_1  5# happyReduction_22+happyReduction_22 happy_x_1 	 =  case happyOutTok happy_x_1 of { (Ident happy_var_1) -> -	happyIn9+	happyIn10 		 (CmdName happy_var_1 	)} -happyReduce_22 = happySpecReduce_1  6# happyReduction_22-happyReduction_22 happy_x_1-	 =  case happyOut11 happy_x_1 of { happy_var_1 -> -	happyIn10+happyReduce_23 = happySpecReduce_1  6# happyReduction_23+happyReduction_23 happy_x_1+	 =  case happyOut12 happy_x_1 of { happy_var_1 -> +	happyIn11 		 (happy_var_1 	)} -happyReduce_23 = happySpecReduce_0  6# happyReduction_23-happyReduction_23  =  happyIn10+happyReduce_24 = happySpecReduce_0  6# happyReduction_24+happyReduction_24  =  happyIn11 		 ([] 	) -happyReduce_24 = happySpecReduce_1  7# happyReduction_24-happyReduction_24 happy_x_1-	 =  case happyOut7 happy_x_1 of { happy_var_1 -> -	happyIn11+happyReduce_25 = happySpecReduce_1  7# happyReduction_25+happyReduction_25 happy_x_1+	 =  case happyOut8 happy_x_1 of { happy_var_1 -> +	happyIn12 		 ([happy_var_1] 	)} -happyReduce_25 = happySpecReduce_3  7# happyReduction_25-happyReduction_25 happy_x_3+happyReduce_26 = happySpecReduce_3  7# happyReduction_26+happyReduction_26 happy_x_3 	happy_x_2 	happy_x_1-	 =  case happyOut7 happy_x_1 of { happy_var_1 -> -	case happyOut11 happy_x_3 of { happy_var_3 -> -	happyIn11+	 =  case happyOut8 happy_x_1 of { happy_var_1 -> +	case happyOut12 happy_x_3 of { happy_var_3 -> +	happyIn12 		 (happy_var_1 : happy_var_3 	)}} @@ -359,8 +360,11 @@ happyError' = parseError  parser tks = happySomeParser where-  happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))+  happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) +exprParser tks = happySomeParser where+  happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut8 x))+ happySeq = happyDontSeq  @@ -448,6 +452,9 @@  parseScript :: String -> Either String Script parseScript = lexer >=> parser++parseExprH :: String -> Either String ExprH+parseExprH = lexer >=> exprParser  --------------------------------------------- 

@@ -4,6 +4,8 @@ module HERMIT.ParserCore     ( parseCore     , parseCoreExprT+    , parse2BeforeT+    , parse3BeforeT     , parse2beforeBiR     , parse3beforeBiR     , parse4beforeBiR@@ -256,21 +258,17 @@   mkIntExpr' :: Integer -> CoreParseM CoreExpr-#if __GLASGOW_HASKELL__ > 706 mkIntExpr' i = do     dflags <- lift getDynFlags     return $ mkIntExpr dflags i-#else-mkIntExpr' i = return $ mkIntExpr i-#endif  lookupName :: String -> CoreParseM CoreExpr lookupName nm = do-    c <- ask-    v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId nm c+    vset <- ask+    v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId (parseName nm) vset     return $ varToCoreExpr v -type CoreParseM a = ReaderT HermitC HermitM a+type CoreParseM a = ReaderT VarSet HermitM a  parseError :: Monad m => [Token] -> m a parseError ts = fail $ "core parse error: " ++ show ts@@ -337,19 +335,30 @@  --------------------------------------------- -parseCore :: CoreString -> HermitC -> HermitM CoreExpr+parseCore :: BoundVars c => CoreString -> c -> HermitM CoreExpr parseCore (CoreString s) c =     case lexer s of         Left msg -> fail msg-        Right tokens -> runReaderT (parser tokens) c+        Right tokens -> runReaderT (parser tokens) (boundVars c)  ---------------------------------------------  -- These should probably go somewhere else.  -- | Parse a 'CoreString' to a 'CoreExpr', using the current context.-parseCoreExprT :: CoreString -> TransformH a CoreExpr-parseCoreExprT = contextonlyT . parseCore+parseCoreExprT :: (BoundVars c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, HasStash 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)+              => (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)+              => (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)  parse2beforeBiR :: (CoreExpr -> CoreExpr -> BiRewriteH a)                 -> CoreString -> CoreString -> BiRewriteH a

@@ -2,15 +2,11 @@ {-# OPTIONS -fglasgow-exts -cpp #-} {-# LANGUAGE CPP #-} module HERMIT.ParserType-#if __GLASGOW_HASKELL__ <= 706-    () where-#else     ( parseType     , parseTypeT     , parseTypeWithHoles     , parseTypeWithHolesT     ) where-#endif  import Control.Arrow import Control.Monad.State@@ -238,14 +234,10 @@ happySeq = happyDontSeq  -#if __GLASGOW_HASKELL__ <= 706-findType = error "findType cannot be called in < GHC 7.8"-#endif- lookupName :: String -> TypeParseM Type lookupName nm = do     c <- getContext-    et <- lift $ attemptM $ findType nm c+    et <- lift $ attemptM $ findType (parseName nm) c     either (const (addTyVar nm)) return et  catchFrees :: Type -> TypeParseM ([TyVar], Type)@@ -268,7 +260,7 @@ addTyVar :: String -> TypeParseM Type addTyVar tvStr = do     used <- gets tpUsed-    case [ tv | tv <- used, getOccString tv == tvStr ] of+    case [ tv | tv <- used, unqualifiedName tv == tvStr ] of         [] -> do tv <- lift $ newTyVarH tvStr liftedTypeKind                  modify $ \ st -> st { tpUsed = tv : tpUsed st }                  return $ mkTyVarTy tv

@@ -3,10 +3,6 @@  import HList -#if __GLASGOW_HASKELL__ < 708-import Data.Function (fix)-#endif- data Tree a = Node (Tree a) (Tree a) | Leaf a  flatten :: Tree a -> [a]

@@ -4,10 +4,6 @@ import HList import Data.List -#if __GLASGOW_HASKELL__ < 708-import Data.Function (fix)-#endif- data Tree a = Node (Tree a) (Tree a) | Leaf a  qsort        :: Ord a => [a] -> [a]

@@ -3,10 +3,6 @@  import HList -#if __GLASGOW_HASKELL__ < 708-import Data.Function (fix)-#endif- rev :: [a] -> [a] rev []     = [] rev (y:ys) = rev ys ++ [y]

@@ -3,10 +3,6 @@  import Prelude hiding (abs) -#if __GLASGOW_HASKELL__ < 708-import Data.Function (fix)-#endif- data Expr = Val Int | Add Expr Expr | Throw | Catch Expr Expr  type Mint = Maybe Int

@@ -6,10 +6,6 @@ import Prelude hiding ((*),(-)) import GHC.Exts -#if __GLASGOW_HASKELL__ < 708-import Data.Function (fix)-#endif- ------------------------------------  fac :: Int -> Int

@@ -5,10 +5,6 @@ import Nat import Stream -#if __GLASGOW_HASKELL__ < 708-import Data.Function (fix)-#endif- fib :: Nat -> Nat fib Zero             = Zero fib (Succ Zero)      = Succ Zero

@@ -1,11 +1,6 @@ {-# LANGUAGE CPP #-} module Main where -#if __GLASGOW_HASKELL__ < 708--- so we can fix-intro-import Data.Function (fix)-#endif- import Prelude hiding ((+))  data Nat = Z | S Nat

@@ -3,10 +3,6 @@  import HList -#if __GLASGOW_HASKELL__ < 708-import Data.Function (fix)-#endif- data Tree a = Node (Tree a) (Tree a) | Leaf a  flatten :: Tree a -> [a]

@@ -5,10 +5,6 @@  import Control.Monad (forM_) -#if __GLASGOW_HASKELL__ < 708-import Data.Function (fix)-#endif- data Nat = Z | S Nat  toInt :: Nat -> Int

@@ -1,10 +1,6 @@ {-# LANGUAGE CPP #-} module Main where -#if __GLASGOW_HASKELL__ < 708-import Data.Function (fix)-#endif- import Prelude hiding (last)  -------------------------------------------------

@@ -3,10 +3,6 @@  import HList -#if __GLASGOW_HASKELL__ < 708-import Data.Function (fix)-#endif- import Data.List  data Tree a = Node (Tree a) (Tree a) | Leaf a

@@ -4,10 +4,6 @@ import HList -- import Seq -#if __GLASGOW_HASKELL__ < 708-import Data.Function (fix)-#endif- rev :: [a] -> [a] rev []     = [] rev (x:xs) = rev xs ++ [x]

@@ -1,5 +1,5 @@ Name:                hermit-Version:             0.5.0.0+Version:             0.6.0.0 Synopsis:            Haskell Equational Reasoning Model-to-Implementation Tunnel Description:   HERMIT uses Haskell to express semi-formal models,@@ -28,12 +28,12 @@   .   @    $ hermit Reverse.hs Reverse.hss resume-   [starting HERMIT v0.5.0.0 on Reverse.hs]+   [starting HERMIT v0.6.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.5.0.0 ... linking ... done.+   Loading package hermit-0.6.0.0 ... linking ... done.    [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )    Linking Reverse ...    $ ./Reverse@@ -44,12 +44,12 @@   .   @    $ hermit Reverse.hs-   [starting HERMIT v0.5.0.0 on Reverse.hs]+   [starting HERMIT v0.6.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.5.0.0 ... linking ... done.+   Loading package hermit-0.6.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@@ -143,9 +143,9 @@                  containers >= 0.5.0.0,                  data-default >= 0.5.0,                  directory >= 1.2.0.0,-                 ghc >= 7.6,+                 ghc >= 7.8,                  haskeline >= 0.7.0.3,-                 kure >= 2.16.0,+                 kure >= 2.16.4,                  marked-pretty >= 0.1,                  mtl >= 2.1.2,                  operational >= 0.2.2.1,@@ -154,13 +154,13 @@                  temporary >= 1.2.0.3,                  transformers -  if !os(windows)+  if os(windows)+    build-depends: Win32+  else     build-depends: terminfo >= 0.3.2.5 -  if impl(ghc >= 7.8)-    build-tools: happy >= 1.19.3, alex >= 3.1.3-  else-    build-tools: happy, alex+  build-tools:   alex >= 3.1.3,+                 happy >= 1.19.3    default-language: Haskell2010 @@ -226,6 +226,7 @@        HERMIT.PrettyPrinter.GHC         HERMIT.Shell.Command+       HERMIT.Shell.Completion        HERMIT.Shell.Dictionary        HERMIT.Shell.Interpreter        HERMIT.Shell.Externals@@ -241,6 +242,11 @@        HERMIT.Syntax         Paths_hermit++  if os(windows)+    Other-modules:+        HERMIT.Win32.Console+        HERMIT.Win32.IO    Hs-Source-Dirs: src 

@@ -3,9 +3,9 @@ import Data.Maybe (fromMaybe)  import HERMIT.GHC-import HERMIT.Plugin.Builder (getPhaseFlag)+import HERMIT.Plugin.Builder (getPassFlag) import HERMIT.Plugin  plugin :: Plugin-plugin = hermitPlugin $ \ options -> let (pn,opts) = fromMaybe (0,options) (getPhaseFlag options)-                                     in phase pn $ interactive [] opts+plugin = hermitPlugin $ \ options -> let (pn,opts) = fromMaybe (0,options) (getPassFlag options)+                                     in pass pn $ interactive [] opts

@@ -178,9 +178,9 @@   boundVars :: VarSet -> VarSet   boundVars = id --- | List all variables bound in the context that match the given name.-findBoundVars :: BoundVars c => String -> c -> VarSet-findBoundVars nm = filterVarSet (cmpString2Var nm) . boundVars+-- | List all variables bound in the context that match the given predicate.+findBoundVars :: BoundVars c => (Var -> Bool) -> c -> VarSet+findBoundVars p = filterVarSet p . boundVars  -- | A class of contexts from which HERMIT bindings can be retrieved. class BoundVars c => ReadBindings c where

@@ -58,11 +58,11 @@           , isCoArg           , exprKindOrType           , exprTypeM-          , endoFunType+          , endoFunTypeM           , splitTyConAppM           , splitFunTypeM-          , endoFunExprType-          , funExprArgResTypes+          , endoFunExprTypeM+          , funExprArgResTypesM           , funExprsWithInverseTypes           , appCount           , mapAlts@@ -184,24 +184,15 @@  -- | Syntactic Equality of 'Coercion's. coercionSyntaxEq :: Coercion -> Coercion -> Bool-#if __GLASGOW_HASKELL__ > 706 coercionSyntaxEq (Refl role1 ty1)        (Refl role2 ty2)        = role1 == role2 && typeSyntaxEq ty1 ty2 coercionSyntaxEq (TyConAppCo role1 tc1 cos1) (TyConAppCo role2 tc2 cos2) = role1 == role2 && tc1 == tc2 && all2 coercionSyntaxEq cos1 cos2-#else-coercionSyntaxEq (Refl ty1)              (Refl ty2)              = typeSyntaxEq ty1 ty2-coercionSyntaxEq (TyConAppCo tc1 cos1)   (TyConAppCo tc2 cos2)   = tc1 == tc2 && all2 coercionSyntaxEq cos1 cos2-#endif coercionSyntaxEq (AppCo co11 co12)       (AppCo co21 co22)       = coercionSyntaxEq co11 co21 && coercionSyntaxEq co12 co22 coercionSyntaxEq (ForAllCo v1 co1)       (ForAllCo v2 co2)       = v1 == v2 && coercionSyntaxEq co1 co2 coercionSyntaxEq (CoVarCo v1)            (CoVarCo v2)            = v1 == v2-#if __GLASGOW_HASKELL__ > 706 coercionSyntaxEq (AxiomInstCo con1 ind1 cos1) (AxiomInstCo con2 ind2 cos2) = con1 == con2 && ind1 == ind2 && all2 coercionSyntaxEq cos1 cos2 coercionSyntaxEq (LRCo lr1 co1)          (LRCo lr2 co2)          = lr1 == lr2 && coercionSyntaxEq co1 co2 coercionSyntaxEq (UnivCo role1 ty11 ty12) (UnivCo role2 ty21 ty22) = role1 == role2 && typeSyntaxEq ty11 ty21 && typeSyntaxEq ty12 ty22-#else-coercionSyntaxEq (AxiomInstCo con1 cos1) (AxiomInstCo con2 cos2) = con1 == con2 && all2 coercionSyntaxEq cos1 cos2-coercionSyntaxEq (UnsafeCo ty11 ty12)    (UnsafeCo ty21 ty22)    = typeSyntaxEq ty11 ty21 && typeSyntaxEq ty12 ty22-#endif+coercionSyntaxEq (SubCo co1)             (SubCo co2)             = coercionSyntaxEq co1 co2 coercionSyntaxEq (SymCo co1)             (SymCo co2)             = coercionSyntaxEq co1 co2 coercionSyntaxEq (TransCo co11 co12)     (TransCo co21 co22)     = coercionSyntaxEq co11 co21 && coercionSyntaxEq co12 co22 coercionSyntaxEq (NthCo n1 co1)          (NthCo n2 co2)          = n1 == n2 && coercionSyntaxEq co1 co2@@ -308,8 +299,7 @@ freeVarsBind :: CoreBind -> VarSet freeVarsBind (NonRec v e) = freeVarsExpr e `unionVarSet` freeVarsVar v freeVarsBind (Rec defs)   = let (bs,es) = unzip defs-                             in delVarSetList (unionVarSets $ map freeVarsExpr es) bs-                                `unionVarSet`  unionVarSets (map freeVarsVar bs)+                             in delVarSetList (unionVarSets (map freeVarsVar bs ++ map freeVarsExpr es)) bs  -- | Find all free variables on a binder. Equivalent to idFreeVars, but safe to call on type bindings. freeVarsVar :: Var -> VarSet@@ -380,30 +370,33 @@ splitTyConAppM :: Monad m => Type -> m (TyCon, [Type]) splitTyConAppM = maybeM "splitTyConApp failed." . splitTyConApp_maybe --- | Return the domain and codomain types of a function type, if it is a function type.-splitFunTypeM :: Monad m => Type -> m (Type,Type)-splitFunTypeM = maybeM "not a function type." . splitFunTy_maybe+-- | Get the quantified variables, domain, and codomain of a function type.+splitFunTypeM :: MonadCatch m => Type -> m ([TyVar], Type, Type)+splitFunTypeM ty = prefixFailMsg "Split function type failed: " $ do+    let (tvs, fTy) = splitForAllTys ty+    (argTy, resTy) <- maybeM "not a function type." $ splitFunTy_maybe fTy+    return (tvs, argTy, resTy)  -- | Return the domain/codomain type of an endofunction type.-endoFunType :: Monad m => Type -> m Type-endoFunType ty =-  do (ty1,ty2) <- splitFunTypeM ty+endoFunTypeM :: MonadCatch m => Type -> m ([TyVar], Type)+endoFunTypeM ty =+  do (tvs,ty1,ty2) <- splitFunTypeM ty      guardMsg (eqType ty1 ty2) ("argument and result types differ.")-     return ty1+     return (tvs, ty1)  -- | Return the domain/codomain type of an endofunction expression.-endoFunExprType :: Monad m => CoreExpr -> m Type-endoFunExprType = exprTypeM >=> endoFunType+endoFunExprTypeM :: MonadCatch m => CoreExpr -> m ([TyVar], Type)+endoFunExprTypeM = exprTypeM >=> endoFunTypeM  -- | Return the domain and codomain types of a function expression.-funExprArgResTypes :: Monad m => CoreExpr -> m (Type,Type)-funExprArgResTypes = exprTypeM >=> splitFunTypeM+funExprArgResTypesM :: MonadCatch m => CoreExpr -> m ([TyVar],Type,Type)+funExprArgResTypesM = exprTypeM >=> splitFunTypeM  -- | Check two expressions have types @a -> b@ and @b -> a@, returning @(a,b)@. funExprsWithInverseTypes :: MonadCatch m => CoreExpr -> CoreExpr -> m (Type,Type) funExprsWithInverseTypes f g =-  do (fdom,fcod) <- funExprArgResTypes f-     (gdom,gcod) <- funExprArgResTypes g+  do (_,fdom,fcod) <- funExprArgResTypesM f -- TODO: don't throw away TyVars+     (_,gdom,gcod) <- funExprArgResTypesM g      setFailMsg "functions do not have inverse types." $        do guardM (eqType fdom gcod)           guardM (eqType gdom fcod)

@@ -20,6 +20,7 @@     , module HERMIT.Dictionary.Undefined     , module HERMIT.Dictionary.Unfold     , module HERMIT.Dictionary.Unsafe+    , module HERMIT.Dictionary.WorkerWrapper.Common -- TODO: rename     , module HERMIT.Dictionary.WorkerWrapper.Fix     , module HERMIT.Dictionary.WorkerWrapper.FixResult     ) where@@ -64,6 +65,8 @@ import qualified HERMIT.Dictionary.Unfold as Unfold import           HERMIT.Dictionary.Unsafe hiding (externals) import qualified HERMIT.Dictionary.Unsafe as Unsafe+import           HERMIT.Dictionary.WorkerWrapper.Common hiding (externals)+import qualified HERMIT.Dictionary.WorkerWrapper.Common as WorkerWrapperCommon import           HERMIT.Dictionary.WorkerWrapper.Fix hiding (externals) import qualified HERMIT.Dictionary.WorkerWrapper.Fix as WorkerWrapperFix import           HERMIT.Dictionary.WorkerWrapper.FixResult hiding (externals)@@ -92,6 +95,7 @@     ++ Undefined.externals     ++ Unfold.externals     ++ Unsafe.externals+    ++ WorkerWrapperCommon.externals     ++ WorkerWrapperFix.externals     ++ WorkerWrapperFixResult.externals 

@@ -1,50 +1,47 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} module HERMIT.Dictionary.AlphaConversion-       ( -- * Alpha-Renaming and Shadowing-         externals-         -- ** Alpha-Renaming-       , alphaR-       , alphaLamR-       , alphaCaseBinderR-       , alphaAltWithR-       , alphaAltVarsR-       , alphaAltR-       , alphaCaseR-       , alphaLetWithR-       , alphaLetVarsR-       , alphaLetR-       , alphaProgConsWithR-       , alphaProgConsIdsR-       , alphaProgConsR-       , alphaProgR-         -- ** Shadow Detection and Unshadowing-       , unshadowR-       , unshadowExprR-       , unshadowAltR-       , unshadowProgR-       , visibleVarsT-       , cloneVarAvoidingT---       , freshNameGenAvoidingT-       , freshNameGenAvoiding-       , detectShadowsM-       , replaceVarR-       )-where+    ( -- * Alpha-Renaming and Shadowing+      externals+      -- ** Alpha-Renaming+    , alphaR+    , alphaLamR+    , alphaCaseBinderR+    , alphaAltWithR+    , alphaAltVarsR+    , alphaAltR+    , alphaCaseR+    , alphaLetWithR+    , alphaLetVarsR+    , alphaLetR+    , alphaProgConsWithR+    , alphaProgConsIdsR+    , alphaProgConsR+    , alphaProgR+      -- ** Shadow Detection and Unshadowing+    , unshadowR+    , unshadowExprR+    , unshadowAltR+    , unshadowProgR+    , visibleVarsT+    , cloneVarAvoidingT+    , freshNameGenAvoiding+    , detectShadowsM+    , replaceVarR+    ) where -import Control.Applicative import Control.Arrow-import Control.Monad (liftM2)+import Control.Monad (liftM, liftM2) import Data.Char (isDigit) import Data.Function (on)-import Data.List (intersect)-import Data.Maybe (fromMaybe, listToMaybe)+import Data.List (intersect, delete, elemIndex)+import Data.Maybe (listToMaybe)  import HERMIT.Core import HERMIT.Context-import HERMIT.Monad import HERMIT.Kure import HERMIT.External import HERMIT.GHC+import HERMIT.Name import HERMIT.Utilities(dupsBy)  import HERMIT.Dictionary.GHC hiding (externals)@@ -106,7 +103,7 @@  -- | 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.-cloneVarAvoidingT :: BoundVars c => Var -> Maybe String -> [Var] -> Transform c HermitM CoreTC Var+cloneVarAvoidingT :: (BoundVars c, MonadUnique m) => Var -> Maybe String -> [Var] -> Transform c m CoreTC Var cloneVarAvoidingT v mn vs =   do vvs <- visibleVarsT      let nameModifier = freshNameGenAvoiding mn (extendVarSetList vvs vs)@@ -125,7 +122,7 @@                      , nm `notElem` names                      ]    where-           names = map uqName (varSetElems curr)+           names = varSetToStrings curr            nums = reverse $ takeWhile isDigit (reverse old)            baseLeng = length $ drop (length nums) old            base = take baseLeng old@@ -136,8 +133,8 @@  -- | Discard variables from the first set that do not shadow a variable in the second set. shadowedBy :: VarSet -> VarSet -> VarSet-shadowedBy vs fvs = let fvUqNames = map uqName (varSetElems fvs)-                     in filterVarSet (\ v -> uqName v `elem` fvUqNames) vs+shadowedBy vs fvs = let fvNames = varSetToStrings fvs+                     in filterVarSet (\ v -> unqualifiedName v `elem` fvNames) vs  -- | Shadows are any duplicates in the list, or any occurrences of the list elements in the set. detectShadowsM :: Monad m => [Var] -> VarSet -> m VarSet@@ -147,72 +144,86 @@  -- | Rename local variables with manifestly unique names (x, x0, x1, ...). --   Does not rename top-level definitions.-unshadowR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb)-          => Rewrite c HermitM Core+unshadowR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c+             , ReadPath c Crumb, MonadCatch m, MonadUnique m )+          => Rewrite c m Core unshadowR = setFailMsg "No shadows to eliminate." $     anytdR (promoteExprR unshadowExprR <+ promoteAltR unshadowAltR <+ promoteProgR unshadowProgR) -unshadowExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb)-              => Rewrite c HermitM CoreExpr+unshadowExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m)+              => Rewrite c m CoreExpr unshadowExprR = do-    bs  <- letVarsT <+ (return <$> (caseBinderIdT <+ lamVarT))-    fvs <- unionVarSet <$> boundVarsT <*> arr freeVarsExpr+    bs  <- letVarsT <+ (liftM return (caseBinderIdT <+ lamVarT))+    fvs <- liftM2 unionVarSet boundVarsT (arr freeVarsExpr)     ss  <- detectShadowsM bs fvs     alphaLamR Nothing <+ alphaLetVarsR (varSetElems ss) <+ alphaCaseBinderR Nothing -unshadowAltR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb)-             => Rewrite c HermitM CoreAlt+unshadowAltR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m)+             => Rewrite c m CoreAlt unshadowAltR = do     bs  <- arr altVars-    fvs <- unionVarSet <$> boundVarsT <*> arr freeVarsAlt+    fvs <- liftM2 unionVarSet boundVarsT (arr freeVarsAlt)     ss  <- detectShadowsM bs fvs     alphaAltVarsR (varSetElems ss) -unshadowProgR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb)-              => Rewrite c HermitM CoreProg+unshadowProgR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m)+              => Rewrite c m CoreProg unshadowProgR = do     bs  <- progConsIdsT-    fvs <- unionVarSet <$> boundVarsT <*> arr freeVarsProg+    fvs <- liftM2 unionVarSet boundVarsT (arr freeVarsProg)     ss  <- detectShadowsM bs fvs     alphaProgConsIdsR (varSetElems ss)  dupVars :: [Var] -> [Var]-dupVars = dupsBy ((==) `on` uqName)+dupVars = dupsBy ((==) `on` unqualifiedName)  ----------------------------------------------------------------------- --- Maybe this should be defined elsewhere.+-- Maybe this should be defined in Dictionary.GHC.  -- | Replace all occurrences of a specified variable. --   Arguments are the variable to replace and the replacement variable, respectively. replaceVarR :: (Injection a Core, MonadCatch m) => Var -> Var -> Rewrite c m a replaceVarR v v' = extractR $ tryR $ substR v $ varToCoreExpr v' --- | Given a variable to replace, and a replacement, produce a 'Var' @->@ 'Var' function that---   acts as an identity for all 'Var's except the one to replace, for which it returns the replacment.---   Don't export this, it'll likely just cause confusion.-replaceVar :: Var -> Var -> (Var -> Var)-replaceVar v v' = replaceVars [(v,v')]+-- TODO: Experimental+replaceRecBindVarR :: Monad m => Id -> Id -> Rewrite c m CoreBind+replaceRecBindVarR v v' =+   do Rec ies <- idR+      let (is,es) = unzip ies+      case elemIndex v is of+        Nothing -> fail "Specified identifier does not occur in the current recursive binding group."+        Just n  -> let is0       = delete v is+                       (is1,is2) = splitAt n is0+                       is'       = is1 ++ v' : is2+                       es'       = map (substCoreExpr v (Var v')) es+                       -- TODO.  Do we need to initialize the emptySubst with bindFreeVars?+                       sub       = extendSubst emptySubst v (Var v')+                   in return $ snd $ substBind sub (Rec (zip is' es')) --- | Given a lists of variables to replace, and their replacements, produce a 'Var' @->@ 'Var' function that---   acts as in identity for all 'Var's except the ones to replace, for which it returns the replacment.---   Don't export this, it'll likely just cause confusion.-replaceVars :: [(Var,Var)] -> (Var -> Var)-replaceVars kvs v = fromMaybe v (lookup v kvs)+                   -- let is0       = delete v is+                   --     emptySub  = mkEmptySubst $ mkInScopeSet $ unionVarSets (map (localFreeVarsExpr . Var) is0)+                   --     sub       = extendSubst emptySub v (Var v')+                   --     (is1,is2) = splitAt n (snd $ substRecBndrs sub is0)+                   --     is'       = is1 ++ v' : is2+                   --     es'       = map (substCoreExpr v (Var v')) es+                   -- in return $ Rec (zip is' es')  -----------------------------------------------------------------------  -- | Alpha rename a lambda binder.  Optionally takes a suggested new name.-alphaLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Rewrite c HermitM CoreExpr+alphaLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+          => Maybe String -> Rewrite c m CoreExpr alphaLamR mn = setFailMsg (wrongFormForAlpha "Lam v e") $               do v  <- lamVarT                  v' <- extractT (cloneVarAvoidingT v mn [v])-                 lamAnyR (arr $ replaceVar v v') (replaceVarR v v')+                 lamAnyR (return v') (replaceVarR v v')  -----------------------------------------------------------------------  -- | Alpha rename a case binder.  Optionally takes a suggested new name.-alphaCaseBinderR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Rewrite c HermitM CoreExpr+alphaCaseBinderR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+                 => Maybe String -> Rewrite c m CoreExpr alphaCaseBinderR mn = setFailMsg (wrongFormForAlpha "Case e i ty alts") $                      do i  <- caseBinderIdT                         i' <- extractT (cloneVarAvoidingT i mn [i])@@ -221,7 +232,8 @@ -----------------------------------------------------------------------  -- | Rename the specified variable in a case alternative.  Optionally takes a suggested new name.-alphaAltVarR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Var -> Rewrite c HermitM CoreAlt+alphaAltVarR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+             => Maybe String -> Var -> Rewrite c m CoreAlt alphaAltVarR mn v = do     (con, vs, rhs) <- idR     v' <- extractT (cloneVarAvoidingT v mn vs)@@ -238,129 +250,150 @@  -- | Rename the specified variables in a case alternative, using the suggested names where provided. -- Suggested names *must* be provided in left-to-right order matching the order of the alt binders.-alphaAltVarsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe String,Var)] -> Rewrite c HermitM CoreAlt+alphaAltVarsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+                  => [(Maybe String,Var)] -> Rewrite c m CoreAlt alphaAltVarsWithR = andR . map (uncurry alphaAltVarR) . reverse -- note: right-to-left so type subst aren't undone  -- | Rename the variables bound in a case alternative with the given list of suggested names.-alphaAltWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [String] -> Rewrite c HermitM CoreAlt+alphaAltWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+              => [String] -> Rewrite c m CoreAlt alphaAltWithR ns =   do vs <- arr altVars      alphaAltVarsWithR $ zip (map Just ns) vs  -- | Rename the specified variables in a case alternative.-alphaAltVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreAlt+alphaAltVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+              => [Var] -> Rewrite c m CoreAlt alphaAltVarsR vs =   do bs <- arr altVars      alphaAltVarsWithR (zip (repeat Nothing) (bs `intersect` vs))  -- | Rename all identifiers bound in a case alternative.-alphaAltR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreAlt+alphaAltR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+          => Rewrite c m CoreAlt alphaAltR = arr altVars >>= alphaAltVarsR  -----------------------------------------------------------------------  -- | Rename all identifiers bound in a case expression.-alphaCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+alphaCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+           => Rewrite c m CoreExpr alphaCaseR = alphaCaseBinderR Nothing >+> caseAllR idR idR idR (const alphaAltR)  -----------------------------------------------------------------------  -- | Alpha rename a non-recursive let binder.  Optionally takes a suggested new name.-alphaLetNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Rewrite c HermitM CoreExpr+alphaLetNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+                => Maybe String -> Rewrite c m CoreExpr alphaLetNonRecR mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $                     do v  <- letNonRecVarT                        v' <- extractT (cloneVarAvoidingT v mn [v])                        letNonRecAnyR (return v') idR (replaceVarR v v')  -- | Alpha rename a non-recursive let binder if the variable appears in the argument list.  Optionally takes a suggested new name.-alphaLetNonRecVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> [Var] -> Rewrite c HermitM CoreExpr-alphaLetNonRecVarsR mn vs = whenM ((`elem` vs) <$> letNonRecVarT) (alphaLetNonRecR mn)+alphaLetNonRecVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+                    => Maybe String -> [Var] -> Rewrite c m CoreExpr+alphaLetNonRecVarsR mn vs = whenM (liftM (`elem` vs) letNonRecVarT) (alphaLetNonRecR mn)   -- TODO: Maybe it would be more efficient to rename all the Ids at once, rather than one by one?  -- | Rename the specified identifiers in a recursive let, using the suggested names where provided.-alphaLetRecIdsWithR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe String,Id)] -> Rewrite c HermitM CoreExpr+alphaLetRecIdsWithR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                                   , BoundVars c, MonadCatch m, MonadUnique m )+                    => [(Maybe String,Id)] -> Rewrite c m CoreExpr alphaLetRecIdsWithR = andR . map (uncurry alphaLetRecIdR)   where     -- | Rename the specified identifier bound in a recursive let.  Optionally takes a suggested new name.-    alphaLetRecIdR :: Maybe String -> Id -> Rewrite c HermitM CoreExpr+    alphaLetRecIdR :: Maybe String -> Id -> Rewrite c m CoreExpr     alphaLetRecIdR mn i = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $                      do is <- letRecIdsT                         i' <- extractT (cloneVarAvoidingT i mn is)-                        letRecDefAnyR (\ _ -> (arr (replaceVar i i'), replaceVarR i i')) (replaceVarR i i')+                        letAnyR (replaceRecBindVarR i i') (replaceVarR i i')   -- | Rename the identifiers bound in a Let with the given list of suggested names.-alphaLetWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [String] -> Rewrite c HermitM CoreExpr+alphaLetWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+              => [String] -> Rewrite c m CoreExpr alphaLetWithR ns = alphaLetNonRecR (listToMaybe ns)                   <+ (letRecIdsT >>= (alphaLetRecIdsWithR . zip (map Just ns)))  -- | Rename the specified variables bound in a let.-alphaLetVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreExpr+alphaLetVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+              => [Var] -> Rewrite c m CoreExpr alphaLetVarsR vs = alphaLetNonRecVarsR Nothing vs                    <+ (do bs <- letT (arr bindVars) successT const                           alphaLetRecIdsWithR (zip (repeat Nothing) (bs `intersect` vs))                       )  -- | Rename all identifiers bound in a Let.-alphaLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+alphaLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+          => Rewrite c m CoreExpr alphaLetR = letVarsT >>= alphaLetVarsR  -----------------------------------------------------------------------  -- | Alpha rename a non-recursive top-level binder.  Optionally takes a suggested new name.-alphaProgConsNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Rewrite c HermitM CoreProg+alphaProgConsNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+                     => Maybe String -> Rewrite c m CoreProg alphaProgConsNonRecR mn = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $                     do i <- progConsNonRecIdT-                       guardMsg (not $ isExportedId i) ("Identifier " ++ var2String i ++ " is exported, and thus cannot be alpha-renamed.")+                       guardMsg (not $ isExportedId i) ("Identifier " ++ unqualifiedName i ++ " is exported, and thus cannot be alpha-renamed.")                        i' <- extractT (cloneVarAvoidingT i mn [i])                        consNonRecAnyR (return i') idR (replaceVarR i i')  -- | Alpha rename a non-recursive top-level binder if the identifier appears in the argument list.  Optionally takes a suggested new name.-alphaProgConsNonRecIdsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> [Id] -> Rewrite c HermitM CoreProg-alphaProgConsNonRecIdsR mn is = whenM ((`elem` is) <$> progConsNonRecIdT) (alphaProgConsNonRecR mn)+alphaProgConsNonRecIdsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+                        => Maybe String -> [Id] -> Rewrite c m CoreProg+alphaProgConsNonRecIdsR mn is = whenM (liftM (`elem` is) progConsNonRecIdT) (alphaProgConsNonRecR mn)  -- TODO: Maybe it would be more efficient to rename all the Ids at once, rather than one by one?  -- | Rename the specified identifiers in a recursive top-level binding at the head of a program, using the suggested names where provided.-alphaProgConsRecIdsWithR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe String,Id)] -> Rewrite c HermitM CoreProg+alphaProgConsRecIdsWithR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                                        , BoundVars c, MonadCatch m, MonadUnique m )+                         => [(Maybe String,Id)] -> Rewrite c m CoreProg alphaProgConsRecIdsWithR = andR . map (uncurry alphaProgConsRecIdR) . filter (not . isExportedId . snd)   where     -- | Rename the specified identifier bound in a recursive top-level binder.  Optionally takes a suggested new name.-    alphaProgConsRecIdR :: Maybe String -> Id -> Rewrite c HermitM CoreProg+    alphaProgConsRecIdR :: Maybe String -> Id -> Rewrite c m CoreProg     alphaProgConsRecIdR mn i =  setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $                       do is <- progConsRecIdsT                          i' <- extractT (cloneVarAvoidingT i mn is)-                         consRecDefAnyR (\ _ -> (arr (replaceVar i i'), replaceVarR i i')) (replaceVarR i i')+                         progConsAnyR (replaceRecBindVarR i i') (replaceVarR i i')   -- | Rename the identifiers bound in the top-level binding at the head of the program with the given list of suggested names.-alphaProgConsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [String] -> Rewrite c HermitM CoreProg+alphaProgConsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+                   => [String] -> Rewrite c m CoreProg alphaProgConsWithR ns = alphaProgConsNonRecR (listToMaybe ns)                         <+ (progConsRecIdsT >>= (alphaProgConsRecIdsWithR . zip (map Just ns)))  -- | Rename the specified variables bound in the top-level binding at the head of the program.-alphaProgConsIdsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Id] -> Rewrite c HermitM CoreProg+alphaProgConsIdsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+                  => [Id] -> Rewrite c m CoreProg alphaProgConsIdsR vs = alphaProgConsNonRecIdsR Nothing vs                        <+ (do bs <- progConsT (arr bindVars) successT const                               alphaProgConsRecIdsWithR (zip (repeat Nothing) (bs `intersect` vs))                           )  -- | Rename all identifiers bound in the top-level binding at the head of the program.-alphaProgConsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreProg+alphaProgConsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+               => Rewrite c m CoreProg alphaProgConsR = progConsIdsT >>= alphaProgConsIdsR  -----------------------------------------------------------------------  -- | Rename all identifiers bound at the top-level.-alphaProgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreProg+alphaProgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+           => Rewrite c m CoreProg alphaProgR = alphaProgConsR >+> progConsAllR idR alphaProgR  -----------------------------------------------------------------------  -- | Alpha rename any bindings at this node.  Note: does not rename case alternatives unless invoked on the alternative.-alphaR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core+alphaR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+       => Rewrite c m Core alphaR = setFailMsg "Cannot alpha-rename here." $            promoteExprR (alphaLamR Nothing <+ alphaCaseBinderR Nothing <+ alphaLetR)         <+ promoteAltR alphaAltR

@@ -13,8 +13,6 @@     , callNameG     , callDataConT     , callDataConNameT-    , callsR-    , callsT       -- ** Collecting variable bindings     , progConsIdsT     , progConsRecIdsT@@ -32,11 +30,9 @@     , boundVarsT     , findBoundVarT     , findIdT-#if __GLASGOW_HASKELL__ > 706     , findVarT     , findTyConT     , findTypeT-#endif     , varBindingDepthT     , varIsOccurrenceOfT     , exprIsOccurrenceOfT@@ -63,9 +59,9 @@  ------------------------------------------------------------------------------ --- | Apply a transformation to a value in the current context.+-- | apply a transformation to a value in the current context. applyInContextT :: Transform c m a b -> a -> Transform c m x b-applyInContextT t a = contextonlyT $ \ c -> apply t c a+applyInContextT t a = contextonlyT $ \ c -> applyT t c a  -- Note: this is the same as: return a >>> t @@ -78,6 +74,7 @@                                 App {} -> return (collectArgs e)                                 _      -> fail "not an application or variable occurence." +-- | Succeeds if we are looking at an application matching the given predicate. callPredT :: Monad m => (Id -> [CoreExpr] -> Bool) -> Transform c m CoreExpr (CoreExpr, [CoreExpr]) callPredT p = do     call@(Var i, args) <- callT@@ -86,9 +83,11 @@  -- | Succeeds if we are looking at an application of given function --   returning zero or more arguments to which it is applied.-callNameT :: MonadCatch m => String -> Transform c m CoreExpr (CoreExpr, [CoreExpr])-callNameT nm = setFailMsg ("callNameT failed: not a call to '" ++ nm ++ ".") $-    callPredT (const . cmpString2Var nm)+--+-- Note: comparison is performed with cmpHN2Var.+callNameT :: MonadCatch m => HermitName -> Transform c m CoreExpr (CoreExpr, [CoreExpr])+callNameT nm = prefixFailMsg ("callNameT failed: not a call to '" ++ show nm ++ ".")+             $ callPredT (const . cmpHN2Var nm)  -- | Succeeds if we are looking at a fully saturated function call. callSaturatedT :: Monad m => Transform c m CoreExpr (CoreExpr, [CoreExpr])@@ -97,20 +96,15 @@ --       idArity is conservatively set to zero by default.  -- | Succeeds if we are looking at an application of given function-callNameG :: MonadCatch m => String -> Transform c m CoreExpr ()-callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >>= \_ -> constT (return ())+callNameG :: MonadCatch m => HermitName -> Transform c m CoreExpr ()+callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >> return ()  -- | Succeeds if we are looking at an application of a data constructor. callDataConT :: MonadCatch m => Transform c m CoreExpr (DataCon, [Type], [CoreExpr]) callDataConT = prefixFailMsg "callDataConT failed:" $-#if __GLASGOW_HASKELL__ > 706     do mb <- contextfreeT $ \ e -> let in_scope = mkInScopeSet (mkVarEnv [ (v,v) | v <- varSetElems (localFreeVarsExpr e) ])                                    in return $ exprIsConApp_maybe (in_scope, idUnfolding) e        maybe (fail "not a datacon application.") return mb-#else-    contextfreeT (return . exprIsConApp_maybe idUnfolding)-        >>= maybe (fail "not a datacon application.") return-#endif  -- | Succeeds if we are looking at an application of a named data constructor. callDataConNameT :: MonadCatch m => String -> Transform c m CoreExpr (DataCon, [Type], [CoreExpr])@@ -119,16 +113,6 @@     guardMsg (cmpString2Name nm (dataConName dc)) "wrong datacon."     return res --- TODO: Both callsR and callsT should be eliminated, now that we have callNameT--- | Apply a rewrite to all applications of a given function in a top-down manner, pruning on success.-callsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => String -> Rewrite c m CoreExpr -> Rewrite c m Core-callsR nm rr = prunetdR (promoteExprR $ callNameG nm >> rr)---- | Apply a translate to all applications of a given function in a top-down manner,---   pruning on success, collecting the results.-callsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => String -> Transform c m CoreExpr b -> Transform c m Core [b]-callsT nm t = collectPruneT (promoteExprT $ callNameG nm >> t)- ------------------------------------------------------------------------------  -- | List the identifiers bound by the top-level binding group at the head of the program.@@ -200,35 +184,39 @@ boundVarsT = contextonlyT (return . boundVars)  -- | Find the unique variable bound in the context that matches the given name, failing if it is not unique.-findBoundVarT :: (BoundVars c, MonadCatch m) => String -> Transform c m a Var-findBoundVarT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $-                        do c <- contextT-                           case varSetElems (findBoundVars nm c) of-                             []         -> fail "no matching variables in scope."-                             [v]        -> return v-                             _ : _ : _  -> fail "multiple matching variables in scope."+findBoundVarT :: (BoundVars c, MonadCatch m) => (Var -> Bool) -> Transform c m a Var+findBoundVarT p = do+    c <- contextT+    case varSetElems (findBoundVars p c) of+        []         -> fail "no matching variables in scope."+        [v]        -> return v+        _ : _ : _  -> fail "multiple matching variables in scope."  --------------------------------------------------------------------------------------------------  -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.-findIdT :: (BoundVars c, HasModGuts m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> Transform c m a Id-findIdT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ contextonlyT (findId nm)+findIdT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)+        => HermitName -> Transform c m a Id+findIdT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findId nm) -#if __GLASGOW_HASKELL__ > 706 -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.-findVarT :: (BoundVars c, HasModGuts m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> Transform c m a Var-findVarT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ contextonlyT (findVar nm)+findVarT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)+         => HermitName -> Transform c m a Var+findVarT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findVar nm)  -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.-findTyConT :: (BoundVars c, HasModGuts m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> Transform c m a TyCon-findTyConT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ contextonlyT (findTyCon nm)+findTyConT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)+           => HermitName -> Transform c m a TyCon+findTyConT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findTyCon nm)  -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.-findTypeT :: (BoundVars c, HasModGuts m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> Transform c m a Type-findTypeT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ contextonlyT (findType nm)-#endif+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@@ -241,7 +229,7 @@  -- | 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-withVarsInScope vs t = transform $ apply t . flip (foldl (flip addLambdaBinding)) vs -- careful to add left-to-right+withVarsInScope vs t = transform $ applyT t . flip (foldl (flip addLambdaBinding)) vs -- careful to add left-to-right  ------------------------------------------------------------------------------ 

@@ -8,17 +8,22 @@     , bashR     , bashExtendedWithR     , bashDebugR-    )-where+    , smashR+    , smashUsingR+    , smashExtendedWithR+    ) where  import Control.Arrow +import Data.String (fromString)+ import HERMIT.Context import HERMIT.Core+import HERMIT.External import HERMIT.GHC-import HERMIT.Monad import HERMIT.Kure-import HERMIT.External+import HERMIT.Monad+import HERMIT.Name  import HERMIT.Dictionary.Debug hiding (externals) import HERMIT.Dictionary.GHC hiding (externals)@@ -31,7 +36,8 @@ externals ::  [External] externals =     [ external "unfold-basic-combinator" (promoteExprR unfoldBasicCombinatorR :: RewriteH Core)-        [ "Unfold the current expression if it is one of the basic combinators: ($), (.), id, flip, const, fst or snd." ]+        [ "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)         [ "innermost (unfold-basic-combinator <+ beta-reduce-plus <+ safe-let-subst <+ case-reduce <+ let-elim)" ]     , external "bash" (bashR :: RewriteH Core)@@ -52,16 +58,20 @@  ------------------------------------------------------------------------------------------------------ -basicCombinators :: [String]-basicCombinators = ["$",".","id","flip","const","fst","snd","curry","uncurry"]+basicCombinators :: [HermitName]+basicCombinators = map fromString ["$",".","id","flip","const","fst","snd","curry","uncurry"] --- | Unfold the current expression if it is one of the basic combinators: ('$'), ('.'), 'id', 'flip', 'const', 'fst' or 'snd'.+-- | Unfold the current expression if it is one of the basic combinators:+-- ('$'), ('.'), 'id', 'flip', 'const', 'fst', 'snd', 'curry', and 'uncurry'. --   This is intended to be used as a component of simplification traversals such as 'simplifyR' or 'bashR'.-unfoldBasicCombinatorR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr-unfoldBasicCombinatorR = setFailMsg "unfold-basic-combinator failed." $-     unfoldNamesR basicCombinators+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 -simplifyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM Core+simplifyR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+             , MonadCatch m, MonadUnique m )+          => Rewrite c m Core simplifyR = setFailMsg "Simplify failed: nothing to simplify." $     innermostR (   promoteBindR recToNonrecR                 <+ promoteExprR ( unfoldBasicCombinatorR@@ -73,80 +83,68 @@  ------------------------------------------------------------------------------------------------------ -bashR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM Core+-- | Bash is intended as a general-purpose cleanup/simplification command.+-- It performs rewrites such as let floating, case floating, and case elimination, when safe.+-- It also performs dead binding elimination and case reduction, and unfolds a number of+-- basic combinators. See 'bashComponents' for a list of rewrites performed.+-- Bash also performs occurrence analysis and de-zombification on the result, to update+-- 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 bashR = bashExtendedWithR [] -bashExtendedWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core+-- | 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 bashExtendedWithR rs = bashUsingR (rs ++ map fst bashComponents) --smashR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM Core-smashR = smashExtendedWithR []--smashExtendedWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core-smashExtendedWithR rs = smashUsingR (rs ++ map fst smashComponents1) (map fst smashComponents2)----- | Like bashR, but outputs name of each successful sub-rewrite, providing a log.+-- | Like 'bashR', but outputs name of each successful sub-rewrite, providing a log. -- Also performs core lint on the result of a successful sub-rewrite. -- If core lint fails, shows core fragment before and after the sub-rewrite which introduced the problem. -- Note: core fragment which fails linting is still returned! Otherwise would behave differently than bashR. -- Useful for debugging the bash command itself.-bashDebugR :: RewriteH Core-bashDebugR = bashUsingR [ idR >>= \e -> r >>> traceR nm >>> (catchM (promoteT lintExprT >> idR)-                                                                    (\s -> do _ <- return e >>> observeR "[before]"-                                                                              observeR ("[" ++ nm ++ "]\n" ++ s)))+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+bashDebugR = bashUsingR [ bracketR nm r >>> catchM (promoteT lintExprT >> idR) traceR                         | (r,nm) <- bashComponents ] --- bashUsingR :: forall c m. (ExtendPath c Crumb, AddBindings c, MonadCatch m) => [Rewrite c m Core] -> Rewrite c m Core--- bashUsingR rs =---     setFailMsg "bash failed: nothing to do." $---     readerT $ \ core1 -> occurAnalyseR >>> readerT (\ core2 -> if core1 `coreSyntaxEq` core2---                                                                  then bashCoreR      -- equal, no progress yet---                                                                  else tryR bashCoreR -- unequal, progress has already been made---                                                    )---   -- the changedByR combinator doesn't quite do what we need here---   where---     bashCoreR :: Rewrite c m Core---     bashCoreR = repeatR (innermostR (catchesT rs) >>> occurAnalyseR)--bashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => [Rewrite c m Core] -> Rewrite c m Core-bashUsingR rs =-    setFailMsg "bash failed: nothing to do." $+-- | 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+bashUsingR rs = setFailMsg "bash failed: nothing to do." $     repeatR (occurAnalyseR >>> onetdR (catchesT rs)) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR -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 rs1 rs2 =-    setFailMsg "smash failed: nothing to do." $-    repeatR (occurAnalyseR >>> (onetdR (catchesT rs1) <+ onetdR (catchesT rs2))) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR--- --   occurAnalyseChangedR >+> (innermostR (catchesT rs) >>> occurAnalyseR)- {- Occurrence Analysis updates meta-data, as well as performing some basic simplifications. occurAnalyseR always succeeds, whereas occurAnalyseChangedR fails is the result is syntactically equivalent. The awkwardness is because:   - we want bash to fail if nothing changes-  - we want bash to succeed if the result is not syntactically-equivalent (ideally, if any changes are made at all, but that's not the case yet)+  - we want bash to succeed if the result is not syntactically-equivalent+    (ideally, if any changes are made at all, but that's not the case yet)   - we want bash to update the meta-data   - after running bash there should be nothing left to do (i.e. an immediately subsequent bash should always fail) -Also, it's still possible for some meta-data to be out-of-date after bash, despite the case analysis.  For example, if the focal point is a case-alt rhs, this won't update the identifer info of variables bound in the alternative.+Also, it's still possible for some meta-data to be out-of-date after bash, despite the case analysis.+For example, if the focal point is a case-alt rhs, this won't update the identifer info of variables+bound in the alternative. -}  bashHelp :: [String]-bashHelp = "Iteratively apply the following rewrites until nothing changes:" : map snd (bashComponents-                                                                                         :: [(RewriteH Core,String)] -- to resolve ambiguity+bashHelp = "Iteratively apply the following rewrites until nothing changes:"+         : map snd (bashComponents :: [(RewriteH Core,String)] -- to resolve ambiguity                                                                                        )- -- TODO: Think about a good order for bash.-bashComponents :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [(Rewrite c HermitM Core, String)]+bashComponents :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+                  , MonadCatch m, MonadUnique m )+               => [(Rewrite c m Core, String)] bashComponents =   [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr")    -- ??     (promoteExprR betaReduceR, "beta-reduce")                        -- O(1)   , (promoteExprR (caseReduceR True), "case-reduce")                 -- O(n)-  , (promoteExprR (caseReduceIdR True), "case-reduce-id")            -- O(n)+  , (promoteExprR (caseReduceUnfoldR True), "case-reduce-unfold")    -- O(n)   , (promoteExprR caseElimSeqR, "case-elim-seq")   , (promoteExprR unfoldBasicCombinatorR, "unfold-basic-combinator") -- O(n)   , (promoteExprR inlineCaseAlternativeR, "inline-case-alternative") -- O(n)@@ -171,6 +169,28 @@   ]  +------------------------------------------------------------------------------------------------------++-- | Smash is a more powerful but less efficient version of bash.+-- Unlike bash, smash is not concerned with whether it duplicates work,+-- 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+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+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 rs1 rs2 =+    setFailMsg "smash failed: nothing to do." $+    repeatR (occurAnalyseR >>> (onetdR (catchesT rs1) <+ onetdR (catchesT rs2))) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR++ 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@@ -178,12 +198,14 @@   -- | As bash, but with "let-nonrec-subst" instead of "let-nonrec-subst-safe".-smashComponents1 :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [(Rewrite c HermitM Core, String)]+smashComponents1 :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+                    , MonadCatch m, MonadUnique m )+                 => [(Rewrite c m Core, String)] smashComponents1 =   [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr")    -- ??     (promoteExprR betaReduceR, "beta-reduce")                        -- O(1)   , (promoteExprR (caseReduceR True), "case-reduce")                 -- O(n)-  , (promoteExprR (caseReduceIdR True), "case-reduce-id")            -- O(n)+  , (promoteExprR (caseReduceUnfoldR True), "case-reduce-unfold")    -- O(n)   , (promoteExprR caseElimSeqR, "case-elim-seq")   , (promoteExprR unfoldBasicCombinatorR, "unfold-basic-combinator") -- O(n)   , (promoteExprR inlineCaseAlternativeR, "inline-case-alternative") -- O(n)@@ -207,14 +229,9 @@ --  , (promoteExprR dezombifyR, "dezombify")                           -- O(1) -- performed at the end   ] -smashComponents2 :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [(Rewrite c HermitM Core, String)]+smashComponents2 :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c+                    , MonadCatch m, MonadUnique m )+                 => [(Rewrite c m Core, String)] smashComponents2 =-  [-    (promoteExprR caseElimMergeAltsR, "case-elim-merge-alts") -- do this last, lest it prevent other simplifications-  ]----- (beta-reduce <+ case-reduce <+ case-reduce-id <+ case-elim-seq <+ unfold-basic-combinator <+ inline-case-alternative <+ eta-reduce <+ let-subst <+ case-float-app <+ case-float-case <+ case-float-let <+ case-float-cast <+ let-float-app <+ let-float-arg <+ let-float-lam <+ let-float-let <+ let-float-case <+ let-float-cast <+ let-float-top <+ cast-elim-refl <+ cast-elim-sym---------------------------------------------------------------------------------------------------------+    [ (promoteExprR caseElimMergeAltsR, "case-elim-merge-alts") -- do this last, lest it prevent other simplifications+    ]

@@ -1,48 +1,51 @@ {-# LANGUAGE FlexibleContexts #-} module HERMIT.Dictionary.Debug-       ( -- * Debugging Dictionarys-         externals-       , bracketR-       , observeR-       , observeFailureR-       , traceR-       )-where+    ( -- * Debugging Rewrites+      externals+    , bracketR+    , observeR+    , observeFailureR+    , traceR+    ) where  import Control.Arrow -import HERMIT.Kure+import HERMIT.Context+import HERMIT.Core import HERMIT.External+import HERMIT.Kure import HERMIT.Monad  -- | Exposed debugging 'External's. externals :: [External] externals = map (.+ Debug)-         [ external "trace" (traceR :: String -> RewriteH Core)-                [ "give a side-effect message as output when processing this command" ]-         , external "observe" (observeR :: String -> RewriteH Core)-                [ "give a side-effect message as output, and observe the value being processed" ]-         , external "observe-failure" (observeFailureR :: String -> RewriteH Core -> RewriteH Core)-                [ "give a side-effect message if the rewrite fails, including the failing input" ]-         , external "bracket" (bracketR :: String -> RewriteH Core -> RewriteH Core)-                [ "if given rewrite succeeds, see its input and output" ]-         ]+    [ external "trace" (traceR :: String -> RewriteH Core)+        [ "give a side-effect message as output when processing this command" ]+    , external "observe" (observeR :: String -> RewriteH Core)+        [ "give a side-effect message as output, and observe the value being processed" ]+    , external "observe-failure" (observeFailureR :: String -> RewriteH Core -> RewriteH Core)+        [ "give a side-effect message if the rewrite fails, including the failing input" ]+    , external "bracket" (bracketR :: String -> RewriteH Core -> RewriteH Core)+        [ "if given rewrite succeeds, see its input and output" ]+    ]  -- | If the 'Rewrite' fails, print out the 'Core', with a message.-observeFailureR :: Injection a CoreTC => String -> RewriteH a -> RewriteH a+observeFailureR :: (Injection a CoreTC, 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 => String -> RewriteH a-observeR msg = extractR $ sideEffectR $ \ cxt core ->-        sendDebugMessage $ DebugCore msg cxt core+observeR :: (Injection a CoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, Monad m)+         => String -> Rewrite c m a+observeR msg = extractR $ sideEffectR $ \ cxt -> sendDebugMessage . DebugCore msg cxt  -- | Just say something, every time the rewrite is done.-traceR :: String -> RewriteH a+traceR :: (HasDebugChan m, Monad m) => String -> Rewrite c m a traceR msg = sideEffectR $ \ _ _ -> sendDebugMessage $ DebugTick msg  -- | Show before and after a rewrite.-bracketR :: Injection a CoreTC => String -> RewriteH a -> RewriteH a+bracketR :: (Injection a CoreTC, 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.     (e,r) <- idR &&& attemptM rr

@@ -1,25 +1,25 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}  module HERMIT.Dictionary.FixPoint-       ( -- * Operations on the Fixed Point Operator (fix)-         -- | Note that many of these operations require 'Data.Function.fix' to be explicitly imported, if it is not used in the source file.-         HERMIT.Dictionary.FixPoint.externals-         -- ** Rewrites and BiRewrites on Fixed Points-       , fixIntroR-       , fixComputationRuleBR-       , fixRollingRuleBR-       , fixFusionRuleBR-         -- ** Utilities-       , mkFixT-       , isFixExprT-       )-where+    ( -- * Operations on the Fixed Point Operator (fix)+      HERMIT.Dictionary.FixPoint.externals+      -- ** Rewrites and BiRewrites on Fixed Points+    , fixIntroR+    , fixIntroNonRecR+    , fixIntroRecR+    , fixComputationRuleBR+    , fixRollingRuleBR+    , fixFusionRuleBR+      -- ** Utilities+    , isFixExprT+    ) where  import Control.Applicative import Control.Arrow+import Control.Monad import Control.Monad.IO.Class -import Data.Monoid (mempty)+import Data.String (fromString)  import HERMIT.Context import HERMIT.Core@@ -27,60 +27,100 @@ import HERMIT.Kure import HERMIT.External import HERMIT.GHC+import HERMIT.Name import HERMIT.ParserCore import HERMIT.Utilities  import HERMIT.Dictionary.Common-import HERMIT.Dictionary.GHC+import HERMIT.Dictionary.Function+import HERMIT.Dictionary.Kure import HERMIT.Dictionary.Reasoning import HERMIT.Dictionary.Undefined+import HERMIT.Dictionary.Unfold  --------------------------------------------------------------------------------------------------  -- | Externals for manipulating fixed points. externals ::  [External] externals =-         [ external "fix-intro" (promoteDefR fixIntroR :: RewriteH Core)-                [ "rewrite a recursive binding into a non-recursive binding using fix"-                ] .+ Introduce .+ Context-         , external "fix-computation-rule" (promoteExprBiR fixComputationRuleBR :: BiRewriteH Core)-                [ "Fixed-Point Computation Rule",-                  "fix t f  <==>  f (fix t f)"-                ] .+ Context-         , external "fix-rolling-rule" (promoteExprBiR fixRollingRuleBR :: BiRewriteH Core)-                [ "Rolling Rule",-                  "fix tyA (\\ a -> f (g a))  <==>  f (fix tyB (\\ b -> g (f b))"-                ] .+ Context-         , external "fix-fusion-rule" ((\ f g h lhsR rhsR strictf -> promoteExprBiR (fixFusionRule (Just (lhsR,rhsR)) (Just strictf) f g h)) :: CoreString -> CoreString -> CoreString -> RewriteH Core -> RewriteH Core -> RewriteH Core -> BiRewriteH Core)-                [ "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"-                , "f (fix g) <==> fix h"-                ] .+ Context-         , external "fix-fusion-rule-unsafe" ((\ f g h lhsR rhsR -> promoteExprBiR (fixFusionRule (Just (lhsR,rhsR)) Nothing f g h)) :: CoreString -> CoreString -> CoreString -> RewriteH Core -> RewriteH Core -> BiRewriteH Core)-                [ "(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"-                , "f (fix g) <==> fix h"-                , "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)-                [ "(Very Unsafe) Fixed-point Fusion Rule"-                , "Given f :: A -> B, g :: A -> A, h :: B -> B, then"-                , "f (fix g) <==> fix h"-                , "Note that the preconditions that f (g a) == h (f a) and that f is strict are required to hold."-                ] .+ Context .+ PreCondition-         ]+    [ external "fix-intro" (fixIntroR :: RewriteH Core)+        [ "rewrite a function binding into a non-recursive binding using fix" ] .+ Introduce .+ Context+    , external "fix-computation-rule" (promoteExprBiR fixComputationRuleBR :: BiRewriteH Core)+        [ "Fixed-Point Computation Rule",+          "fix t f  <==>  f (fix t f)"+        ] .+ Context+    , external "fix-rolling-rule" (promoteExprBiR fixRollingRuleBR :: BiRewriteH Core)+        [ "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)+        [ "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"+        , "f (fix g) <==> fix h"+        ] .+ 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)+        [ "(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"+        , "f (fix g) <==> fix h"+        , "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)+        [ "(Very Unsafe) Fixed-point Fusion Rule"+        , "Given f :: A -> B, g :: A -> A, h :: B -> B, then"+        , "f (fix g) <==> fix h"+        , "Note that the preconditions that f (g a) == h (f a) and that f is strict are required to hold."+        ] .+ Context .+ PreCondition+    ]  -------------------------------------------------------------------------------------------------- +fixIntroR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+             , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+          => Rewrite c m Core+fixIntroR = promoteR fixIntroRecR <+ promoteR fixIntroNonRecR++fixIntroNonRecR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+                   , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+                => Rewrite c m CoreBind+fixIntroNonRecR = prefixFailMsg "fix introduction failed: " $ do+    NonRec f rhs <- idR+    rhs' <- polyFixT f <<< return rhs+    return $ NonRec f rhs'+ -- |  @f = e@   ==\>   @f = fix (\\ f -> e)@-fixIntroR :: RewriteH CoreDef-fixIntroR = prefixFailMsg "fix introduction failed: " $-           do Def f _ <- idR-              f' <- constT $ cloneVarH id f-              Def f <$> (mkFixT =<< (defT mempty (extractR $ substR f $ varToCoreExpr f') (\ () e' -> Lam f' e')))+fixIntroRecR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+                , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+             => Rewrite c m CoreDef+fixIntroRecR = prefixFailMsg "fix introduction failed: " $ do+    Def f rhs <- idR+    rhs' <- polyFixT f <<< return rhs+    return $ Def f rhs' +-- | Helper for fixIntroNonRecR and fixIntroRecR. Argument is function name.+-- Meant to be applied to RHS of function.+polyFixT :: forall c m.+            ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+            , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+         => Id -> Rewrite c m CoreExpr+polyFixT f = do+    (tvs, body) <- arr collectTyBinders+    f' <- constT $ newIdH (unqualifiedName f) (exprType body)+    body' <- contextonlyT $ \ c -> do+                let constLam = mkCoreLams tvs $ varToCoreExpr f'+                    c' = addBindingGroup (NonRec f constLam)   -- we want to unfold f such as to throw away TyArgs+                       $ addBindingGroup (NonRec f' body)    c -- add f' to context so its in-scope after unfolding+                applyT (tryR (extractR (anyCallR (promoteR (unfoldPredR (const . (==f))) :: Rewrite c m Core)))) c' body+    liftM (mkCoreLams tvs) $ buildFixT $ Lam f' body'+ --------------------------------------------------------------------------------------------------  -- | @fix ty f@  \<==\>  @f (fix ty f)@@@ -129,7 +169,7 @@      rollingRuleResult :: Type -> CoreExpr -> CoreExpr -> TransformH z CoreExpr     rollingRuleResult ty f g = do x <- constT (newIdH "x" ty)-                                  mkFixT (Lam x (App f (App g (Var x))))+                                  buildFixT (Lam x (App f (App g (Var x))))      wrongFixBody :: String     wrongFixBody = "body of fix does not have the form: Lam v (App f (App g (Var v)))"@@ -141,12 +181,12 @@ -- h :: B -> B  -- | If @f@ is strict, then (@f (g a)@ == @h (f a)@)  ==\>  (@f (fix g)@ == @fix h@)-fixFusionRuleBR :: Maybe (CoreExprEqualityProof HermitC HermitM) -> Maybe (RewriteH CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr -> BiRewriteH CoreExpr+fixFusionRuleBR :: Maybe (EqualityProof HermitC HermitM) -> Maybe (RewriteH CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr -> BiRewriteH CoreExpr fixFusionRuleBR meq mfstrict f g h = beforeBiR   (prefixFailMsg "fixed-point fusion failed: " $-   do (tyA,tyB) <- funExprArgResTypes f-      tyA'      <- endoFunExprType g-      tyB'      <- endoFunExprType h+   do (_,tyA,tyB) <- funExprArgResTypesM f -- TODO: don't throw away TyVars+      (_,tyA')    <- endoFunExprTypeM g+      (_,tyB')    <- endoFunExprTypeM h       guardMsg (typeAlphaEq tyA tyA' && typeAlphaEq tyB tyB') "given functions do not have compatible types."       whenJust (verifyStrictT f) mfstrict       whenJust (\ eq ->@@ -167,13 +207,13 @@                        guardMsg (exprAlphaEq f f') "first argument function does not match."                        (_,g') <- isFixExprT <<< return fixg                        guardMsg (exprAlphaEq g g') "second argument function does not match."-                       mkFixT h+                       buildFixT h         fixFusionR :: RewriteH CoreExpr        fixFusionR = prefixFailMsg "(reversed) fixed-point fusion failed: " $                     do (_,h') <- isFixExprT                        guardMsg (exprAlphaEq h h') "third argument function does not match."-                       App f <$> mkFixT g+                       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@@ -184,24 +224,14 @@ -- | Check that the expression has the form "fix t (f :: t -> t)", returning "t" and "f". isFixExprT :: TransformH CoreExpr (Type,CoreExpr) isFixExprT = withPatFailMsg (wrongExprForm "fix t f") $ -- fix :: forall a. (a -> a) -> a-  do App (App (Var fixId) (Type ty)) f <- idR-     fixId' <- findFixId-     guardMsg (fixId == fixId') (var2String fixId ++ " does not match " ++ fixLocation)+  do (Var fixId, [Type ty, f]) <- callT+     fixId' <- findIdT fixLocation+     guardMsg (fixId == fixId') (unqualifiedName fixId ++ " does not match " ++ show fixLocation)      return (ty,f)  -------------------------------------------------------------------------------------------------- --- | f  ==>  fix f-mkFixT :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => CoreExpr -> Transform c m z CoreExpr-mkFixT f = do t <- endoFunExprType f-              fixId <- findFixId-              return $ mkCoreApps (varToCoreExpr fixId) [Type t, f]--fixLocation :: String-fixLocation = "Data.Function.fix"---- TODO: will crash if 'fix' is not used (or explicitly imported) in the source file.-findFixId :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id-findFixId = findIdT fixLocation+fixLocation :: HermitName+fixLocation = fromString "Data.Function.fix"  --------------------------------------------------------------------------------------------------

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} module HERMIT.Dictionary.Fold     ( -- * Fold/Unfold Transformation       externals@@ -7,24 +8,24 @@     , stashFoldAnyR       -- * Unlifted fold interface     , fold-    , unifyTypes+    , unifyTypes -- TODO: remove in favor of GHC's unification     , tyMatchesToCoreExpr-    )--where+    ) where  import Control.Arrow import Control.Applicative import Control.Monad+import Control.Monad.IO.Class  import qualified Data.Map as Map  import HERMIT.Core import HERMIT.Context-import HERMIT.Monad-import HERMIT.Kure import HERMIT.External import HERMIT.GHC+import HERMIT.Kure+import HERMIT.Monad+import HERMIT.Name  import HERMIT.Dictionary.Common (varBindingDepthT,inScope,findIdT) import HERMIT.Dictionary.Inline hiding (externals)@@ -35,7 +36,7 @@  externals :: [External] externals =-    [ external "fold" (promoteExprR . foldR :: String -> RewriteH Core)+    [ external "fold" (promoteExprR . foldR :: HermitName -> RewriteH Core)         [ "fold a definition"         , ""         , "double :: Int -> Int"@@ -47,7 +48,7 @@         , ""         , "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 :: Label -> RewriteH Core)+    , 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@@ -55,26 +56,25 @@  ------------------------------------------------------------------------ -stashFoldR :: ReadBindings c => Label -> Rewrite c HermitM CoreExpr+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) $ var2String 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.)"+        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 => Rewrite c HermitM CoreExpr+stashFoldAnyR :: (ReadBindings c, HasStash m, MonadCatch m) => Rewrite c m CoreExpr stashFoldAnyR = setFailMsg "Fold failed: no definitions could be folded." $-                catchesM =<< map stashFoldR <$> (Map.keys <$> constT getStash)+                catchesM =<< liftM (map stashFoldR) (liftM Map.keys (constT getStash)) -foldR :: ReadBindings c => String -> Rewrite c HermitM CoreExpr-foldR nm = prefixFailMsg "Fold failed: " $ do-    v <- findIdT nm-    foldVarR v Nothing+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 => Var -> Maybe BindingDepth -> Rewrite c HermitM CoreExpr-foldVarR v md = do+foldVarR :: (ReadBindings c, MonadCatch m, MonadUnique m) => Maybe BindingDepth -> Var -> Rewrite c m CoreExpr+foldVarR md v = do     case md of         Nothing    -> return ()         Just depth -> do depth' <- varBindingDepthT v@@ -148,7 +148,7 @@ 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 +                                                   | 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@@ -190,7 +190,7 @@     return (x ++ tyMatchesToCoreExpr t ++ concat y)  foldMatch vs as (Cast e c) (Cast e' c') = do-    guard (coreEqCoercion c c') +    guard (coreEqCoercion c c')     foldMatch vs as e e'  foldMatch vs as (Type t1) (Type t2) = liftM tyMatchesToCoreExpr $ foldMatchType vs as t1 t2@@ -221,6 +221,10 @@               -> Type                 -- ^ expression we are checking               -> Maybe [(TyVar,Type)] -- ^ mapping of vars to types, or failure +-- 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'+ 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)]@@ -237,7 +241,7 @@     let f ty1 ty2 | isKind ty1 && eqKind ty1 ty2 = return []                   | otherwise = foldMatchType vs as ty1 ty2     liftM concat $ zipWithM f kOrTys1 kOrTys2-    + foldMatchType vs as (FunTy ty1 ty2) (FunTy ty1' ty2') = do     x <- foldMatchType vs as ty1 ty1'     y <- foldMatchType vs as ty2 ty2'

@@ -1,25 +1,34 @@-{-# LANGUAGE FlexibleContexts, RankNTypes #-}+{-# LANGUAGE CPP, FlexibleContexts, RankNTypes, ScopedTypeVariables #-} module HERMIT.Dictionary.Function     ( externals+    , appArgM+    , buildApplicationM+    , buildCompositionT+    , buildFixT+    , buildIdT     , staticArgR     , staticArgPosR     , staticArgPredR     , staticArgTypesR-    )-where+    ) where  import Control.Arrow+import Control.Monad.IO.Class  import Data.List (nub, intercalate, intersect, partition, transpose)+import Data.Maybe (isNothing)+import Data.String (fromString)  import HERMIT.Context import HERMIT.Core-import HERMIT.Monad-import HERMIT.Kure import HERMIT.External import HERMIT.GHC+import HERMIT.Kure+import HERMIT.Monad+import HERMIT.Name  import HERMIT.Dictionary.Common+import HERMIT.Dictionary.GHC hiding (externals)  externals ::  [External] externals =@@ -34,15 +43,18 @@ ------------------------------------------------------------------------------------------------------  -- | Traditional Static Argument Transformation-staticArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c) => Rewrite c HermitM CoreDef+staticArgR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb, MonadCatch m, MonadUnique m)+           => Rewrite c m CoreDef staticArgR = staticArgPredR (return . map fst)  -- | Static Argument Transformation that only considers type arguments to be static.-staticArgTypesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c) => Rewrite c HermitM CoreDef+staticArgTypesR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb, MonadCatch m, MonadUnique m)+                => Rewrite c m CoreDef staticArgTypesR = staticArgPredR (return . map fst . filter (isTyVar . snd))  -- | Static Argument Transformations which requires that arguments in the given position are static.-staticArgPosR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c) => [Int] -> Rewrite c HermitM CoreDef+staticArgPosR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb, MonadCatch m, MonadUnique m)+              => [Int] -> Rewrite c m CoreDef staticArgPosR is' = staticArgPredR $ \ss' -> let is = nub is'                                                  ss = map fst ss'                                             in if is == (is `intersect` ss)@@ -50,9 +62,10 @@                                                else fail $ "args " ++ commas (filter (`notElem` ss) is) ++ " are not static."  -- | Generalized Static Argument Transformation, which allows static arguments to be filtered.-staticArgPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c)-               => ([(Int, Var)] -> HermitM [Int]) -- ^ given list of static args and positions, decided which to transform-               -> Rewrite c HermitM CoreDef+staticArgPredR :: forall c m. (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb+                              , MonadCatch m, MonadUnique m)+               => ([(Int, Var)] -> m [Int]) -- ^ given list of static args and positions, decided which to transform+               -> Rewrite c m CoreDef staticArgPredR decide = prefixFailMsg "static-arg failed: " $ do     Def f rhs <- idR     let (bnds, body) = collectBinders rhs@@ -60,9 +73,11 @@     contextonlyT $ \ c -> do         let bodyContext = foldl (flip addLambdaBinding) c bnds -        -- TODO: we convert an Id to string here, and callsT then uses cmpString2Var-        --       refactor to avoid intermediate string!-        callPats <- apply (callsT (var2String f) (callT >>> arr snd)) bodyContext (ExprCore body)+            callPatsT :: Transform c m CoreExpr [[CoreExpr]]+            callPatsT = extractT $ collectPruneT+                            (promoteExprT $ callPredT (const . (== f)) >>> arr snd :: Transform c m Core [CoreExpr])++        callPats <- applyT callPatsT bodyContext body         let argExprs = transpose callPats             numCalls = length callPats             allBinds = zip [0..] bnds@@ -92,17 +107,91 @@             $ "type variables in args " ++ commas (nub $ map fst unboundTys) ++ " would become unbound unless args "               ++ commas (nub $ map snd unboundTys) ++ " are included in the transformation." -        wkr <- newIdH (var2String f ++ "'") (exprType (mkCoreLams dbnds body))+        wkr <- newIdH (unqualifiedName f ++ "'") (exprType (mkCoreLams dbnds body))          let replaceCall :: Monad m => Rewrite c m CoreExpr             replaceCall = do-                (_,exprs) <- callT+                (_,exprs) <- callPredT (const . (== f))                 return $ mkApps (Var wkr) [ e | (p,e) <- zip [0..] exprs, (p::Int) `elem` ps ] -        ExprCore body' <- apply (callsR (var2String f) replaceCall) bodyContext (ExprCore body)+        body' <- applyT (extractR $ prunetdR (promoteExprR replaceCall :: Rewrite c m Core)) bodyContext body          return $ Def f $ mkCoreLams bnds $ Let (Rec [(wkr, mkCoreLams dbnds body')])                                              $ mkApps (Var wkr) (varsToCoreExprs dbnds) +------------------------------------------------------------------------------++-- | Get the nth argument of an application. Arg 0 is the function being applied.+appArgM :: Monad m => Int -> CoreExpr -> m CoreExpr+appArgM n e | n < 0     = fail "appArgM: arg must be non-negative"+            | otherwise = let (fn,args) = collectArgs e+                              l = fn : args+                          in if n > length args+                             then fail "appArgM: not enough arguments"+                             else return $ l !! n++-- | Build composition of two functions.+buildCompositionT :: (BoundVars c, HasDynFlags m, 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++-- | 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+    (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")+                 return+                 (tcUnifyTys bindFn [domF] [xTy])++    f' <- substOrApply f [ (v, Type $ substTyVar sub v) | v <- vsF ]+    x' <- substOrApply x [ (v, Type $ substTyVar sub v) | v <- vsX ]+    let vs = [ v | v <- vsF ++ vsX, isNothing $ lookupTyVar sub v ]  -- things we should stick back on as foralls+    -- TODO: make sure vsX don't capture anything in f'+    --       and vsF' doesn't capture anything in x'+    return $ mkCoreLams vs $ mkCoreApp f' x'++-- | Given expression for f, build fix f.+buildFixT :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+          => CoreExpr -> Transform c m x CoreExpr+buildFixT f = do+    (tvs, ty) <- endoFunExprTypeM f+    fixId <- findIdT $ fromString "Data.Function.fix"+    f' <- substOrApply f [ (v, varToCoreExpr v) | v <- tvs ]+    return $ mkCoreLams tvs $ mkCoreApps (varToCoreExpr fixId) [Type ty, f']++-- | Build an expression that is the monomorphic id function for given type.+buildIdT :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+         => Type -> Transform c m x CoreExpr+buildIdT ty = do+    idId <- findIdT $ fromString "Data.Function.id"+    return $ mkCoreApp (varToCoreExpr idId) (Type ty)++------------------------------------------------------------------------------+ commas :: Show a => [a] -> String commas = intercalate "," . map show++-- | Like mkCoreApps, but automatically beta-reduces when possible.+substOrApply :: Monad m => CoreExpr -> [(Var,CoreExpr)] -> m CoreExpr+substOrApply e         []         = return e+substOrApply (Lam b e) ((v,ty):r) = if b == v+                                    then substOrApply e r >>= return . substCoreExpr b ty+                                    else fail $ "substOrApply: unexpected binder - "+                                                ++ unqualifiedName b ++ " - " ++ unqualifiedName v+substOrApply e         rest       = return $ mkCoreApps e (map snd rest)++------------------------------------------------------------------------------

@@ -1,42 +1,47 @@ {-# 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-       , substR-       , substCoreAlt-       , substCoreExpr-         -- ** Utilities- --      , inScope-       , dynFlagsT-       , arityOf-         -- ** Lifted GHC capabilities-         -- A zombie is an identifer that has 'OccInfo' 'IAmDead', but still has occurrences.-       , lintExprT-       , lintModuleT-       , occurAnalyseR-       , occurAnalyseChangedR-       , occurAnalyseExprChangedR-       , occurAnalyseAndDezombifyR-       , dezombifyR-       )-where+    ( -- * GHC-based Transformations+     -- | This module contains transformations that are reflections of GHC functions, or derived from GHC functions.+     externals+     -- ** Substitution+    , substR+    , substCoreAlt+    , substCoreExpr+     -- ** Utilities+    --      , inScope+    , dynFlagsT+    , arityOf+     -- ** Lifted GHC capabilities+     -- A zombie is an identifer that has 'OccInfo' 'IAmDead', but still has occurrences.+    , lintExprT+    , lintModuleT+    , occurAnalyseR+    , occurAnalyseChangedR+    , occurAnalyseExprChangedR+    , occurAnalyseAndDezombifyR+    , dezombifyR+    , buildDictionary+    , buildDictionaryT+    , buildTypeable+    ) where  import qualified Bag import qualified CoreLint -import Control.Arrow--import Data.List (mapAccumL)+import           Control.Arrow+import           Control.Monad.IO.Class -import HERMIT.Core-import HERMIT.Context-import HERMIT.Kure-import HERMIT.External-import HERMIT.GHC+import           Data.Char (isSpace)+import           Data.List (mapAccumL) -import HERMIT.Dictionary.Debug hiding (externals)+import           HERMIT.Core+import           HERMIT.Context+import           HERMIT.Dictionary.Debug hiding (externals)+import           HERMIT.External+import           HERMIT.GHC+import           HERMIT.Kure+import           HERMIT.Monad+import           HERMIT.Name  ------------------------------------------------------------------------ @@ -125,11 +130,7 @@ lintModuleT =   do dynFlags <- dynFlagsT      bnds     <- arr mg_binds-#if __GLASGOW_HASKELL__ > 706      let (warns, errs)    = CoreLint.lintCoreBindings [] bnds -- [] are vars to treat as in scope, used by GHCi-#else-     let (warns, errs)    = CoreLint.lintCoreBindings bnds-#endif          dumpSDocs endMsg = Bag.foldBag (\ d r -> d ++ ('\n':r)) (showSDoc dynFlags) endMsg      if Bag.isEmptyBag errs        then return $ dumpSDocs "Core Lint Passed" warns@@ -143,11 +144,7 @@ lintExprT = transform $ \ c e -> do     dflags <- getDynFlags     maybe (return "Core Lint Passed") (fail . showSDoc dflags)-#if __GLASGOW_HASKELL__ > 706                  $ CoreLint.lintExpr (varSetElems $ boundVars c) e-#else-                 $ CoreLint.lintUnfolding noSrcLoc (varSetElems $ boundVars c) e-#endif  ------------------------------------------- @@ -168,13 +165,23 @@  -- | Apply 'occurAnalyseExprR' to all sub-expressions. occurAnalyseR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core-occurAnalyseR = let r  = promoteExprR (arr occurAnalyseExpr)+occurAnalyseR = let r  = promoteExprR (arr occurAnalyseExpr_NoBinderSwap) -- See Note [No Binder Swap]                     go = r <+ anyR go                  in tryR go -- always succeed +{-+  Note [No Binder Swap]++  The binder swap performed by occurrence analysis in GHC <= 7.8.3 is buggy+  in that it can lead to unintended variable capture (Trac #9440). Concretely,+  this will send bash into a loop, or cause core lint to fail. As this is an+  un-expected change as far as HERMIT users are concerned anyway, we use the+  version that doesn't perform the binder swap.+-}+ -- | Occurrence analyse an expression, failing if the result is syntactically equal to the initial expression. occurAnalyseExprChangedR :: MonadCatch m => Rewrite c m CoreExpr-occurAnalyseExprChangedR = changedByR exprSyntaxEq (arr occurAnalyseExpr)+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@@ -198,3 +205,37 @@ -}  ----------------------------------------------------------------------++-- TODO: this is mostly an example, move somewhere?+buildTypeable :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadIO m) => Type -> m (Id, [CoreBind])+buildTypeable ty = do+    evar <- runTcM $ do+        cls <- tcLookupClass typeableClassName+        let predTy = mkClassPred cls [typeKind ty, ty] -- recall that Typeable is now poly-kinded+        newWantedEvVar predTy+    buildDictionary evar++-- | Build a dictionary for the given+buildDictionary :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadIO m) => Id -> m (Id, [CoreBind])+buildDictionary evar = do+    (i, bs) <- runTcM $ do+        loc <- getCtLoc $ GivenOrigin UnkSkol+        let predTy = varType evar+            nonC = mkNonCanonical $ CtWanted { ctev_pred = predTy, ctev_evar = evar, ctev_loc = loc }+            wCs = mkFlatWC [nonC]+        (wCs', bnds) <- solveWantedsTcM wCs+        reportAllUnsolved wCs'+        return (evar, bnds)+    bnds <- runDsM $ dsEvBinds bs+    return (i,bnds)++buildDictionaryT :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadUnique m)+                 => Transform c m Type CoreExpr+buildDictionaryT = prefixFailMsg "buildDictionaryT failed: " $ contextfreeT $ \ ty -> do+    dflags <- getDynFlags+    binder <- newIdH ("$d" ++ zEncodeString (filter (not . isSpace) (showPpr dflags ty))) ty+    (i,bnds) <- buildDictionary binder+    guardMsg (notNull bnds) "no dictionary bindings generated."+    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)

@@ -17,6 +17,7 @@ import HERMIT.GHC import HERMIT.Kure import HERMIT.Monad+import HERMIT.Name -- import HERMIT.Utilities (soleElement)  import HERMIT.Dictionary.Common@@ -30,7 +31,7 @@  ------------------------------------------------------------------------------ -inductionCaseSplit :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb) +inductionCaseSplit :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb)                    => [Var] -> Id -> CoreExpr -> CoreExpr -> Transform c HermitM x [(Maybe DataCon,[Var],CoreExpr,CoreExpr)] inductionCaseSplit vs i lhsE rhsE =     do -- first construct an expression containing both the LHS and the RHS

@@ -1,40 +1,30 @@ {-# LANGUAGE CPP, TupleSections, FlexibleContexts, ScopedTypeVariables #-} module HERMIT.Dictionary.Inline-         ( -- * Inlining-           externals-         , InlineConfig(..)-         , CaseBinderInlineOption(..)-         , getUnfoldingT-         , ensureBoundT-         , inlineR-         , inlineNameR-         , inlineNamesR-         , inlineMatchingPredR-         , inlineCaseScrutineeR-         , inlineCaseAlternativeR-         , configurableInlineR-         , inlineTargetsT-         )--where--#if __GLASGOW_HASKELL__ > 706-#else-import TcType (tcSplitDFunTy)-#endif+    ( -- * Inlining+      externals+    , InlineConfig(..)+    , CaseBinderInlineOption(..)+    , getUnfoldingT+    , ensureBoundT+    , inlineR+    , inlineNameR+    , inlineNamesR+    , inlineMatchingPredR+    , inlineCaseScrutineeR+    , inlineCaseAlternativeR+    , configurableInlineR+    , inlineTargetsT+    ) where  import Control.Arrow-import Control.Applicative import Control.Monad -import Data.List (intercalate)- import HERMIT.Context import HERMIT.Core import HERMIT.External import HERMIT.GHC import HERMIT.Kure-import HERMIT.Monad+import HERMIT.Name  import HERMIT.Dictionary.Common @@ -43,17 +33,17 @@ -- | 'External's for inlining variables. externals :: [External] externals =-            [ external "inline" (promoteExprR inlineR :: RewriteH Core)-                [ "(Var v) ==> <defn of v>" ].+ Eval .+ Deep-            , external "inline" (promoteExprR . inlineNameR :: String -> RewriteH Core)-                [ "Given a specific v, (Var v) ==> <defn of v>" ] .+ Eval .+ Deep-            , external "inline" (promoteExprR . inlineNamesR :: [String] -> RewriteH Core)-                [ "If the current variable matches any of the given names, then inline it." ] .+ Eval .+ Deep-            , external "inline-case-scrutinee" (promoteExprR inlineCaseScrutineeR :: RewriteH Core)-                [ "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" (promoteExprR inlineR :: RewriteH Core)+        [ "(Var v) ==> <defn of v>" ].+ Eval .+ Deep+    , external "inline" (promoteExprR . inlineMatchingPredR . mkOccPred :: OccurrenceName -> RewriteH Core)+        [ "Given a specific v, (Var v) ==> <defn of v>" ] .+ Eval .+ Deep+    , external "inline" (promoteExprR . inlineNamesR :: [String] -> RewriteH Core)+        [ "If the current variable matches any of the given names, then inline it." ] .+ Eval .+ Deep+    , external "inline-case-scrutinee" (promoteExprR inlineCaseScrutineeR :: RewriteH Core)+        [ "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+    ]  ------------------------------------------------------------------------ @@ -62,37 +52,50 @@ data InlineConfig           = CaseBinderOnly CaseBinderInlineOption | AllBinders deriving (Eq, Show)  -- | If the current variable matches the given name, then inline it.-inlineNameR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => String -> Rewrite c HermitM CoreExpr+inlineNameR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+               , ReadBindings c, HasEmptyContext c, MonadCatch m )+            => String -> Rewrite c m CoreExpr inlineNameR nm = inlineMatchingPredR (cmpString2Var nm)  -- | If the current variable matches any of the given names, then inline it.-inlineNamesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [String] -> Rewrite c HermitM CoreExpr+inlineNamesR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                , ReadBindings c, HasEmptyContext c, MonadCatch m )+             => [String] -> Rewrite c m CoreExpr inlineNamesR []  = fail "inline-names failed: no names given." inlineNamesR nms = inlineMatchingPredR (\ v -> any (flip cmpString2Var v) nms)  -- | If the current variable satisifies the predicate, then inline it.-inlineMatchingPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => (Id -> Bool) -> Rewrite c HermitM CoreExpr+inlineMatchingPredR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                       , ReadBindings c, HasEmptyContext c, MonadCatch m )+                    => (Id -> Bool) -> Rewrite c m CoreExpr inlineMatchingPredR idPred = configurableInlineR AllBinders (arr $ idPred)  -- | Inline the current variable.-inlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr+inlineR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c,+            ReadBindings c, ReadPath c Crumb, MonadCatch m )+        => Rewrite c m CoreExpr inlineR = configurableInlineR AllBinders (return True)  -- | Inline the current identifier if it is a case binder, using the scrutinee rather than the case-alternative pattern.-inlineCaseScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr+inlineCaseScrutineeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                        , ReadBindings c, HasEmptyContext c, MonadCatch m )+                     => Rewrite c m CoreExpr inlineCaseScrutineeR = configurableInlineR (CaseBinderOnly Scrutinee) (return True)  -- | Inline the current identifier if is a case binder, using the case-alternative pattern rather than the scrutinee.-inlineCaseAlternativeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr+inlineCaseAlternativeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                          , ReadBindings c, HasEmptyContext c, MonadCatch m )+                       => Rewrite c m CoreExpr inlineCaseAlternativeR = configurableInlineR (CaseBinderOnly Alternative) (return True)  -- | The implementation of inline, an important transformation. -- This *only* works if the current expression has the form @Var v@ (it does not traverse the expression). -- It can trivially be prompted to more general cases using traversal strategies.-configurableInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c)+configurableInlineR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c+                       , ReadPath c Crumb, MonadCatch m )                     => InlineConfig-                    -> (Transform c HermitM Id Bool) -- ^ Only inline identifiers that satisfy this predicate.-                    -> Rewrite c HermitM CoreExpr+                    -> (Transform c m Id Bool) -- ^ Only inline identifiers that satisfy this predicate.+                    -> Rewrite c m CoreExpr configurableInlineR config p =    prefixFailMsg "Inline failed: " $    do b <- varT p@@ -106,8 +109,8 @@ -- Fails, listing unbound variables if not. ensureBoundT :: (Monad m, ReadBindings c) => Transform c m CoreExpr () ensureBoundT = do-    unbound <- transform $ \ c -> return . filter (not . inScope c) . varSetElems . localFreeVarsExpr-    guardMsg (null unbound) $ "the following variables are unbound: " ++ intercalate ", " (map getOccString unbound)+    unbound <- transform $ \ c -> return . filterVarSet (not . inScope c) . localFreeVarsExpr+    guardMsg (isEmptyVarSet unbound) $ "the following variables are unbound: " ++ showVarSet unbound  -- NOTE: When inlining, we have to take care to avoid variable capture. --       Our approach is to track the binding depth of the inlined identifier.@@ -136,29 +139,25 @@      all uncaptured `liftM` extractT collectDepthsT  -- | Return the unfolding of an identifier, and a predicate over the binding depths of all variables within that unfolding to determine if they have been captured in their new location.-getUnfoldingT :: ReadBindings c+getUnfoldingT :: (ReadBindings c, MonadCatch m)               => InlineConfig-              -> Transform c HermitM Id (CoreExpr, BindingDepth -> Bool)+              -> Transform c m Id (CoreExpr, BindingDepth -> Bool) getUnfoldingT config = transform $ \ c i ->     case lookupHermitBinding i c of       Nothing -> do requireAllBinders config                     let uncaptured = (<= 0) -- i.e. is global-		    -- this check is necessary because idInfo panics on TyVars, though it-		    -- should never be the case that a type variable is NOT in the context,-		    -- at least this will give a reasonable error message, instead of a GHC panic.-		    guardMsg (isId i) "type variable is not in Env (this should not happen)."+                    -- This check is necessary because idInfo panics on TyVars. Type variables should+                    -- ALWAYS be in the context (so we should never be in this branch), but at least this+                    -- 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)-#if __GLASGOW_HASKELL__ > 706-                      dunf@(DFunUnfolding {})         -> (,uncaptured) <$> dFunExpr dunf-#else-                      DFunUnfolding _arity dc args    -> (,uncaptured) <$> dFunExpr dc args (idType i)-#endif+                      dunf@(DFunUnfolding {})         -> liftM (,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   = (, (<= depth+1)) <$> alt2Exp tys alt+                                                  altExprDepthM   = liftM (, (<= depth+1)) $ alt2Exp tys alt                                                   scrutExprDepthM = return (s, (< depth))                                                in case config of                                                     CaseBinderOnly Scrutinee   -> scrutExprDepthM@@ -200,44 +199,14 @@ alt2Exp tys (DataAlt dc, vs) = return $ mkCoreConApps dc (map Type tys ++ map (varToCoreExpr . zapVarOccInfo) 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) => Transform c HermitM Core [String]-inlineTargetsT = collectT $ promoteT $ whenM (testM inlineR) (varT $ arr var2String)+inlineTargetsT :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                  , ReadBindings c, HasEmptyContext c, MonadCatch m )+               => Transform c m Core [String]+inlineTargetsT = collectT $ promoteT $ whenM (testM inlineR) (varT $ arr unqualifiedName)  -- | Build a CoreExpr for a DFunUnfolding-#if __GLASGOW_HASKELL__ > 706-{--data Unfolding-  = ...-  | DFunUnfolding {     -- The Unfolding of a DFunId-                -- See Note [DFun unfoldings]-                --     df = /\a1..am. \d1..dn. MkD t1 .. tk-                        --                                 (op1 a1..am d1..dn)-                    --                                 (op2 a1..am d1..dn)-        df_bndrs :: [Var],      -- The bound variables [a1..m],[d1..dn]-        df_con   :: DataCon,    -- The dictionary data constructor (never a newtype datacon)-        df_args  :: [CoreExpr]  -- Args of the data con: types, superclasses and methods,-    }                           -- in positional order--}-dFunExpr :: Unfolding -> HermitM CoreExpr--- TODO: is this correct?-dFunExpr dunf@(DFunUnfolding {}) = return $ mkCoreConApps (df_con dunf) (df_args dunf)+dFunExpr :: Monad m => Unfolding -> m CoreExpr+dFunExpr dunf@(DFunUnfolding {}) = return $ mkCoreLams (df_bndrs dunf) $ mkCoreConApps (df_con dunf) (df_args dunf) dFunExpr _ = fail "dFunExpr: not a DFunUnfolding"-#else-dFunExpr :: DataCon -> [DFunArg CoreExpr] -> Type -> HermitM CoreExpr-dFunExpr dc args ty = do-    let (_, _, _, tcArgs) = tcSplitDFunTy ty-        (forallTvs, ty')  = splitForAllTys ty-        (argTys, _resTy)  = splitFunTys ty'--    ids <- mapM (uncurry newIdH) $ zip [ [ch] | ch <- cycle ['a'..'z'] ] argTys-    vars <- mapM (cloneVarH id) forallTvs--    let allVars = varsToCoreExprs $ vars ++ ids--        mkArg (DFunLamArg i) = allVars !! i-        mkArg (DFunPolyArg e) = mkCoreApps e allVars--    return $ mkCoreConApps dc $ map Type tcArgs ++ map mkArg args-#endif  ------------------------------------------------------------------------

@@ -1,11 +1,11 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}  module HERMIT.Dictionary.Kure-       ( -- * KURE Strategies-         externals-       , anyCallR-       )-where+    ( -- * KURE Strategies+      externals+    , anyCallR+    , betweenR+    ) where  import Control.Arrow import Control.Monad (liftM)@@ -98,6 +98,8 @@        [ "Promote a RewriteCore to a RewriteCoreTC" ]    , external "extract"    (extractR :: RewriteH CoreTC -> RewriteH Core)        [ "Extract a RewriteCore from a RewriteCoreTC" ]+   , external "between"    (betweenR :: Int -> Int -> RewriteH CoreTC -> RewriteH CoreTC)+       [ "between x y rr -> perform rr at least x times and at most y times." ]    ]  ------------------------------------------------------------------------------------@@ -137,3 +139,14 @@           rec = anyCallR rr  ------------------------------------------------------------------------------------++-- | betweenR x y rr -> perform rr at least x times and at most y times.+betweenR :: MonadCatch m => Int -> Int -> Rewrite c m a -> Rewrite c m a+betweenR l h rr | l < 0 = fail "betweenR: lower limit below zero"+                | h < l = fail "betweenR: upper limit less than lower limit"+                | otherwise = go 0+    where -- 'c' is number of times rr has run already+          go c | c >= h = idR               -- done+               | c < l  = rr >>> go (c+1)   -- haven't hit lower bound yet+               | otherwise = tryR (rr >>> go (c+1))  -- met lower bound+

@@ -1,37 +1,36 @@ {-# LANGUAGE FlexibleContexts #-}  module HERMIT.Dictionary.Local-       ( -- * Local Structural Manipulations-         HERMIT.Dictionary.Local.externals-         -- ** Binding Groups-       , module HERMIT.Dictionary.Local.Bind-         -- ** Case Expressions-       , module HERMIT.Dictionary.Local.Case-         -- ** Cast Expressions-       , module HERMIT.Dictionary.Local.Cast-         -- ** Let Expressions-       , module HERMIT.Dictionary.Local.Let-         -- ** Miscellaneous-       , abstractR-       , pushR-       , betaReduceR-       , betaReducePlusR-       , betaExpandR-       , etaReduceR-       , etaExpandR-       , multiEtaExpandR-       , flattenModuleR-       , flattenProgramR-       , flattenProgramT-       )-where+    ( -- * Local Structural Manipulations+      HERMIT.Dictionary.Local.externals+      -- ** Binding Groups+    , module HERMIT.Dictionary.Local.Bind+      -- ** Case Expressions+    , module HERMIT.Dictionary.Local.Case+      -- ** Cast Expressions+    , module HERMIT.Dictionary.Local.Cast+      -- ** Let Expressions+    , module HERMIT.Dictionary.Local.Let+      -- ** Miscellaneous+    , abstractR+    , pushR+    , betaReduceR+    , betaExpandR+    , etaReduceR+    , etaExpandR+    , multiEtaExpandR+    , flattenModuleR+    , flattenProgramR+    , flattenProgramT+    ) where  import HERMIT.Core import HERMIT.Context-import HERMIT.Kure-import HERMIT.Monad import HERMIT.External import HERMIT.GHC+import HERMIT.Kure+import HERMIT.Monad+import HERMIT.Name import HERMIT.Utilities  import HERMIT.Dictionary.Common@@ -57,8 +56,6 @@         [ "((\\ v -> E1) E2) ==> let v = E2 in E1"         , "This form of beta-reduction is safe if E2 is an arbitrary expression"         , "(won't duplicate work)." ]                                 .+ Eval .+ Shallow-    , external "beta-reduce-plus" (promoteExprR betaReducePlusR :: RewriteH Core)-        [ "Perform one or more beta-reductions."]                               .+ Eval .+ Shallow     , external "beta-expand" (promoteExprR betaExpandR :: RewriteH Core)         [ "(let v = e1 in e2) ==> (\\ v -> e2) e1" ]                            .+ Shallow     , external "eta-reduce" (promoteExprR etaReduceR :: RewriteH Core)@@ -71,7 +68,7 @@     , external "flatten-program" (promoteProgR flattenProgramR :: RewriteH Core)         [ "Flatten all the top-level binding groups in a program (list of binding groups) to a single"         , "recursive binding group.  This can be useful if you intend to apply GHC RULES." ]-    , external "abstract" (promoteExprR . abstractR :: String -> RewriteH Core)+    , external "abstract" (promoteExprR . abstractR . mkOccPred :: OccurrenceName -> RewriteH Core)         [ "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)@@ -96,49 +93,6 @@     do App (Lam v e1) e2 <- idR        return $ Let (NonRec v e2) e1 --multiBetaReduceR :: MonadCatch m =>  (Int -> Bool) -> Rewrite c m CoreExpr-multiBetaReduceR p = prefixFailMsg "Multi-Beta-Reduce failed: " $-    do-        e <- idR-        let (f,xs) = collectArgs e-        guardMsg (p (length xs)) "incorrect number of arguments."--        let (vs,e0) = collectBinders f--        guardMsg (length vs >= length xs) "insufficent lambdas."--        let (vs1,vs2) = splitAt (length xs) vs--        return-           $ mkLets (zipWith NonRec vs1 xs)-           $ mkLams vs2 e0---- TODO: inline this everywhere--- Neil: Are we sure we want to inline this?--- | Perform one or more beta-reductions.-betaReducePlusR :: MonadCatch m => Rewrite c m CoreExpr-betaReducePlusR = multiBetaReduceR (> 0)--{---        tagFailR "betaReducePlus failed." $-        appT liftLambda idR App >>> beta_reduce-  where-          -- lift lambda finds the (perhaps hidden) lambda, and brings it out-          liftLambda = observeR "pre-liftLambda" >>> liftLambda' >>> observeR "post-liftLambda"-          liftLambda' =-                   (do e@(Lam {}) <- idR-                       return e)-                <+ (betaReducePlus-                        >>> observeR "liftLambda(UP)"-                            -- let v = e in ...-                            -- TODO: check scope here-                        >>> (do Let bds (Lam v e) <- idR-                                return (Lam v (Let bds e)))-                   )--}- -- | (let v = e1 in e2) ==> (\\ v -> e2) e1 betaExpandR :: MonadCatch m => Rewrite c m CoreExpr betaExpandR = setFailMsg ("Beta-expansion failed: " ++ wrongExprForm "Let (NonRec v e1) e2") $@@ -158,7 +112,7 @@                                Nothing -> fail "the argument expression is not a type variable."                                Just v2 -> guardMsg (v1 == v2) "type variables are not equal."                   _       -> fail "the argument expression is not a variable."-               guardMsg (v1 `notElemVarSet` freeVarsExpr f) $ var2String v1 ++ " is free in the function being applied."+               guardMsg (v1 `notElemVarSet` freeVarsExpr f) $ unqualifiedName v1 ++ " is free in the function being applied."                return f  -- | e1 ==> (\\ v -> e1 v)@@ -199,12 +153,13 @@  -- | Abstract over a variable using a lambda. --   e  ==>  (\ x. e) x-abstractR :: (ReadBindings c) => String -> Rewrite c HermitM CoreExpr-abstractR nm = prefixFailMsg "abstraction failed: " $-   do v  <- findBoundVarT nm-      v' <- constT (cloneVarH id v) -- currently uses the same visible name (via "id").  We could do something else here, e.g. add a prime suffix.+abstractR :: (ReadBindings c, MonadCatch m, MonadUnique m) => (Var -> Bool) -> Rewrite c m CoreExpr+abstractR p = prefixFailMsg "abstraction failed: " $+   do v  <- findBoundVarT p+      v' <- constT (cloneVarH id v) -- currently uses the same visible name (via "id").+                                    -- We could do something else here, e.g. add a prime suffix.       e  <- arr (substCoreExpr v (varToCoreExpr v'))-      return $ App (Lam v' e) (varToCoreExpr v)+      return $ mkCoreApp (Lam v' e) (varToCoreExpr v)  ------------------------------------------------------------------------------------------------------ 

@@ -1,10 +1,9 @@ module HERMIT.Dictionary.Local.Bind-       ( -- * Rewrites on Binding Groups-         externals-       , nonrecToRecR-       , recToNonrecR-       )-where+    ( -- * Rewrites on Binding Groups+      externals+    , nonrecToRecR+    , recToNonrecR+    ) where  import HERMIT.Core import HERMIT.External@@ -41,7 +40,7 @@ recToNonrecR = prefixFailMsg "Converting singleton recursive binding to non-recursive binding failed: " $                withPatFailMsg (wrongExprForm "Rec [Def v e]") $   do Rec [(v,e)] <- idR-     guardMsg (v `notElemVarSet` freeIdsExpr e) ("'" ++ uqName v ++ " is recursively defined.")+     guardMsg (v `notElemVarSet` freeIdsExpr e) ("'" ++ unqualifiedName v ++ " is recursively defined.")      return (NonRec v e)  ------------------------------------------------------------------------------

@@ -5,6 +5,7 @@       externals     , caseFloatAppR     , caseFloatArgR+    , caseFloatArgLemmaR     , caseFloatCaseR     , caseFloatCastR     , caseFloatLetR@@ -15,7 +16,7 @@     , caseReduceR     , caseReduceDataconR     , caseReduceLiteralR-    , caseReduceIdR+    -- , caseReduceIdR     , caseReduceUnfoldR     , caseSplitR     , caseSplitInlineR@@ -28,29 +29,32 @@     , caseElimMergeAltsR     , caseIntroSeqR     , caseElimSeqR-    )-where+    ) where -import Data.List-import Data.Monoid import Control.Arrow import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class +import Data.List+import Data.Monoid+ import HERMIT.Core import HERMIT.Context-import HERMIT.Monad-import HERMIT.Kure-import HERMIT.GHC import HERMIT.External-import HERMIT.Utilities+import HERMIT.GHC+import HERMIT.Kure+import HERMIT.Monad+import HERMIT.Name import HERMIT.ParserCore+import HERMIT.Utilities  import HERMIT.Dictionary.Common 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)+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@@ -60,30 +64,33 @@ externals :: [External] externals =     [ external "case-float-app" (promoteExprR caseFloatAppR :: RewriteH Core)-        [ "(case ec of alt -> e) v ==> case ec of alt -> e v" ]              .+ Commute .+ Shallow+        [ "(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)         [ "Given a proof that f is strict, then"-        , "f (case s of alt -> e) ==> case s of alt -> f e" ]                .+ Commute .+ Shallow+        , "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)         [ "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+        , "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)         [ "For a specified f,"-        , "f (case s of alt -> e) ==> case s of alt -> f e" ]                .+ Commute .+ Shallow .+ PreCondition+        , "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+        [ "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)+        [ "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)         [ "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)         [ "cast (case s of p -> e) co ==> case s of p -> cast e co" ]        .+ Shallow .+ Commute     , external "case-float-let" (promoteExprR caseFloatLetR :: RewriteH Core)-        [ "let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e" ] .+ Commute .+ Shallow+        [ "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)-        [ "case-float = case-float-app <+ case-float-case <+ case-float-let <+ case-float-cast" ]    .+ Commute .+ Shallow+        [ "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)         [ "Float in a Case whatever the context." ]                             .+ Commute .+ Shallow .+ PreCondition     , external "case-float-in-args" (promoteExprR caseFloatInArgsR :: RewriteH Core)-        [ "Float in a Case whose alternatives are parallel applications of the same function." ] .+ Commute .+ Shallow .+ PreCondition+        [ "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)     --     [ "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)@@ -95,21 +102,19 @@     , external "case-reduce-literal" (promoteExprR (caseReduceLiteralR True) :: RewriteH Core)         [ "Case of Known Constructor"         , "case L of L -> e ==> e" ]                                         .+ Shallow .+ Eval-    , external "case-reduce-id" (promoteExprR (caseReduceIdR True) :: RewriteH Core)-        [ "Inline the case scrutinee (if it is an identifier) and then case-reduce." ] .+ Shallow .+ Eval .+ Context     , external "case-reduce-unfold" (promoteExprR (caseReduceUnfoldR True) :: RewriteH Core)-        [ "Unfold the case scrutinee (if it is a function application) and then case-reduce." ] .+ Shallow .+ Eval .+ Context+        [ "Unfold the case scrutinee and then case-reduce." ] .+ Shallow .+ Eval .+ Context     , external "case-split" (promoteExprR . caseSplitR . cmpString2Var :: String -> RewriteH Core)         [ "case-split 'x"-        , "e ==> case x of C1 vs -> e; C2 vs -> e, where x is free in e" ] .+ Shallow+        , "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)         [ "Like case-split, but additionally inlines the matched constructor "-        , "applications for all occurances of the named variable." ] .+ Deep+        , "applications for all occurances of the named variable." ] .+ Deep .+ Strictness     , external "case-intro-seq" (promoteExprR . caseIntroSeqR . cmpString2Var :: String -> RewriteH Core)         [ "Force evaluation of a variable by introducing a case."-        , "case-seq 'v is is equivalent to adding @(seq v)@ in the source code." ] .+ Shallow .+ Introduce+        , "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)-        [ "Eliminate a case that corresponds to a pointless seq."  ] .+ Deep .+ Eval+        [ "Eliminate a case that corresponds to a pointless seq."  ] .+ Deep .+ Eval .+ Strictness     , external "case-inline-alternative" (promoteExprR caseInlineAlternativeR :: RewriteH Core)         [ "Inline the case binder as the case-alternative pattern everywhere in the case alternatives." ] .+ Deep     , external "case-inline-scrutinee" (promoteExprR caseInlineScrutineeR :: RewriteH Core)@@ -122,7 +127,7 @@         [ "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)-        [ "case s of w; C vs -> e ==> e if w and vs are not free in e" ]     .+ Shallow+        [ "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)         [ "Eliminate a case, inlining any occurrences of the case binder as the scrutinee." ] .+ Deep     , external "case-elim-merge-alts" (promoteExprR caseElimMergeAltsR :: RewriteH Core)@@ -135,7 +140,7 @@ ------------------------------------------------------------------------------  -- | case s of w; C vs -> e ==> e if w and vs are not free in e-caseElimR :: Rewrite c HermitM CoreExpr+caseElimR :: MonadCatch m => Rewrite c m CoreExpr caseElimR = prefixFailMsg "Case elimination failed: " $             withPatFailMsg (wrongExprForm "Case s bnd ty alts") $  do Case _ bnd _ alts <- idR@@ -148,10 +153,11 @@ ------------------------------------------------------------------------------  -- | (case s of alt1 -> e1; alt2 -> e2) v ==> case s of alt1 -> e1 v; alt2 -> e2 v-caseFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m)+              => Rewrite c m CoreExpr caseFloatAppR = prefixFailMsg "Case floating from App function failed: " $   do-    captures    <- appT (map mkVarSet <$> caseAltVarsT) (arr freeVarsExpr) (flip (map . intersectVarSet))+    captures    <- appT (liftM (map mkVarSet) caseAltVarsT) (arr freeVarsExpr) (flip (map . intersectVarSet))     bndrCapture <- appT caseBinderIdT (arr freeVarsExpr) elemVarSet     appT ((if not bndrCapture then idR else alphaCaseBinderR Nothing)           >>> caseAllR idR idR idR (\i -> if isEmptyVarSet (captures !! i) then idR else alphaAltR)@@ -169,9 +175,10 @@  -- | @f (case s of alt1 -> e1; alt2 -> e2)@ ==> @case s of alt1 -> f e1; alt2 -> f e2@ --   Only safe if @f@ is strict.-caseFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c)-              => Maybe CoreExpr -> Maybe (Rewrite c HermitM CoreExpr) -- ^ Maybe the function to float past, and maybe a proof of its strictness.-              -> Rewrite c HermitM CoreExpr+caseFloatArgR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c+                 , HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+              => Maybe CoreExpr -> Maybe (Rewrite c m CoreExpr) -- ^ Maybe the function to float past, and maybe a proof of its strictness.+              -> Rewrite c m CoreExpr caseFloatArgR mf mstrict = prefixFailMsg "Case floating from App argument failed: " $                            withPatFailMsg "App f (Case s w ty alts)" $   do App f (Case s w _ alts) <- idR@@ -191,39 +198,41 @@                                                                              )                                                        ) >>> caseFloatArgR Nothing Nothing --- caseFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, HasGlobalRdrEnv c)---               => Maybe (CoreExpr, Maybe (Rewrite c HermitM CoreExpr)) -- ^ Maybe the function to float past, and maybe a proof of its strictness.---               -> Rewrite c HermitM CoreExpr--- caseFloatArgR mfstrict = prefixFailMsg "Case floating from App argument failed: " $---                          withPatFailMsg "App f (Case s w ty alts)" $---   do App f (Case s w _ alts) <- idR---      whenJust (\ (f', mstrict) ->---                      do guardMsg (exprAlphaEq f f') "given function does not match current application."---                         whenJust (verifyStrictT f) mstrict---               )---               mfstrict+-- | @f (case s of alt1 -> e1; alt2 -> e2)@ ==> @case s of alt1 -> f e1; alt2 -> f e2@+--   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+    App f (Case s w _ alts) <- idR ---      let fvs         = freeVarsExpr f---          altCaptures = map (intersectVarSet fvs . mkVarSet . altVars) alts---          bndrCapture = elemVarSet w fvs+    let fvs         = freeVarsExpr f+        altCaptures = map (intersectVarSet fvs . mkVarSet . altVars) alts+        bndrCapture = elemVarSet w fvs ---      if | bndrCapture                   -> appAllR idR (alphaCaseBinderR Nothing) >>> caseFloatArgR Nothing---         | all isEmptyVarSet altCaptures -> let new_alts = mapAlts (App f) alts---                                             in return $ Case s w (coreAltsType new_alts) new_alts---         | otherwise                     -> appAllR idR (caseAllR idR idR idR (\ n -> let vs = varSetElems (altCaptures !! n)---                                                                                       in if null vs then idR else alphaAltVarsR vs---                                                                              )---                                                        ) >>> caseFloatArgR Nothing+    if | bndrCapture ->+            appAllR idR (alphaCaseBinderR Nothing) >>> caseFloatArgR Nothing Nothing+       | all isEmptyVarSet altCaptures -> do+            let new_alts = mapAlts (App f) alts+            buildStrictnessLemmaT nm f+            return $ Case s w (coreAltsType new_alts) new_alts+       | otherwise ->+            appAllR idR (caseAllR idR idR idR (\ n -> let vs = varSetElems (altCaptures !! n)+                                                      in if null vs then idR else alphaAltVarsR vs+                                              )+                        ) >>> caseFloatArgR Nothing Nothing  -- | case (case s1 of alt11 -> e11; alt12 -> e12) of alt21 -> e21; alt22 -> e22 --   ==> --   case s1 of --     alt11 -> case e11 of alt21 -> e21; alt22 -> e22 --     alt12 -> case e12 of alt21 -> e21; alt22 -> e22-caseFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m)+               => Rewrite c m CoreExpr caseFloatCaseR = prefixFailMsg "Case floating from Case failed: " $   do-    captures <- caseT (map mkVarSet <$> caseAltVarsT) idR mempty (const $ arr freeVarsAlt) (\ vss w () fvs -> map (intersectVarSet (delVarSet (unionVarSets fvs) w)) vss)+    captures <- caseT (liftM (map mkVarSet) caseAltVarsT) idR mempty (const $ arr freeVarsAlt) (\ vss w () fvs -> map (intersectVarSet (delVarSet (unionVarSets fvs) w)) vss)     -- does the binder of the inner case, shadow a free variable in any of the outer case alts?     bndrCapture <- caseT caseBinderIdT idR mempty (const $ arr freeVarsAlt) (\ innerBndr w () fvs -> innerBndr `elemVarSet` (delVarSet (unionVarSets fvs) w))     caseT ((if not bndrCapture then idR else alphaCaseBinderR Nothing)@@ -235,7 +244,8 @@           (\ (Case s1 b1 _ alts1) b2 ty alts2 -> Case s1 b1 ty $ mapAlts (\s -> Case s b2 ty alts2) alts1)  -- | let v = case s of alt1 -> e1 in e ==> case s of alt1 -> let v = e1 in e-caseFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m)+              => Rewrite c m CoreExpr caseFloatLetR = prefixFailMsg "Case floating from Let failed: " $   do vs <- letNonRecT idR caseAltVarsT mempty (\ letVar caseVars () -> letVar `elem` concat caseVars)      let bdsAction = if not vs then idR else nonRecAllR idR alphaCaseR@@ -252,7 +262,8 @@  -- | caseFloatR = caseFloatAppR <+ caseFloatCaseR <+ caseFloatLetR <+ caseFloatCastR --   Note: does NOT include caseFloatArg-caseFloatR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseFloatR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m)+           => Rewrite c m CoreExpr caseFloatR = setFailMsg "Unsuitable expression for Case floating." $     caseFloatAppR <+ caseFloatCaseR <+ caseFloatLetR <+ caseFloatCastR @@ -288,20 +299,18 @@  ------------------------------------------------------------------------------ --- | Inline the case scrutinee (if it is an identifier), and then perform case reduction.---   If first argument is True, perform substitution in RHS, if False, build let expressions.-caseReduceIdR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Bool -> Rewrite c HermitM CoreExpr-caseReduceIdR subst = caseAllR inlineR idR idR (const idR) >>> caseReduceR subst---- | Inline the case scrutinee (if it is an identifier), and then perform case reduction.+-- | Unfold the case scrutinee and then perform case reduction. --   If first argument is True, perform substitution in RHS, if False, build let expressions.-caseReduceUnfoldR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Bool -> Rewrite c HermitM CoreExpr+caseReduceUnfoldR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                     , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+                  => Bool -> Rewrite c m CoreExpr caseReduceUnfoldR subst = caseAllR unfoldR idR idR (const idR) >>> caseReduceR subst  -- | Case of Known Constructor. --   Eliminate a case if the scrutinee is a data constructor or a literal. --   If first argument is True, perform substitution in RHS, if False, build let expressions.-caseReduceR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Bool -> Rewrite c HermitM CoreExpr+caseReduceR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m)+            => Bool -> Rewrite c m CoreExpr caseReduceR subst =     setFailMsg "Unsuitable expression for Case reduction." $     caseReduceDataconR subst <+ caseReduceLiteralR subst@@ -315,12 +324,8 @@     prefixFailMsg "Case reduction failed: " $     withPatFailMsg (wrongExprForm "Case (Lit l) v t alts") $ do         Case s bndr _ alts <- idR-#if __GLASGOW_HASKELL__ > 706         let in_scope = mkInScopeSet (localFreeVarsExpr s)         case exprIsLiteral_maybe (in_scope, idUnfolding) s of-#else-        case exprIsLiteral_maybe idUnfolding s of-#endif             Nothing -> fail "scrutinee is not a literal."             Just l  -> do guardMsg (not (litIsLifted l)) "cannot case-reduce lifted literals" -- see Trac #5603                           case findAlt (LitAlt l) alts of@@ -332,19 +337,17 @@ -- | Case of Known Constructor. --   Eliminate a case if the scrutinee is a data constructor. --   If first argument is True, perform substitution in RHS, if False, build let expressions.-caseReduceDataconR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Bool -> Rewrite c HermitM CoreExpr+caseReduceDataconR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                                  , ReadBindings c, MonadCatch m, MonadUnique m )+                   => Bool -> Rewrite c m CoreExpr caseReduceDataconR subst = prefixFailMsg "Case reduction failed: " $                            withPatFailMsg (wrongExprForm "Case e v t alts") go     where-        go :: Rewrite c HermitM CoreExpr+        go :: Rewrite c m CoreExpr         go = do             Case e bndr _ alts <- idR-#if __GLASGOW_HASKELL__ > 706             let in_scope = mkInScopeSet (localFreeVarsExpr e)             case exprIsConApp_maybe (in_scope, idUnfolding) e of-#else-            case exprIsConApp_maybe idUnfolding e of-#endif                 Nothing                -> fail "head of scrutinee is not a data constructor."                 Just (dc, univTys, es) -> case findAlt (DataAlt dc) alts of                     Nothing             -> fail "no matching alternative."@@ -367,12 +370,12 @@ -- e ==> case i of i --         []     -> e --         (a:as) -> e-caseSplitR :: (Id -> Bool) -> Rewrite c HermitM CoreExpr+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 -> (dc,) <$> sequence [ newIdH a ty | (a,ty) <- zip aNms $ dataConInstArgTys dc tys ])+                  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@@ -384,7 +387,7 @@ -- -- e -> case v of v --        _ -> e-caseIntroSeqR :: (Id -> Bool) -> Rewrite c HermitM CoreExpr+caseIntroSeqR :: (MonadCatch m, MonadUnique m) => (Id -> Bool) -> Rewrite c m CoreExpr caseIntroSeqR idPred = prefixFailMsg "case-intro-seq failed: " $              do i <- matchingFreeIdT idPred                 contextfreeT $ \ e -> do guardMsg (not $ isTyCoArg e) "cannot case on a type or coercion."@@ -406,25 +409,33 @@ -- for each occurance of the named variable. -- -- > caseSplitInline idPred = caseSplit idPred >>> caseInlineAlternativeR-caseSplitInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => (Id -> Bool) -> Rewrite c HermitM CoreExpr+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  ------------------------------------------------------------------------------ -caseInlineBinderR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => CaseBinderInlineOption -> Rewrite c HermitM CoreExpr+caseInlineBinderR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                                 , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+                  => CaseBinderInlineOption -> Rewrite c m CoreExpr caseInlineBinderR opt =   do w <- caseBinderIdT      caseAllR idR idR idR $ \ _ -> setFailMsg "no inlinable occurrences." $                                    do depth <- varBindingDepthT w-                                      extractR $ anybuR (promoteExprR (configurableInlineR (CaseBinderOnly opt) (varIsOccurrenceOfT w depth)) :: Rewrite c HermitM Core)+                                      extractR $ anybuR (promoteExprR (configurableInlineR (CaseBinderOnly opt) (varIsOccurrenceOfT w depth)) :: Rewrite c m Core)  -- | Inline the case binder as the case scrutinee everywhere in the case alternatives.-caseInlineScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr+caseInlineScrutineeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                        , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+                     => Rewrite c m CoreExpr caseInlineScrutineeR = prefixFailMsg "case-inline-scrutinee failed: " $                        caseInlineBinderR Scrutinee  -- | Inline the case binder as the case-alternative pattern everywhere in the case alternatives.-caseInlineAlternativeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr+caseInlineAlternativeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                          , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+                       => Rewrite c m CoreExpr caseInlineAlternativeR = prefixFailMsg "case-inline-alternative failed: " $                          caseInlineBinderR Alternative @@ -444,31 +455,42 @@                     return $ Case e w ty [(DEFAULT,[],head rhss)]  -- | In the case alternatives, fold any occurrences of the case alt patterns to the case binder.-caseFoldBinderR :: forall c.  (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr+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 w (Just depth)) :: Rewrite c HermitM Core)+                                     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, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr+caseMergeAltsWithBinderR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                            , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+                         => Rewrite c m CoreExpr caseMergeAltsWithBinderR =     prefixFailMsg "merge-case-alts-with-binder failed: " $     withPatFailMsg (wrongExprForm "Case e w ty alts") $     tryR caseFoldBinderR >>> caseMergeAltsR  -- | Eliminate a case, inlining any occurrences of the case binder as the scrutinee.-caseElimInlineScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr+caseElimInlineScrutineeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                            , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+                         => Rewrite c m CoreExpr caseElimInlineScrutineeR = alphaCaseBinderR Nothing >>> tryR caseInlineScrutineeR >>> caseElimR --- | Eliminate a case, merging the case alternatives into a single default alternative and inlining the case binder as the scrutinee (if possible).-caseElimMergeAltsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr+-- | Eliminate a case, merging the case alternatives into a single default alternative+-- and inlining the case binder as the scrutinee (if possible).+caseElimMergeAltsR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                      , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+                   => Rewrite c m CoreExpr caseElimMergeAltsR = tryR caseFoldBinderR >>> tryR caseMergeAltsR >>> caseElimInlineScrutineeR  ------------------------------------------------------------------------------  -- | Eliminate a case that corresponds to a pointless 'seq'.-caseElimSeqR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr+caseElimSeqR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c+                , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+             => Rewrite c m CoreExpr caseElimSeqR = prefixFailMsg "case-elim-seq failed: " $                withPatFailMsg "not a seq case." $   do Case s w _ [(DEFAULT,[],rhs)] <- idR

@@ -70,11 +70,7 @@                 withPatFailMsg (wrongExprForm "App (Cast e1 co) e2") $     do App (Cast e1 co) e2 <- idR        case co of-#if __GLASGOW_HASKELL__ > 706             TyConAppCo _r t [c1, c2] -> do-#else-            TyConAppCo t [c1, c2] -> do-#endif                 True <- return (isFunTyCon t)                 return $ Cast (App e1 (Cast e2 (SymCo c1))) c2             ForAllCo t c2 -> do@@ -82,14 +78,12 @@                 return (Cast (App e1 e2) (Coercion.substCo (Coercion.extendTvSubst emptyCvSubst t x') c2))             _ -> fail "castFloatApp" -#if __GLASGOW_HASKELL__ > 706 -- | 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]) splitTyConAppCo_maybe (Refl ro ty)          = (fmap . second . map) (Refl ro) (splitTyConApp_maybe ty) splitTyConAppCo_maybe (TyConAppCo _r tc cs) = Just (tc, cs) splitTyConAppCo_maybe _                     = Nothing-#endif  -- TODO: revisit castElimSymPlusR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreExpr

@@ -1,48 +1,49 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, MultiWayIf, LambdaCase #-}  module HERMIT.Dictionary.Local.Let-       ( -- * Rewrites on Let Expressions-         externals-         -- ** Let Elimination-       , letNonRecSubstR-       , letNonRecSubstSafeR-       , letSubstR-       , letSubstSafeR-       , letElimR-       , letNonRecElimR-       , letRecElimR-       , progBindElimR-       , progBindNonRecElimR-       , progBindRecElimR-         -- ** Let Introduction-       , letIntroR-       , letNonRecIntroR-       , progNonRecIntroR-       , nonRecIntroR-       , letIntroUnfoldingR-         -- ** Let Floating Out-       , letFloatAppR-       , letFloatArgR-       , letFloatLetR-       , letFloatLamR-       , letFloatCaseR-       , letFloatCastR-       , letFloatExprR-       , letFloatTopR-         -- ** Let Floating In-       , letFloatInR-       , letFloatInAppR-       , letFloatInCaseR-       , letFloatInLamR-         -- ** Miscallaneous-       , reorderNonRecLetsR-       , letTupleR-       , letToCaseR-       )-where+    ( -- * Rewrites on Let Expressions+      externals+      -- ** Let Elimination+    , letNonRecSubstR+    , letNonRecSubstSafeR+    , letSubstR+    , letSubstSafeR+    , letElimR+    , letNonRecElimR+    , letRecElimR+    , progBindElimR+    , progBindNonRecElimR+    , progBindRecElimR+      -- ** Let Introduction+    , letIntroR+    , letNonRecIntroR+    , progNonRecIntroR+    , nonRecIntroR+    , letIntroUnfoldingR+      -- ** Let Floating Out+    , letFloatAppR+    , letFloatArgR+    , letFloatLetR+    , letFloatLamR+    , letFloatCaseR+    , letFloatCaseAltR+    , letFloatCastR+    , letFloatExprR+    , letFloatTopR+      -- ** Let Floating In+    , letFloatInR+    , letFloatInAppR+    , letFloatInCaseR+    , letFloatInLamR+      -- ** Miscallaneous+    , reorderNonRecLetsR+    , letTupleR+    , letToCaseR+    ) where  import Control.Arrow import Control.Monad+import Control.Monad.IO.Class  import Data.List import Data.Monoid@@ -53,6 +54,7 @@ import HERMIT.Kure import HERMIT.External import HERMIT.GHC+import HERMIT.Name import HERMIT.Utilities  import HERMIT.Dictionary.Common@@ -83,7 +85,7 @@     --     , "only matches non-recursive lets" ]  .+ Deep .+ Eval     , external "let-intro" (promoteExprR . letIntroR :: String -> RewriteH Core)         [ "e => (let v = e in v), name of v is provided" ]                      .+ Shallow .+ Introduce-    , external "let-intro-unfolding" (promoteExprR . letIntroUnfoldingR :: String -> RewriteH Core)+    , external "let-intro-unfolding" (promoteExprR . letIntroUnfoldingR :: HermitName -> RewriteH Core)         [ "e => let f' = defn[f'/f] in e[f'/f], name of f is provided" ]     , external "let-elim" (promoteExprR letElimR :: RewriteH Core)         [ "Remove an unused let binding."@@ -102,6 +104,13 @@         [ "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)         [ "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)+        [ "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)+        [ "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)         [ "cast (let bnds in e) co ==> let bnds in cast e co" ]                 .+ Commute .+ Shallow     , external "let-float-top" (promoteProgR letFloatTopR :: RewriteH Core)@@ -157,6 +166,29 @@     do Let (NonRec v rhs) body <- idR        return (substCoreExpr v rhs body) +{-+TODO: This was written very early in the project by Andy.+      It was later modified somewhat by Neil, but without reassessing the heurisitc as a whole.+      It may need revisiting.++Safe Subst Heuristic+--------------------++Substitution is safe if (A) OR (B) OR (C).++(A) The let-bound variable is a type or coercion.++(B) The let-bound value is either:+      (i)   a variable;+      (ii)  a lambda;+      (iii) an application that requires more value arguments before it can perform any computation.++(C) In the body, the let-bound variable must NOT occur:+      (i)  more than once;+      (ii) inside a lambda.++-}+ -- | Currently we always substitute types and coercions, and use a heuristic to decide whether to substitute expressions. --   This may need revisiting. letNonRecSubstSafeR :: forall c m. (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, ReadBindings c, HasEmptyContext c, MonadCatch m) => Rewrite c m CoreExpr@@ -270,7 +302,8 @@ -------------------------------------------------------------------------------------------  -- | @let v = ev in e@ ==> @case ev of v -> e@-letToCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+letToCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m)+           => Rewrite c m CoreExpr letToCaseR = prefixFailMsg "Converting Let to Case failed: " $             withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $   do Let (NonRec v ev) _ <- idR@@ -281,7 +314,8 @@ -------------------------------------------------------------------------------------------  -- | @(let v = ev in e) x@ ==> @let v = ev in e x@-letFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+letFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+             => Rewrite c m CoreExpr letFloatAppR = prefixFailMsg "Let floating from App function failed: " $                withPatFailMsg (wrongExprForm "App (Let bnds body) e") $   do App (Let bnds body) e <- idR@@ -291,7 +325,8 @@         else appAllR (alphaLetVarsR $ varSetElems vs) idR >>> letFloatAppR  -- | @f (let v = ev in e)@ ==> @let v = ev in f e@-letFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+letFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+             => Rewrite c m CoreExpr letFloatArgR = prefixFailMsg "Let floating from App argument failed: " $                withPatFailMsg (wrongExprForm "App f (Let bnds body)") $   do App f (Let bnds body) <- idR@@ -301,7 +336,8 @@         else appAllR idR (alphaLetVarsR $ varSetElems vs) >>> letFloatArgR  -- | @let v = (let bds in e1) in e2@ ==> @let bds in let v = e1 in e2@-letFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+letFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+             => Rewrite c m CoreExpr letFloatLetR = prefixFailMsg "Let floating from Let failed: " $                withPatFailMsg (wrongExprForm "Let (NonRec v (Let bds e1)) e2") $   do Let (NonRec v (Let bds e1)) e2 <- idR@@ -313,20 +349,22 @@ -- | @(\ v -> let binds in e2)@  ==>  @let binds in (\ v1 -> e2)@ --   Fails if @v@ occurs in the RHS of @binds@. --   If @v@ is shadowed in binds, then @v@ will be alpha-renamed.-letFloatLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+letFloatLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+             => Rewrite c m CoreExpr letFloatLamR = prefixFailMsg "Let floating from Lam failed: " $                withPatFailMsg (wrongExprForm "Lam v1 (Let bds body)") $   do Lam v (Let binds body) <- idR      let bs  = bindVars binds          fvs = freeVarsBind binds-     guardMsg (v `notElemVarSet` fvs) (var2String v ++ " occurs in the RHS of the let-bindings.")+     guardMsg (v `notElemVarSet` fvs) (unqualifiedName v ++ " occurs in the RHS of the let-bindings.")      if v `elem` bs       then alphaLamR Nothing >>> letFloatLamR       else return $ Let binds (Lam v body)  -- | @case (let bnds in e) of bndr alts@ ==> @let bnds in (case e of bndr alts)@ --   Fails if any variables bound in @bnds@ occurs in @alts@.-letFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+letFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+              => Rewrite c m CoreExpr letFloatCaseR = prefixFailMsg "Let floating from Case failed: " $                 withPatFailMsg (wrongExprForm "Case (Let bnds e) w ty alts") $   do Case (Let bnds e) w ty alts <- idR@@ -335,6 +373,57 @@        then return $ Let bnds (Case e w ty alts)        else caseAllR (alphaLetVarsR $ varSetElems captures) idR idR (const idR) >>> letFloatCaseR +-- | case e of w { ... ; p -> let b = rhs in body ; ... }  ==>+--   let b = rhs in case e of { ... ; p -> body ; ... }+--+-- where no variable in `p` or `w` occurs freely in `rhs`,+-- and where `b` does not capture a free variable in the overall case,+-- and where `w` is not rebound in `b`.+letFloatCaseAltR :: MonadCatch m => Maybe Int -> Rewrite c m CoreExpr+letFloatCaseAltR maybeN = prefixFailMsg "Let float from case alternative failed: " $+                          withPatFailMsg (wrongExprForm "Case s w ty alts") $ do+        -- Perform the first safe let-floating out of a case alternative+    let letFloatOneAltM :: MonadCatch m => Id -> VarSet -> [CoreAlt] -> m (CoreBind,[CoreAlt])+        letFloatOneAltM w fvs = go+            where go [] = fail "no lets can be safely floated from alternatives."+                  go (alt:rest) = (do (bind,alt') <- letFloatAltM w fvs alt+                                      return (bind,alt':rest))+                                  <+ liftM (second (alt :)) (go rest)++        -- (p -> let bnds in body) ==> (bnds, p -> body)+        letFloatAltM :: Monad m => Id -> VarSet -> CoreAlt -> m (CoreBind,CoreAlt)+        letFloatAltM w fvs (con, vs, Let bnds body) = do+          let bSet = mkVarSet (bindVars bnds)+              vSet = mkVarSet (w:vs)++          -- 'w' is not in 'fvs', but if it is rebound by 'b', doing this rewrite+          -- would cause it to bind things that were previously bound by 'b'.+          guardMsg (not (w `elemVarSet` bSet)) "floating would allow case binder to capture variables."++          -- no free vars in 'rhs' are bound by 'p' or 'w'+          guardMsg (isEmptyVarSet $ vSet `intersectVarSet` freeVarsBind bnds)+                   "floating would cause variables in rhs to become unbound."++          -- no free vars in overall case are bound by 'b'+          guardMsg (isEmptyVarSet $ bSet `intersectVarSet` fvs)+                   "floating would cause let binders to capture variables in case expression."++          return (bnds, (con, vs, body))+        letFloatAltM _ _ _ = fail "no let expression on alternative right-hand side."++    Case e w ty alts <- idR+    fvs <- arr freeVarsExpr+    let l = length alts - 1+    case maybeN of+        Just n | n < 0 || n > l -> fail $ "valid alternative indices: 0 to " ++ show l+               | otherwise      -> do+            let (pre, alt:suf) = splitAt n alts+            (bnds,alt') <- letFloatAltM w fvs alt+            return $ Let bnds $ Case e w ty $ pre ++ (alt':suf)+        Nothing -> do+            (bnds,alts') <- letFloatOneAltM w fvs alts+            return $ Let bnds $ Case e w ty alts'+ -- | @cast (let bnds in e) co@ ==> @let bnds in cast e co@ letFloatCastR :: MonadCatch m => Rewrite c m CoreExpr letFloatCastR = prefixFailMsg "Let floating from Cast failed: " $@@ -343,12 +432,15 @@      return $ Let bnds (Cast e co)  -- | Float a 'Let' through an expression, whatever the context.-letFloatExprR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr-letFloatExprR = setFailMsg "Unsuitable expression for Let floating." $-               letFloatArgR <+ letFloatAppR <+ letFloatLetR <+ letFloatLamR <+ letFloatCaseR <+ letFloatCastR+letFloatExprR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+              => Rewrite c m CoreExpr+letFloatExprR = setFailMsg "Unsuitable expression for Let floating."+              $ letFloatArgR <+ letFloatAppR <+ letFloatLetR <+ letFloatLamR+                  <+ letFloatCaseR <+ letFloatCaseAltR Nothing <+ letFloatCastR  -- | @'ProgCons' ('NonRec' v ('Let' bds e)) p@ ==> @'ProgCons' bds ('ProgCons' ('NonRec' v e) p)@-letFloatTopR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreProg+letFloatTopR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+             => Rewrite c m CoreProg letFloatTopR = prefixFailMsg "Let floating to top level failed: " $                withPatFailMsg (wrongExprForm "NonRec v (Let bds e) `ProgCons` p") $                do ProgCons (NonRec v (Let bds e)) p <- idR@@ -362,12 +454,14 @@ -------------------------------------------------------------------------------------------  -- | Float in a 'Let' if possible.-letFloatInR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) => Rewrite c HermitM CoreExpr+letFloatInR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m)+            => Rewrite c m CoreExpr letFloatInR = letFloatInCaseR <+ letFloatInAppR <+ letFloatInLamR  -- | @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@-letFloatInCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) => Rewrite c HermitM CoreExpr+letFloatInCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m)+                => Rewrite c m CoreExpr letFloatInCaseR = prefixFailMsg "Let floating in to case failed: " $                   withPatFailMsg (wrongExprForm "Let bnds (Case s w ty alts)") $   do Let bnds (Case s w ty alts) <- idR@@ -379,7 +473,8 @@      return (Case (Let bnds s) w ty alts) >>> caseAllR idR idR idR (\_ -> altAllR idR (\_ -> idR) (arr (Let bnds) >>> alphaLetR))  -- | @let v = ev in f a@ ==> @(let v = ev in f) (let v = ev in a)@-letFloatInAppR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) => Rewrite c HermitM CoreExpr+letFloatInAppR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m)+               => Rewrite c m CoreExpr letFloatInAppR = prefixFailMsg "Let floating in to app failed: " $                 withPatFailMsg (wrongExprForm "Let bnds (App e1 e2)") $   do Let bnds (App e1 e2) <- idR@@ -434,7 +529,7 @@  -- | 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}-letTupleR :: String -> Rewrite c HermitM CoreExpr+letTupleR :: (MonadCatch m, MonadUnique m) => String -> Rewrite c m CoreExpr letTupleR nm = prefixFailMsg "Let-tuple failed: " $       do (bnds, body) <- arr collectLets          let numBnds = length bnds@@ -465,32 +560,29 @@ -- This code could be factored better.  -- | @e@ ==> @let v = e in v@-letIntroR :: String -> Rewrite c HermitM CoreExpr+letIntroR :: (MonadCatch m, MonadUnique m) => String -> Rewrite c m CoreExpr letIntroR nm = do e <- idR                   Let (NonRec v e') _ <- letNonRecIntroR nm e                   return $ Let (NonRec v e') (varToCoreExpr v)  -- | @body@ ==> @let v = e in body@-letNonRecIntroR :: String -> CoreExpr -> Rewrite c HermitM CoreExpr+letNonRecIntroR :: (MonadCatch m, MonadUnique m) => String -> CoreExpr -> Rewrite c m CoreExpr letNonRecIntroR nm e = prefixFailMsg "Let-introduction failed: " $-     contextfreeT $ \ body -> do let tyk = exprKindOrType e-                                 v <- if | isTypeArg e  -> newTyVarH nm tyk-                                         | isCoArg e    -> newCoVarH nm tyk-                                         | otherwise    -> newIdH nm tyk+     contextfreeT $ \ body -> do v <- newVarH nm $ exprKindOrType e                                  return $ Let (NonRec v e) body   -- This isn't a "Let", but it's serving the same role.  Maybe create a Local/Prog module?  -- | @prog@ ==> @'ProgCons' (v = e) prog@-progNonRecIntroR :: String -> CoreExpr -> Rewrite c HermitM CoreProg+progNonRecIntroR :: (MonadCatch m, MonadUnique m) => String -> CoreExpr -> Rewrite c m CoreProg progNonRecIntroR nm e = prefixFailMsg "Top-level binding introduction failed: " $   do guardMsg (not $ isTyCoArg e) "Top-level type or coercion definitions are prohibited."      contextfreeT $ \ prog -> do i <- newIdH nm (exprType e)                                  return $ ProgCons (NonRec i e) prog  -- | nonRecIntroR nm e = 'letNonRecIntroR nm e' <+ 'progNonRecIntroR nm e'-nonRecIntroR :: String -> CoreExpr -> Rewrite c HermitM Core+nonRecIntroR :: (MonadCatch m, MonadUnique m) => String -> CoreExpr -> Rewrite c m Core nonRecIntroR nm e = readerT $ \case                       ExprCore{} -> promoteExprR (letNonRecIntroR nm e)                       ProgCore{} -> promoteProgR (progNonRecIntroR nm e)@@ -498,7 +590,9 @@  -- | Introduce a local definition for a (possibly imported) identifier. -- Rewrites occurences of the identifier to point to this new local definiton.-letIntroUnfoldingR :: (BoundVars c, ReadBindings c) => String -> Rewrite c HermitM CoreExpr+letIntroUnfoldingR :: ( BoundVars c, ReadBindings c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m+                      , MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+                   => HermitName -> Rewrite c m CoreExpr letIntroUnfoldingR nm = do     i <- findIdT nm     (rhs,_) <- getUnfoldingT AllBinders <<< return i

@@ -1,33 +1,35 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, FlexibleInstances, InstanceSigs #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, InstanceSigs, ScopedTypeVariables, TypeFamilies #-}  module HERMIT.Dictionary.Navigation-       ( -- * Navigation-         externals-       , occurrenceOfT-       , bindingOfT-       , bindingGroupOfT-       , rhsOfT-       , parentOfT-       , occurrenceOfTargetsT-       , bindingOfTargetsT-       , bindingGroupOfTargetsT-       , rhsOfTargetsT-       , Considerable(..)-       , considerables-       , considerConstructT-       , nthArgPath-       )-where+    ( -- * Navigation+      externals+    , occurrenceOfT+    , bindingOfT+    , bindingGroupOfT+    , rhsOfT+    , parentOfT+    , occurrenceOfTargetsT+    , bindingOfTargetsT+    , bindingGroupOfTargetsT+    , rhsOfTargetsT+    , Considerable(..)+    , considerables+    , considerConstructT+    , nthArgPath+    , string2considerable+    ) where +import Data.Dynamic (Typeable) import Data.Monoid  import Control.Arrow  import HERMIT.Core import HERMIT.Context-import HERMIT.Kure import HERMIT.External import HERMIT.GHC hiding ((<>))+import HERMIT.Kure+import HERMIT.Name  import HERMIT.Dictionary.Navigation.Crumbs @@ -35,32 +37,33 @@  -- | 'External's involving navigating to named entities. externals :: [External]-externals = crumbExternals ++ map (.+ Navigation)-            [ external "rhs-of" (rhsOfT . cmpString2Var :: String -> TransformH Core LocalPathH)-                [ "Find the path to the RHS of the binding of the named variable." ]-            , external "binding-group-of" (bindingGroupOfT . cmpString2Var :: String -> TransformH CoreTC LocalPathH)-                [ "Find the path to the binding group of the named variable." ]-            , external "binding-of" (bindingOfT . cmpString2Var :: String -> TransformH CoreTC LocalPathH)-                [ "Find the path to the binding of the named variable." ]-            , external "occurrence-of" (occurrenceOfT . cmpString2Var :: String -> TransformH CoreTC LocalPathH)-                [ "Find the path to the first occurrence of the named variable." ]-            , external "consider" (considerConstruct :: String -> TransformH Core LocalPathH)-                [ "consider <c> focuses on the first construct <c>.",-                  recognizedConsiderables]-            , external "arg" (promoteExprT . nthArgPath :: Int -> TransformH Core LocalPathH)-                [ "arg n focuses on the (n-1)th argument of a nested application." ]-            , external "lams-body" (promoteExprT lamsBodyT :: TransformH Core LocalPathH)-                [ "Descend into the body after a sequence of lambdas." ]-            , external "lets-body" (promoteExprT letsBodyT :: TransformH Core LocalPathH)-                [ "Descend into the body after a sequence of let bindings." ]-            , external "prog-end" (promoteModGutsT gutsProgEndT <+ promoteProgT progEndT :: TransformH Core LocalPathH)-                [ "Descend to the end of a program." ]--            , external "parent-of" (parentOfT :: TransformH Core LocalPathH -> TransformH Core LocalPathH)-                [ "Focus on the parent of another focal point." ]-            , external "parent-of" (parentOfT :: TransformH CoreTC LocalPathH -> TransformH CoreTC LocalPathH)-                [ "Focus on the parent of another focal point." ]-            ]+externals = crumbExternals+    ++ map (.+ Navigation)+        [ external "rhs-of" (rhsOfT . mkRhsOfPred :: RhsOfName -> TransformH Core LocalPathH)+            [ "Find the path to the RHS of the binding of the named variable." ]+        , external "binding-group-of" (bindingGroupOfT . cmpString2Var :: String -> TransformH CoreTC LocalPathH)+            [ "Find the path to the binding group of the named variable." ]+        , external "binding-of" (bindingOfT . mkBindingPred :: BindingName -> TransformH CoreTC LocalPathH)+            [ "Find the path to the binding of the named variable." ]+        , external "occurrence-of" (occurrenceOfT . mkOccPred :: OccurrenceName -> TransformH CoreTC LocalPathH)+            [ "Find the path to the first occurrence of the named variable." ]+        , external "application-of" (applicationOfT . mkOccPred :: OccurrenceName -> TransformH CoreTC LocalPathH)+            [ "Find the path to the first application of the named variable." ]+        , external "consider" (considerConstructT :: Considerable -> TransformH Core LocalPathH)+            [ "consider <c> focuses on the first construct <c>.", recognizedConsiderables ]+        , external "arg" (promoteExprT . nthArgPath :: Int -> TransformH Core LocalPathH)+            [ "arg n focuses on the (n-1)th argument of a nested application." ]+        , external "lams-body" (promoteExprT lamsBodyT :: TransformH Core LocalPathH)+            [ "Descend into the body after a sequence of lambdas." ]+        , external "lets-body" (promoteExprT letsBodyT :: TransformH Core LocalPathH)+            [ "Descend into the body after a sequence of let bindings." ]+        , external "prog-end" (promoteModGutsT gutsProgEndT <+ promoteProgT progEndT :: TransformH Core LocalPathH)+            [ "Descend to the end of a program." ]+        , external "parent-of" (parentOfT :: TransformH Core LocalPathH -> TransformH Core LocalPathH)+            [ "Focus on the parent of another focal point." ]+        , external "parent-of" (parentOfT :: TransformH CoreTC LocalPathH -> TransformH CoreTC LocalPathH)+            [ "Focus on the parent of another focal point." ]+        ]  --------------------------------------------------------------------------------------- @@ -99,6 +102,12 @@ 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+applicationOfT p = prefixFailMsg "application-of failed:" $ oneNonEmptyPathToT go+    where go = promoteExprT (appT (extractT go) successT const) <+ arr (occurrenceOf p)+ -----------------------------------------------------------------------  bindingGroupOf :: (Var -> Bool) -> CoreBind -> Bool@@ -186,7 +195,13 @@  -- | Language constructs that can be zoomed to. data Considerable = Binding | Definition | CaseAlt | Variable | Literal | Application | Lambda | LetExpr | CaseOf | Casty | Ticky | TypeExpr | CoercionExpr+    deriving Typeable +instance Extern Considerable where+    type Box Considerable = Considerable+    box = id+    unbox = id+ recognizedConsiderables :: String recognizedConsiderables = "Recognized constructs are: " ++ show (map fst considerables) @@ -206,12 +221,6 @@                   , ("type",TypeExpr)                   , ("coerce",CoercionExpr)                   ]--considerConstruct :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => String -> Transform c m Core LocalPathH-considerConstruct str = case string2considerable str of-                          Nothing -> fail $ "Unrecognized construct \"" ++ str ++ "\". Perhaps you meant \"binding-of '" ++ str ++ "\"? "-                                            ++ recognizedConsiderables ++ "."-                          Just c  -> considerConstructT c  -- | 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

@@ -1,13 +1,12 @@ {-# LANGUAGE CPP, LambdaCase, FlexibleContexts #-}  module HERMIT.Dictionary.Query-  ( -- * Queries and Predicates-    externals-  , infoT-  , compareCoreAtT-  , compareBoundIdsT-  )-where+    ( -- * Queries and Predicates+      externals+    , infoT+    , compareCoreAtT+    , compareBoundIdsT+    ) where  import Control.Arrow @@ -20,6 +19,7 @@ import HERMIT.GHC import HERMIT.Kure import HERMIT.Monad+import HERMIT.Name  import HERMIT.Dictionary.AlphaConversion hiding (externals) import HERMIT.Dictionary.Common@@ -31,13 +31,13 @@ -- | Externals that reflect GHC functions, or are derived from GHC functions. externals :: [External] externals =-         [ external "info" (infoT :: TransformH CoreTC String)-                [ "Display information about the current node." ] .+ Query-         , external "compare-bound-ids" (compareBoundIds :: String -> String -> TransformH CoreTC ())-                [ "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 ())-                [ "Compare the core fragments at the end of the given paths for alpha-equality."] .+ Query .+ Predicate-         ]+    [ external "info" (infoT :: TransformH CoreTC String)+        [ "Display information about the current node." ] .+ Query+    , external "compare-bound-ids" (compareBoundIds :: HermitName -> HermitName -> TransformH CoreTC ())+        [ "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 ())+        [ "Compare the core fragments at the end of the given paths for alpha-equality."] .+ Query .+ Predicate+    ]  -------------------------------------------------------- @@ -52,7 +52,7 @@               pa       =   "Path:     " ++ showCrumbs (snocPathToPath $ absPath c)               children =   "Children: " ++ showCrumbs crumbs               bds      =   "Local bindings in scope: " ++ concat-                                [ "\n  " ++ var2String k ++  " : " ++ hermitBindingSummary hbs+                                [ "\n  " ++ unqualifiedName k ++  " : " ++ hermitBindingSummary hbs                                 | (k,hbs) <- Map.toList (hermitBindings c)                                 ]               freevars = [ "Free local identifiers:  " ++ showVarSet (filterVarSet isLocalId fvs)@@ -63,11 +63,14 @@                typeId   = case coreTC of                              Core (ExprCore e)      -> let tyK = exprKindOrType e+                                                           modName i = case nameModule_maybe (getName i) of+                                                                        Nothing -> "no module name."+                                                                        Just m -> moduleNameString (moduleName m)                                                         in [(if isKind tyK then "Kind:        " else "Type:        ") ++ showPpr dynFlags tyK] ++                                                            case e of                                                              Var i -> [ ""                                                                       , "OccName:                  " ++ getOccString i-                                                                      , if isLocalVar i then "Local" else "Global"+                                                                      , if isLocalVar i then "Local" else "Global: " ++ modName i                                                                       , "Unique:                   " ++ show (getUnique i)                                                                       , "Identifier arity:         " ++ show (arityOf c i)                                                                       , "Identifier binding depth: " ++ runKureM show id (lookupHermitBindingDepth i c)@@ -151,14 +154,10 @@                          TransCo{}     -> "TransCo"                          NthCo{}       -> "NthCo"                          InstCo{}      -> "InstCo"-#if __GLASGOW_HASKELL__ > 706                          AxiomRuleCo{} -> "AxiomRuleCo"                          LRCo{}        -> "LRCo"                          SubCo{}       -> "SubCo"                          UnivCo{}      -> "UnivCo"-#else-                         UnsafeCo{}    -> "UnsafeCo"-#endif  -------------------------------------------------------- @@ -180,7 +179,8 @@      guardMsg (e1 `exprAlphaEq` e2) "bindings are not alpha-equivalent."  -- | Compare the definitions of the two named identifiers for alpha-equality.-compareBoundIds :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => String -> String -> Transform c HermitM x ()+compareBoundIds :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c)+                => HermitName -> HermitName -> Transform c HermitM x () compareBoundIds nm1 nm2 = do i1 <- findIdT nm1                              i2 <- findIdT nm2                              compareBoundIdsT i1 i2

@@ -4,16 +4,19 @@ module HERMIT.Dictionary.Reasoning     ( -- * Equational Reasoning       externals-    , CoreExprEquality(..)-    , RewriteCoreExprEqualityBox(..)-    , TransformCoreExprEqualityStringBox(..)-    , CoreExprEqualityProof-    , flipCoreExprEquality+    , EqualityProof+    , flipEquality     , eqLhsIntroR     , eqRhsIntroR     , birewrite     , extensionalityR-    -- ** Lifting transformations over 'CoreExprEquality'+    , getLemmasT+    , getLemmaByNameT+    , insertLemmaR+    , lemmaR+    , markLemmaUsedR+    , modifyLemmaR+    -- ** Lifting transformations over 'Equality'     , lhsT     , rhsT     , bothT@@ -21,9 +24,9 @@     , lhsR     , rhsR     , bothR-    , ppCoreExprEqualityT-    , proveCoreExprEqualityT-    , verifyCoreExprEqualityT+    , ppEqualityT+    , proveEqualityT+    , verifyEqualityT     , verifyEqualityLeftToRightT     , verifyEqualityCommonTargetT     , verifyIsomorphismT@@ -38,36 +41,34 @@     , discardUniVars     ) where -import Control.Applicative-import Control.Arrow-import Control.Monad-import Control.Monad.IO.Class--import Data.List (nubBy)-import Data.Maybe (fromMaybe)-import Data.Monoid-import Data.Typeable--import HERMIT.Context-import HERMIT.Core-import HERMIT.External-import HERMIT.GHC-import HERMIT.Kure-import HERMIT.Monad-import HERMIT.ParserCore-#if __GLASGOW_HASKELL__ >= 708-import HERMIT.ParserType-#endif-import HERMIT.Utilities+import           Control.Applicative+import           Control.Arrow+import           Control.Monad+import           Control.Monad.IO.Class -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 Data.Map as Map+import           Data.List (nubBy)+import           Data.Maybe (fromMaybe)+import           Data.Monoid -import HERMIT.PrettyPrinter.Common+import           HERMIT.Context+import           HERMIT.Core+import           HERMIT.External+import           HERMIT.GHC+import           HERMIT.Kure+import           HERMIT.Monad+import           HERMIT.Name+import           HERMIT.ParserCore+import           HERMIT.ParserType+import           HERMIT.PrettyPrinter.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 @@ -88,72 +89,91 @@         [ "Alpha-rename a universally quantified variable." ]     , external "unshadow-equality" unshadowEqualityR         [ "Unshadow an equality." ]+    , external "lemma" (promoteExprBiR . lemmaR :: LemmaName -> BiRewriteH Core)+        [ "Generate a bi-directional rewrite from a lemma." ]+    , external "lemma-lhs-intro" (lemmaLhsIntroR :: LemmaName -> RewriteH Core)+        [ "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)+        [ "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)+        [ "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)+        [ "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)+        [ "Apply a transformation to a lemma, returning the result." ]+    , external "extensionality" (extensionalityR . Just :: String -> RewriteH Equality)+        [ "Given a name 'x, then"+        , "f == g  ==>  forall x.  f x == g x" ]+    , external "extensionality" (extensionalityR Nothing :: RewriteH Equality)+        [ "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)+        [ "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." ]     ]  ------------------------------------------------------------------------------ --- | An equality is represented as a set of universally quantified binders, and then the LHS and RHS of the equality.-data CoreExprEquality = CoreExprEquality [CoreBndr] CoreExpr CoreExpr--data RewriteCoreExprEqualityBox =-        RewriteCoreExprEqualityBox (RewriteH CoreExprEquality) deriving Typeable--instance Extern (RewriteH CoreExprEquality) where-    type Box (RewriteH CoreExprEquality) = RewriteCoreExprEqualityBox-    box = RewriteCoreExprEqualityBox-    unbox (RewriteCoreExprEqualityBox r) = r--data TransformCoreExprEqualityStringBox =-        TransformCoreExprEqualityStringBox (TransformH CoreExprEquality String) deriving Typeable--instance Extern (TransformH CoreExprEquality String) where-    type Box (TransformH CoreExprEquality String) = TransformCoreExprEqualityStringBox-    box = TransformCoreExprEqualityStringBox-    unbox (TransformCoreExprEqualityStringBox t) = t--type CoreExprEqualityProof c m = (Rewrite c m CoreExpr, Rewrite c m CoreExpr)+type EqualityProof c m = (Rewrite c m CoreExpr, Rewrite c m CoreExpr) --- | Flip the LHS and RHS of a 'CoreExprEquality'.-flipCoreExprEquality :: CoreExprEquality -> CoreExprEquality-flipCoreExprEquality (CoreExprEquality xs lhs rhs) = CoreExprEquality xs rhs lhs+-- | 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 CoreExprEquality+extensionalityR :: Maybe String -> Rewrite c HermitM Equality extensionalityR mn = prefixFailMsg "extensionality failed: " $-  do CoreExprEquality vs lhs rhs <- idR+  do Equality vs lhs rhs <- idR       let tyL = exprKindOrType lhs          tyR = exprKindOrType rhs      guardMsg (tyL `typeAlphaEq` tyR) "type mismatch between sides of equality.  This shouldn't happen, so is probably a bug."       -- TODO: use the fresh-name-generator in AlphaConversion to avoid shadowing.-     (argTy,_) <- splitFunTypeM tyL+     (_,argTy,_) <- splitFunTypeM tyL      v <- constT $ newVarH (fromMaybe "x" mn) argTy       let x = varToCoreExpr v -     return $ CoreExprEquality (vs ++ [v])-                               (mkCoreApp lhs x)-                               (mkCoreApp rhs x)+     return $ Equality (vs ++ [v]) (mkCoreApp lhs x) (mkCoreApp rhs x)  ------------------------------------------------------------------------------  -- | @e@ ==> @let v = lhs in e@-eqLhsIntroR :: CoreExprEquality -> Rewrite c HermitM Core-eqLhsIntroR (CoreExprEquality bs lhs _) = nonRecIntroR "lhs" (mkCoreLams bs lhs)+eqLhsIntroR :: Equality -> Rewrite c HermitM Core+eqLhsIntroR (Equality bs lhs _) = nonRecIntroR "lhs" (mkCoreLams bs lhs)  -- | @e@ ==> @let v = rhs in e@-eqRhsIntroR :: CoreExprEquality -> Rewrite c HermitM Core-eqRhsIntroR (CoreExprEquality bs _ rhs) = nonRecIntroR "rhs" (mkCoreLams bs rhs)+eqRhsIntroR :: Equality -> Rewrite c HermitM Core+eqRhsIntroR (Equality bs _ rhs) = nonRecIntroR "rhs" (mkCoreLams bs rhs)  ------------------------------------------------------------------------------ --- | Create a 'BiRewrite' from a 'CoreExprEquality'.+-- | 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.-birewrite :: (AddBindings c, ReadBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c) => CoreExprEquality -> BiRewrite c HermitM CoreExpr-birewrite (CoreExprEquality bnds l r) = bidirectional (foldUnfold l r) (foldUnfold r l)+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@@ -163,46 +183,46 @@                 -- create a temporary context with an unfolding for the                 -- transitory function so we can reuse unfoldR.                 c' = addHermitBindings [(v, NONREC rhsLam, mempty)] c-            apply unfoldR c' e'+            applyT unfoldR c' e' --- | Lift a transformation over 'CoreExpr' into a transformation over the left-hand side of a 'CoreExprEquality'.-lhsT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m CoreExprEquality b-lhsT t = idR >>= \ (CoreExprEquality vs lhs _) -> return lhs >>> withVarsInScope vs t+-- | 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 --- | Lift a transformation over 'CoreExpr' into a transformation over the right-hand side of a 'CoreExprEquality'.-rhsT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m CoreExprEquality b-rhsT t = idR >>= \ (CoreExprEquality vs _ rhs) -> return rhs >>> withVarsInScope vs t+-- | 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 'CoreExpr' into a transformation over both sides of a 'CoreExprEquality'.-bothT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m CoreExprEquality (b,b)+-- | 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 '[Var]' into a transformation over the universally quantified variables of a 'CoreExprEquality'.-forallVarsT :: Monad m => Transform c m [Var] b -> Transform c m CoreExprEquality b-forallVarsT t = idR >>= \ (CoreExprEquality vs _ _) -> return vs >>> t+-- | 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 rewrite over 'CoreExpr' into a rewrite over the left-hand side of a 'CoreExprEquality'.-lhsR :: (AddBindings c, Monad m, ReadPath c Crumb) => Rewrite c m CoreExpr -> Rewrite c m CoreExprEquality+-- | 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-    CoreExprEquality vs lhs rhs <- idR+    Equality vs lhs rhs <- idR     lhs' <- withVarsInScope vs r <<< return lhs-    return $ CoreExprEquality vs lhs' rhs+    return $ Equality vs lhs' rhs --- | Lift a rewrite over 'CoreExpr' into a rewrite over the right-hand side of a 'CoreExprEquality'.-rhsR :: (AddBindings c, Monad m, ReadPath c Crumb) => Rewrite c m CoreExpr -> Rewrite c m CoreExprEquality+-- | 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-    CoreExprEquality vs lhs rhs <- idR+    Equality vs lhs rhs <- idR     rhs' <- withVarsInScope vs r <<< return rhs-    return $ CoreExprEquality vs lhs rhs'+    return $ Equality vs lhs rhs' --- | Lift a rewrite over 'CoreExpr' into a rewrite over both sides of a 'CoreExprEquality'.-bothR :: (AddBindings c, MonadCatch m, ReadPath c Crumb) => Rewrite c m CoreExpr -> Rewrite c m CoreExprEquality+-- | 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 bothR r = lhsR r >+> rhsR r  ------------------------------------------------------------------------------ -ppCoreExprEqualityT :: PrettyPrinter -> TransformH CoreExprEquality DocH-ppCoreExprEqualityT pp = do+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)@@ -219,30 +239,30 @@ -- -- TODO: need to know type of 'x' to generate a variable. class BuildEquality a where-    mkEquality :: a -> HermitM CoreExprEquality+    mkEquality :: a -> HermitM Equality  instance BuildEquality (CoreExpr,CoreExpr) where-    mkEquality :: (CoreExpr,CoreExpr) -> HermitM CoreExprEquality-    mkEquality (lhs,rhs) = return $ CoreExprEquality [] lhs rhs+    mkEquality :: (CoreExpr,CoreExpr) -> HermitM Equality+    mkEquality (lhs,rhs) = return $ Equality [] lhs rhs  instance BuildEquality a => BuildEquality (CoreExpr -> a) where-    mkEquality :: (CoreExpr -> a) -> HermitM CoreExprEquality+    mkEquality :: (CoreExpr -> a) -> HermitM Equality     mkEquality f = do         x <- newIdH "x" (error "need to create a type")-        CoreExprEquality bnds lhs rhs <- mkEquality (f (varToCoreExpr x))-        return $ CoreExprEquality (x:bnds) lhs rhs+        Equality bnds lhs rhs <- mkEquality (f (varToCoreExpr x))+        return $ Equality (x:bnds) lhs rhs  ------------------------------------------------------------------------------ --- | Verify that a 'CoreExprEquality' holds, by applying a rewrite to each side, and checking that the results are equal.-proveCoreExprEqualityT :: forall c m. (AddBindings c, Monad m, ReadPath c Crumb)-                        => CoreExprEqualityProof c m -> Transform c m CoreExprEquality ()-proveCoreExprEqualityT (l,r) = lhsR l >>> rhsR r >>> verifyCoreExprEqualityT+-- | 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 --- | Verify that the left- and right-hand sides of a 'CoreExprEquality' are alpha equivalent.-verifyCoreExprEqualityT :: Monad m => Transform c m CoreExprEquality ()-verifyCoreExprEqualityT = do-    CoreExprEquality _ lhs rhs <- idR+-- | 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."  ------------------------------------------------------------------------------@@ -257,7 +277,7 @@      guardMsg (exprAlphaEq targetExpr resultExpr) "result of running proof on lhs of equality does not match rhs of equality."  -- | Given two expressions, and a rewrite to apply to each, verify that the resulting expressions are equal.-verifyEqualityCommonTargetT :: MonadCatch m => CoreExpr -> CoreExpr -> CoreExprEqualityProof c m -> Transform c m a ()+verifyEqualityCommonTargetT :: MonadCatch m => CoreExpr -> CoreExpr -> EqualityProof c m -> Transform c m a () verifyEqualityCommonTargetT lhs rhs (l,r) =   prefixFailMsg "equality verification failed: " $   do lhsResult <- l <<< return lhs@@ -317,16 +337,14 @@ ------------------------------------------------------------------------------  -- TODO: revisit this for binder re-ordering issue-instantiateDictsR :: RewriteH CoreExprEquality-#if __GLASGOW_HASKELL__ >= 708+instantiateDictsR :: RewriteH Equality instantiateDictsR = prefixFailMsg "Dictionary instantiation failed: " $ do     bs <- forallVarsT idR     let dArgs = filter (\b -> isId b && isDictTy (varType b)) bs         uniqDs = nubBy (\ b1 b2 -> eqType (varType b1) (varType b2)) dArgs     guardMsg (not (null uniqDs)) "no universally quantified dictionaries can be instantiated."     ds <- forM uniqDs $ \ b -> constT $ do-            guts <- getModGuts-            (i,bnds) <- liftCoreM $ buildDictionary guts b+            (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                             _ -> mkCoreLets bnds (varToCoreExpr i)@@ -344,15 +362,12 @@                 then return $ lookup3 b ds                 else buildSubst b     contextfreeT $ instantiateEquality allDs-#else-instantiateDictsR = fail "Dictionaries cannot be instantiated in GHC 7.6"-#endif  ------------------------------------------------------------------------------ -alphaEqualityR :: (Var -> Bool) -> (String -> String) -> RewriteH CoreExprEquality+alphaEqualityR :: (Var -> Bool) -> (String -> String) -> RewriteH Equality alphaEqualityR p f = prefixFailMsg "Alpha-renaming binder in equality failed: " $ do-    CoreExprEquality bs lhs rhs <- idR+    Equality bs lhs rhs <- idR     guardMsg (any p bs) "specified variable is not universally quantified."      let (bs',i:vs) = break p bs -- this is safe because we know i is in bs@@ -363,11 +378,11 @@         (subst', vs') = substBndrs subst vs         lhs'          = substExpr (text "coreExprEquality-lhs") subst' lhs         rhs'          = substExpr (text "coreExprEquality-rhs") subst' rhs-    return $ CoreExprEquality (bs'++(i':vs')) lhs' rhs'+    return $ Equality (bs'++(i':vs')) lhs' rhs' -unshadowEqualityR :: RewriteH CoreExprEquality+unshadowEqualityR :: RewriteH Equality unshadowEqualityR = prefixFailMsg "Unshadowing equality failed: " $ do-    c@(CoreExprEquality bs _ _) <- idR+    c@(Equality bs _ _) <- idR     bvs <- boundVarsT     let visible = unionVarSets [bvs , freeVarsEquality c]     ss <- varSetElems <$> detectShadowsM bs visible@@ -375,39 +390,35 @@     let f = freshNameGenAvoiding Nothing . extendVarSet visible     andR [ alphaEqualityR (==s) (f s) | s <- reverse ss ] >>> bothR (tryR unshadowExprR) -freeVarsEquality :: CoreExprEquality -> VarSet-freeVarsEquality (CoreExprEquality bs lhs rhs) =+freeVarsEquality :: Equality -> VarSet+freeVarsEquality (Equality bs lhs rhs) =     delVarSetList (unionVarSets (map freeVarsExpr [lhs,rhs])) bs  ------------------------------------------------------------------------------ -instantiateEqualityVarR :: (Var -> Bool) -> CoreString -> RewriteH CoreExprEquality+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-#if __GLASGOW_HASKELL__ >= 708                       | otherwise -> do let (before,_) = break (==b) bs                                         (ty, tvs) <- withVarsInScope before $ parseTypeWithHolesT cs                                         return (Type ty, tvs)-#else-                      | otherwise -> fail "cannot instantiate type binders in GHC 7.6"-#endif     eq <- contextfreeT $ instantiateEqualityVar p e new     (_,_) <- return eq >>> bothT lintExprT -- sanity check     return eq --- | Instantiate one of the universally quantified variables in a 'CoreExprEquality'.+-- | 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-                                    -> CoreExprEquality -> m CoreExprEquality-instantiateEqualityVar p e new (CoreExprEquality bs lhs rhs)+                                    -> 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@@ -427,21 +438,68 @@         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 "coreExprEquality-lhs") subst' lhs-            rhs'          = substExpr (text "coreExprEquality-rhs") subst' rhs-        instantiateEquality (noAdds tvs) $ CoreExprEquality (bs'++new++vs') lhs' rhs'+            lhs'          = substExpr (text "equality-lhs") subst' lhs+            rhs'          = substExpr (text "equality-rhs") subst' rhs+        instantiateEquality (noAdds tvs) $ Equality (bs'++new++vs') lhs' rhs'  noAdds :: [(Var,CoreExpr)] -> [(Var,CoreExpr,[Var])] noAdds ps = [ (v,e,[]) | (v,e) <- ps ] --- | Instantiate a set of universally quantified variables in a 'CoreExprEquality'.+-- | 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])] -> CoreExprEquality -> m CoreExprEquality+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).  ------------------------------------------------------------------------------ -discardUniVars :: CoreExprEquality -> CoreExprEquality-discardUniVars (CoreExprEquality _ lhs rhs) = CoreExprEquality [] lhs rhs+discardUniVars :: Equality -> Equality+discardUniVars (Equality _ lhs rhs) = Equality [] lhs rhs++------------------------------------------------------------------------------++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)++------------------------------------------------------------------------------++-- We use sideEffectR because only rewrites generate new state in the Kernel.++insertLemmaR :: (HasLemmas m, Monad m) => LemmaName -> Lemma -> Rewrite c m a+insertLemmaR nm l = sideEffectR $ \ _ _ -> insertLemma nm l++modifyLemmaR :: (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)++markLemmaUsedR :: (HasLemmas m, Monad m) => LemmaName -> Rewrite c m a+markLemmaUsedR nm = modifyLemmaR nm id idR id (const True)++------------------------------------------------------------------------------++lemmaNameToEqualityT :: (HasLemmas m, Monad m) => LemmaName -> Transform c m x Equality+lemmaNameToEqualityT nm = liftM lemmaEq $ getLemmaByNameT nm++-- | @e@ ==> @let v = lhs in e@  (also works in a similar manner at Program nodes)+lemmaLhsIntroR :: LemmaName -> RewriteH Core+lemmaLhsIntroR = lemmaNameToEqualityT >=> eqLhsIntroR++-- | @e@ ==> @let v = rhs in e@  (also works in a similar manner at Program nodes)+lemmaRhsIntroR :: LemmaName -> RewriteH Core+lemmaRhsIntroR = lemmaNameToEqualityT >=> eqRhsIntroR+

@@ -1,33 +1,31 @@-{-# LANGUAGE CPP, FlexibleContexts #-}+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TypeFamilies #-} module HERMIT.Dictionary.Rules-       ( -- * GHC Rewrite Rules and Specialisation-         externals-         -- ** Rules-       , RuleNameString-       , ruleR-       , rulesR-       , ruleToEqualityT-       , ruleNameToEqualityT-       , getHermitRuleT-       , getHermitRulesT-       -- , verifyCoreRuleT-       -- , verifyRuleT-       -- , ruleLhsIntroR-       -- , ruleRhsIntroR-         -- ** Specialisation-       , specConstrR-       )-where+    ( -- * GHC Rewrite Rules and Specialisation+      externals+      -- ** Rules+    , RuleName(..)+    , RuleNameListBox(..)+    , ruleR+    , rulesR+    , ruleToEqualityT+    , ruleNameToEqualityT+    , getHermitRuleT+    , getHermitRulesT+      -- ** Specialisation+    , specConstrR+    , specialiseR+    ) where -import IOEnv hiding (liftIO) import qualified SpecConstr import qualified Specialise  import Control.Arrow import Control.Monad +import Data.Dynamic (Typeable) import Data.Function (on) import Data.List (deleteFirstsBy,intercalate)+import Data.String (IsString(..))  import HERMIT.Core import HERMIT.Context@@ -36,166 +34,117 @@ import HERMIT.External import HERMIT.GHC -import HERMIT.Dictionary.Common (inScope,callT) import HERMIT.Dictionary.GHC (dynFlagsT)--- import HERMIT.Dictionary.Induction import HERMIT.Dictionary.Kure (anyCallR) import HERMIT.Dictionary.Reasoning hiding (externals)-import HERMIT.Dictionary.Unfold (cleanupUnfoldR)+import HERMIT.Dictionary.Unfold (betaReducePlusR) +import IOEnv hiding (liftIO)+ ------------------------------------------------------------------------ --- | Externals that reflect GHC functions, or are derived from GHC functions.+-- | Externals dealing with GHC rewrite rules. externals :: [External] externals =-         [ external "rules-help-list" (rulesHelpListT :: TransformH CoreTC String)-                [ "List all the rules in scope." ] .+ Query-         , external "rule-help" (ruleHelpT :: RuleNameString -> TransformH CoreTC String)-                [ "Display details on the named rule." ] .+ Query-         , external "apply-rule" (promoteExprR . ruleR :: RuleNameString -> RewriteH Core)-                [ "Apply a named GHC rule" ] .+ Shallow-         , external "apply-rules" (promoteExprR . rulesR :: [RuleNameString] -> RewriteH Core)-                [ "Apply named GHC rules, succeed if any of the rules succeed" ] .+ Shallow-         , external "add-rule" ((\ rule_name id_name -> promoteModGutsR (addCoreBindAsRule rule_name id_name)) :: String -> String -> RewriteH Core)-                [ "add-rule \"rule-name\" <id> -- adds a new rule that freezes the right hand side of the <id>"]  .+ Introduce-         , external "unfold-rule" ((\ nm -> promoteExprR (ruleR nm >>> cleanupUnfoldR)) :: String -> RewriteH Core)-                [ "Unfold a named GHC rule" ] .+ Deep .+ Context .+ TODO -- TODO: does not work with rules with no arguments-         , external "spec-constr" (promoteModGutsR specConstrR :: RewriteH Core)-                [ "Run GHC's SpecConstr pass, which performs call pattern specialization."] .+ Deep-         , external "specialise" (promoteModGutsR specialise :: RewriteH Core)-                [ "Run GHC's specialisation pass, which performs type and dictionary specialisation."] .+ Deep-         ]+    [ external "rule-help" (rulesHelpListT :: TransformH CoreTC String)+        [ "List all the rules in scope." ] .+ Query+    , external "rule-help" (ruleHelpT :: RuleName -> TransformH CoreTC String)+        [ "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)+        [ "Create a lemma from a GHC RULE." ]+    , external "spec-constr" (promoteModGutsR specConstrR :: RewriteH Core)+        [ "Run GHC's SpecConstr pass, which performs call pattern specialization."] .+ Deep+    , external "specialise" (promoteModGutsR specialiseR :: RewriteH Core)+        [ "Run GHC's specialisation pass, which performs type and dictionary specialisation."] .+ Deep+    ]  ------------------------------------------------------------------------ -{--lookupRule :: (Activation -> Bool)	-- When rule is active-	    -> IdUnfoldingFun		-- When Id can be unfolded-            -> InScopeSet-	    -> Id -> [CoreExpr]-	    -> [CoreRule] -> Maybe (CoreRule, CoreExpr)--GHC HEAD:-type InScopeEnv = (InScopeSet, IdUnfoldingFun)+newtype RuleName = RuleName String deriving (Eq, Typeable) -lookupRule :: DynFlags -> InScopeEnv-           -> (Activation -> Bool)      -- When rule is active-           -> Id -> [CoreExpr]-           -> [CoreRule] -> Maybe (CoreRule, CoreExpr)--}+instance Extern RuleName where+    type Box RuleName = RuleName+    box = id+    unbox = id --- Neil: Commented this out as it's not (currently) used.--- rulesToEnv :: [CoreRule] -> Map.Map String (Rewrite c m CoreExpr)--- rulesToEnv rs = Map.fromList---         [ ( unpackFS (ruleName r), rulesToRewrite c m [r] )---         | r <- rs---         ]+instance IsString RuleName where fromString = RuleName+instance Show RuleName where show (RuleName s) = s -type RuleNameString = String+newtype RuleNameListBox = RuleNameListBox [RuleName] deriving Typeable --- TODO: deprecate this (and related functions) in favor of 'biRuleUnsafeR'-#if __GLASGOW_HASKELL__ > 706-rulesToRewriteH :: (ReadBindings c, HasDynFlags m, MonadCatch m) => [CoreRule] -> Rewrite c m CoreExpr-#else-rulesToRewriteH :: (ReadBindings c, MonadCatch m) => [CoreRule] -> Rewrite c m CoreExpr-#endif-rulesToRewriteH rs = prefixFailMsg "RulesToRewrite failed: " $-                     withPatFailMsg "rule not matched." $ do-    (Var fn, args) <- callT-    transform $ \ c e -> do-        let in_scope = mkInScopeSet (mkVarEnv [ (v,v) | v <- varSetElems (localFreeVarsExpr e) ])-#if __GLASGOW_HASKELL__ > 706-        dflags <- getDynFlags-        case lookupRule dflags (in_scope, const NoUnfolding) (const True) fn args [r | r <- rs, ru_fn r == idName fn] of-#else-        case lookupRule (const True) (const NoUnfolding) in_scope fn args [r | r <- rs, ru_fn r == idName fn] of-#endif-            Nothing         -> fail "rule not matched"-            Just (r, expr)  -> do-                let e' = mkApps expr (drop (ruleArity r) args)-                if all (inScope c) $ varSetElems $ localFreeVarsExpr e' -- TODO: The problem with this check, is that it precludes the case where this is an intermediate transformation.  I can imagine situations where some variables would be out-of-scope at this point, but in scope again after a subsequent transformation.-                  then return e'-                  else fail $ unlines ["Resulting expression after rule application contains variables that are not in scope."-                                      ,"This can probably be solved by running the flatten-module command at the top level."]+instance Extern [RuleName] where+    type Box [RuleName] = RuleNameListBox+    box = RuleNameListBox+    unbox (RuleNameListBox l) = l --- | Lookup a rule and attempt to construct a corresponding rewrite.-ruleR :: (ReadBindings c, HasCoreRules c) => RuleNameString -> Rewrite c HermitM CoreExpr-ruleR r = do-    theRules <- getHermitRulesT-    case lookup r theRules of-        Nothing -> fail $ "failed to find rule: " ++ show r ++ ". If you think the rule exists, try running the flatten-module command at the top level."-        Just rr -> rulesToRewriteH [rr]+-- | 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) -rulesR :: (ReadBindings c, HasCoreRules c) => [RuleNameString] -> Rewrite c HermitM CoreExpr+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 --- | Return all the RULES (including specialization RULES on binders) currently in scope.-getHermitRulesT :: HasCoreRules c => Transform c HermitM a [(RuleNameString, CoreRule)]+-- | 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     rb      <- liftCoreM getRuleBase     mgRules <- liftM mg_rules getModGuts     hscEnv  <- liftCoreM getHscEnv     rb'     <- liftM eps_rule_base $ liftIO $ runIOEnv () $ readMutVar (hsc_EPS hscEnv)-    return [ (unpackFS (ruleName r), r)-           | r <- hermitCoreRules c ++ mgRules ++ concat (nameEnvElts rb) ++ concat (nameEnvElts rb')-           ]+    let allRules = hermitCoreRules c ++ mgRules ++ concat (nameEnvElts rb) ++ concat (nameEnvElts rb')+    return [ (fromString (unpackFS (ruleName r)), r) | r <- allRules ] -getHermitRuleT :: HasCoreRules c => RuleNameString -> Transform c HermitM a CoreRule+-- | Get a GHC CoreRule by name.+getHermitRuleT :: (HasCoreRules c, HasHermitMEnv m, LiftCoreM m, MonadIO m) => RuleName -> Transform c m a CoreRule getHermitRuleT name =   do rulesEnv <- getHermitRulesT      case filter ((name ==) . fst) rulesEnv of-       []      -> fail ("Rule \"" ++ name ++ "\" not found.")+       []      -> fail $ "failed to find rule: " ++ show name ++ ". If you think the rule exists, "+                         ++ "try running the flatten-module command at the top level."        [(_,r)] -> return r-       _       -> fail ("Rule name \"" ++ name ++ "\" is ambiguous.")+       _       -> fail ("Rule name \"" ++ show name ++ "\" is ambiguous.") -rulesHelpListT :: HasCoreRules c => Transform c HermitM a String+-- | List names of all CoreRules in scope.+rulesHelpListT :: (HasCoreRules c, HasHermitMEnv m, LiftCoreM m, MonadIO m) => Transform c m a String rulesHelpListT = do     rulesEnv <- getHermitRulesT-    return (intercalate "\n" $ reverse $ map fst rulesEnv)--ruleHelpT :: HasCoreRules c => RuleNameString -> Transform c HermitM a String-ruleHelpT name = showSDoc <$> dynFlagsT <*> ((pprRulesForUser . (:[])) <$> getHermitRuleT name)---- Too much information.--- rulesHelpT :: HasCoreRules c => Transform c HermitM a String--- rulesHelpT = do---     rulesEnv <- getHermitRulesT---     dynFlags <- dynFlagsT---     return  $ (show (map fst rulesEnv) ++ "\n") ++---               showSDoc dynFlags (pprRulesForUser $ concatMap snd rulesEnv)+    return (intercalate "\n" $ reverse $ map (show.fst) rulesEnv) -makeRule :: RuleNameString -> Id -> CoreExpr -> CoreRule-makeRule rule_name nm =   mkRule True   -- auto-generated-                                 False  -- local-                                 (mkFastString rule_name)-                                 NeverActive    -- because we need to call for these-                                 (varName nm)-                                 []-                                 []+-- | 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] --- TODO: check if a top-level binding-addCoreBindAsRule :: Monad m => RuleNameString -> String -> Rewrite c m ModGuts-addCoreBindAsRule rule_name nm = contextfreeT $ \ modGuts ->-        case [ (v,e)-             | bnd   <- mg_binds modGuts-             , (v,e) <- bindToVarExprs bnd-             ,  nm `cmpString2Var` v-             ] of-         [] -> fail $ "cannot find binding " ++ nm-         [(v,e)] -> return $ modGuts { mg_rules = mg_rules modGuts-                                              ++ [makeRule rule_name v e]-                                     }-         _ -> fail $ "found multiple bindings for " ++ nm+-- | Build an Equality from a named GHC rewrite rule.+ruleNameToEqualityT :: ( 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 --- | Returns the universally quantified binders, the LHS, and the RHS.-ruleToEqualityT :: (BoundVars c, HasDynFlags m, HasModGuts m, MonadThings m, MonadCatch m) => Transform c m CoreRule CoreExprEquality+-- | 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 $ CoreExprEquality (ru_bndrs r) (mkCoreApps (Var f) (ru_args r)) (ru_rhs r)--ruleNameToEqualityT :: (BoundVars c, HasCoreRules c) => RuleNameString -> Transform c HermitM a CoreExprEquality-ruleNameToEqualityT name = getHermitRuleT name >>> ruleToEqualityT+     f <- lookupId $ ru_fn r+     return $ Equality (ru_bndrs r) (mkCoreApps (Var f) (ru_args r)) (ru_rhs r)  ------------------------------------------------------------------------ @@ -207,20 +156,20 @@     rs' <- return e' >>> extractT specRules     let specRs = deleteFirstsBy ((==) `on` ru_name) rs' rs     guardMsg (notNull specRs) "no rules created."-    return e' >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewriteH specRs)))+    let applyAllR = extractR+                  $ repeatR+                  $ anyCallR+                  $ promoteExprR+                  $ rulesToRewrite specRs+    return e' >>> applyAllR  -- | Run GHC's specialisation pass, and apply any rules generated.-specialise :: RewriteH ModGuts-specialise = prefixFailMsg "specialisation failed: " $ do+specialiseR :: RewriteH ModGuts+specialiseR = prefixFailMsg "specialisation failed: " $ do     gRules <- arr mg_rules     lRules <- extractT specRules -#if __GLASGOW_HASKELL__ <= 706-    dflags <- dynFlagsT-    guts <- contextfreeT $ liftCoreM . Specialise.specProgram dflags-#else     guts <- contextfreeT $ liftCoreM . Specialise.specProgram-#endif      lRules' <- return guts >>> extractT specRules -- spec rules on bindings in this module     let gRules' = mg_rules guts            -- plus spec rules on imported bindings@@ -229,7 +178,7 @@         specRs = gSpecRs ++ lSpecRs     guardMsg (notNull specRs) "no rules created."     liftIO $ putStrLn $ unlines $ map (unpackFS . ru_name) specRs-    return guts >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewriteH specRs)))+    return guts >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewrite specRs)))  -- | Get all the specialization rules on a binding. --   These are created by SpecConstr and other GHC passes.@@ -246,5 +195,13 @@ -- | Find all specialization rules in a Core fragment. specRules :: TransformH Core [CoreRule] specRules = crushtdT $ promoteBindT bindSpecRules++-- | Turn a list of rules into a rewrite which succeeds on the first successful rule.+-- Note: this should only be used for built-in and compiler-generated rules which we assume+-- are correct, because it does not record a lemma obligation for the rules used.+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 ]  ------------------------------------------------------------------------

@@ -3,6 +3,7 @@     ( -- * Working with Undefined Values       -- | Note that many of these operations require 'GHC.Err.undefined' to be explicitly imported if it is not used in the source file.       externals+    , buildStrictnessLemmaT     , verifyStrictT     , mkUndefinedValT     , isUndefinedValT@@ -18,12 +19,12 @@     , undefinedCaseR     , undefinedCastR     , undefinedTickR-    )-where+    ) where -import Control.Monad ((>=>))+import Control.Monad ((>=>), liftM) import Control.Monad.IO.Class import Data.Monoid+import Data.String (fromString)  import HERMIT.Context import HERMIT.Core@@ -31,6 +32,7 @@ import HERMIT.GHC hiding ((<>)) import HERMIT.Kure import HERMIT.Monad+import HERMIT.Name  import HERMIT.Dictionary.Common import HERMIT.Dictionary.GHC (substR)@@ -43,7 +45,7 @@     [ external "replace-current-expr-with-undefined" (promoteExprR replaceCurrentExprWithUndefinedR :: RewriteH Core)         [ "Set the current expression to \"undefined\"."         ] .+ Shallow .+ Context .+ Unsafe-    , external "replace-id-with-undefined" (replaceIdWithUndefined :: String -> RewriteH Core)+    , external "replace-id-with-undefined" (replaceIdWithUndefined :: HermitName -> RewriteH Core)         [ "Replace the specified identifier with \"undefined\"."         ] .+ Deep .+ Context .+ Unsafe     , external "error-to-undefined" (promoteExprR errorToUndefinedR :: RewriteH Core)@@ -79,48 +81,46 @@  ------------------------------------------------------------------------ -undefinedLocation :: String-undefinedLocation = "GHC.Err.undefined"+undefinedLocation :: HermitName+undefinedLocation = fromString "GHC.Err.undefined" --- TODO: will crash if 'undefined' is not used (or explicitly imported) in the source file.-findUndefinedIdT :: (BoundVars c, MonadCatch m, HasModGuts m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id+findUndefinedIdT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id findUndefinedIdT = findIdT undefinedLocation  -- | Check if the current expression is an undefined value.-isUndefinedValT :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m CoreExpr ()+isUndefinedValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m CoreExpr () isUndefinedValT = prefixFailMsg "not an undefined value: " $                   withPatFailMsg (wrongExprForm "App (Var undefined) (Type ty)") $                   do App (Var un) (Type _) <- idR                      un' <- findUndefinedIdT-                     guardMsg (un == un') ("identifier is not " ++ undefinedLocation)+                     guardMsg (un == un') ("identifier is not " ++ show undefinedLocation)  ------------------------------------------------------------------------ -errorLocation :: String-errorLocation = "GHC.Err.error"+errorLocation :: HermitName+errorLocation = fromString "GHC.Err.error" --- TODO: will crash if 'error' is not used (or explicitly imported) in the source file.-findErrorIdT :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id+findErrorIdT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id findErrorIdT = findIdT errorLocation  -- | Check if the current expression is an undefined value.-isErrorValT :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m CoreExpr ()+isErrorValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m CoreExpr () isErrorValT = prefixFailMsg "not an error value: " $               withPatFailMsg (wrongExprForm "App (App (Var error) (Type ty)) string") $               do App (App (Var er) (Type _)) _ <- idR                  er' <- findErrorIdT-                 guardMsg (er == er') ("identifier is not " ++ errorLocation)+                 guardMsg (er == er') ("identifier is not " ++ show errorLocation)  ------------------------------------------------------------------------  -- | error ty string ==> undefined ty-errorToUndefinedR :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+errorToUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr errorToUndefinedR = prefixFailMsg "error-to-undefined failed: " (isErrorValT >> replaceCurrentExprWithUndefinedR)  ------------------------------------------------------------------------  -- | Make an undefined value of the given type.-mkUndefinedValT :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Type -> Transform c m a CoreExpr+mkUndefinedValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Type -> Transform c m a CoreExpr mkUndefinedValT ty =   do un <- findUndefinedIdT      return $ App (varToCoreExpr un) (Type ty)@@ -128,67 +128,67 @@ ------------------------------------------------------------------------------------------------------  -- | Set the current expression to 'undefined'.-replaceCurrentExprWithUndefinedR :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+replaceCurrentExprWithUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr replaceCurrentExprWithUndefinedR = contextfreeT exprTypeM >>= mkUndefinedValT  -- | Replace all occurrences of the specified identifier with 'undefined'.-replaceIdWithUndefinedR :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Id -> Rewrite c m Core+replaceIdWithUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Id -> Rewrite c m Core replaceIdWithUndefinedR i = mkUndefinedValT (idType i) >>= substR i -replaceIdWithUndefined :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => String -> Rewrite c m Core+replaceIdWithUndefined :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m)                        => HermitName -> Rewrite c m Core replaceIdWithUndefined = findIdT >=> replaceIdWithUndefinedR  ------------------------------------------------------------------------------------------------------  -- | undefinedExprR = undefinedAppR <+ undefinedLamR <+ undefinedLetR <+ undefinedCastR <+ undefinedTickR <+ undefinedCaseR-undefinedExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedExprR = setFailMsg "undefined-expr failed."                    (undefinedAppR <+ undefinedLamR <+ undefinedLetR <+ undefinedCastR <+ undefinedTickR <+ undefinedCaseR)  ------------------------------------------------------------------------------------------------------  -- | @(undefined ty1) e@ ==> @undefined ty2@-undefinedAppR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedAppR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedAppR = prefixFailMsg "undefined-app failed: " $                 do appT isUndefinedValT successT (<>)                    replaceCurrentExprWithUndefinedR  -- | @(\ v -> undefined ty1)@ ==> @undefined ty2@  (where v is not a 'TyVar')-undefinedLamR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedLamR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedLamR = prefixFailMsg "undefined-lam failed: " $                 do lamT successT isUndefinedValT (<>)                    replaceCurrentExprWithUndefinedR  -- | let bds in (undefined ty) ==> undefined ty-undefinedLetR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedLetR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedLetR = prefixFailMsg "undefined-let failed: " $                 do letT successT isUndefinedValT (<>)                    replaceCurrentExprWithUndefinedR  -- | Cast (undefined ty1) co ==> undefined ty2-undefinedCastR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedCastR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedCastR = prefixFailMsg "undefined-cast failed: " $                 do castT isUndefinedValT successT (<>)                    replaceCurrentExprWithUndefinedR  -- | Tick tick (undefined ty1) ==> undefined ty1-undefinedTickR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedTickR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedTickR = prefixFailMsg "undefined-tick failed: " $                 do tickT successT isUndefinedValT (<>)                    replaceCurrentExprWithUndefinedR  -- | undefinedCaseR = undefinedCaseScrutineeR <+ undefinedCaseAltsR-undefinedCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseR = setFailMsg "undefined-case failed" (undefinedCaseScrutineeR <+ undefinedCaseAltsR)  -- | case (undefined ty) of alts ==> undefined ty-undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseScrutineeR = prefixFailMsg "undefined-case failed: " $                  do caseT isUndefinedValT successT successT (const successT) (\ _ _ _ _ -> ())                     replaceCurrentExprWithUndefinedR  -- | case e of {pat_1 -> undefined ty ; pat_2 -> undefined ty ; ... ; pat_n -> undefined ty} ==> undefined ty-undefinedCaseAltsR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseAltsR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseAltsR = prefixFailMsg "undefined-case-alts failed: " $                      do caseAltT successT successT successT (const (successT,const successT,isUndefinedValT)) (\ _ _ _ _ -> ())                         replaceCurrentExprWithUndefinedR@@ -196,12 +196,30 @@ ------------------------------------------------------------------------  -- | Verify that the given rewrite is a proof that the given expression is a strict function.-verifyStrictT :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => CoreExpr -> Rewrite c m CoreExpr -> Transform c m a ()+verifyStrictT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => CoreExpr -> Rewrite c m CoreExpr -> Transform c m a () verifyStrictT f r = prefixFailMsg "strictness verification failed: " $-  do (argTy, resTy) <- constT (funExprArgResTypes f)+  do (_, argTy, resTy) <- constT (funExprArgResTypesM f)      undefArg       <- mkUndefinedValT argTy      rhs            <- mkUndefinedValT resTy      let lhs = App f undefArg      verifyEqualityLeftToRightT lhs rhs r++-- | Apply the given expression to undefined, at the proper type.+applyToUndefinedT :: (BoundVars c, HasDynFlags m, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+                  => CoreExpr -> Transform c m x CoreExpr+applyToUndefinedT f = do+    let (tvs, body) = collectTyBinders f+    (_,dom,_) <- splitFunTypeM (exprType body)+    undef <- mkUndefinedValT dom+    return $ mkCoreLams tvs $ mkCoreApp body undef++-- | 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+    (tvs, lhs) <- liftM collectTyBinders $ applyToUndefinedT f+    rhs <- mkUndefinedValT (exprType lhs)+    constT $ insertLemma nm $ Lemma (Equality tvs lhs rhs) False True  ------------------------------------------------------------------------

@@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TupleSections, LambdaCase #-} module HERMIT.Dictionary.Unfold     ( externals-    , cleanupUnfoldR+    , betaReducePlusR     , rememberR     , showStashT     , unfoldR@@ -22,15 +22,16 @@ import HERMIT.PrettyPrinter.Common (DocH, PrettyH, TransformDocH(..), PrettyC)  import HERMIT.Dictionary.Common+import HERMIT.Dictionary.GHC (substCoreExpr) import HERMIT.Dictionary.Inline (inlineR)-import HERMIT.Dictionary.Local.Let (letNonRecSubstR)  import HERMIT.Core import HERMIT.Context-import HERMIT.Kure-import HERMIT.Monad import HERMIT.External import HERMIT.GHC+import HERMIT.Kure+import HERMIT.Monad+import HERMIT.Name  import Prelude hiding (exp) @@ -40,17 +41,17 @@  externals :: [External] externals =-    [ external "cleanup-unfold" (promoteExprR cleanupUnfoldR :: RewriteH Core)-        [ "Clean up immediately nested fully-applied lambdas, from the bottom up" ] .+ Deep-    , external "remember" (rememberR :: Label -> RewriteH Core)+    [ external "beta-reduce-plus" (promoteExprR betaReducePlusR :: RewriteH Core)+        [ "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 :: String -> RewriteH Core)+    , external "unfold-remembered" (promoteExprR . unfoldStashR :: RememberedName -> RewriteH Core)         [ "Unfold a remembered definition." ] .+ Deep .+ Context     , external "unfold" (promoteExprR unfoldR :: RewriteH Core)         [ "In application f x y z, unfold f." ] .+ Deep .+ Context-    , external "unfold" (promoteExprR . unfoldNameR :: String -> RewriteH Core)+    , external "unfold" (promoteExprR . unfoldNameR . unOccurrenceName :: OccurrenceName -> RewriteH Core)         [ "Inline a definition, and apply the arguments; traditional unfold." ] .+ Deep .+ Context-    , external "unfold" (promoteExprR . unfoldNamesR :: [String] -> RewriteH Core)+    , external "unfold" (promoteExprR . unfoldNamesR . map unOccurrenceName:: [OccurrenceName] -> RewriteH Core)         [ "Unfold a definition if it is named in the list." ] .+ Deep .+ Context     , external "unfold-saturated" (promoteExprR unfoldSaturatedR :: RewriteH Core)         [ "Unfold a definition only if the function is fully applied." ] .+ Deep .+ Context@@ -62,44 +63,41 @@  ------------------------------------------------------------------------ --- | cleanupUnfoldR cleans a unfold operation---  (for example, an inline or rule application)--- It is used at the level of the top-redex.--- Invariant: will not introduce let bindings-cleanupUnfoldR :: (AddBindings c, ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoreExpr-cleanupUnfoldR = do-    (f, args) <- callT <+ arr (,[])-    let (vs, body) = collectBinders f-        lenargs = length args-        lenvs = length vs-        comp = compare lenargs lenvs-        body' = case comp of-                    LT -> mkCoreLams (drop lenargs vs) body-                    _  -> body-        bnds = zipWith NonRec vs args-    body'' <- andR (replicate (length bnds) letNonRecSubstR) <<< return (mkCoreLets bnds body')-    return $ case comp of-                GT -> mkCoreApps body'' $ drop lenvs args-                _  -> body''+-- | Perform one or more beta reductions.+betaReducePlusR :: MonadCatch m => Rewrite c m CoreExpr+betaReducePlusR = prefixFailMsg "Multi-beta-reduction failed: " $ do+    (f,args) <- callT+    let (f',args',atLeastOne) = reduceAll f args False+        reduceAll (Lam v body) (a:as) _ = reduceAll (substCoreExpr v a body) as True+        reduceAll e            as     b = (e,as,b)+    guardMsg atLeastOne "no beta reductions possible."+    return $ mkCoreApps f' args'  -- | A more powerful 'inline'. Matches two cases: --      Var ==> inlines --      App ==> inlines the head of the function call for the app tree-unfoldR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr-unfoldR = prefixFailMsg "unfold failed: " (go >>> cleanupUnfoldR)-    where go :: Rewrite c HermitM CoreExpr+unfoldR :: forall c m. ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c+                       , ReadBindings c, ReadPath c Crumb, MonadCatch m )+        => Rewrite c m CoreExpr+unfoldR = prefixFailMsg "unfold failed: " (go >>> tryR betaReducePlusR)+    where go :: Rewrite c m CoreExpr           go = appAllR go idR <+ inlineR -- this order gives better error messages -unfoldPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => (Id -> [CoreExpr] -> Bool) -> Rewrite c HermitM CoreExpr+unfoldPredR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+               , MonadCatch m )+            => (Id -> [CoreExpr] -> Bool) -> Rewrite c m CoreExpr unfoldPredR p = callPredT p >> unfoldR -unfoldNameR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => String -> Rewrite c HermitM CoreExpr-unfoldNameR nm = prefixFailMsg ("unfold '" ++ nm ++ " failed: ") (callNameT nm >> unfoldR)+unfoldNameR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c+               , MonadCatch m )+            => HermitName -> Rewrite c m CoreExpr+unfoldNameR nm = prefixFailMsg ("unfold '" ++ show nm ++ " failed: ") (callNameT nm >> unfoldR) -unfoldNamesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [String] -> Rewrite c HermitM CoreExpr+unfoldNamesR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c+                , MonadCatch m )+             => [HermitName] -> Rewrite c m CoreExpr unfoldNamesR []  = fail "unfold-names failed: no names given."-unfoldNamesR nms = setFailMsg "unfold-names failed." $-                   orR (map unfoldNameR nms)+unfoldNamesR nms = setFailMsg "unfold-names failed." $ orR (map unfoldNameR nms)  unfoldSaturatedR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr unfoldSaturatedR = callSaturatedT >> unfoldR@@ -112,7 +110,7 @@  -- | Stash a binding with a name for later use. -- Allows us to look at past definitions.-rememberR :: Label -> Rewrite c HermitM Core+rememberR :: RememberedName -> Rewrite c HermitM Core rememberR label = sideEffectR $ \ _ -> \case                                           DefCore def           -> saveDef label def                                           BindCore (NonRec i e) -> saveDef label (Def i e)@@ -128,7 +126,7 @@ --         _           -> fail "remember: not a binding"  -- | Apply a stashed definition (like inline, but looks in stash instead of context).-unfoldStashR :: ReadBindings c => String -> Rewrite c HermitM CoreExpr+unfoldStashR :: ReadBindings c => RememberedName -> Rewrite c HermitM CoreExpr unfoldStashR label = prefixFailMsg "Inlining stashed definition failed: " $                      withPatFailMsg (wrongExprForm "Var v") $     do (c, Var v) <- exposeT@@ -139,12 +137,12 @@                         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 " ++ var2String i ++ " not " ++ var2String v+                   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 $ apply (extractT pp) pctx d-                return $ PP.text ("[ " ++ l ++ " ]") PP.$+$ dfn PP.$+$ PP.space+                dfn <- constT $ applyT (extractT pp) pctx d+                return $ PP.text ("[ " ++ show l ++ " ]") PP.$+$ dfn PP.$+$ PP.space     return $ PP.vcat docs

@@ -20,10 +20,10 @@ externals :: [External] externals = map (.+ Unsafe)     [ external "unsafe-replace" (promoteExprR . unsafeReplaceR :: CoreString -> RewriteH Core)-        [ "replace the currently focused expression with a new expression" +        [ "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 :: String -> RewriteH Core)-        [ "replace the currently focused expression with an expression from the stash"+    , 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" ]     ] @@ -36,7 +36,7 @@         guardMsg (eqType (exprKindOrType e) (exprKindOrType e')) "expression types differ."         return e' -unsafeReplaceStashR :: String -> RewriteH CoreExpr+unsafeReplaceStashR :: RememberedName -> RewriteH CoreExpr unsafeReplaceStashR label = prefixFailMsg "unsafe-replace failed: " $     contextfreeT $ \ e -> do         Def _ rhs <- lookupDef label

@@ -1,12 +1,82 @@-module HERMIT.Dictionary.WorkerWrapper.Common where+{-# LANGUAGE CPP, DeriveDataTypeable, TypeFamilies #-}+module HERMIT.Dictionary.WorkerWrapper.Common+    ( externals+    , WWAssumptionTag(..)+    , WWAssumption(..)+    , assumptionAEqualityT+    , assumptionBEqualityT+    , assumptionCEqualityT+    , split1BetaR+    , split2BetaR+    , workLabel+    ) where -import HERMIT.Monad-import HERMIT.Kure+import Control.Monad.IO.Class++import Data.String (fromString)+import Data.Typeable++import HERMIT.Context+import HERMIT.Core+import HERMIT.External import HERMIT.GHC+import HERMIT.Kure+import HERMIT.Monad+import HERMIT.ParserCore +import HERMIT.Dictionary.Common+import HERMIT.Dictionary.Function hiding (externals)+import HERMIT.Dictionary.Reasoning hiding (externals)+import HERMIT.Name+ -------------------------------------------------------------------------------------------------- -data WWAssumptionTag = A | B | C deriving (Eq,Ord,Show,Read)+-- | New Worker/Wrapper-related externals.+externals :: [External]+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)+        [ "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)+        [ "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)+        [ "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)+        [ "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)+        [ "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."+        , "  <name>-assumption: unproven lemma for w/w assumption C."+        , "  <name>-fusion: assumed lemma for w/w fusion."+        ]+    ]++--------------------------------------------------------------------------------------------------++data WWAssumptionTag = A | B | C deriving (Eq,Ord,Show,Read,Typeable)++instance Extern WWAssumptionTag where+    type Box WWAssumptionTag = WWAssumptionTag+    box i = i+    unbox i = i+ data WWAssumption = WWAssumption WWAssumptionTag (RewriteH CoreExpr)  --------------------------------------------------------------------------------------------------@@ -17,7 +87,94 @@ -- 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 :: Label-workLabel = "recursive-definition-of-work-for-use-by-ww-fusion"+workLabel :: RememberedName+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+                        , MonadCatch m, MonadIO m, MonadThings m )+                     => CoreExpr -> CoreExpr -> Transform c m x Equality+assumptionAEqualityT 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++-- Given abs, rep, and f expressions, build "abs . rep . f = f"+assumptionBEqualityT :: ( BoundVars c, HasDynFlags m, 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+    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++-- 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+    lhs' <- buildFixT lhs+    rhs' <- buildFixT rhs+    return $ Equality vs 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+    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++-- 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+               , MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+            => LemmaName -> CoreExpr -> CoreExpr -> Rewrite c m CoreExpr+split1BetaR nm absE repE = do+    (_fixId, [_tyA, f]) <- callNameT $ fromString "Data.Function.fix"++    g <- 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)++    assumptionEq <- assumptionCEqualityT absE repE f+    _ <- insertLemmaR (fromString (show nm ++ "-assumption")) $ Lemma assumptionEq False True -- unproven, used++    wwFusionEq <- wwFusionEqualityT absE repE workRhs+    _ <- insertLemmaR (fromString (show nm ++ "-fusion")) $ Lemma wwFusionEq True False -- proven (assumed), unused++    return $ mkCoreLets [NonRec gId g, NonRec workId workRhs] newRhs++split2BetaR :: ( BoundVars c, HasDynFlags m, 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+    (_fixId, [_tyA, f]) <- callNameT $ fromString "Data.Function.fix"+    fixfE <- idR++    repFixFE <- buildApplicationM repE fixfE+    workId <- constT $ newIdH "worker" $ exprType repFixFE++    newRhs <- buildApplicationM absE (varToCoreExpr workId)++    assumptionEq <- assumptionCEqualityT absE repE f+    _ <- insertLemmaR (fromString (show nm ++ "-assumption")) $ Lemma assumptionEq False True -- unproven, used++    wwFusionEq <- wwFusionEqualityT absE repE (varToCoreExpr workId)+    _ <- insertLemmaR (fromString (show nm ++ "-fusion")) $ Lemma wwFusionEq True False -- proven (assumed), unused++    return $ mkCoreLets [NonRec workId repFixFE] newRhs

@@ -1,28 +1,30 @@ module HERMIT.Dictionary.WorkerWrapper.Fix-       ( -- * The Worker/Wrapper Transformation-         -- | Note that many of these operations require 'Data.Function.fix' to be in scope.-         HERMIT.Dictionary.WorkerWrapper.Fix.externals-       , wwFacBR-       , wwSplitR-       , wwSplitStaticArg-       , wwGenerateFusionR-       , wwFusionBR-       , wwAssA-       , wwAssB-       , wwAssC-       )-where+    ( -- * The Worker/Wrapper Transformation+      -- | Note that many of these operations require 'Data.Function.fix' to be in scope.+      HERMIT.Dictionary.WorkerWrapper.Fix.externals+    , wwFacBR+    , wwSplitR+    , wwSplitStaticArg+    , wwGenerateFusionR+    , wwFusionBR+    , wwAssA+    , wwAssB+    , wwAssC+    ) where  import Control.Applicative import Control.Arrow +import Data.String (fromString)+ import HERMIT.Core-import HERMIT.Monad-import HERMIT.Kure import HERMIT.External import HERMIT.GHC-import HERMIT.Utilities+import HERMIT.Kure+import HERMIT.Monad+import HERMIT.Name import HERMIT.ParserCore+import HERMIT.Utilities  import HERMIT.Dictionary.AlphaConversion import HERMIT.Dictionary.Common@@ -171,7 +173,7 @@                      guardMsg (eqType tyA tA) ("wrapper/unwrapper types do not match fix body type.")                      whenJust (verifyWWAss wrap unwrap f) mAss                      b <- constT (newIdH "x" tyB)-                     App wrap <$> mkFixT (Lam b (App unwrap (App f (App wrap (Var b)))))+                     App wrap <$> buildFixT (Lam b (App unwrap (App f (App wrap (Var b)))))      wwR :: RewriteH CoreExpr     wwR  =    prefixFailMsg "(reverse) worker/wrapper factorisation failed: " $@@ -183,7 +185,7 @@                       guardMsg (equivalentBy exprAlphaEq [wrap, wrap1, wrap2]) "wrappers do not match."                       guardMsg (exprAlphaEq unwrap unwrap1) "unwrappers do not match."                       whenJust (verifyWWAss wrap unwrap f) mAss-                      mkFixT f+                      buildFixT f      wrongFixBody :: String     wrongFixBody = "body of fix does not have the form Lam b (App unwrap (App f (App wrap (Var b))))"@@ -251,11 +253,11 @@ -- | \\ wrap unwrap ->  (@prog = expr@  ==>  @prog = let f = \\ prog -> expr in let work = unwrap (f (wrap work)) in wrap work)@ wwSplitR :: Maybe WWAssumption -> CoreExpr -> CoreExpr -> RewriteH CoreDef wwSplitR mAss wrap unwrap =-      fixIntroR+      fixIntroRecR       >>> defAllR idR ( appAllR idR (letIntroR "f")                         >>> letFloatArgR                         >>> letAllR idR ( forwardT (wwFacBR mAss wrap unwrap)-                                          >>> appAllR idR ( unfoldNameR "fix"+                                          >>> appAllR idR ( unfoldNameR (fromString "Data.Function.fix")                                                             >>> alphaLetWithR ["work"]                                                             >>> letRecAllR (\ _ -> defAllR idR (betaReduceR >>> letNonRecSubstR)                                                                                    >>> extractR (wwGenerateFusionR mAss)@@ -440,8 +442,8 @@   prefixFailMsg ("verification of worker/wrapper assumption C failed: ") $   do (tyA,_) <- wrapUnwrapTypes wrap unwrap      a       <- constT (newIdH "a" tyA)-     rhs     <- mkFixT f-     lhs     <- mkFixT (Lam a (App wrap (App unwrap (App f (Var a)))))+     rhs     <- buildFixT f+     lhs     <- buildFixT (Lam a (App wrap (App unwrap (App f (Var a)))))      verifyEqualityLeftToRightT lhs rhs assC  --------------------------------------------------------------------------------------------------

@@ -1,31 +1,33 @@ {-# LANGUAGE TupleSections #-}  module HERMIT.Dictionary.WorkerWrapper.FixResult-       ( -- * The Worker/Wrapper Transformation (Result Variant)-         -- | Note that many of these operations require 'Data.Function.fix' to be in scope.-         HERMIT.Dictionary.WorkerWrapper.FixResult.externals-       , wwResultFacBR-       , wwResultSplitR-       , wwResultSplitStaticArg-       , wwResultGenerateFusionR-       , wwResultFusionBR-       , wwResultAssA-       , wwResultAssB-       , wwResultAssC-       )-where+    ( -- * The Worker/Wrapper Transformation (Result Variant)+      -- | Note that many of these operations require 'Data.Function.fix' to be in scope.+      HERMIT.Dictionary.WorkerWrapper.FixResult.externals+    , wwResultFacBR+    , wwResultSplitR+    , wwResultSplitStaticArg+    , wwResultGenerateFusionR+    , wwResultFusionBR+    , wwResultAssA+    , wwResultAssB+    , wwResultAssC+    ) where  import Prelude hiding (abs)  import Control.Arrow +import Data.String (fromString)+ import HERMIT.Core-import HERMIT.Monad-import HERMIT.Kure import HERMIT.External import HERMIT.GHC-import HERMIT.Utilities+import HERMIT.Kure+import HERMIT.Monad+import HERMIT.Name import HERMIT.ParserCore+import HERMIT.Utilities  import HERMIT.Dictionary.AlphaConversion import HERMIT.Dictionary.Common@@ -172,7 +174,7 @@     wwL :: Type -> Type -> RewriteH CoreExpr     wwL tyA tyB = prefixFailMsg "worker/wrapper factorisation failed: " $                   do (tyXA,f)  <- isFixExprT-                     (tyX,tA)  <- constT (splitFunTypeM tyXA)+                     (_,tyX,tA)  <- constT (splitFunTypeM tyXA)                      let tyXB  =  FunTy tyX tyB                      h         <- constT (newIdH "h" tyXB)                      guardMsg (eqType tyA tA) ("abs/rep types do not match fix body type.")@@ -182,7 +184,7 @@                       whenJust (verifyWWAss abs rep f) mAss -                     work <- mkFixT (Lam h (Lam x1 (App rep+                     work <- buildFixT (Lam h (Lam x1 (App rep                                                         (App (App f (Lam x2 (App abs (App (Var h) (Var x2)))))                                                              (Var x1)                                                         )@@ -203,7 +205,7 @@                  guardMsg (equivalentBy exprAlphaEq [abs, abs1, abs2]) "abs's do not match."                  guardMsg (exprAlphaEq rep rep1) "rep's do not match."                  whenJust (verifyWWAss abs rep f) mAss-                 mkFixT f+                 buildFixT f      wrongForm :: String     wrongForm = wrongExprForm "\\ x1 -> abs (fix (\\ h x2 -> rep (f (\\ x3 -> abs (h x3)) x2)) x1)"@@ -282,11 +284,11 @@ -- | \\ abs rep -> (@prog = expr@  ==>  @prog = let f = \\ prog -> expr in let work = \\ x1 -> rep (f (\\ x2 -> abs (work x2)) x1) in \\ x0 -> abs (work x0)@) wwResultSplitR :: Maybe WWAssumption -> CoreExpr -> CoreExpr -> RewriteH CoreDef wwResultSplitR mAss abs rep =-      fixIntroR+      fixIntroRecR       >>> defAllR idR ( appAllR idR (letIntroR "f")                         >>> letFloatArgR                         >>> letAllR idR ( forwardT (wwResultFacBR mAss abs rep)-                                          >>> lamAllR idR (appAllR idR (appAllR ( unfoldNameR "fix"+                                          >>> lamAllR idR (appAllR idR (appAllR ( unfoldNameR (fromString "Data.Function.fix")                                                                                   >>> alphaLetWithR ["work"]                                                                                   >>> letRecAllR (\ _ -> defAllR idR (betaReduceR >>> letNonRecSubstR)                                                                                                          >>> extractR (wwResultGenerateFusionR mAss)@@ -461,9 +463,9 @@            -> TransformH x () verifyAssB abs rep f assB =   prefixFailMsg ("verification of worker/wrapper assumption B failed: ") $-  do (tyA,_) <- absRepTypes abs rep-     tyXA     <- constT (endoFunExprType f)-     (tyX,tA) <- constT (splitFunTypeM tyXA)+  do (tyA,_)    <- absRepTypes abs rep+     (_,tyXA)   <- constT (endoFunExprTypeM f)+     (_,tyX,tA) <- constT (splitFunTypeM tyXA)      guardMsg (eqType tyA tA) "type of program body does not match types of abs/rep."      h        <- constT (newIdH "h" tyXA)      x        <- constT (newIdH "x" tyX)@@ -478,14 +480,14 @@            -> TransformH a () verifyAssC abs rep f assC =   prefixFailMsg ("verification of worker/wrapper assumption C failed: ") $-  do (tyA,_)  <- absRepTypes abs rep-     tyXA     <- constT (endoFunExprType f)-     (tyX,tA) <- constT (splitFunTypeM tyXA)+  do (tyA,_)    <- absRepTypes abs rep+     (_,tyXA)   <- constT (endoFunExprTypeM f)+     (_,tyX,tA) <- constT (splitFunTypeM tyXA)      guardMsg (eqType tyA tA) "type of program body does not match types of abs/rep."      h        <- constT (newIdH "h" tyXA)      x        <- constT (newIdH "x" tyX)-     rhs      <- mkFixT f-     lhs      <- mkFixT (Lam h (Lam x (App abs (App rep (App (App f (Var h)) (Var x))))))+     rhs      <- buildFixT f+     lhs      <- buildFixT (Lam h (Lam x (App abs (App rep (App (App f (Var h)) (Var x))))))      verifyEqualityLeftToRightT lhs rhs assC  --------------------------------------------------------------------------------------------------

@@ -1,9 +1,10 @@ {-# LANGUAGE ViewPatterns #-}-module HERMIT.Driver +module HERMIT.Driver     ( hermitVersion     , ghcFlags     , hermitDriver     , usage+    , usageOutput     ) where  import Data.List (isPrefixOf, partition)@@ -14,7 +15,7 @@ import System.Process import System.Exit -hermitVersion :: String   +hermitVersion :: String hermitVersion = "HERMIT v" ++ showVersion P.version  ghcFlags :: [String]@@ -26,11 +27,9 @@ --           , "-v0"            ] -usage :: IO ()-usage = putStrLn $ unlines-        [hermitVersion-        ,""-        ,"usage: hermit File.hs SCRIPTNAME"+usageOutput :: String+usageOutput = unlines+        ["usage: hermit File.hs SCRIPTNAME"         ,"       - OR -"         ,"       hermit File.hs [HERMIT_ARGS] [+module_name [MOD_ARGS]]* [-- [ghc-args]]"         ,""@@ -45,6 +44,7 @@         ,""         ,"HERMIT_ARGS"         ,"  -opt=MODULE : where MODULE is the module containing a HERMIT optimization plugin"+        ,"  -pN         : where 0<=N<=17 is the stage in the optimization pipeline HERMIT targets"         ,"  -vN         : controls verbosity, where N is one of the following values:"         ,"                  0 : suppress HERMIT messages, pass -v0 to GHC"         ,"                  1 : suppress HERMIT messages"@@ -56,7 +56,10 @@         ,"  resume     : skip interactive mode and resume compilation after any scripts"         ] --- | Entry point for HERMIT driver executable. +usage :: IO ()+usage = mapM_ putStrLn [hermitVersion, "", usageOutput]++-- | Entry point for HERMIT driver executable. -- First String in list is expected to be target file name. hermitDriver :: [String] -> IO () hermitDriver [] = usage

@@ -1,54 +1,52 @@ {-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances, DeriveDataTypeable #-}  module HERMIT.External-       (-       -- * Externals-         External-       , ExternalName-       , ExternalHelp-       , externName-       , externDyn-       , externHelp-       , externTypeString-       , externTypeArgResString-       , Dictionary-       , toDictionary-       , addToDictionary-       , toHelp-       , external-       , Extern(..)-       , matchingExternals-       -- * Tags-       , CmdTag(..)-       , TagE-       , Tag((.+),remTag,tagMatch)-       , (.&)-       , (.||)-       , notT-       , externTags-       , dictionaryOfTags-       -- * Boxes-       -- | Boxes are used by the 'Extern' class.-       , TagBox(..)-       , IntBox(..)-       , RewriteCoreBox(..)-       , RewriteCoreTCBox(..)-       , BiRewriteCoreBox(..)-       , TransformCoreStringBox(..)-       , TransformCoreTCStringBox(..)-       , TransformCoreCheckBox(..)-       , TransformCoreTCCheckBox(..)-       , TransformCorePathBox(..)-       , TransformCoreTCPathBox(..)-       , CoreString(..)-       , CoreBox(..)-       , CrumbBox(..)-       , PathBox(..)-       , StringBox(..)-       , StringListBox(..)-       , IntListBox(..)-       , RewriteCoreListBox(..)-) where+    ( -- * Externals+      External+    , ExternalName+    , ExternalHelp+    , externName+    , externDyn+    , externHelp+    , externTypeString+    , externTypeArgResString+    , splitFunTyArgs+    , toHelp+    , external+    , Extern(..)+    , matchingExternals+      -- * Tags+    , CmdTag(..)+    , TagE+    , Tag((.+),remTag,tagMatch)+    , (.&)+    , (.||)+    , notT+    , externTags+    , 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(..)+    ) where  import Data.Map hiding (map) import Data.Dynamic@@ -58,6 +56,7 @@ import HERMIT.Core import HERMIT.Context (LocalPathH) import HERMIT.Kure+import HERMIT.Monad  ----------------------------------------------------------------- @@ -80,11 +79,12 @@             | Deep           -- ^ Command may make a deep change, can be O(n).             | Shallow        -- ^ Command operates on local nodes only, O(1).             | Navigation     -- ^ Uses 'Path' or 'Lens' to focus onto something.-            | Query          -- ^ A question we ask.+            | Query          -- ^ Extract information from an expression.             | Predicate      -- ^ Something that passes or fails.             | Introduce      -- ^ Introduce something, like a new name.             | Commute        -- ^ Commute is when you swap nested terms.             | PreCondition   -- ^ Operation has a (perhaps undocumented) precondition.+            | Strictness     -- ^ Alters the strictness of the expression.             | Debug          -- ^ Commands specifically to help debugging.             | VersionControl -- ^ Version control for Core syntax.             | Context        -- ^ A command that uses its context, such as inlining.@@ -96,22 +96,6 @@             | Experiment     -- ^ Things we are trying out.             | Deprecated     -- ^ A command that will be removed in a future release;                              --   it has probably been renamed or subsumed by another command.----- Unsure about these-{--            | Local         -- local thing, O(1)-            | CaseCmd       -- works on case statements-            | Context       -- something that uses the context-            | GHC           -- a tunnel into GHC-            | Lens          -- focuses into a specific node-            | LetCmd        -- works on let statements-            | Meta          -- combines other commands-            | Restful       -- RESTful API commands-            | Slow          -- this command is slow--}-            -- Other String-            -- etc     deriving (Eq, Show, Read, Bounded, Enum)  -- | Lists all the tags paired with a short description of what they're about.@@ -121,31 +105,30 @@                             , tag `notElem` map fst notes                             ]   where notes =-          -- These should give the user a clue about what the sub-commands-          -- might do-          [ (Shell,        "Shell-specific command.")-          , (Eval,         "The arrow of evaluation (reduces a term).")-          , (KURE,         "Direct reflection of a combinator from the KURE DSL.")-          , (Loop,         "Command may operate multiple times.")-          , (Deep,         "Command may make a deep change, can be O(n).")-          , (Shallow,      "Command operates on local nodes only, O(1).")-          , (Navigation,   "Navigate via focus, or directional command.")-          , (Query,        "A question we ask.")-          , (Predicate,    "Something that passes or fails.")-          , (Introduce,    "Introduce something, like a new name.")-          , (Commute,      "Commute is when you swap nested terms.")-          , (PreCondition, "Operation has a (perhaps undocumented) precondition.")-          , (Debug,        "A command specifically to help debugging.")-          , (VersionControl,"Version control for Core syntax.")-          , (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.")-          , (Proof,        "Commands related to proving lemmas.")-          , (TODO,         "An incomplete or potentially buggy command.")-          , (Experiment,   "Things we are trying out, use at your own risk.")-          , (Deprecated,   "A command that will be removed in a future release; it has probably been renamed or subsumed by another command.")+          -- These should give the user a clue about what the sub-commands might do+          [ (Shell,          "Shell-specific command.")+          , (Eval,           "The arrow of evaluation (reduces a term).")+          , (KURE,           "Direct reflection of a combinator from the KURE DSL.")+          , (Loop,           "Command may operate multiple times.")+          , (Deep,           "Command may make a deep change, can be O(n).")+          , (Shallow,        "Command operates on local nodes only, O(1).")+          , (Navigation,     "Navigate via focus, or directional command.")+          , (Query,          "Extract information from an expression.")+          , (Predicate,      "Something that passes or fails.")+          , (Introduce,      "Introduce something, like a new name.")+          , (Commute,        "Commute is when you swap nested terms.")+          , (PreCondition,   "Operation has a (perhaps undocumented) precondition.")+          , (Strictness,     "Alters the strictness of an expression.")+          , (Debug,          "A command specifically to help debugging.")+          , (VersionControl, "Version control for Core syntax.")+          , (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.")+          , (Proof,          "Commands related to proving lemmas.")+          , (TODO,           "An incomplete or potentially buggy command.")+          , (Experiment,     "Things we are trying out, use at your own risk.")+          , (Deprecated,     "A command that will be removed in a future release; it has probably been renamed or subsumed by another command.")           ] - -- Unfortunately, record update syntax seems to associate to the right. -- These operators save us some parentheses. infixl 3 .+@@ -234,20 +217,6 @@ matchingExternals tag exts = [ (e,tr) | e <- exts, tagMatch tag e                                       , Just tr <- [fmap unbox $ fromDynamic $ externDyn e] ] --- | A 'Dictionary' is a collection of 'Dynamic's.---   Looking up a 'Dynamic' (via an 'ExternalName' key) returns a list, as there can be multiple 'Dynamic's with the same name.-type Dictionary = Map ExternalName [Dynamic]---- | Build a 'Data.Map' from names to 'Dynamic' values.-toDictionary :: [External] -> Dictionary-toDictionary = fromListWith (++) . map toEntry--toEntry :: External -> (ExternalName, [Dynamic])-toEntry e = (externName e, [externDyn e])--addToDictionary :: External -> Dictionary -> Dictionary-addToDictionary ex d = fromListWith (++) $ toEntry ex : toList d- -- | Build a 'Data.Map' from names to help information. toHelp :: [External] -> Map ExternalName ExternalHelp toHelp = fromListWith (++) . map toH@@ -266,9 +235,9 @@  -- | Remove the word 'Box' from a string. deBoxify :: String -> String-deBoxify xs +deBoxify xs     | "CLSBox -> " `isPrefixOf` xs = deBoxify (drop 10 xs)-deBoxify xs +deBoxify xs     | "Box" `isPrefixOf` xs        = deBoxify (drop 3 xs) deBoxify (x:xs)                    = x : deBoxify xs deBoxify []                        = []@@ -435,14 +404,12 @@  ----------------------------------------------------------------- --- TODO: Is this deliberately called "CoreBox" rather than "CoreStringBox"?-newtype CoreString = CoreString { unCoreString :: String }-data CoreBox = CoreBox CoreString deriving Typeable+newtype CoreString = CoreString { unCoreString :: String } deriving Typeable  instance Extern CoreString where-    type Box CoreString = CoreBox-    box = CoreBox-    unbox (CoreBox s) = s+    type Box CoreString = CoreString+    box = id+    unbox = id  ----------------------------------------------------------------- @@ -479,5 +446,37 @@     type Box [RewriteH Core] = RewriteCoreListBox     box = RewriteCoreListBox     unbox (RewriteCoreListBox l) = l++-----------------------------------------------------------------++instance Extern RememberedName where+    type Box RememberedName = RememberedName+    box = id+    unbox = id++-----------------------------------------------------------------++instance Extern LemmaName where+    type Box LemmaName = LemmaName+    box = id+    unbox = id++-----------------------------------------------------------------++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  -----------------------------------------------------------------

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP, InstanceSigs, TypeSynonymInstances, FlexibleInstances #-}-#if __GLASGOW_HASKELL__ > 706 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}-#endif -- Above shadowing disabled because the eqExprX function has lots of shadowing module HERMIT.GHC     ( -- * GHC Imports@@ -9,101 +7,95 @@       module GhcPlugins     , ppIdInfo     , zapVarOccInfo-    , var2String     , thRdrNameGuesses     , varNameNS     , isQualified     , cmpString2Name     , cmpString2Var-    , fqName-    , uqName-    , findNamesFromString+    , qualifiedName+    , unqualifiedName     , alphaTyVars     , Type(..)     , TyLit(..)     , GhcException(..)     , throwGhcException     , exprArity-    , occurAnalyseExpr+    , occurAnalyseExpr_NoBinderSwap     , isKind     , isLiftedTypeKindCon-#if __GLASGOW_HASKELL__ > 706-    , coAxiomName-    , CoAxiom.BranchIndex-    , CoAxiom.CoAxiom-    , CoAxiom.Branched-#endif     , notElemVarSet     , varSetToStrings     , showVarSet     , Pair(..)     , bndrRuleAndUnfoldingVars-#if __GLASGOW_HASKELL__ <= 706-    , exprType-    , Control.Monad.IO.Class.liftIO-#else-    , runDsMtoCoreM-    , runTcMtoCoreM-    , buildTypeable-    , buildDictionary+    , coAxiomName+    , CoAxiom.BranchIndex+    , CoAxiom.CoAxiom+    , CoAxiom.Branched+    , Bag.foldBag     , eqExprX-    , lookupRdrNameInModuleForPlugins+    , loadSysInterface+    , lookupRdrNameInModule+    , reportAllUnsolved+    , zEncodeString+#ifdef mingw32_HOST_OS+    , initStaticOpts #endif-    , mkPhiTy-    , mkSigmaTy+    , module Class+    , module DsBinds+    , module DsMonad+    , module ErrUtils+    , module PrelNames+    , module TcEnv+    , module TcMType+    , module TcRnMonad+    , module TcRnTypes+    , module TcSimplify+    , module TcType+    , module Unify     , getHscEnvCoreM     ) where -#if __GLASGOW_HASKELL__ <= 706--- GHC 7.6-import qualified Control.Monad.IO.Class-import qualified MonadUtils (MonadIO,liftIO)-import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, exprType, liftIO, PluginPass, getHscEnv)-import TysPrim (alphaTy, alphaTyVars)-import Panic (throwGhcException, GhcException(..))-import PprCore (pprCoreExpr)-import Data.Monoid hiding ((<>))-#else--- GHC 7.8-import Finder (findImportedModule, cannotFindModule)--- we hide these so that they don't get inadvertently used.  See Core.hs-import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, PluginPass, getHscEnv)-import LoadIface (loadPluginInterface)-import Panic (throwGhcException, throwGhcExceptionIO, GhcException(..))-import TcRnMonad (initIfaceTcRn)-import TysPrim (alphaTyVars)-#endif---- hacky direct GHC imports-import Convert (thRdrNameGuesses)-import CoreArity-import qualified CoreMonad -- for getHscEnv-import Kind (isKind,isLiftedTypeKindCon)-import qualified OccName -- for varName-import OccurAnal (occurAnalyseExpr)-import Pair (Pair(..))-import TcType (mkPhiTy, mkSigmaTy)-import TypeRep (Type(..),TyLit(..))--#if __GLASGOW_HASKELL__ <= 706-import Data.Maybe (isJust)-#else+-- Imports from GHC. import qualified Bag+import           Class (classTyCon) import qualified CoAxiom -- for coAxiomName-import DsBinds (dsEvBinds)-import DsMonad (DsM, initDsTc)-import PrelNames (typeableClassName)-import TcEnv (tcLookupClass)-import TcMType (newWantedEvVar)-import TcRnMonad (getCtLoc)-import TcRnTypes (TcM, mkNonCanonical, mkFlatWC, CtEvidence(..), SkolemInfo(..), CtOrigin(..))-import TcSimplify (solveWantedsTcM)--import HERMIT.GHC.Typechecker+import           Convert (thRdrNameGuesses)+import           CoreArity+import qualified CoreMonad -- for getHscEnv+import           DsBinds (dsEvBinds)+import           DsMonad (DsM, initDsTc)+import           Encoding (zEncodeString)+import           ErrUtils (pprErrMsgBag)+import           Finder (findImportedModule, cannotFindModule)+-- we hide these so that they don't get inadvertently used.+-- several are redefined in Core.hs and elsewhere+import           GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, PluginPass, getHscEnv, RuleName)+import           Kind (isKind,isLiftedTypeKindCon)+import           LoadIface (loadSysInterface)+import qualified OccName -- for varName+import           OccurAnal (occurAnalyseExpr_NoBinderSwap)+import           Pair (Pair(..))+import           Panic (throwGhcException, throwGhcExceptionIO, GhcException(..))+import           PrelNames (typeableClassName)+#if mingw32_HOST_OS+import           StaticFlags #endif+import           TcEnv (tcLookupClass)+import           TcErrors (reportAllUnsolved)+import           TcMType (newWantedEvVar)+import           TcRnMonad (getCtLoc, initIfaceTcRn)+import           TcRnTypes (TcM, mkNonCanonical, mkFlatWC, CtEvidence(..), SkolemInfo(..), CtOrigin(..))+import           TcSimplify (solveWantedsTcM)+import           TcType (mkPhiTy, mkSigmaTy)+import           TypeRep (Type(..),TyLit(..))+import           TysPrim (alphaTyVars)+import           Unify (tcUnifyTys, BindFlag(..))  import Data.List (intercalate) +import HERMIT.GHC.Typechecker+ --------------------------------------------------------------------------  -- | Rename this namespace, as 'varName' is already a function in Var.@@ -113,36 +105,11 @@ getHscEnvCoreM :: CoreM HscEnv getHscEnvCoreM = CoreMonad.getHscEnv -#if __GLASGOW_HASKELL__ <= 706--- Note: prior to 7.8, the Let case was buggy for type--- bindings, so we provide a fixed definition here.-exprType :: CoreExpr -> Type--- ^ Recover the type of a well-typed Core expression. Fails when--- applied to the actual 'CoreSyn.Type' expression as it cannot--- really be said to have a type-exprType (Var var)           = idType var-exprType (Lit lit)           = literalType lit-exprType (Coercion co)       = coercionType co-exprType (Let bind body)-  | NonRec tv rhs <- bind-  , Type ty <- rhs           = substTyWith [tv] [ty] (exprType body)-  | otherwise                = exprType body-exprType (Case _ _ ty _)     = ty-exprType (Cast _ co)         = pSnd (coercionKind co)-exprType (Tick _ e)          = exprType e-exprType (Lam binder expr)   = mkPiType binder (exprType expr)-exprType e@(App _ _)-  = case collectArgs e of-        (fun, args) -> applyTypeToArgs e (exprType fun) args--exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy-#endif- --------------------------------------------------------------------------  -- | Convert a 'VarSet' to a list of user-readable strings. varSetToStrings :: VarSet -> [String]-varSetToStrings = map var2String . varSetElems+varSetToStrings = map unqualifiedName . varSetElems  -- | Show a human-readable version of a 'VarSet'. showVarSet :: VarSet -> String@@ -150,13 +117,8 @@  -------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ <= 706--- coAxiomName :: CoAxiom -> Name--- coAxiomName = coAxiomName-#else coAxiomName :: CoAxiom.CoAxiom br -> Name coAxiomName = CoAxiom.coAxiomName-#endif  -- varName :: Var -> Name -- nameOccName :: Name -> OccName@@ -166,24 +128,20 @@ -- getOccString :: NamedThing a => a -> String  -- | Get the unqualified name from a 'NamedThing'.-uqName :: NamedThing nm => nm -> String-uqName = getOccString+unqualifiedName :: NamedThing nm => nm -> String+unqualifiedName = getOccString  -- | Get the fully qualified name from a 'Name'.-fqName :: Name -> String-fqName nm = modStr ++ uqName nm+qualifiedName :: Name -> String+qualifiedName nm = modStr ++ unqualifiedName nm     where modStr = maybe "" (\m -> moduleNameString (moduleName m) ++ ".") (nameModule_maybe nm) --- | Convert a variable to a neat string for printing (unqualfied name).-var2String :: Var -> String-var2String = uqName . varName- -- | Compare a 'String' to a 'Name' for equality. -- Strings containing a period are assumed to be fully qualified names. -- (Except for ".", which is an unqualified reference to composition.) cmpString2Name :: String -> Name -> Bool-cmpString2Name str nm | isQualified str = str == fqName nm-                      | otherwise       = str == uqName nm+cmpString2Name str nm | isQualified str = str == qualifiedName nm+                      | otherwise       = str == unqualifiedName nm  isQualified :: String -> Bool isQualified [] = False@@ -193,12 +151,6 @@ cmpString2Var :: String -> Var -> Bool cmpString2Var str = cmpString2Name str . varName --- | Find 'Name's matching a given fully qualified or unqualified name.-findNamesFromString :: GlobalRdrEnv -> String -> [Name]-findNamesFromString rdrEnv str | isQualified str = res-                               | otherwise       = res-    where res = [ nm | elt <- globalRdrEnvElts rdrEnv, let nm = gre_name elt, cmpString2Name str nm ]- -- | Pretty-print an identifier. ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo v info@@ -224,12 +176,7 @@     has_caf_info = not (mayHaveCafRefs caf_info)      str_info = strictnessInfo info-    has_strictness =-#if __GLASGOW_HASKELL__ > 706-        True-#else-        isJust str_info-#endif+    has_strictness = True      unf_info = unfoldingInfo info     has_unf = hasSomeUnfolding unf_info@@ -255,23 +202,8 @@ notElemVarSet :: Var -> VarSet -> Bool notElemVarSet v vs = not (v `elemVarSet` vs) -#if __GLASGOW_HASKELL__ <= 706-instance Monoid VarSet where-  mempty :: VarSet-  mempty = emptyVarSet--  mappend :: VarSet -> VarSet -> VarSet-  mappend = unionVarSet- -------------------------------------------------------------------------- -instance Control.Monad.IO.Class.MonadIO CoreM where-  liftIO :: IO a -> CoreM a-  liftIO = MonadUtils.liftIO-#endif----------------------------------------------------------------------------- -- This function is copied from GHC, which defines but doesn't expose it. -- A 'let' can bind a type variable, and idRuleVars assumes -- it's seeing an Id. This function tests first.@@ -281,44 +213,6 @@  -------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 706-runTcMtoCoreM :: ModGuts -> TcM a -> CoreM a-runTcMtoCoreM guts m = do-    env <- CoreMonad.getHscEnv-    -- What is the effect of HsSrcFile (should we be using something else?)-    -- What should the boolean flag be set to?-    (msgs, mr) <- liftIO $ initTcFromModGuts env guts HsSrcFile False m-    -- There is probably something better for reporting the errors.-    let dumpSDocs endMsg = Bag.foldBag (\ d r -> d ++ ('\n':r)) show endMsg-        showMsgs (warns, errs) = "Errors:\n" ++ dumpSDocs ("Warnings:\n" ++ dumpSDocs "" warns) errs-    maybe (fail $ showMsgs msgs) return mr--runDsMtoCoreM :: ModGuts -> DsM a -> CoreM a-runDsMtoCoreM guts = runTcMtoCoreM guts . initDsTc---- TODO: this is mostly an example, move somewhere?-buildTypeable :: ModGuts -> Type -> CoreM (Id, [CoreBind])-buildTypeable guts ty = do-    evar <- runTcMtoCoreM guts $ do-        cls <- tcLookupClass typeableClassName-        let predTy = mkClassPred cls [typeKind ty, ty] -- recall that Typeable is now poly-kinded-        newWantedEvVar predTy-    buildDictionary guts evar---- | Build a dictionary for the given-buildDictionary :: ModGuts -> Id -> CoreM (Id, [CoreBind])-buildDictionary guts evar = do-    (i, bs) <- runTcMtoCoreM guts $ do-        loc <- getCtLoc $ GivenOrigin UnkSkol-        let predTy = varType evar-            nonC = mkNonCanonical $ CtWanted { ctev_pred = predTy, ctev_evar = evar, ctev_loc = loc }-            wCs = mkFlatWC [nonC]-        (_wCs', bnds) <- solveWantedsTcM wCs-        -- TODO: check for unsolved constraints?-        return (evar, bnds)-    bnds <- runDsMtoCoreM guts $ dsEvBinds bs-    return (i,bnds)- -- This function used to be in GHC itself, but was removed. -- It compares core for equality modulo alpha. eqExprX :: IdUnfoldingFun -> RnEnv2 -> CoreExpr -> CoreExpr -> Bool@@ -391,10 +285,16 @@ -- * If the module could not be found -- * If we could not determine the imports of the module ----- This is adapted from GHC's function of the same name, but using--- initTcFromModGuts instead of initTcInteractive.-lookupRdrNameInModuleForPlugins :: HscEnv -> ModGuts -> ModuleName -> RdrName -> IO (Maybe Name)-lookupRdrNameInModuleForPlugins hsc_env guts mod_name rdr_name = do+-- This is adapted from GHC's function called lookupRdrNameInModuleForPlugins,+-- but using initTcFromModGuts instead of initTcInteractive. Also, we ImportBySystem+-- instead of ImportByPlugin, so the EPS gets populated with RULES and instances from+-- the loaded module.+--+-- TODO: consider importing by plugin first, then only importing by system when a name+-- is successfully found... as written we will load RULES/instances if the module loads+-- successfully, even if the name is not found.+lookupRdrNameInModule :: HscEnv -> ModGuts -> ModuleName -> RdrName -> IO (Maybe Name)+lookupRdrNameInModule hsc_env guts mod_name rdr_name = do     -- First find the package the module resides in by searching exposed packages and home modules     found_module <- findImportedModule hsc_env mod_name Nothing     case found_module of@@ -402,7 +302,8 @@             -- Find the exports of the module             (_, mb_iface) <- initTcFromModGuts hsc_env guts HsSrcFile False $                              initIfaceTcRn $-                             loadPluginInterface doc mod+                             loadSysInterface doc mod+             case mb_iface of                 Just iface -> do                     -- Try and find the required name in the exports@@ -427,4 +328,3 @@  throwCmdLineError :: String -> IO a throwCmdLineError = throwGhcExceptionIO . CmdLineError-#endif

@@ -1,15 +1,11 @@ {-# LANGUAGE CPP, RankNTypes #-}-module HERMIT.GHC.Typechecker -    ( -#if __GLASGOW_HASKELL__ > 706+module HERMIT.GHC.Typechecker+    (       initTcFromModGuts     , mk_type_env     , tcLookupGlobal-#endif     ) where -#if __GLASGOW_HASKELL__ > 706- import Annotations (emptyAnnEnv) import HsSyn import RdrName@@ -34,7 +30,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map -import Prelude +import Prelude import VarSet (emptyVarSet)  -- Note: the contents of this module should eventually be folded into GHC proper.@@ -178,5 +174,3 @@ mk_dfun_n :: ModGuts -> OccSet -- TODO mk_dfun_n _ = emptyOccSet--#endif

@@ -1,17 +1,18 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables, TupleSections, GADTs #-}  module HERMIT.Kernel-        ( -- * The HERMIT Kernel-          AST-        , Kernel-        , hermitKernel-        , resumeK-        , abortK-        , applyK-        , queryK-        , deleteK-        , listK-) where+    ( -- * The HERMIT Kernel+      AST+    , Kernel+    , KernelEnv(..)+    , hermitKernel+    , resumeK+    , abortK+    , applyK+    , queryK+    , deleteK+    , listK+    ) where  import Prelude hiding (lookup) @@ -27,12 +28,12 @@ --   For now, operations on a 'Kernel' are sequential, but later --   it will be possible to have two 'applyK's running in parallel. data Kernel = Kernel-  { resumeK ::            AST                                        -> IO ()           -- ^ Halt the 'Kernel' and return control to GHC, which compiles the specified 'AST'.-  , abortK  ::                                                          IO ()           -- ^ Halt the 'Kernel' and abort GHC without compiling.-  , applyK  ::            AST -> RewriteH ModGuts     -> HermitMEnv  -> IO (KureM AST)  -- ^ Apply a 'Rewrite' to the specified 'AST' and return a handle to the resulting 'AST'.-  , queryK  :: forall a . AST -> TransformH ModGuts a -> HermitMEnv  -> IO (KureM a)    -- ^ Apply a 'TransformH' to the 'AST' and return the resulting value.-  , deleteK ::            AST                                        -> IO ()           -- ^ Delete the internal record of the specified 'AST'.-  , listK   ::                                                          IO [AST]        -- ^ List all the 'AST's tracked by the 'Kernel'.+  { resumeK ::            AST                                      -> IO ()          -- ^ Halt the 'Kernel' and return control to GHC, which compiles the specified 'AST'.+  , abortK  ::                                                        IO ()          -- ^ Halt the 'Kernel' and abort GHC without compiling.+  , applyK  ::            AST -> RewriteH ModGuts     -> KernelEnv -> IO (KureM AST) -- ^ Apply a 'Rewrite' to the specified 'AST' and return a handle to the resulting 'AST'.+  , queryK  :: forall a . AST -> TransformH ModGuts a -> KernelEnv -> IO (KureM a)   -- ^ Apply a 'TransformH' to the 'AST' and return the resulting value.+  , deleteK ::            AST                                      -> IO ()          -- ^ Delete the internal record of the specified 'AST'.+  , listK   ::                                                        IO [AST]       -- ^ List all the 'AST's tracked by the 'Kernel'.   }  -- | A /handle/ for a specific version of the 'ModGuts'.@@ -42,15 +43,28 @@ data Msg s r = forall a . Req (s -> CoreM (KureM (a,s))) (MVar (KureM a))              | Done (s -> CoreM r) -type KernelState = Map AST (DefStash, ModGuts)+type ASTMap = Map AST KernelState +data KernelState = KernelState { _ksStash  :: DefStash+                               , _ksLemmas :: Lemmas+                               , ksGuts   :: ModGuts+                               }++fromHermitMResult :: HermitMResult ModGuts -> KernelState+fromHermitMResult hRes = sideEffectsOnly hRes (hResult hRes)++sideEffectsOnly :: HermitMResult a -> ModGuts -> KernelState+sideEffectsOnly hRes = KernelState (hResStash hRes) (hResLemmas hRes)++data KernelEnv = KernelEnv { kEnvChan :: DebugMessage -> HermitM () }+ -- | Start a HERMIT client by providing an IO function that takes the initial 'Kernel' and inital 'AST' handle. --   The 'Modguts' to 'CoreM' Modguts' function required by GHC Plugins is returned. --   The callback is only ever called once. hermitKernel :: (Kernel -> AST -> IO ()) -> ModGuts -> CoreM ModGuts hermitKernel callback modGuts = do -        msgMV :: MVar (Msg KernelState ModGuts) <- liftIO newEmptyMVar+        msgMV :: MVar (Msg ASTMap ModGuts) <- liftIO newEmptyMVar          nextASTname :: MVar AST <- liftIO newEmptyMVar @@ -58,38 +72,53 @@                                                loop (succ n)                                 in loop 0 -        let sendDone :: (KernelState -> CoreM ModGuts) -> IO ()+        let sendDone :: (ASTMap -> CoreM ModGuts) -> IO ()             sendDone = putMVar msgMV . Done -        let sendReq :: (KernelState -> CoreM (KureM (a, KernelState))) -> IO (KureM a)+        let sendReq :: (ASTMap -> CoreM (KureM (a, ASTMap))) -> IO (KureM a)             sendReq fn = do rep  <- newEmptyMVar                             putMVar msgMV (Req fn rep)                             takeMVar rep -        let sendReqRead :: (KernelState -> CoreM (KureM a)) -> IO (KureM a)-            sendReqRead fn = sendReq (\ st -> (fmap.fmap) (,st) $ fn st)+        let sendReqRead :: (ASTMap -> CoreM (KureM a)) -> IO (KureM a)+            sendReqRead fn = sendReq (\ st -> (fmap.fmap) (,st) $ fn st) -- >>= return . fmap fst -        let sendReqWrite :: (KernelState -> CoreM KernelState) -> IO ()-            sendReqWrite fn = sendReq (fmap ( return . ((),) ) . fn) >>= liftKureM+        let sendReqWrite :: (ASTMap -> CoreM ASTMap) -> IO ()+            sendReqWrite fn = sendReq (fmap ( return . ((),) ) . fn) >>= {- fmap fst . -} liftKureM          let kernel :: Kernel             kernel = Kernel-                { resumeK = \ name -> sendDone $ \ st -> findWithErrMsg name st (\ msg -> throwGhcException $ ProgramError $ msg ++ ", exiting HERMIT and aborting GHC compilation.") (return.snd)+                { resumeK = \ name ->+                                sendDone $ \ st ->+                                    findWithErrMsg name+                                                   st+                                                   (\ msg -> throwGhcException+                                                             $ ProgramError+                                                             $ msg ++ ", exiting HERMIT and aborting GHC compilation.")+                                                   (return.ksGuts) -                , abortK  = sendDone $ \ _ -> throwGhcException (ProgramError "Exiting HERMIT and aborting GHC compilation.")+                , abortK  = sendDone $ \ _ -> throwGhcException+                                              $ ProgramError "Exiting HERMIT and aborting GHC compilation." -                , applyK = \ name r hm_env -> sendReq $ \ st -> findWithErrMsg name st fail $ \ (defs, guts) -> runHM (guts,hm_env)-                                                                                                               defs-                                                                                                               (\ defs' guts' -> do ast <- liftIO $ takeMVar nextASTname-                                                                                                                                    return $ return (ast, insert ast (defs',guts') st))-                                                                                                               (return . fail)-                                                                                                               (apply r (topLevelHermitC guts) guts)+                , applyK = \ name r kEnv ->+                                sendReq $ \ st ->+                                    findWithErrMsg name st fail $ \ (KernelState defs lemmas guts) ->+                                        runHM (kEnvChan kEnv)+                                              (mkEnv guts defs lemmas)+                                              (\ hRes -> do+                                                    ast <- liftIO $ takeMVar nextASTname+                                                    return $ return (ast, insert ast (fromHermitMResult hRes) st))+                                              (return . fail)+                                              (applyT r (topLevelHermitC guts) guts) -                , queryK = \ name t hm_env -> sendReqRead $ \ st -> findWithErrMsg name st fail $ \ (defs, guts) -> runHM (guts,hm_env)-                                                                                                                      defs-                                                                                                                      (\ _ -> return.return)-                                                                                                                      (return . fail)-                                                                                                                      (apply t (topLevelHermitC guts) guts)+                , queryK = \ name t kEnv ->+                                sendReqRead $ \ st ->+                                    findWithErrMsg name st fail $ \ (KernelState defs lemmas guts) ->+                                        runHM (kEnvChan kEnv)+                                              (mkEnv guts defs lemmas)+                                              (return . return . hResult)+                                              (return . fail)+                                              (applyT t (topLevelHermitC guts) guts)                  , deleteK = \ name -> sendReqWrite (return . delete name) @@ -99,7 +128,7 @@         -- We always start with AST 0         ast0 <- liftIO $ takeMVar nextASTname -        let loop :: KernelState -> CoreM ModGuts+        let loop :: ASTMap -> CoreM ModGuts             loop st = do                 m <- liftIO $ takeMVar msgMV                 case m of@@ -109,7 +138,7 @@          _pid <- liftIO $ forkIO $ callback kernel ast0 -        loop (singleton ast0 (empty, modGuts))+        loop (singleton ast0 $ KernelState empty empty modGuts)          -- (Kill the pid'd thread? do we need to?)