hermit 0.2.0.0 → 0.3.0.0

raw patch · 126 files changed

+14182/−11254 lines, 126 filesdep +temporarydep +terminfodep ~kuredep ~processPVP ok

version bump matches the API change (PVP)

Dependencies added: temporary, terminfo

Dependency ranges changed: kure, process

API changes (from Hackage documentation)

Files

• dist/build/HERMIT/Parser.hs +752/−0
• dist/build/HERMIT/ParserCore.hs +624/−0
• dist/build/Language/HERMIT/Parser.hs +0/−728
• dist/build/Language/HERMIT/ParserCore.hs +0/−588
• driver/Main.hs +18/−3
• examples/WWSplitTactic.hss +0/−18
• examples/concatVanishes/ConcatVanishes.hss +15/−6
• examples/concatVanishes/Flatten.hs +0/−7
• examples/concatVanishes/Flatten.hss +2/−3
• examples/concatVanishes/HList.hs +4/−8
• examples/concatVanishes/QSort.hs +0/−6
• examples/concatVanishes/QSort.hss +2/−5
• examples/concatVanishes/Rev.hs +0/−6
• examples/concatVanishes/Rev.hss +2/−4
• examples/evaluation/Eval.hs +8/−7
• examples/evaluation/Eval.hss +21/−17
• examples/factorial/Fac.hs +4/−0
• examples/factorial/Fac.hss +6/−21
• examples/fib-stream/Fib.hss +1/−1
• examples/fib-tuple/Fib.hs +1/−1
• examples/fib-tuple/Fib.hss +6/−5
• examples/flatten/Flatten.hs +0/−7
• examples/flatten/Flatten.hss +12/−18
• examples/flatten/HList.hs +4/−0
• examples/hanoi/Hanoi.hss +6/−6
• examples/last/Last.hs +6/−2
• examples/last/Last.hss +6/−16
• examples/mean/Mean.hss +2/−2
• examples/qsort/HList.hs +4/−5
• examples/qsort/QSort.hs +0/−7
• examples/qsort/QSort.hss +8/−27
• examples/reverse/HList.hs +4/−5
• examples/reverse/Reverse.hs +2/−6
• examples/reverse/Reverse.hss +12/−19
• hermit.cabal +66/−54
• src/HERMIT.hs +2/−3
• src/HERMIT/Context.hs +287/−0
• src/HERMIT/Core.hs +549/−0
• src/HERMIT/Dictionary.hs +92/−0
• src/HERMIT/Dictionary/AlphaConversion.hs +324/−0
• src/HERMIT/Dictionary/Common.hs +251/−0
• src/HERMIT/Dictionary/Composite.hs +148/−0
• src/HERMIT/Dictionary/Debug.hs +53/−0
• src/HERMIT/Dictionary/FixPoint.hs +208/−0
• src/HERMIT/Dictionary/Fold.hs +174/−0
• src/HERMIT/Dictionary/Function.hs +106/−0
• src/HERMIT/Dictionary/GHC.hs +375/−0
• src/HERMIT/Dictionary/Inline.hs +217/−0
• src/HERMIT/Dictionary/Kure.hs +115/−0
• src/HERMIT/Dictionary/Local.hs +235/−0
• src/HERMIT/Dictionary/Local/Bind.hs +47/−0
• src/HERMIT/Dictionary/Local/Case.hs +451/−0
• src/HERMIT/Dictionary/Local/Cast.hs +133/−0
• src/HERMIT/Dictionary/Local/Let.hs +426/−0
• src/HERMIT/Dictionary/Navigation.hs +248/−0
• src/HERMIT/Dictionary/Navigation/Crumbs.hs +100/−0
• src/HERMIT/Dictionary/New.hs +76/−0
• src/HERMIT/Dictionary/Query.hs +178/−0
• src/HERMIT/Dictionary/Reasoning.hs +109/−0
• src/HERMIT/Dictionary/Undefined.hs +194/−0
• src/HERMIT/Dictionary/Unfold.hs +152/−0
• src/HERMIT/Dictionary/Unsafe.hs +45/−0
• src/HERMIT/Dictionary/WorkerWrapper/Common.hs +23/−0
• src/HERMIT/Dictionary/WorkerWrapper/Fix.hs +458/−0
• src/HERMIT/Dictionary/WorkerWrapper/FixResult.hs +502/−0
• src/HERMIT/External.hs +474/−0
• src/HERMIT/GHC.hs +227/−0
• src/HERMIT/Interp.hs +88/−0
• src/HERMIT/Kernel.hs +120/−0
• src/HERMIT/Kernel/Scoped.hs +167/−0
• src/HERMIT/Kure.hs +1324/−0
• src/HERMIT/Kure/SumTypes.hs +453/−0
• src/HERMIT/Monad.hs +176/−0
• src/HERMIT/Optimize.hs +214/−0
• src/HERMIT/Parser.y +195/−0
• src/HERMIT/ParserCore.y +186/−0
• src/HERMIT/Plugin.hs +128/−0
• src/HERMIT/PrettyPrinter/AST.hs +130/−0
• src/HERMIT/PrettyPrinter/Clean.hs +444/−0
• src/HERMIT/PrettyPrinter/Common.hs +479/−0
• src/HERMIT/PrettyPrinter/GHC.hs +71/−0
• src/HERMIT/Shell/Command.hs +586/−0
• src/HERMIT/Shell/Dictionary.hs +75/−0
• src/HERMIT/Shell/Externals.hs +265/−0
• src/HERMIT/Shell/Renderer.hs +78/−0
• src/HERMIT/Shell/ScriptToRewrite.hs +126/−0
• src/HERMIT/Shell/Types.hs +201/−0
• src/HERMIT/Syntax.hs +59/−0
• src/HERMIT/Utilities.hs +40/−0
• src/Language/HERMIT/Context.hs +0/−231
• src/Language/HERMIT/Core.hs +0/−293
• src/Language/HERMIT/Dictionary.hs +0/−151
• src/Language/HERMIT/External.hs +0/−430
• src/Language/HERMIT/GHC.hs +0/−172
• src/Language/HERMIT/Interp.hs +0/−88
• src/Language/HERMIT/Kernel.hs +0/−122
• src/Language/HERMIT/Kernel/Scoped.hs +0/−183
• src/Language/HERMIT/Kure.hs +0/−1358
• src/Language/HERMIT/Kure/SumTypes.hs +0/−255
• src/Language/HERMIT/Monad.hs +0/−171
• src/Language/HERMIT/Optimize.hs +0/−158
• src/Language/HERMIT/Parser.y +0/−189
• src/Language/HERMIT/ParserCore.y +0/−167
• src/Language/HERMIT/Plugin.hs +0/−127
• src/Language/HERMIT/PrettyPrinter/AST.hs +0/−112
• src/Language/HERMIT/PrettyPrinter/Clean.hs +0/−422
• src/Language/HERMIT/PrettyPrinter/Common.hs +0/−481
• src/Language/HERMIT/PrettyPrinter/GHC.hs +0/−68
• src/Language/HERMIT/Primitive/AlphaConversion.hs +0/−314
• src/Language/HERMIT/Primitive/Common.hs +0/−275
• src/Language/HERMIT/Primitive/Debug.hs +0/−53
• src/Language/HERMIT/Primitive/FixPoint.hs +0/−407
• src/Language/HERMIT/Primitive/Fold.hs +0/−153
• src/Language/HERMIT/Primitive/GHC.hs +0/−611
• src/Language/HERMIT/Primitive/Inline.hs +0/−188
• src/Language/HERMIT/Primitive/Kure.hs +0/−101
• src/Language/HERMIT/Primitive/Local.hs +0/−215
• src/Language/HERMIT/Primitive/Local/Case.hs +0/−273
• src/Language/HERMIT/Primitive/Local/Cast.hs +0/−120
• src/Language/HERMIT/Primitive/Local/Let.hs +0/−289
• src/Language/HERMIT/Primitive/Navigation.hs +0/−157
• src/Language/HERMIT/Primitive/Navigation/Crumbs.hs +0/−100
• src/Language/HERMIT/Primitive/New.hs +0/−190
• src/Language/HERMIT/Primitive/Unfold.hs +0/−151
• src/Language/HERMIT/Shell/Command.hs +0/−813
• src/Language/HERMIT/Syntax.hs +0/−55

@@ -0,0 +1,752 @@+{-# OPTIONS_GHC -w #-}+{-# OPTIONS -fglasgow-exts -cpp #-}+module HERMIT.Parser+    ( Script+    , parseScript+    , unparseScript+    , unparseExprH+    , ExprH(..)+    ) where++import Data.Char (isSpace)+import Data.List (intercalate)++import Control.Monad ((>=>))++import HERMIT.Syntax (isScriptInfixIdChar, isScriptIdFirstChar, isScriptIdChar)+import qualified Data.Array as Happy_Data_Array+import qualified GHC.Exts as Happy_GHC_Exts++-- parser produced by Happy Version 1.19.0++newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11 = 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 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn5 #-}+happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t5+happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut5 #-}+happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn6 #-}+happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t6+happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut6 #-}+happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn7 #-}+happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t7+happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut7 #-}+happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn8 #-}+happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t8+happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut8 #-}+happyIn9 :: t9 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn9 #-}+happyOut9 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t9+happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut9 #-}+happyIn10 :: t10 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn10 #-}+happyOut10 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t10+happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut10 #-}+happyIn11 :: t11 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn11 #-}+happyOut11 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t11+happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut11 #-}+happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyInTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> (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"#++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"#++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"#++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"#++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"#++happyReduceArr = Happy_Data_Array.array (1, 25) [+	(1 , happyReduce_1),+	(2 , happyReduce_2),+	(3 , happyReduce_3),+	(4 , happyReduce_4),+	(5 , happyReduce_5),+	(6 , happyReduce_6),+	(7 , happyReduce_7),+	(8 , happyReduce_8),+	(9 , happyReduce_9),+	(10 , happyReduce_10),+	(11 , happyReduce_11),+	(12 , happyReduce_12),+	(13 , happyReduce_13),+	(14 , happyReduce_14),+	(15 , happyReduce_15),+	(16 , happyReduce_16),+	(17 , happyReduce_17),+	(18 , happyReduce_18),+	(19 , happyReduce_19),+	(20 , happyReduce_20),+	(21 , happyReduce_21),+	(22 , happyReduce_22),+	(23 , happyReduce_23),+	(24 , happyReduce_24),+	(25 , happyReduce_25)+	]++happy_n_terms = 15 :: Int+happy_n_nonterms = 8 :: Int++happyReduce_1 = happySpecReduce_2  0# happyReduction_1+happyReduction_1 happy_x_2+	happy_x_1+	 =  case happyOut4 happy_x_2 of { happy_var_2 -> +	happyIn4+		 (CmdName "{" : happy_var_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+		 (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+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_6 = happySpecReduce_1  2# happyReduction_6+happyReduction_6 happy_x_1+	 =  case happyOut7 happy_x_1 of { happy_var_1 -> +	happyIn6+		 ([happy_var_1]+	)}++happyReduce_7 = happySpecReduce_3  2# happyReduction_7+happyReduction_7 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+		 ([happy_var_1, CmdName "}"] ++ happy_var_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+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_9 = happySpecReduce_2  2# happyReduction_9+happyReduction_9 happy_x_2+	happy_x_1+	 =  case happyOut4 happy_x_2 of { happy_var_2 -> +	happyIn6+		 (happy_var_2+	)}++happyReduce_10 = happySpecReduce_3  3# happyReduction_10+happyReduction_10 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut8 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+		 (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+		 (happy_var_1+	)}++happyReduce_12 = happySpecReduce_2  4# happyReduction_12+happyReduction_12 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+		 (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+		 (happy_var_1+	)}++happyReduce_14 = happySpecReduce_2  5# happyReduction_14+happyReduction_14 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_2 of { (Ident happy_var_2) -> +	happyIn9+		 (SrcName happy_var_2+	)}++happyReduce_15 = happySpecReduce_2  5# happyReduction_15+happyReduction_15 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_2 of { (InfixOp happy_var_2) -> +	happyIn9+		 (SrcName happy_var_2+	)}++happyReduce_16 = happySpecReduce_2  5# happyReduction_16+happyReduction_16 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_2 of { (Quote happy_var_2) -> +	happyIn9+		 (SrcName happy_var_2+	)}++happyReduce_17 = happySpecReduce_1  5# happyReduction_17+happyReduction_17 happy_x_1+	 =  case happyOutTok happy_x_1 of { (Quote happy_var_1) -> +	happyIn9+		 (CmdName happy_var_1+	)}++happyReduce_18 = happySpecReduce_1  5# happyReduction_18+happyReduction_18 happy_x_1+	 =  case happyOutTok happy_x_1 of { (CoreString happy_var_1) -> +	happyIn9+		 (CoreH happy_var_1+	)}++happyReduce_19 = happySpecReduce_3  5# happyReduction_19+happyReduction_19 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut10 happy_x_2 of { happy_var_2 -> +	happyIn9+		 (ListH happy_var_2+	)}++happyReduce_20 = happySpecReduce_3  5# happyReduction_20+happyReduction_20 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut7 happy_x_2 of { happy_var_2 -> +	happyIn9+		 (happy_var_2+	)}++happyReduce_21 = happySpecReduce_1  5# happyReduction_21+happyReduction_21 happy_x_1+	 =  case happyOutTok happy_x_1 of { (Ident happy_var_1) -> +	happyIn9+		 (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+		 (happy_var_1+	)}++happyReduce_23 = happySpecReduce_0  6# happyReduction_23+happyReduction_23  =  happyIn10+		 ([]+	)++happyReduce_24 = happySpecReduce_1  7# happyReduction_24+happyReduction_24 happy_x_1+	 =  case happyOut7 happy_x_1 of { happy_var_1 -> +	happyIn11+		 ([happy_var_1]+	)}++happyReduce_25 = happySpecReduce_3  7# happyReduction_25+happyReduction_25 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+		 (happy_var_1 : happy_var_3+	)}}++happyNewToken action sts stk [] =+	happyDoAction 14# notHappyAtAll action sts stk []++happyNewToken action sts stk (tk:tks) =+	let cont i = happyDoAction i tk action sts stk tks in+	case tk of {+	ParenLeft -> cont 1#;+	ParenRight -> cont 2#;+	ScopeStart -> cont 3#;+	ScopeEnd -> cont 4#;+	ListStart -> cont 5#;+	ListDelim -> cont 6#;+	ListEnd -> cont 7#;+	StmtEnd -> cont 8#;+	Tick -> cont 9#;+	CoreString happy_dollar_dollar -> cont 10#;+	Quote happy_dollar_dollar -> cont 11#;+	Ident happy_dollar_dollar -> cont 12#;+	InfixOp happy_dollar_dollar -> cont 13#;+	_ -> happyError' (tk:tks)+	}++happyError_ 14# tk tks = happyError' tks+happyError_ _ tk tks = happyError' (tk:tks)++happyThen :: () => Either String a -> (a -> Either String b) -> Either String b+happyThen = (>>=)+happyReturn :: () => a -> Either String a+happyReturn = (return)+happyThen1 m k tks = (>>=) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> Either String a+happyReturn1 = \a tks -> (return) a+happyError' :: () => [(Token)] -> Either String a+happyError' = parseError++parser tks = happySomeParser where+  happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))++happySeq = happyDontSeq+++parseError :: [Token] -> Either String a+parseError ts = Left $ "Parse error: " ++ show ts++-- | A simple expression language AST, for things parsed from 'String' or JSON structures.+data ExprH+    = SrcName String                -- ^ Variable names (refers to source code).+    | CmdName String                -- ^ Commands (to be looked up in 'HERMIT.Dictionary').+    | AppH ExprH ExprH              -- ^ Application.+    | CoreH String                  -- ^ Core Fragment+    | ListH [ExprH]                 -- ^ List of expressions+    deriving (Eq, Show)++data Token+    = ParenLeft+    | ParenRight+    | ScopeStart+    | ScopeEnd+    | ListStart+    | ListDelim+    | ListEnd+    | StmtEnd+    | Tick+    | CoreString String+    | Quote String+    | Ident String+    | InfixOp String+    deriving (Eq, Show)++lexError :: String -> Either String a+lexError msg = Left ("Lexer error: " ++ msg)++lexer :: String -> Either String [Token]+lexer []           = Right []+lexer ('\n':cs)    = fmap (StmtEnd:)    $ lexer cs+lexer (';' :cs)    = fmap (StmtEnd:)    $ lexer cs+lexer ('(' :cs)    = fmap (ParenLeft:)  $ lexer cs+lexer (')' :cs)    = fmap (ParenRight:) $ lexer cs+lexer ('{' :cs)    = fmap (ScopeStart:) $ lexer cs+lexer ('}' :cs)    = fmap (ScopeEnd:)   $ lexer cs+lexer ('\'':cs)    = fmap (Tick:)       $ lexer cs+lexer ('\"':cs)    = do (str,cs') <- lexString cs+                        fmap (Quote str:) $ lexer cs'+lexer ('[':'|':cs) = do (str,cs') <- lexCore cs+                        fmap (CoreString str:) $ lexer cs'+lexer ('-':'-':cs) = let (_,s') = span (/= '\n') cs in lexer s'+lexer ('[' :cs)    = fmap (ListStart:)  $ lexer cs+lexer (',' :cs)    = fmap (ListDelim:)  $ lexer cs+lexer (']' :cs)    = fmap (ListEnd:)    $ lexer cs+lexer s@(c:cs)     | isSpace             c = lexer cs+                   | isScriptIdFirstChar c = let (i,s') = span isScriptIdChar s+                                              in fmap (Ident i:) $ lexer s'+                   | isScriptInfixIdChar c = let (op,s') = span isScriptInfixIdChar s+                                              in fmap (InfixOp op:) $ lexer s'+lexer s            = lexError $ "no match on " ++ s++lexString :: String -> Either String (String,String)+lexString ('\"':cs)      = Right ([],cs)+lexString ('\\':'\"':cs) = do (c',r) <- lexString cs+                              return ('"':c',r)+lexString (c:cs)         = do (c',r) <- lexString cs+                              return (c:c',r)+lexString []             = lexError "no matching quote"++lexCore :: String -> Either String (String,String)+lexCore ('|':']':rest) = Right ([],rest)+lexCore (c:cs)         = do (c',r) <- lexCore cs+                            return (c:c',r)+lexCore []             = lexError "no closing |]"++---------------------------------------------++-- | Use ghci Parser.hs to run this test function.+test = do+    ln <- getLine+    case ln of+        "quit" -> return ()+        _      -> do print $ lexer ln+                     print $ parseScript ln+                     test++type Script = [ExprH]++parseScript :: String -> Either String Script+parseScript = lexer >=> parser++---------------------------------------------++unparseScript :: Script -> String+unparseScript = intercalate " ; " . map unparseExprH++unparseExprH :: ExprH -> String+unparseExprH (SrcName nm)+    | nm /= "" && (all isScriptInfixIdChar nm || isScriptIdFirstChar (head nm) && all isScriptIdChar (tail nm)) = "'" ++ nm+    | otherwise = "'\"" ++ concatMap escape nm ++ "\""+        where escape '\"' = "\\\""+              escape c    = [c]+unparseExprH (CmdName nm)+    | nm == "{"             = "{ "+    | nm == "}"             = " }"+    | all isScriptIdChar nm = nm+    | otherwise             = show nm     -- with quotes+unparseExprH (AppH (AppH (CmdName nm) e1) e2)+    | all isScriptInfixIdChar nm+    = unparseAtom e1 ++ " " ++ nm ++ " " ++ unparseAtom e2+unparseExprH (AppH e1 e2) = unparseExprH e1 ++ " " ++ unparseAtom e2+unparseExprH (CoreH s)    = "[|" ++ s ++ "|]"+unparseExprH (ListH es)   = "[" ++ intercalate "," (map unparseExprH es) ++ "]"++unparseAtom :: ExprH -> String+unparseAtom e@(AppH {}) = "(" ++ unparseExprH e ++ ")"+unparseAtom e           = unparseExprH e++---------------------------------------------+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp ++{-# LINE 13 "templates/GenericTemplate.hs" #-}++++++#if __GLASGOW_HASKELL__ > 706+#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool)+#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool)+#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool)+#else+#define LT(n,m) (n Happy_GHC_Exts.<# m)+#define GTE(n,m) (n Happy_GHC_Exts.>=# m)+#define EQ(n,m) (n Happy_GHC_Exts.==# m)+#endif+{-# LINE 45 "templates/GenericTemplate.hs" #-}+++data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList++++++{-# LINE 66 "templates/GenericTemplate.hs" #-}++{-# LINE 76 "templates/GenericTemplate.hs" #-}++{-# LINE 85 "templates/GenericTemplate.hs" #-}++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is 0#, it means we've just accepted a partial+-- parse (a %partial parser).  We must ignore the saved token on the top of+-- the stack in this case.+happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =+	happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = +	(happyTcHack j (happyTcHack st)) (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++++happyDoAction i tk st+	= {- nothing -}+++	  case action of+		0#		  -> {- nothing -}+				     happyFail i tk st+		-1# 	  -> {- nothing -}+				     happyAccept i tk st+		n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}++				     (happyReduceArr Happy_Data_Array.! rule) i tk st+				     where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))+		n		  -> {- nothing -}+++				     happyShift new_state i tk st+                                     where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))+   where off    = indexShortOffAddr happyActOffsets st+         off_i  = (off Happy_GHC_Exts.+# i)+	 check  = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#))+                  then EQ(indexShortOffAddr happyCheck off_i, i)+		  else False+         action+          | check     = indexShortOffAddr happyTable off_i+          | otherwise = indexShortOffAddr happyDefActions st+++indexShortOffAddr (HappyA# arr) off =+	Happy_GHC_Exts.narrow16Int# i+  where+        i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)+        high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))+        low  = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))+        off' = off Happy_GHC_Exts.*# 2#++++++data HappyAddr = HappyA# Happy_GHC_Exts.Addr#+++++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++{-# LINE 169 "templates/GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =+     let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+--     trace "shifting the error token" $+     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)++happyShift new_state i tk st sts stk =+     happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_0 nt fn j tk st@((action)) sts stk+     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')+     = let r = fn v1 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')+     = let r = fn v1 v2 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+     = let r = fn v1 v2 v3 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happyReduce k nt fn j tk st sts stk+     = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of+	 sts1@((HappyCons (st1@(action)) (_))) ->+        	let r = fn stk in  -- it doesn't hurt to always seq here...+       		happyDoSeq r (happyGoto nt j tk st1 sts1 r)++happyMonadReduce k nt fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+      case happyDrop k (HappyCons (st) (sts)) of+        sts1@((HappyCons (st1@(action)) (_))) ->+          let drop_stk = happyDropStk k stk in+          happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))++happyMonad2Reduce k nt fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+      case happyDrop k (HappyCons (st) (sts)) of+        sts1@((HappyCons (st1@(action)) (_))) ->+         let drop_stk = happyDropStk k stk++             off = indexShortOffAddr happyGotoOffsets st1+             off_i = (off Happy_GHC_Exts.+# nt)+             new_state = indexShortOffAddr happyTable off_i++++          in+          happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))++happyDrop 0# l = l+happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t++happyDropStk 0# l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction+++happyGoto nt j tk st = +   {- nothing -}+   happyDoAction j tk new_state+   where off = indexShortOffAddr happyGotoOffsets st+         off_i = (off Happy_GHC_Exts.+# nt)+         new_state = indexShortOffAddr happyTable off_i+++++-----------------------------------------------------------------------------+-- Error recovery (0# is the error token)++-- parse error if we are in recovery and we fail again+happyFail 0# tk old_st _ stk@(x `HappyStk` _) =+     let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+--	trace "failing" $ +        happyError_ i tk++{-  We don't need state discarding for our restricted implementation of+    "error".  In fact, it can cause some bogus parses, so I've disabled it+    for now --SDM++-- discard a state+happyFail  0# tk old_st (HappyCons ((action)) (sts)) +						(saved_tok `HappyStk` _ `HappyStk` stk) =+--	trace ("discarding state, depth " ++ show (length stk))  $+	happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+--                       save the old token and carry on.+happyFail  i tk (action) sts stk =+--      trace "entering error recovery" $+	happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll :: a+notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions+++happyTcHack :: Happy_GHC_Exts.Int# -> a -> a+happyTcHack x y = y+{-# INLINE happyTcHack #-}+++-----------------------------------------------------------------------------+-- Seq-ing.  If the --strict flag is given, then Happy emits +--	happySeq = happyDoSeq+-- otherwise it emits+-- 	happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq   a b = a `seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template.  GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.+++{-# NOINLINE happyDoAction #-}+{-# NOINLINE happyTable #-}+{-# NOINLINE happyCheck #-}+{-# NOINLINE happyActOffsets #-}+{-# NOINLINE happyGotoOffsets #-}+{-# NOINLINE happyDefActions #-}++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.

@@ -0,0 +1,624 @@+{-# OPTIONS_GHC -w #-}+{-# OPTIONS -fglasgow-exts -cpp #-}+{-# LANGUAGE CPP #-}+ module HERMIT.ParserCore (parseCore, parseCoreExprT, parse2beforeBiR, parse3beforeBiR) where++import Control.Arrow+import Control.Monad.Reader+import Data.Char (isSpace, isDigit)++import HERMIT.Context+import HERMIT.External+import HERMIT.GHC+import HERMIT.Kure+import HERMIT.Monad+import HERMIT.Syntax (isCoreInfixIdChar, isCoreIdFirstChar, isCoreIdChar)++import HERMIT.Dictionary.Common++import Language.KURE.MonadCatch (prefixFailMsg)++import Language.Haskell.TH as TH+import qualified Data.Array as Happy_Data_Array+import qualified GHC.Exts as Happy_GHC_Exts++-- parser produced by Happy Version 1.19.0++newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 = 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)+happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn4 #-}+happyOut4 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t4+happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut4 #-}+happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn5 #-}+happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t5+happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut5 #-}+happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn6 #-}+happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t6+happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut6 #-}+happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn7 #-}+happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t7+happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut7 #-}+happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn8 #-}+happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t8+happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut8 #-}+happyIn9 :: t9 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn9 #-}+happyOut9 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t9+happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut9 #-}+happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyInTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> (Token)+happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOutTok #-}+++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\xf8\xff\xf8\xff\xf8\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\xf0\xff\xf6\xff\x00\x00\x00\x00\x00\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\x0b\x00\x18\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\xfc\xff\xf8\xff\xf7\xff\xf9\xff\x00\x00\xf4\xff\xf6\xff\xf5\xff\x00\x00\x00\x00\xfa\xff\xfd\xff\xfb\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x0c\x00\x0d\x00\x0d\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\x1c\x00\x22\x00\x1e\x00\x1c\x00\x20\x00\x1e\x00\xff\xff\x20\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x02\x00\x03\x00\x04\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\x08\x00\x0e\x00\x10\x00\x08\x00\x0c\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0b\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x09\x00\xff\xff\x0a\x00\x09\x00\x0b\x00\x0a\x00\x00\x00\x0b\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0e\x00\x04\x00\x05\x00\x06\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\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\x00"#++happyReduceArr = Happy_Data_Array.array (1, 11) [+	(1 , happyReduce_1),+	(2 , happyReduce_2),+	(3 , happyReduce_3),+	(4 , happyReduce_4),+	(5 , happyReduce_5),+	(6 , happyReduce_6),+	(7 , happyReduce_7),+	(8 , happyReduce_8),+	(9 , happyReduce_9),+	(10 , happyReduce_10),+	(11 , happyReduce_11)+	]++happy_n_terms = 35 :: Int+happy_n_nonterms = 6 :: Int++happyReduce_1 = happySpecReduce_1  0# happyReduction_1+happyReduction_1 happy_x_1+	 =  case happyOut5 happy_x_1 of { happy_var_1 -> +	happyIn4+		 (happy_var_1+	)}++happyReduce_2 = happySpecReduce_2  1# happyReduction_2+happyReduction_2 happy_x_2+	happy_x_1+	 =  case happyOut5 happy_x_1 of { happy_var_1 -> +	case happyOut6 happy_x_2 of { happy_var_2 -> +	happyIn5+		 (App happy_var_1 happy_var_2+	)}}++happyReduce_3 = happySpecReduce_1  1# happyReduction_3+happyReduction_3 happy_x_1+	 =  case happyOut6 happy_x_1 of { happy_var_1 -> +	happyIn5+		 (happy_var_1+	)}++happyReduce_4 = happySpecReduce_3  2# happyReduction_4+happyReduction_4 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut4 happy_x_2 of { happy_var_2 -> +	happyIn6+		 (happy_var_2+	)}++happyReduce_5 = happyMonadReduce 2# 2# happyReduction_5+happyReduction_5 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen (( lookupName "()" Var)+	) (\r -> happyReturn (happyIn6 r))++happyReduce_6 = happySpecReduce_1  2# happyReduction_6+happyReduction_6 happy_x_1+	 =  case happyOut9 happy_x_1 of { happy_var_1 -> +	happyIn6+		 (happy_var_1+	)}++happyReduce_7 = happySpecReduce_1  2# happyReduction_7+happyReduction_7 happy_x_1+	 =  case happyOut7 happy_x_1 of { happy_var_1 -> +	happyIn6+		 (happy_var_1+	)}++happyReduce_8 = happySpecReduce_1  2# happyReduction_8+happyReduction_8 happy_x_1+	 =  case happyOut8 happy_x_1 of { happy_var_1 -> +	happyIn6+		 (happy_var_1+	)}++happyReduce_9 = happyMonadReduce 1# 3# happyReduction_9+happyReduction_9 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen (case happyOutTok happy_x_1 of { (Tinteger happy_var_1) -> +	( mkIntExpr' happy_var_1)}+	) (\r -> happyReturn (happyIn7 r))++happyReduce_10 = happyMonadReduce 1# 4# happyReduction_10+happyReduction_10 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen (case happyOutTok happy_x_1 of { (Tstring happy_var_1) -> +	( lift $ mkStringExpr happy_var_1)}+	) (\r -> happyReturn (happyIn8 r))++happyReduce_11 = happyMonadReduce 1# 5# happyReduction_11+happyReduction_11 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen (case happyOutTok happy_x_1 of { (Tname happy_var_1) -> +	( lookupName happy_var_1 varToCoreExpr)}+	) (\r -> happyReturn (happyIn9 r))++happyNewToken action sts stk [] =+	happyDoAction 34# notHappyAtAll action sts stk []++happyNewToken action sts stk (tk:tks) =+	let cont i = happyDoAction i tk action sts stk tks in+	case tk of {+	Tforall -> cont 1#;+	Trec -> cont 2#;+	Tlet -> cont 3#;+	Tin -> cont 4#;+	Tcase -> cont 5#;+	Tof -> cont 6#;+	Tcast -> cont 7#;+	Tnote -> cont 8#;+	Texternal -> cont 9#;+	Tlocal -> cont 10#;+	Twild -> cont 11#;+	Toparen -> cont 12#;+	Tcparen -> cont 13#;+	Tobrace -> cont 14#;+	Tcbrace -> cont 15#;+	Thash -> cont 16#;+	Teq -> cont 17#;+	Tcolon -> cont 18#;+	Tcoloncolon -> cont 19#;+	Tcoloneqcolon -> cont 20#;+	Tstar -> cont 21#;+	Tarrow -> cont 22#;+	Tlambda -> cont 23#;+	Tat -> cont 24#;+	Tdot -> cont 25#;+	Tquestion -> cont 26#;+	Tsemicolon -> cont 27#;+	Tname happy_dollar_dollar -> cont 28#;+	Tcname happy_dollar_dollar -> cont 29#;+	Tinteger happy_dollar_dollar -> cont 30#;+	Trational happy_dollar_dollar -> cont 31#;+	Tstring happy_dollar_dollar -> cont 32#;+	Tchar happy_dollar_dollar -> cont 33#;+	_ -> happyError' (tk:tks)+	}++happyError_ 34# tk tks = happyError' tks+happyError_ _ tk tks = happyError' (tk:tks)++happyThen :: () => CoreParseM a -> (a -> CoreParseM b) -> CoreParseM b+happyThen = (>>=)+happyReturn :: () => a -> CoreParseM a+happyReturn = (return)+happyThen1 m k tks = (>>=) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> CoreParseM a+happyReturn1 = \a tks -> (return) a+happyError' :: () => [(Token)] -> CoreParseM a+happyError' = parseError++parser tks = happySomeParser where+  happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))++happySeq = happyDontSeq+++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 -> (Id -> CoreExpr) -> CoreParseM CoreExpr+lookupName nm k = do+    c <- ask+    v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId (TH.mkName nm) c+    return (k v)++type CoreParseM a = ReaderT HermitC HermitM a++parseError :: Monad m => [Token] -> m a+parseError ts = fail $ "core parse error: " ++ show ts++data Token+    = Tforall+    | Trec+    | Tlet+    | Tin+    | Tcase+    | Tof+    | Tcast+    | Tnote+    | Texternal+    | Tlocal+    | Twild --+    | Toparen --+    | Tcparen --+    | Tobrace+    | Tcbrace+    | Thash+    | Teq+    | Tcolon --+    | Tcoloncolon --+    | Tcoloneqcolon+    | Tstar+    | Tarrow+    | Tlambda --+    | Tat+    | Tdot+    | Tquestion+    | Tsemicolon+    | Tname String+    | Tcname String+    | Tinteger Integer+    | Trational Float+    | Tstring String+    | Tchar Char+    deriving (Eq, Show)++lexer :: String -> Either String [Token]+lexer []           = Right []+lexer ('_' :cs)    = fmap (Twild:)       $ lexer cs+lexer ('(' :cs)    = fmap (Toparen:)     $ lexer cs+lexer (')' :cs)    = fmap (Tcparen:)     $ lexer cs+lexer (':':':':cs) = fmap (Tcoloncolon:) $ lexer cs+-- lexer (':' :cs)    = fmap (Tcolon:)      $ lexer cs+lexer ('\\':cs)    = fmap (Tlambda:)     $ lexer cs+lexer ('-':'>':cs) = fmap (Tarrow:)      $ lexer cs+lexer ('\"':cs)    = let (str,rest) = span (/='\"') cs+                     in case rest of+                           ('\"':cs') -> fmap (Tstring str:) $ lexer cs'+                           _          -> Left "lexer: no matching quote"+lexer s@(c:cs) | isSpace           c = lexer cs+               | isDigit           c = let (i,s') = span isDigit s+                                         in fmap (Tinteger (read i):) $ lexer s'+               | isCoreIdFirstChar c = let (i,s') = span isCoreIdChar s+                                         in fmap (Tname i:) $ lexer s'+               | isCoreInfixIdChar c = let (op,s') = span isCoreInfixIdChar s+                                         in fmap (Tname op:) $ lexer s'+lexer s            = Left $ "lexer: no match on " ++ s++---------------------------------------------++parseCore :: CoreString -> HermitC -> HermitM CoreExpr+parseCore (CoreString s) c =+    case lexer s of+        Left msg -> fail msg+        Right tokens -> runReaderT (parser tokens) c++---------------------------------------------++-- These three should probably go somewhere else.++-- | Parse a 'CoreString' to a 'CoreExpr', using the current context.+parseCoreExprT :: CoreString -> TranslateH a CoreExpr+parseCoreExprT = contextonlyT . parseCore++parse2beforeBiR :: (CoreExpr -> CoreExpr -> BiRewriteH a) -> CoreString -> CoreString -> BiRewriteH a+parse2beforeBiR f s1 s2 = beforeBiR (parseCoreExprT s1 &&& parseCoreExprT s2) (uncurry f)++parse3beforeBiR :: (CoreExpr -> CoreExpr -> CoreExpr -> BiRewriteH a) -> CoreString -> CoreString -> CoreString -> BiRewriteH a+parse3beforeBiR f s1 s2 s3 = beforeBiR ((parseCoreExprT s1 &&& parseCoreExprT s2) &&& parseCoreExprT s3) ((uncurry.uncurry) f)++---------------------------------------------+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp ++{-# LINE 13 "templates/GenericTemplate.hs" #-}++++++#if __GLASGOW_HASKELL__ > 706+#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool)+#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool)+#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool)+#else+#define LT(n,m) (n Happy_GHC_Exts.<# m)+#define GTE(n,m) (n Happy_GHC_Exts.>=# m)+#define EQ(n,m) (n Happy_GHC_Exts.==# m)+#endif+{-# LINE 45 "templates/GenericTemplate.hs" #-}+++data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList++++++{-# LINE 66 "templates/GenericTemplate.hs" #-}++{-# LINE 76 "templates/GenericTemplate.hs" #-}++{-# LINE 85 "templates/GenericTemplate.hs" #-}++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is 0#, it means we've just accepted a partial+-- parse (a %partial parser).  We must ignore the saved token on the top of+-- the stack in this case.+happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =+	happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = +	(happyTcHack j (happyTcHack st)) (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++++happyDoAction i tk st+	= {- nothing -}+++	  case action of+		0#		  -> {- nothing -}+				     happyFail i tk st+		-1# 	  -> {- nothing -}+				     happyAccept i tk st+		n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}++				     (happyReduceArr Happy_Data_Array.! rule) i tk st+				     where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))+		n		  -> {- nothing -}+++				     happyShift new_state i tk st+                                     where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))+   where off    = indexShortOffAddr happyActOffsets st+         off_i  = (off Happy_GHC_Exts.+# i)+	 check  = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#))+                  then EQ(indexShortOffAddr happyCheck off_i, i)+		  else False+         action+          | check     = indexShortOffAddr happyTable off_i+          | otherwise = indexShortOffAddr happyDefActions st+++indexShortOffAddr (HappyA# arr) off =+	Happy_GHC_Exts.narrow16Int# i+  where+        i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)+        high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))+        low  = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))+        off' = off Happy_GHC_Exts.*# 2#++++++data HappyAddr = HappyA# Happy_GHC_Exts.Addr#+++++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++{-# LINE 169 "templates/GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =+     let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+--     trace "shifting the error token" $+     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)++happyShift new_state i tk st sts stk =+     happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_0 nt fn j tk st@((action)) sts stk+     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')+     = let r = fn v1 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')+     = let r = fn v1 v2 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+     = let r = fn v1 v2 v3 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happyReduce k nt fn j tk st sts stk+     = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of+	 sts1@((HappyCons (st1@(action)) (_))) ->+        	let r = fn stk in  -- it doesn't hurt to always seq here...+       		happyDoSeq r (happyGoto nt j tk st1 sts1 r)++happyMonadReduce k nt fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+      case happyDrop k (HappyCons (st) (sts)) of+        sts1@((HappyCons (st1@(action)) (_))) ->+          let drop_stk = happyDropStk k stk in+          happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))++happyMonad2Reduce k nt fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+      case happyDrop k (HappyCons (st) (sts)) of+        sts1@((HappyCons (st1@(action)) (_))) ->+         let drop_stk = happyDropStk k stk++             off = indexShortOffAddr happyGotoOffsets st1+             off_i = (off Happy_GHC_Exts.+# nt)+             new_state = indexShortOffAddr happyTable off_i++++          in+          happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))++happyDrop 0# l = l+happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t++happyDropStk 0# l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction+++happyGoto nt j tk st = +   {- nothing -}+   happyDoAction j tk new_state+   where off = indexShortOffAddr happyGotoOffsets st+         off_i = (off Happy_GHC_Exts.+# nt)+         new_state = indexShortOffAddr happyTable off_i+++++-----------------------------------------------------------------------------+-- Error recovery (0# is the error token)++-- parse error if we are in recovery and we fail again+happyFail 0# tk old_st _ stk@(x `HappyStk` _) =+     let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+--	trace "failing" $ +        happyError_ i tk++{-  We don't need state discarding for our restricted implementation of+    "error".  In fact, it can cause some bogus parses, so I've disabled it+    for now --SDM++-- discard a state+happyFail  0# tk old_st (HappyCons ((action)) (sts)) +						(saved_tok `HappyStk` _ `HappyStk` stk) =+--	trace ("discarding state, depth " ++ show (length stk))  $+	happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+--                       save the old token and carry on.+happyFail  i tk (action) sts stk =+--      trace "entering error recovery" $+	happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll :: a+notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions+++happyTcHack :: Happy_GHC_Exts.Int# -> a -> a+happyTcHack x y = y+{-# INLINE happyTcHack #-}+++-----------------------------------------------------------------------------+-- Seq-ing.  If the --strict flag is given, then Happy emits +--	happySeq = happyDoSeq+-- otherwise it emits+-- 	happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq   a b = a `seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template.  GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.+++{-# NOINLINE happyDoAction #-}+{-# NOINLINE happyTable #-}+{-# NOINLINE happyCheck #-}+{-# NOINLINE happyActOffsets #-}+{-# NOINLINE happyGotoOffsets #-}+{-# NOINLINE happyDefActions #-}++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.

@@ -1,728 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}-module Language.HERMIT.Parser-    ( parseStmtsH-    , unparseExprH-    , numStmtsH-    , ExprH(..)-    ) where--import Data.Char (isSpace)-import Data.List (intercalate)--import Language.HERMIT.Syntax (isScriptInfixIdChar, isScriptIdFirstChar, isScriptIdChar)-import qualified Data.Array as Happy_Data_Array-import qualified GHC.Exts as Happy_GHC_Exts---- parser produced by Happy Version 1.18.6--newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11 = 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 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t5-happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut5 #-}-happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t6-happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut6 #-}-happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t7-happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut7 #-}-happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn8 #-}-happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t8-happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut8 #-}-happyIn9 :: t9 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t9-happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut9 #-}-happyIn10 :: t10 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn10 #-}-happyOut10 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t10-happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut10 #-}-happyIn11 :: t11 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn11 #-}-happyOut11 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t11-happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut11 #-}-happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)-happyInTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> (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"#--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"#--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"#--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"#--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"#--happyReduceArr = Happy_Data_Array.array (1, 25) [-	(1 , happyReduce_1),-	(2 , happyReduce_2),-	(3 , happyReduce_3),-	(4 , happyReduce_4),-	(5 , happyReduce_5),-	(6 , happyReduce_6),-	(7 , happyReduce_7),-	(8 , happyReduce_8),-	(9 , happyReduce_9),-	(10 , happyReduce_10),-	(11 , happyReduce_11),-	(12 , happyReduce_12),-	(13 , happyReduce_13),-	(14 , happyReduce_14),-	(15 , happyReduce_15),-	(16 , happyReduce_16),-	(17 , happyReduce_17),-	(18 , happyReduce_18),-	(19 , happyReduce_19),-	(20 , happyReduce_20),-	(21 , happyReduce_21),-	(22 , happyReduce_22),-	(23 , happyReduce_23),-	(24 , happyReduce_24),-	(25 , happyReduce_25)-	]--happy_n_terms = 15 :: Int-happy_n_nonterms = 8 :: Int--happyReduce_1 = happySpecReduce_2  0# happyReduction_1-happyReduction_1 happy_x_2-	happy_x_1-	 =  case happyOut4 happy_x_2 of { happy_var_2 -> -	happyIn4-		 (CmdName "{" : happy_var_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-		 (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-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_6 = happySpecReduce_1  2# happyReduction_6-happyReduction_6 happy_x_1-	 =  case happyOut7 happy_x_1 of { happy_var_1 -> -	happyIn6-		 ([happy_var_1]-	)}--happyReduce_7 = happySpecReduce_3  2# happyReduction_7-happyReduction_7 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-		 ([happy_var_1, CmdName "}"] ++ happy_var_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-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_9 = happySpecReduce_2  2# happyReduction_9-happyReduction_9 happy_x_2-	happy_x_1-	 =  case happyOut4 happy_x_2 of { happy_var_2 -> -	happyIn6-		 (happy_var_2-	)}--happyReduce_10 = happySpecReduce_3  3# happyReduction_10-happyReduction_10 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut8 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-		 (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-		 (happy_var_1-	)}--happyReduce_12 = happySpecReduce_2  4# happyReduction_12-happyReduction_12 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-		 (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-		 (happy_var_1-	)}--happyReduce_14 = happySpecReduce_2  5# happyReduction_14-happyReduction_14 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_2 of { (Ident happy_var_2) -> -	happyIn9-		 (SrcName happy_var_2-	)}--happyReduce_15 = happySpecReduce_2  5# happyReduction_15-happyReduction_15 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_2 of { (InfixOp happy_var_2) -> -	happyIn9-		 (SrcName happy_var_2-	)}--happyReduce_16 = happySpecReduce_2  5# happyReduction_16-happyReduction_16 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_2 of { (Quote happy_var_2) -> -	happyIn9-		 (SrcName happy_var_2-	)}--happyReduce_17 = happySpecReduce_1  5# happyReduction_17-happyReduction_17 happy_x_1-	 =  case happyOutTok happy_x_1 of { (Quote happy_var_1) -> -	happyIn9-		 (CmdName happy_var_1-	)}--happyReduce_18 = happySpecReduce_1  5# happyReduction_18-happyReduction_18 happy_x_1-	 =  case happyOutTok happy_x_1 of { (CoreString happy_var_1) -> -	happyIn9-		 (CoreH happy_var_1-	)}--happyReduce_19 = happySpecReduce_3  5# happyReduction_19-happyReduction_19 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut10 happy_x_2 of { happy_var_2 -> -	happyIn9-		 (ListH happy_var_2-	)}--happyReduce_20 = happySpecReduce_3  5# happyReduction_20-happyReduction_20 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut7 happy_x_2 of { happy_var_2 -> -	happyIn9-		 (happy_var_2-	)}--happyReduce_21 = happySpecReduce_1  5# happyReduction_21-happyReduction_21 happy_x_1-	 =  case happyOutTok happy_x_1 of { (Ident happy_var_1) -> -	happyIn9-		 (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-		 (happy_var_1-	)}--happyReduce_23 = happySpecReduce_0  6# happyReduction_23-happyReduction_23  =  happyIn10-		 ([]-	)--happyReduce_24 = happySpecReduce_1  7# happyReduction_24-happyReduction_24 happy_x_1-	 =  case happyOut7 happy_x_1 of { happy_var_1 -> -	happyIn11-		 ([happy_var_1]-	)}--happyReduce_25 = happySpecReduce_3  7# happyReduction_25-happyReduction_25 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-		 (happy_var_1 : happy_var_3-	)}}--happyNewToken action sts stk [] =-	happyDoAction 14# notHappyAtAll action sts stk []--happyNewToken action sts stk (tk:tks) =-	let cont i = happyDoAction i tk action sts stk tks in-	case tk of {-	ParenLeft -> cont 1#;-	ParenRight -> cont 2#;-	ScopeStart -> cont 3#;-	ScopeEnd -> cont 4#;-	ListStart -> cont 5#;-	ListDelim -> cont 6#;-	ListEnd -> cont 7#;-	StmtEnd -> cont 8#;-	Tick -> cont 9#;-	CoreString happy_dollar_dollar -> cont 10#;-	Quote happy_dollar_dollar -> cont 11#;-	Ident happy_dollar_dollar -> cont 12#;-	InfixOp happy_dollar_dollar -> cont 13#;-	_ -> happyError' (tk:tks)-	}--happyError_ tk tks = happyError' (tk:tks)--happyThen :: () => Either String a -> (a -> Either String b) -> Either String b-happyThen = (>>=)-happyReturn :: () => a -> Either String a-happyReturn = (return)-happyThen1 m k tks = (>>=) m (\a -> k a tks)-happyReturn1 :: () => a -> b -> Either String a-happyReturn1 = \a tks -> (return) a-happyError' :: () => [(Token)] -> Either String a-happyError' = parseError--parser tks = happySomeParser where-  happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))--happySeq = happyDontSeq---parseError :: [Token] -> Either String a-parseError ts = Left $ "parse error: " ++ show ts---- | A simple expression language AST, for things parsed from 'String' or JSON structures.-data ExprH-    = SrcName String                -- ^ Variable names (refers to source code).-    | CmdName String                -- ^ Commands (to be looked up in 'Language.HERMIT.Dictionary').-    | AppH ExprH ExprH              -- ^ Application.-    | CoreH String                  -- ^ Core Fragment-    | ListH [ExprH]                 -- ^ List of expressions-    deriving (Eq, Show)--data Token-    = ParenLeft-    | ParenRight-    | ScopeStart-    | ScopeEnd-    | ListStart-    | ListDelim-    | ListEnd-    | StmtEnd-    | Tick-    | CoreString String-    | Quote String-    | Ident String-    | InfixOp String-    deriving (Eq, Show)--lexer :: String -> Either String [Token]-lexer []           = Right []-lexer ('\n':cs)    = fmap (StmtEnd:)    $ lexer cs-lexer (';' :cs)    = fmap (StmtEnd:)    $ lexer cs-lexer ('(' :cs)    = fmap (ParenLeft:)  $ lexer cs-lexer (')' :cs)    = fmap (ParenRight:) $ lexer cs-lexer ('{' :cs)    = fmap (ScopeStart:) $ lexer cs-lexer ('}' :cs)    = fmap (ScopeEnd:)   $ lexer cs-lexer ('\'':cs)    = fmap (Tick:)       $ lexer cs-lexer ('\"':cs)    = do (str,cs') <- lexString cs-                        fmap (Quote str:) $ lexer cs'-lexer ('[':'|':cs) = do (str,cs') <- lexCore cs-                        fmap (CoreString str:) $ lexer cs'-lexer ('-':'-':cs) = let (_,s') = span (/= '\n') cs in lexer s'-lexer ('[' :cs)    = fmap (ListStart:)  $ lexer cs-lexer (',' :cs)    = fmap (ListDelim:)  $ lexer cs-lexer (']' :cs)    = fmap (ListEnd:)    $ lexer cs-lexer s@(c:cs)     | isSpace             c = lexer cs-                   | isScriptIdFirstChar c = let (i,s') = span isScriptIdChar s-                                              in fmap (Ident i:) $ lexer s'-                   | isScriptInfixIdChar c = let (op,s') = span isScriptInfixIdChar s-                                              in fmap (InfixOp op:) $ lexer s'-lexer s            = Left $ "lexer: no match on " ++ s--lexString :: String -> Either String (String,String)-lexString ('\"':cs)      = Right ([],cs)-lexString ('\\':'\"':cs) = do (c',r) <- lexString cs-                              return ('"':c',r)-lexString (c:cs)         = do (c',r) <- lexString cs-                              return (c:c',r)-lexString []             = Left "lexer: no matching quote"--lexCore :: String -> Either String (String,String)-lexCore ('|':']':rest) = Right ([],rest)-lexCore (c:cs)         = do (c',r) <- lexCore cs-                            return (c:c',r)-lexCore []             = Left "lexer: no closing |]"--------------------------------------------------- | Use ghci Parser.hs to run this test function.-test = do-    ln <- getLine-    case ln of-        "quit" -> return ()-        _      -> do print $ lexer ln-                     print $ parseStmtsH ln-                     test--parseStmtsH :: String -> Either String [ExprH]-parseStmtsH s = lexer s >>= parser--numStmtsH :: [ExprH] -> Int-numStmtsH = length . filter isCounted-    where isCounted (CmdName "{") = False-          isCounted (CmdName "}") = False-          isCounted _             = True------------------------------------------------unparseExprH :: ExprH -> String-unparseExprH (SrcName nm)-    | nm /= "" && (all isScriptInfixIdChar nm || isScriptIdFirstChar (head nm) && all isScriptIdChar (tail nm)) = "'" ++ nm-    | otherwise = "'\"" ++ concatMap escape nm ++ "\""-        where escape '\"' = "\\\""-              escape c    = [c]-unparseExprH (CmdName nm)-    | nm == "{"             = "{ "-    | nm == "}"             = " }"-    | all isScriptIdChar nm = nm-    | otherwise             = show nm     -- with quotes-unparseExprH (AppH (AppH (CmdName nm) e1) e2)-    | all isScriptInfixIdChar nm-    = unparseAtom e1 ++ " " ++ nm ++ " " ++ unparseAtom e2-unparseExprH (AppH e1 e2) = unparseExprH e1 ++ " " ++ unparseAtom e2-unparseExprH (CoreH s)    = "[|" ++ s ++ "|]"-unparseExprH (ListH es)   = "[" ++ intercalate "," (map unparseExprH es) ++ "]"--unparseAtom :: ExprH -> String-unparseAtom e@(AppH {}) = "(" ++ unparseExprH e ++ ")"-unparseAtom e           = unparseExprH e------------------------------------------------{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}--- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp --{-# LINE 30 "templates/GenericTemplate.hs" #-}---data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList------{-# LINE 51 "templates/GenericTemplate.hs" #-}--{-# LINE 61 "templates/GenericTemplate.hs" #-}--{-# LINE 70 "templates/GenericTemplate.hs" #-}--infixr 9 `HappyStk`-data HappyStk a = HappyStk a (HappyStk a)---------------------------------------------------------------------------------- starting the parse--happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll---------------------------------------------------------------------------------- Accepting the parse---- If the current token is 0#, it means we've just accepted a partial--- parse (a %partial parser).  We must ignore the saved token on the top of--- the stack in this case.-happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =-	happyReturn1 ans-happyAccept j tk st sts (HappyStk ans _) = -	(happyTcHack j (happyTcHack st)) (happyReturn1 ans)---------------------------------------------------------------------------------- Arrays only: do the next action----happyDoAction i tk st-	= {- nothing -}---	  case action of-		0#		  -> {- nothing -}-				     happyFail i tk st-		-1# 	  -> {- nothing -}-				     happyAccept i tk st-		n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}--				     (happyReduceArr Happy_Data_Array.! rule) i tk st-				     where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))-		n		  -> {- nothing -}---				     happyShift new_state i tk st-				     where (new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))-   where (off)    = indexShortOffAddr happyActOffsets st-         (off_i)  = (off Happy_GHC_Exts.+# i)-	 check  = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#))-			then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==#  i)-			else False-         (action)-          | check     = indexShortOffAddr happyTable off_i-          | otherwise = indexShortOffAddr happyDefActions st--{-# LINE 130 "templates/GenericTemplate.hs" #-}---indexShortOffAddr (HappyA# arr) off =-	Happy_GHC_Exts.narrow16Int# i-  where-        i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)-        high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))-        low  = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))-        off' = off Happy_GHC_Exts.*# 2#------data HappyAddr = HappyA# Happy_GHC_Exts.Addr#------------------------------------------------------------------------------------- HappyState data type (not arrays)--{-# LINE 163 "templates/GenericTemplate.hs" #-}---------------------------------------------------------------------------------- Shifting a token--happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =-     let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in---     trace "shifting the error token" $-     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)--happyShift new_state i tk st sts stk =-     happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)---- happyReduce is specialised for the common cases.--happySpecReduce_0 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_0 nt fn j tk st@((action)) sts stk-     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)--happySpecReduce_1 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')-     = let r = fn v1 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_2 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')-     = let r = fn v1 v2 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_3 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')-     = let r = fn v1 v2 v3 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happyReduce k i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyReduce k nt fn j tk st sts stk-     = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of-	 sts1@((HappyCons (st1@(action)) (_))) ->-        	let r = fn stk in  -- it doesn't hurt to always seq here...-       		happyDoSeq r (happyGoto nt j tk st1 sts1 r)--happyMonadReduce k nt fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyMonadReduce k nt fn j tk st sts stk =-        happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))-       where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))-             drop_stk = happyDropStk k stk--happyMonad2Reduce k nt fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyMonad2Reduce k nt fn j tk st sts stk =-       happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))-       where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))-             drop_stk = happyDropStk k stk--             (off) = indexShortOffAddr happyGotoOffsets st1-             (off_i) = (off Happy_GHC_Exts.+# nt)-             (new_state) = indexShortOffAddr happyTable off_i-----happyDrop 0# l = l-happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t--happyDropStk 0# l = l-happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs---------------------------------------------------------------------------------- Moving to a new state after a reduction---happyGoto nt j tk st = -   {- nothing -}-   happyDoAction j tk new_state-   where (off) = indexShortOffAddr happyGotoOffsets st-         (off_i) = (off Happy_GHC_Exts.+# nt)-         (new_state) = indexShortOffAddr happyTable off_i------------------------------------------------------------------------------------- Error recovery (0# is the error token)---- parse error if we are in recovery and we fail again-happyFail  0# tk old_st _ stk =---	trace "failing" $ -    	happyError_ tk--{-  We don't need state discarding for our restricted implementation of-    "error".  In fact, it can cause some bogus parses, so I've disabled it-    for now --SDM---- discard a state-happyFail  0# tk old_st (HappyCons ((action)) (sts)) -						(saved_tok `HappyStk` _ `HappyStk` stk) =---	trace ("discarding state, depth " ++ show (length stk))  $-	happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))--}---- Enter error recovery: generate an error token,---                       save the old token and carry on.-happyFail  i tk (action) sts stk =---      trace "entering error recovery" $-	happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)---- Internal happy errors:--notHappyAtAll :: a-notHappyAtAll = error "Internal Happy error\n"---------------------------------------------------------------------------------- Hack to get the typechecker to accept our action functions---happyTcHack :: Happy_GHC_Exts.Int# -> a -> a-happyTcHack x y = y-{-# INLINE happyTcHack #-}----------------------------------------------------------------------------------- Seq-ing.  If the --strict flag is given, then Happy emits ---	happySeq = happyDoSeq--- otherwise it emits--- 	happySeq = happyDontSeq--happyDoSeq, happyDontSeq :: a -> b -> b-happyDoSeq   a b = a `seq` b-happyDontSeq a b = b---------------------------------------------------------------------------------- Don't inline any functions from the template.  GHC has a nasty habit--- of deciding to inline happyGoto everywhere, which increases the size of--- the generated parser quite a bit.---{-# NOINLINE happyDoAction #-}-{-# NOINLINE happyTable #-}-{-# NOINLINE happyCheck #-}-{-# NOINLINE happyActOffsets #-}-{-# NOINLINE happyGotoOffsets #-}-{-# NOINLINE happyDefActions #-}--{-# NOINLINE happyShift #-}-{-# NOINLINE happySpecReduce_0 #-}-{-# NOINLINE happySpecReduce_1 #-}-{-# NOINLINE happySpecReduce_2 #-}-{-# NOINLINE happySpecReduce_3 #-}-{-# NOINLINE happyReduce #-}-{-# NOINLINE happyMonadReduce #-}-{-# NOINLINE happyGoto #-}-{-# NOINLINE happyFail #-}---- end of Happy Template.

@@ -1,588 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}-{-# LANGUAGE CPP #-}-module Language.HERMIT.ParserCore (parseCore) where--import Control.Monad.Reader-import Data.Char (isSpace, isDigit)--import GhcPlugins--import Language.HERMIT.Context-import Language.HERMIT.External-import Language.HERMIT.Monad-import Language.HERMIT.Primitive.Common-import Language.HERMIT.Syntax (isCoreInfixIdChar, isCoreIdFirstChar, isCoreIdChar)--import Language.KURE.MonadCatch (prefixFailMsg)--import Language.Haskell.TH as TH-import qualified Data.Array as Happy_Data_Array-import qualified GHC.Exts as Happy_GHC_Exts---- parser produced by Happy Version 1.18.6--newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 = 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)-happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn4 #-}-happyOut4 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t4-happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut4 #-}-happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t5-happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut5 #-}-happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t6-happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut6 #-}-happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t7-happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut7 #-}-happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn8 #-}-happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t8-happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut8 #-}-happyIn9 :: t9 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t9-happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut9 #-}-happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)-happyInTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> (Token)-happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOutTok #-}---happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\xf8\xff\xf8\xff\xf8\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\xf0\xff\xf6\xff\x00\x00\x00\x00\x00\x00\x00\x00"#--happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\x0b\x00\x18\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyDefActions :: HappyAddr-happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\xfc\xff\xf8\xff\xf7\xff\xf9\xff\x00\x00\xf4\xff\xf6\xff\xf5\xff\x00\x00\x00\x00\xfa\xff\xfd\xff\xfb\xff"#--happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x0c\x00\x0d\x00\x0d\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\x1c\x00\x22\x00\x1e\x00\x1c\x00\x20\x00\x1e\x00\xff\xff\x20\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x02\x00\x03\x00\x04\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\x08\x00\x0e\x00\x10\x00\x08\x00\x0c\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0b\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x09\x00\xff\xff\x0a\x00\x09\x00\x0b\x00\x0a\x00\x00\x00\x0b\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0e\x00\x04\x00\x05\x00\x06\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\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\x00"#--happyReduceArr = Happy_Data_Array.array (1, 11) [-	(1 , happyReduce_1),-	(2 , happyReduce_2),-	(3 , happyReduce_3),-	(4 , happyReduce_4),-	(5 , happyReduce_5),-	(6 , happyReduce_6),-	(7 , happyReduce_7),-	(8 , happyReduce_8),-	(9 , happyReduce_9),-	(10 , happyReduce_10),-	(11 , happyReduce_11)-	]--happy_n_terms = 35 :: Int-happy_n_nonterms = 6 :: Int--happyReduce_1 = happySpecReduce_1  0# happyReduction_1-happyReduction_1 happy_x_1-	 =  case happyOut5 happy_x_1 of { happy_var_1 -> -	happyIn4-		 (happy_var_1-	)}--happyReduce_2 = happySpecReduce_2  1# happyReduction_2-happyReduction_2 happy_x_2-	happy_x_1-	 =  case happyOut5 happy_x_1 of { happy_var_1 -> -	case happyOut6 happy_x_2 of { happy_var_2 -> -	happyIn5-		 (App happy_var_1 happy_var_2-	)}}--happyReduce_3 = happySpecReduce_1  1# happyReduction_3-happyReduction_3 happy_x_1-	 =  case happyOut6 happy_x_1 of { happy_var_1 -> -	happyIn5-		 (happy_var_1-	)}--happyReduce_4 = happySpecReduce_3  2# happyReduction_4-happyReduction_4 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut4 happy_x_2 of { happy_var_2 -> -	happyIn6-		 (happy_var_2-	)}--happyReduce_5 = happyMonadReduce 2# 2# happyReduction_5-happyReduction_5 (happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (( lookupName "()" Var)-	) (\r -> happyReturn (happyIn6 r))--happyReduce_6 = happySpecReduce_1  2# happyReduction_6-happyReduction_6 happy_x_1-	 =  case happyOut9 happy_x_1 of { happy_var_1 -> -	happyIn6-		 (happy_var_1-	)}--happyReduce_7 = happySpecReduce_1  2# happyReduction_7-happyReduction_7 happy_x_1-	 =  case happyOut7 happy_x_1 of { happy_var_1 -> -	happyIn6-		 (happy_var_1-	)}--happyReduce_8 = happySpecReduce_1  2# happyReduction_8-happyReduction_8 happy_x_1-	 =  case happyOut8 happy_x_1 of { happy_var_1 -> -	happyIn6-		 (happy_var_1-	)}--happyReduce_9 = happyMonadReduce 1# 3# happyReduction_9-happyReduction_9 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (Tinteger happy_var_1) -> -	( mkIntExpr' happy_var_1)}-	) (\r -> happyReturn (happyIn7 r))--happyReduce_10 = happyMonadReduce 1# 4# happyReduction_10-happyReduction_10 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (Tstring happy_var_1) -> -	( lift $ mkStringExpr happy_var_1)}-	) (\r -> happyReturn (happyIn8 r))--happyReduce_11 = happyMonadReduce 1# 5# happyReduction_11-happyReduction_11 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (Tname happy_var_1) -> -	( lookupName happy_var_1 varToCoreExpr)}-	) (\r -> happyReturn (happyIn9 r))--happyNewToken action sts stk [] =-	happyDoAction 34# notHappyAtAll action sts stk []--happyNewToken action sts stk (tk:tks) =-	let cont i = happyDoAction i tk action sts stk tks in-	case tk of {-	Tforall -> cont 1#;-	Trec -> cont 2#;-	Tlet -> cont 3#;-	Tin -> cont 4#;-	Tcase -> cont 5#;-	Tof -> cont 6#;-	Tcast -> cont 7#;-	Tnote -> cont 8#;-	Texternal -> cont 9#;-	Tlocal -> cont 10#;-	Twild -> cont 11#;-	Toparen -> cont 12#;-	Tcparen -> cont 13#;-	Tobrace -> cont 14#;-	Tcbrace -> cont 15#;-	Thash -> cont 16#;-	Teq -> cont 17#;-	Tcolon -> cont 18#;-	Tcoloncolon -> cont 19#;-	Tcoloneqcolon -> cont 20#;-	Tstar -> cont 21#;-	Tarrow -> cont 22#;-	Tlambda -> cont 23#;-	Tat -> cont 24#;-	Tdot -> cont 25#;-	Tquestion -> cont 26#;-	Tsemicolon -> cont 27#;-	Tname happy_dollar_dollar -> cont 28#;-	Tcname happy_dollar_dollar -> cont 29#;-	Tinteger happy_dollar_dollar -> cont 30#;-	Trational happy_dollar_dollar -> cont 31#;-	Tstring happy_dollar_dollar -> cont 32#;-	Tchar happy_dollar_dollar -> cont 33#;-	_ -> happyError' (tk:tks)-	}--happyError_ tk tks = happyError' (tk:tks)--happyThen :: () => CoreParseM a -> (a -> CoreParseM b) -> CoreParseM b-happyThen = (>>=)-happyReturn :: () => a -> CoreParseM a-happyReturn = (return)-happyThen1 m k tks = (>>=) m (\a -> k a tks)-happyReturn1 :: () => a -> b -> CoreParseM a-happyReturn1 = \a tks -> (return) a-happyError' :: () => [(Token)] -> CoreParseM a-happyError' = parseError--parser tks = happySomeParser where-  happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))--happySeq = happyDontSeq---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 -> (Id -> CoreExpr) -> CoreParseM CoreExpr-lookupName nm k = do-    c <- ask-    v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId (TH.mkName nm) c-    return (k v)--type CoreParseM a = ReaderT HermitC HermitM a--parseError :: Monad m => [Token] -> m a-parseError ts = fail $ "core parse error: " ++ show ts--data Token-    = Tforall-    | Trec-    | Tlet-    | Tin-    | Tcase-    | Tof-    | Tcast-    | Tnote-    | Texternal-    | Tlocal-    | Twild ---    | Toparen ---    | Tcparen ---    | Tobrace-    | Tcbrace-    | Thash-    | Teq-    | Tcolon ---    | Tcoloncolon ---    | Tcoloneqcolon-    | Tstar-    | Tarrow-    | Tlambda ---    | Tat-    | Tdot-    | Tquestion-    | Tsemicolon-    | Tname String-    | Tcname String-    | Tinteger Integer-    | Trational Float-    | Tstring String-    | Tchar Char-    deriving (Eq, Show)--lexer :: String -> Either String [Token]-lexer []           = Right []-lexer ('_' :cs)    = fmap (Twild:)       $ lexer cs-lexer ('(' :cs)    = fmap (Toparen:)     $ lexer cs-lexer (')' :cs)    = fmap (Tcparen:)     $ lexer cs-lexer (':':':':cs) = fmap (Tcoloncolon:) $ lexer cs--- lexer (':' :cs)    = fmap (Tcolon:)      $ lexer cs-lexer ('\\':cs)    = fmap (Tlambda:)     $ lexer cs-lexer ('-':'>':cs) = fmap (Tarrow:)      $ lexer cs-lexer ('\"':cs)    = let (str,rest) = span (/='\"') cs-                     in case rest of-                           ('\"':cs') -> fmap (Tstring str:) $ lexer cs'-                           _          -> Left "lexer: no matching quote"-lexer s@(c:cs) | isSpace           c = lexer cs-               | isDigit           c = let (i,s') = span isDigit s-                                         in fmap (Tinteger (read i):) $ lexer s'-               | isCoreIdFirstChar c = let (i,s') = span isCoreIdChar s-                                         in fmap (Tname i:) $ lexer s'-               | isCoreInfixIdChar c = let (op,s') = span isCoreInfixIdChar s-                                         in fmap (Tname op:) $ lexer s'-lexer s            = Left $ "lexer: no match on " ++ s-------------------------------------------------parseCore :: CoreString -> HermitC -> HermitM CoreExpr-parseCore (CoreString s) c =-    case lexer s of-        Left msg -> fail msg-        Right tokens -> runReaderT (parser tokens) c-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}--- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp --{-# LINE 30 "templates/GenericTemplate.hs" #-}---data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList------{-# LINE 51 "templates/GenericTemplate.hs" #-}--{-# LINE 61 "templates/GenericTemplate.hs" #-}--{-# LINE 70 "templates/GenericTemplate.hs" #-}--infixr 9 `HappyStk`-data HappyStk a = HappyStk a (HappyStk a)---------------------------------------------------------------------------------- starting the parse--happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll---------------------------------------------------------------------------------- Accepting the parse---- If the current token is 0#, it means we've just accepted a partial--- parse (a %partial parser).  We must ignore the saved token on the top of--- the stack in this case.-happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =-	happyReturn1 ans-happyAccept j tk st sts (HappyStk ans _) = -	(happyTcHack j (happyTcHack st)) (happyReturn1 ans)---------------------------------------------------------------------------------- Arrays only: do the next action----happyDoAction i tk st-	= {- nothing -}---	  case action of-		0#		  -> {- nothing -}-				     happyFail i tk st-		-1# 	  -> {- nothing -}-				     happyAccept i tk st-		n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}--				     (happyReduceArr Happy_Data_Array.! rule) i tk st-				     where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))-		n		  -> {- nothing -}---				     happyShift new_state i tk st-				     where (new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))-   where (off)    = indexShortOffAddr happyActOffsets st-         (off_i)  = (off Happy_GHC_Exts.+# i)-	 check  = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#))-			then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==#  i)-			else False-         (action)-          | check     = indexShortOffAddr happyTable off_i-          | otherwise = indexShortOffAddr happyDefActions st--{-# LINE 130 "templates/GenericTemplate.hs" #-}---indexShortOffAddr (HappyA# arr) off =-	Happy_GHC_Exts.narrow16Int# i-  where-        i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)-        high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))-        low  = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))-        off' = off Happy_GHC_Exts.*# 2#------data HappyAddr = HappyA# Happy_GHC_Exts.Addr#------------------------------------------------------------------------------------- HappyState data type (not arrays)--{-# LINE 163 "templates/GenericTemplate.hs" #-}---------------------------------------------------------------------------------- Shifting a token--happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =-     let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in---     trace "shifting the error token" $-     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)--happyShift new_state i tk st sts stk =-     happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)---- happyReduce is specialised for the common cases.--happySpecReduce_0 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_0 nt fn j tk st@((action)) sts stk-     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)--happySpecReduce_1 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')-     = let r = fn v1 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_2 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')-     = let r = fn v1 v2 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_3 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')-     = let r = fn v1 v2 v3 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happyReduce k i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyReduce k nt fn j tk st sts stk-     = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of-	 sts1@((HappyCons (st1@(action)) (_))) ->-        	let r = fn stk in  -- it doesn't hurt to always seq here...-       		happyDoSeq r (happyGoto nt j tk st1 sts1 r)--happyMonadReduce k nt fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyMonadReduce k nt fn j tk st sts stk =-        happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))-       where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))-             drop_stk = happyDropStk k stk--happyMonad2Reduce k nt fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyMonad2Reduce k nt fn j tk st sts stk =-       happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))-       where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))-             drop_stk = happyDropStk k stk--             (off) = indexShortOffAddr happyGotoOffsets st1-             (off_i) = (off Happy_GHC_Exts.+# nt)-             (new_state) = indexShortOffAddr happyTable off_i-----happyDrop 0# l = l-happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t--happyDropStk 0# l = l-happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs---------------------------------------------------------------------------------- Moving to a new state after a reduction---happyGoto nt j tk st = -   {- nothing -}-   happyDoAction j tk new_state-   where (off) = indexShortOffAddr happyGotoOffsets st-         (off_i) = (off Happy_GHC_Exts.+# nt)-         (new_state) = indexShortOffAddr happyTable off_i------------------------------------------------------------------------------------- Error recovery (0# is the error token)---- parse error if we are in recovery and we fail again-happyFail  0# tk old_st _ stk =---	trace "failing" $ -    	happyError_ tk--{-  We don't need state discarding for our restricted implementation of-    "error".  In fact, it can cause some bogus parses, so I've disabled it-    for now --SDM---- discard a state-happyFail  0# tk old_st (HappyCons ((action)) (sts)) -						(saved_tok `HappyStk` _ `HappyStk` stk) =---	trace ("discarding state, depth " ++ show (length stk))  $-	happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))--}---- Enter error recovery: generate an error token,---                       save the old token and carry on.-happyFail  i tk (action) sts stk =---      trace "entering error recovery" $-	happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)---- Internal happy errors:--notHappyAtAll :: a-notHappyAtAll = error "Internal Happy error\n"---------------------------------------------------------------------------------- Hack to get the typechecker to accept our action functions---happyTcHack :: Happy_GHC_Exts.Int# -> a -> a-happyTcHack x y = y-{-# INLINE happyTcHack #-}----------------------------------------------------------------------------------- Seq-ing.  If the --strict flag is given, then Happy emits ---	happySeq = happyDoSeq--- otherwise it emits--- 	happySeq = happyDontSeq--happyDoSeq, happyDontSeq :: a -> b -> b-happyDoSeq   a b = a `seq` b-happyDontSeq a b = b---------------------------------------------------------------------------------- Don't inline any functions from the template.  GHC has a nasty habit--- of deciding to inline happyGoto everywhere, which increases the size of--- the generated parser quite a bit.---{-# NOINLINE happyDoAction #-}-{-# NOINLINE happyTable #-}-{-# NOINLINE happyCheck #-}-{-# NOINLINE happyActOffsets #-}-{-# NOINLINE happyGotoOffsets #-}-{-# NOINLINE happyDefActions #-}--{-# NOINLINE happyShift #-}-{-# NOINLINE happySpecReduce_0 #-}-{-# NOINLINE happySpecReduce_1 #-}-{-# NOINLINE happySpecReduce_2 #-}-{-# NOINLINE happySpecReduce_3 #-}-{-# NOINLINE happyReduce #-}-{-# NOINLINE happyMonadReduce #-}-{-# NOINLINE happyGoto #-}-{-# NOINLINE happyFail #-}---- end of Happy Template.

@@ -1,4 +1,4 @@--- Simple driver for hermit+{-# LANGUAGE ViewPatterns #-}  module Main where @@ -8,7 +8,7 @@ import System.Process import System.Exit -import Data.List (isPrefixOf)+import Data.List (isPrefixOf, partition) import System.Directory (doesFileExist)  usage :: IO ()@@ -29,6 +29,11 @@         ,""         ,"HERMIT_ARGS"         ,"  -opt=MODULE : where MODULE is the module containing a HERMIT optimization plugin"+        ,"  -vN         : controls verbosity, where N is one of the following values:"+        ,"                  0 : suppress HERMIT messages, pass -v0 to GHC"+        ,"                  1 : suppress HERMIT messages"+        ,"                  2 : pass -v0 to GHC"+        ,"                  3 : (default) display all HERMIT and GHC messages"         ,""         ,"MOD_ARGS"         ,"  SCRIPTNAME : name of script file to run for this module"@@ -70,7 +75,7 @@                     [ "-fplugin-opt=" ++ pluginName ++ ":" ++ m_nm ++ ":" ++ opt                     | (m_nm, m_opts) <- module_args                     , opt <- "" : m_opts-                    ] ++ ghc_args+                    ] ++ extraGHCArgs hermit_args' ++ ghc_args         putStrLn $ "% ghc " ++ unwords cmds         (_,_,_,r) <- createProcess $ proc "ghc" cmds         ex <- waitForProcess r@@ -81,3 +86,13 @@     where go plug flags [] = (plug, flags)           go plug flags (f:fs) | "-opt=" `isPrefixOf` f = go (drop 5 f) flags fs                                | otherwise              = go plug (f:flags) fs++-- | See if the given HERMIT args imply any additional GHC args+extraGHCArgs :: [String] -> [String]+extraGHCArgs (matchArgs (`elem` ["-v0","-v2"]) -> Just (_,r)) = "-v0" : extraGHCArgs r+extraGHCArgs _ = []++matchArgs :: (String -> Bool) -> [String] -> Maybe ([String], [String])+matchArgs p args = case partition p args of+                    ([],_) -> Nothing+                    (as,r) -> Just (as,r)

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

@@ -1,6 +1,15 @@-ww-split-param 1 [|wrap|] [|unwrap|]-any-call (unfold 'wrap)-one-td (unfold 'unwrap)-innermost (case-float-let >+> bash >+> push 'repH >+> unfold-rule "repH ++" >+> unfold-rule "repH (:)" >+> unfold-rule "repH []" >+> unfold-rule "[] ++" >+> unfold-rule "[] ++" >+> unfold-rule "(:) ++")-any-td (unfold-rule "rep-abs-fusion")-any-call (unfold 'absH)+load-as-rewrite "WWA" "WW-Ass-A.hss"+define-rewrite "WWC" "ww-result-AssA-to-AssC WWA"+load-as-rewrite "StrictRepH" "StrictRepH.hss"++run-script "do-the-ww-split" -- ugly hack because we lack paramaterisable scripts++bash+{ rhs-of 'work+  lam-body+  eta-expand 'acc+  lam-body+  bash-extended-with [ push 'repH StrictRepH, forward ww-result-fusion, apply-rules ["repH ++","repH (:)","repH []"] ]+  try (bash-extended-with [push-unsafe 'work])+}+one-td (unfold 'absH)

@@ -5,16 +5,9 @@  data Tree a = Node (Tree a) (Tree a) | Leaf a -unwrap :: (Tree a -> [a]) -> (Tree a -> H a)-unwrap f = repH . f--wrap :: (Tree a -> H a) -> (Tree a -> [a])-wrap g = absH . g- flatten :: Tree a -> [a] flatten (Leaf a)   = [a] flatten (Node l r) = flatten l ++ flatten r  main :: IO () main = print (flatten (Node (Leaf 'h') (Leaf 'i')))-

@@ -1,3 +1,2 @@-flatten-module-consider 'flatten-{ load "ConcatVanishes.hss" }+define-script "do-the-ww-split" "binding-of 'flatten ; ww-result-split-static-arg 1 [0] [| absH |] [| repH |] WWC"+load-and-run "ConcatVanishes.hss"

@@ -14,15 +14,11 @@ absH :: H a -> [a] absH f = f [] +-- Should be in the "List" module+{-# RULES "++ []"  forall xs .  xs ++ [] = xs #-}+{-# RULES "++ strict"           (++) undefined = undefined #-}+ -- The "Algebra" for repH {-# RULES "repH ++" forall xs ys .     repH (xs ++ ys) = repH xs . repH ys #-} {-# RULES "repH []" 	               repH [] = id                        #-} {-# RULES "repH (:)" forall x xs .     repH (x:xs) = ((:) x) . repH xs     #-}---- Should be in the "List" module-{-# RULES "(:) ++" forall x xs ys .    (x:xs) ++ ys = x : (xs ++ ys)       #-}-{-# RULES "[] ++"  forall xs .         [] ++ xs     = xs                   #-}-{-# RULES "++ []"  forall xs .         xs ++ []     = xs                   #-}---- has preconditon-{-# RULES "rep-abs-fusion" forall h .  repH (absH h) = h                   #-}

@@ -6,12 +6,6 @@  data Tree a = Node (Tree a) (Tree a) | Leaf a -unwrap   :: ([a] -> [a]) -> ([a] -> H a)-unwrap f = repH . f--wrap   :: ([a] -> H a) -> ([a] -> [a])-wrap g = absH . g- qsort        :: Ord a => [a] -> [a] qsort []     = [] qsort (a:as) = qsort bs ++ [a] ++ qsort cs

@@ -1,5 +1,2 @@-flatten-module-consider 'qsort-{ load "ConcatVanishes.hss" }-one-td let-subst-bash+define-script "do-the-ww-split" "binding-of 'qsort ; ww-result-split-static-arg 2 [0] [| absH |] [| repH |] WWC"+load-and-run "ConcatVanishes.hss"

@@ -3,12 +3,6 @@ import HList import Data.Function (fix) -unwrap :: ([a] -> [a]) -> ([a] -> H a)-unwrap f = repH . f--wrap :: ([a] -> H a) -> ([a] -> [a])-wrap g = absH . g- rev :: [a] -> [a] rev []     = [] rev (y:ys) = rev ys ++ [y]

@@ -1,4 +1,2 @@-flatten-module-consider 'rev-{ load "ConcatVanishes.hss" }-+define-script "do-the-ww-split" "binding-of 'rev ; ww-result-split-static-arg 1 [0] [| absH |] [| repH |] WWC"+load-and-run "ConcatVanishes.hss"

@@ -1,6 +1,7 @@ module Main where -import Data.Function(fix)+import Prelude hiding (abs)+import Data.Function (fix)  data Expr = Val Int | Add Expr Expr | Throw | Catch Expr Expr @@ -18,13 +19,13 @@                                     Nothing -> Nothing                                     Just n  -> Just (m + n) -unwrap :: (Expr -> Mint) -> Expr -> (Int -> Mint) -> Mint -> Mint-unwrap g e s f = case g e of-                   Nothing -> f-                   Just n  -> s n+abs :: ((Int -> Mint) -> Mint -> Mint) -> Mint+abs h = h Just Nothing -wrap :: (Expr -> (Int -> Mint) -> Mint -> Mint) -> Expr -> Mint-wrap h e = h e Just Nothing+rep :: Mint -> (Int -> Mint) -> Mint -> Mint+rep mn s f = case mn of+               Nothing -> f+               Just n  -> s n  main :: IO () main = print (eval $ Val 5)

@@ -1,19 +1,23 @@+load-as-rewrite "WWA" "WW-Ass-A.hss" flatten-module-consider 'eval-ww-split [| wrap |] [| unwrap |]-{rhs-of 'work-   eta-expand 'e ; lam-body-   eta-expand 's ; lam-body-   eta-expand 'f ; lam-body-   unfold 'unwrap-   one-td (unfold 'f)-   bash-   {-     consider case ; [case-alt 1, alt-rhs] ; abstract 'm-     consider case ; [case-alt 1, alt-rhs] ; abstract 'n-   }-   any-bu (fold 'unwrap)-   any-bu (foreward (ww-fusion [| wrap |] [|unwrap|] [|work|]))+binding-of 'eval+ww-result-split [| abs |] [| rep |] (ww-result-AssA-to-AssC WWA)+{ def-rhs+  let-subst+  { let-body+    alpha-lam 'e+    lam-body+    unfold 'abs+  }+  { rhs-of 'work+    alpha-lam 'e ; lam-body+    unfold 'rep+    bash+    [lam-body, lam-body]+    { consider case ; [ case-alt 1, alt-rhs ] ; abstract 'm+      consider case ; [ case-alt 1, alt-rhs ] ; abstract 'n+    }+    any-bu (fold 'rep)+    any-td (forward ww-result-fusion)+  } }-simplify-any-call (unfold 'wrap)

@@ -6,6 +6,8 @@ import GHC.Exts import Data.Function(fix) +------------------------------------+ fac :: Int -> Int fac 0 = 1 fac n = n * fac (n -1)@@ -26,3 +28,5 @@  (-) :: Int -> Int -> Int (I# x) - (I# y) = I# (x -# y)++------------------------------------

@@ -1,22 +1,7 @@+load-as-rewrite "WWA" "WW-Ass-A.hss" flatten-module-consider 'fac-ww-split [| wrap |] [| unwrap |]-{rhs-of 'work-  eta-expand 'x-  one-td (unfold 'unwrap)-  one-td (unfold 'f)-  one-td (unfold 'wrap)-  simplify-  {-    consider alt ; alt-rhs ; case-float-arg-    consider alt ; alt-rhs ; case-float-arg-  }-  one-td (unfold '-)-  one-td (unfold '*)-  simplify-  innermost case-float-case-}-simplify-innermost (case-float <+ case-reduce)-simplify-{ [def-rhs, let-body] ; eta-expand 'n ; any-call (unfold 'wrap) }+binding-of 'fac+ww-split [| wrap |] [| unwrap |] (ww-AssA-to-AssC WWA)+bash-extended-with [ case-elim-inline-scrutinee , inline [ 'unwrap, 'wrap, '*, '- ] ]++{ [def-rhs, let-body] ; alpha-lam 'n } -- cosmetic

@@ -1,7 +1,7 @@ flatten-module consider 'fib {-  ww-split [| wrap Nat |] [| unwrap Nat |]+  ww-split-unsafe [| wrap Nat |] [| unwrap Nat |]   {rhs-of 'work     unfold 'unwrap     any-call (unfold 'f)

@@ -33,7 +33,7 @@ --                         in (y,x+y)  wrap :: (Nat -> (Nat, Nat)) -> Nat -> Nat-wrap h = fst . h+wrap h n = fst (h n)  unwrap :: (Nat -> Nat) -> Nat -> (Nat, Nat) unwrap h n = (h n, h (S n))

@@ -1,10 +1,12 @@+load-as-rewrite "WWA" "WW-Ass-A.hss" flatten-module-consider 'fib +binding-of 'fib+ { -ww-split [| wrap |] [| unwrap |]-consider 'work ; remember origwork+ww-split [| wrap |] [| unwrap |] (ww-AssA-to-AssC WWA)+binding-of 'work ; remember origwork  -- work = unwrap (f (wrap work)) @@ -34,7 +36,7 @@ -- work 0     = (0, 1) -- work (n+1) = (f (wrap work) (n+1), wrap (unwrap (f (wrap work))) (n+1) + wrap (unwrap (f (wrap work))) n) -any-bu (foreward (ww-assumption-A [| wrap |] [| unwrap |]))+any-bu (forward (ww-assumption-A [| wrap |] [| unwrap |] WWA ))  -- work 0     = (0, 1) -- work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+1) + f (wrap work) n)@@ -61,7 +63,6 @@  } -innermost dead-let-elimination any-call (unfold 'wrap) simplify 

@@ -5,16 +5,9 @@  data Tree a = Node (Tree a) (Tree a) | Leaf a -unwrap :: (Tree a -> [a]) -> (Tree a -> H a)-unwrap f = repH . f--wrap :: (Tree a -> H a) -> (Tree a -> [a])-wrap g = absH . g- flatten :: Tree a -> [a] flatten (Leaf a)   = [a] flatten (Node l r) = flatten l ++ flatten r  main :: IO () main = print (flatten (Node (Leaf 'h') (Leaf 'i')))-

@@ -1,20 +1,14 @@-flatten-module-consider 'flatten-ww-split-param 1 [|wrap|] [|unwrap|]+load-as-rewrite "WWA" "WW-Ass-A.hss"+define-rewrite "WWC" "ww-result-AssA-to-AssC WWA"+load-as-rewrite "StrictRepH" "StrictRepH.hss"+binding-of 'flatten+ww-result-split-static-arg 1 [0] [| absH |] [| repH |] WWC bash-{consider lam ; alpha-lam 't}-any-call (unfold 'wrap)-any-call (unfold 'unwrap)-simplify-{rhs-of 'work-   lam-body-   eta-expand 'acc-   innermost case-float-   any-call (unfold-rule "repH ++")-   one-td (foreward (ww-fusion [| absH t |] [| repH t |] [| work l |]))-   one-td (foreward (ww-fusion [| absH t |] [| repH t |] [| work r |]))-   any-call (unfold-rule "repH (:)")-   any-call (unfold-rule "repH []")-   simplify+{ rhs-of 'work+  alpha-lam 'tree+  lam-body+  eta-expand 'acc+  lam-body+  bash-extended-with [push 'repH StrictRepH, forward ww-result-fusion, apply-rules ["repH ++", "repH (:)", "repH []"] ] }-any-call (unfold 'absH)+one-td (unfold 'absH)

@@ -14,6 +14,10 @@ absH :: H a -> [a] absH f = f [] +-- Should be in a "List" module+{-# RULES "++ []"  forall xs .  xs ++ [] = xs #-}+{-# RULES "++ strict"           (++) undefined = undefined #-}+ -- The "Algebra" for repH {-# RULES "repH ++" forall xs ys   . repH (xs ++ ys) = repH xs . repH ys #-} {-# RULES "repH []" 	             repH [] = id  	       	         #-}

@@ -2,9 +2,9 @@  -- do the w/w split consider 'hanoi-{ ww-split [| wrap |] [| unwrap |] }+{ ww-split-unsafe [| wrap |] [| unwrap |] } -{ consider 'work+{ binding-of 'work   remember origwork    any-call (unfold 'unwrap)@@ -18,7 +18,7 @@   { [case-alt 1, alt-rhs] ; case-split-inline 'a     { case-alt 0 ; any-call (unfold 'f) ; simplify       any-call (unfold origwork)-      any-call (foreward (ww-assumption-A [| wrap |] [| unwrap |]))+      any-call (forward (ww-assumption-A-unsafe [| wrap |] [| unwrap |]))       any-call (unfold 'f)       simplify       any-call (unfold-rule "[] ++")@@ -27,13 +27,13 @@     { case-alt 1 ; any-call (unfold 'f) ; simplify        any-call (unfold origwork)-      any-call (foreward (ww-assumption-A [| wrap |] [| unwrap |]))+      any-call (forward (ww-assumption-A-unsafe [| wrap |] [| unwrap |]))       any-call (unfold 'f)       innermost let-subst ; simplify        -- recursion decrements by two, so must do this again       any-call (unfold origwork)-      any-call (foreward (ww-assumption-A [| wrap |] [| unwrap |]))+      any-call (forward (ww-assumption-A-unsafe [| wrap |] [| unwrap |]))        -- time to let intro       -- need a "occurance 'work" like consider@@ -57,4 +57,4 @@     }   } }-innermost dead-let-elimination+innermost let-elim

@@ -3,17 +3,21 @@ import Data.Function(fix) import Prelude hiding (last) +-------------------------------------------------+ unwrap         :: ([a] -> a) -> a -> [a] -> a unwrap f a as  = f (a:as)  wrap           :: (a -> [a] -> a) -> [a] -> a-wrap f []      = error "wrap _ []"+wrap f []      = undefined wrap f (a:as)  = f a as  last           :: [a] -> a-last []        = error "last []"+last []        = undefined last [a]       = a last (_:a:as)  = last (a:as)  main :: IO () main = print (last "hello")++-------------------------------------------------

@@ -1,17 +1,7 @@+load-as-rewrite "WWB" "WW-Ass-B.hss"+define-rewrite "WWC" "ww-AssB-to-AssC WWB" flatten-module-consider 'last-ww-split-param 1 [|wrap|] [|unwrap|]-{rhs-of 'work-   eta-expand 'b-   lam-body-   eta-expand 'bs-   lam-body-   unfold 'unwrap-   unfold 'f-   bash-   consider app-   unfold 'wrap-   bash-}-any-call (unfold 'wrap)-bash+binding-of 'last+ww-split-static-arg 1 [0] [| wrap |] [| unwrap |] WWC+bash-extended-with [ inline [ 'f, 'wrap, 'unwrap ] ]+unshadow

@@ -7,9 +7,9 @@   { case-expr ; abstract 'xs ; app-fun ; let-intro 'sumlength } } innermost let-float-consider 'sumlength+binding-group-of 'sumlength nonrec-to-rec           -- since we intend sumlength to be a recursive function-rec-def 0+binding-of 'sumlength remember sumlen { [def-rhs, lam-body]   case-split-inline 'xs

@@ -14,12 +14,11 @@ absH :: H a -> [a] absH f = f [] +-- Should be in a "List" module+{-# RULES "++ []"  forall xs .  xs ++ [] = xs #-}+{-# RULES "++ strict"           (++) undefined = undefined #-}+ -- The "Algebra" for repH {-# RULES "repH ++" forall xs ys   . repH (xs ++ ys) = repH xs . repH ys #-} {-# RULES "repH []" 	             repH [] = id  	       	         #-} {-# RULES "repH (:)" forall x xs   . repH (x:xs) = ((:) x) . repH xs     #-}-----

@@ -6,12 +6,6 @@  data Tree a = Node (Tree a) (Tree a) | Leaf a -unwrap :: ([a] -> [a]) -> ([a] -> H a)-unwrap f = repH . f--wrap :: ([a] -> H a) -> ([a] -> [a])-wrap g = absH . g- qsort :: Ord a => [a] -> [a] qsort []     = [] qsort (a:as) = qsort bs ++ [a] ++ qsort cs@@ -20,4 +14,3 @@  main :: IO () main = print (qsort [8,3,5,7,2,9,4,6,3,2])-

@@ -1,34 +1,15 @@-flatten-module-consider 'qsort-ww-split-param 1 [|wrap|] [|unwrap|]+load-as-rewrite "WWA" "WW-Ass-A.hss"+define-rewrite "WWC" "ww-result-AssA-to-AssC WWA"+load-as-rewrite "StrictRepH" "StrictRepH.hss"+binding-of 'qsort+ww-result-split-static-arg 2 [0] [| absH |] [| repH |] WWC bash-{consider lam ; alpha-lam 't}-any-call (unfold 'wrap)-any-call (unfold 'unwrap)-simplify-{rhs-of 'work+{ rhs-of 'work   alpha-lam 'xs   lam-body-  any-td case-float-arg   eta-expand 'acc-  bash-  one-td inline-case-binder -- this used to be part of bash-  bash   lam-body-  {  case-alt 1-     any-td (push 'repH)-     consider alt-     alpha-alt ['bs,'cs]-     any-td (unfold-rule "repH ++")-     any-bu case-float-arg-     simplify-     one-td (foreward (ww-fusion [| absH t |] [| repH t |] [| work bs |]))-     one-td (foreward (ww-fusion [| absH t |] [| repH t |] [| work cs |]))-     any-call (unfold-rule "repH (:)")-     simplify-  }-  any-call (unfold-rule "repH []")-  any-call (unfold 'id)+  bash-extended-with [push 'repH StrictRepH, forward ww-result-fusion, apply-rules ["repH ++", "repH (:)", "repH []"] ]+  bash-extended-with [push-unsafe 'work] } one-td (unfold 'absH)-

@@ -14,12 +14,11 @@ absH :: H a -> [a] absH f = f [] +-- Should be in a "List" module+{-# RULES "++ []"  forall xs .  xs ++ [] = xs #-}+{-# RULES "++ strict"           (++) undefined = undefined #-}+ -- The "Algebra" for repH {-# RULES "repH ++" forall xs ys   . repH (xs ++ ys) = repH xs . repH ys #-} {-# RULES "repH []" 	             repH [] = id  	       	         #-} {-# RULES "repH (:)" forall x xs   . repH (x:xs) = ((:) x) . repH xs     #-}-----

@@ -1,13 +1,9 @@ module Main where  import HList-import Data.Function (fix)--unwrap :: ([a] -> [a]) -> ([a] -> H a)-unwrap f = repH . f+-- import Seq -wrap :: ([a] -> H a) -> ([a] -> [a])-wrap g = absH . g+import Data.Function (fix)  rev :: [a] -> [a] rev []     = []

@@ -1,21 +1,14 @@-flatten-module-consider 'rev-ww-split-param 1 [|wrap|] [|unwrap|]+load-as-rewrite "WWA" "WW-Ass-A.hss"+define-rewrite "WWC" "ww-result-AssA-to-AssC WWA"+load-as-rewrite "StrictRepH" "StrictRepH.hss"+binding-of 'rev+ww-result-split-static-arg 1 [0] [| absH |] [| repH |] WWC bash-{consider lam ; alpha-lam 't}-any-call (unfold 'wrap)-any-call (unfold 'unwrap)-simplify-{rhs-of 'work-   alpha-lam 'ys-   lam-body-   eta-expand 'acc-   innermost case-float-   one-td (unfold-rule "repH ++")-   one-td (foreward (ww-fusion [| absH t |] [| repH t |] [| work xs |]))-   any-call (unfold-rule "repH (:)")-   simplify-   any-call (unfold-rule "repH []")-   any-call (unfold 'id)+{ rhs-of 'work+  alpha-lam 'ys+  lam-body+  eta-expand 'acc+  lam-body+  bash-extended-with [push 'repH StrictRepH, forward ww-result-fusion, apply-rules ["repH ++", "repH (:)", "repH []"] ] }-any-call (unfold 'absH)+one-td (unfold 'absH)

@@ -1,5 +1,5 @@ Name:                hermit-Version:             0.2.0.0+Version:             0.3.0.0 Synopsis:            Haskell Equational Reasoning Model-to-Implementation Tunnel Description:   HERMIT uses Haskell to express semi-formal models,@@ -8,22 +8,16 @@   these models and implementations. The key transformation   in the bridging DSL is the worker/wrapper transformation.   .-  This is a pre-alpha `please give feedback' release.+  This is an alpha `please give feedback' release.   Shortcomings/gotchas include:   .     * Command line completion is ad hoc at the moment.   .     * log command prints linearly, even if command history is a tree.   .-    * The fold rewrite can only fold syntactically alpha-equivalent (up to-      parameters of the function you are folding) expressions.-  .     * RULES have issues with forall types.   .-    * Different core comes out depending on whether you ascribe explicit-      type signatures.-  .-    * A number of rewrites don't enforce preconditions. ex: cast elimination+    * A number of rewrites don't enforce preconditions. eg: cast elimination       always works, even if the cast is necessary   .   Examples can be found in the examples sub-directory.@@ -36,12 +30,12 @@   .   @    $ hermit Reverse.hs Reverse.hss resume-   [starting HERMIT v0.2.0.0 on Reverse.hs]+   [starting HERMIT v0.3.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.2.0.0 ... linking ... done.+   Loading package hermit-0.3.0.0 ... linking ... done.    [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )    Linking Reverse ...    $ ./Reverse@@ -52,12 +46,12 @@   .   @    $ hermit Reverse.hs-   [starting HERMIT v0.2.0.0 on Reverse.hs]+   [starting HERMIT v0.3.0.0 on Reverse.hs]    % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:Main:    [1 of 2] Compiling HList            ( HList.hs, HList.o )    Loading package ghc-prim ... linking ... done.    ...-   Loading package hermit-0.2.0.0 ... linking ... done.+   Loading package hermit-0.3.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@@ -104,12 +98,11 @@ License-file:        LICENSE Author:              Andrew Farmer, Andy Gill, Ed Komp, Neil Sculthorpe Maintainer:          Andy Gill <andygill@ku.edu>-Stability:           pre-alpha+Stability:           alpha build-type:          Simple Cabal-Version:       >= 1.14  extra-source-files:-    examples/WWSplitTactic.hss     examples/concatVanishes/ConcatVanishes.hss     examples/concatVanishes/Flatten.hs     examples/concatVanishes/Flatten.hss@@ -153,63 +146,82 @@                  data-default >= 0.5.0,                  ghc >= 7.6,                  haskeline >= 0.7.0.3,-                 kure >= 2.7.1,+                 kure >= 2.14.0,                  marked-pretty >= 0.1,                  mtl >= 2.1.2,                  operational >= 0.2.2.1,+                 process >= 1.1.0.2,                  stm >= 2.4,                  template-haskell >= 2.8.0.0,+                 temporary >= 1.1.2.4,+                 terminfo >= 0.3.2.5,                  transformers    default-language: Haskell2010    Exposed-modules:        HERMIT-       HERMIT.Driver -       Language.HERMIT.Context-       Language.HERMIT.Core-       Language.HERMIT.Dictionary-       Language.HERMIT.External-       Language.HERMIT.GHC-       Language.HERMIT.Interp-       Language.HERMIT.Kernel-       Language.HERMIT.Kernel.Scoped-       Language.HERMIT.Kure-       Language.HERMIT.Kure.SumTypes-       Language.HERMIT.Monad-       Language.HERMIT.Optimize-       Language.HERMIT.Parser-       Language.HERMIT.ParserCore+       HERMIT.Context+       HERMIT.Core+       HERMIT.Dictionary+       HERMIT.Driver -       Language.HERMIT.Plugin+       HERMIT.Dictionary.AlphaConversion+       HERMIT.Dictionary.Common+       HERMIT.Dictionary.Composite+       HERMIT.Dictionary.Debug+       HERMIT.Dictionary.FixPoint+       HERMIT.Dictionary.Fold+       HERMIT.Dictionary.Function+       HERMIT.Dictionary.GHC+       HERMIT.Dictionary.Inline+       HERMIT.Dictionary.Kure+       HERMIT.Dictionary.Local+       HERMIT.Dictionary.Local.Bind+       HERMIT.Dictionary.Local.Case+       HERMIT.Dictionary.Local.Cast+       HERMIT.Dictionary.Local.Let+       HERMIT.Dictionary.Navigation+       HERMIT.Dictionary.Navigation.Crumbs+       HERMIT.Dictionary.New+       HERMIT.Dictionary.Query+       HERMIT.Dictionary.Reasoning+       HERMIT.Dictionary.Undefined+       HERMIT.Dictionary.Unfold+       HERMIT.Dictionary.Unsafe+       HERMIT.Dictionary.WorkerWrapper.Common+       HERMIT.Dictionary.WorkerWrapper.Fix+       HERMIT.Dictionary.WorkerWrapper.FixResult -       Language.HERMIT.Primitive.AlphaConversion-       Language.HERMIT.Primitive.Common-       Language.HERMIT.Primitive.Debug-       Language.HERMIT.Primitive.FixPoint-       Language.HERMIT.Primitive.Fold-       Language.HERMIT.Primitive.GHC-       Language.HERMIT.Primitive.Inline-       Language.HERMIT.Primitive.Kure-       Language.HERMIT.Primitive.Local-       Language.HERMIT.Primitive.Local.Let-       Language.HERMIT.Primitive.Local.Case-       Language.HERMIT.Primitive.Local.Cast-       Language.HERMIT.Primitive.Navigation-       Language.HERMIT.Primitive.Navigation.Crumbs-       Language.HERMIT.Primitive.New-       Language.HERMIT.Primitive.Unfold+       HERMIT.External+       HERMIT.GHC+       HERMIT.Interp+       HERMIT.Kernel+       HERMIT.Kernel.Scoped+       HERMIT.Kure+       HERMIT.Kure.SumTypes+       HERMIT.Monad+       HERMIT.Optimize+       HERMIT.Parser+       HERMIT.ParserCore+       HERMIT.Plugin -       Language.HERMIT.PrettyPrinter.AST-       Language.HERMIT.PrettyPrinter.Clean-       Language.HERMIT.PrettyPrinter.Common-       Language.HERMIT.PrettyPrinter.GHC+       HERMIT.PrettyPrinter.AST+       HERMIT.PrettyPrinter.Clean+       HERMIT.PrettyPrinter.Common+       HERMIT.PrettyPrinter.GHC -       Language.HERMIT.Shell.Command+       HERMIT.Shell.Command+       HERMIT.Shell.Dictionary+       HERMIT.Shell.Externals+       HERMIT.Shell.ScriptToRewrite+       HERMIT.Shell.Renderer+       HERMIT.Shell.Types    Other-modules:-       Language.HERMIT.Syntax+       HERMIT.Syntax+       HERMIT.Utilities         Paths_hermit 

@@ -1,8 +1,7 @@ module HERMIT (plugin) where -import GhcPlugins--import Language.HERMIT.Optimize+import HERMIT.GHC+import HERMIT.Optimize  plugin :: Plugin plugin = optimize $ \ options -> phase 0 $ interactive [] options

@@ -0,0 +1,287 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, InstanceSigs #-}++module HERMIT.Context+       ( -- * HERMIT Contexts+         -- ** Path Synonyms+         AbsolutePathH+       , LocalPathH+         -- ** The Standard Context+       , HermitC+       , initHermitC+         -- ** Bindings+       , HermitBindingSite(..)+       , BindingDepth+       , HermitBinding+       , hermitBindingSiteExpr+       , hermitBindingExpr+         -- ** Adding bindings to contexts+       , AddBindings(..)+       , addBindingGroup+       , addDefBinding+       , addDefBindingsExcept+       , addLambdaBinding+       , addAltBindings+       , addCaseWildBinding+       , addForallBinding+         -- ** Reading bindings from the context+       , BoundVars(..)+       , boundIn+       , findBoundVars+       , ReadBindings(..)+       , lookupHermitBinding+       , lookupHermitBindingDepth+       , lookupHermitBindingSite+         -- ** Accessing the Global Reader Environment from the context+       , HasGlobalRdrEnv(..)+         -- ** Accessing GHC rewrite rules from the context+       , HasCoreRules(..)+) where++import Prelude hiding (lookup)++import Control.Monad (liftM)++import Data.Monoid (mempty)+import Data.Map hiding (map, foldr, filter)++import qualified Language.Haskell.TH as TH++import Language.KURE+import Language.KURE.ExtendableContext++import HERMIT.Core+import HERMIT.GHC hiding (empty)++------------------------------------------------------------------------++-- | The depth of a binding.  Used, for example, to detect shadowing when inlining.+type BindingDepth = Int+++-- | HERMIT\'s representation of variable bindings.+--   Bound expressions cannot be inlined without checking for shadowing issues (using the depth information).+data HermitBindingSite = LAM                               -- ^ A lambda-bound variable.+                       | NONREC CoreExpr                   -- ^ A non-recursive binding of an expression.+                       | REC CoreExpr                      -- ^ A (potentially) recursive binding of an expression.+                       | SELFREC                           -- ^ A (potentially) recursive binding of a superexpression of the current node.+                       | CASEALT                           -- ^ A variable bound in a case alternative.+                       | CASEWILD CoreExpr (AltCon,[Var])  -- ^ A case wildcard binder.  We store both the scrutinised expression, and the case alternative 'AltCon' and variables.+                       | FORALL                            -- ^ A universally quantified type variable.++type HermitBinding = (BindingDepth, HermitBindingSite)++-- | Retrieve the expression in a 'HermitBindingSite', if there is one.+hermitBindingSiteExpr :: HermitBindingSite -> KureM CoreExpr+hermitBindingSiteExpr b = case b of+                            LAM          -> fail "variable is lambda-bound, not bound to an expression."+                            NONREC e     -> return e+                            REC e        -> return e+                            SELFREC      -> fail "identifier recursively refers to the expression under consideration."+                            CASEALT      -> fail "variable is bound in a case alternative, not bound to an expression."+                            CASEWILD e _ -> return e+                            FORALL       -> fail "variable is a universally quantified type variable."++-- | Retrieve the expression in a 'HermitBinding', if there is one.+hermitBindingExpr :: HermitBinding -> KureM CoreExpr+hermitBindingExpr = hermitBindingSiteExpr . snd++------------------------------------------------------------------------++-- | A class of contexts that can have HERMIT bindings added to them.+class AddBindings c where+  -- | Add a complete set of parrallel bindings to the context.+  --   (Parallel bindings occur in recursive let bindings and case alternatives.)+  --   This can also be used for solitary bindings (e.g. lambdas).+  --   Bindings are added in parallel sets to help with shadowing issues.+  addHermitBindings :: [(Var,HermitBindingSite)] -> c -> c++-- | The bindings are just discarded.+instance AddBindings (SnocPath crumb) where+  addHermitBindings :: [(Var,HermitBindingSite)] -> SnocPath crumb -> SnocPath crumb+  addHermitBindings _ = id++-- | The bindings are added to the base context and the extra context.+instance (AddBindings c, AddBindings e) => AddBindings (ExtendContext c e) where+  addHermitBindings :: [(Var,HermitBindingSite)] -> ExtendContext c e -> ExtendContext c e+  addHermitBindings bnds c = c+                              { baseContext  = addHermitBindings bnds (baseContext c)+                              , extraContext = addHermitBindings bnds (extraContext c)+                              }++-------------------------------------------++-- | Add a single binding to the context.+addHermitBinding  :: AddBindings c => Var -> HermitBindingSite -> c -> c+addHermitBinding v bd = addHermitBindings [(v,bd)]++-- | Add all bindings in a binding group to a context.+addBindingGroup :: AddBindings c => CoreBind -> c -> c+addBindingGroup (NonRec v e) = addHermitBinding  v (NONREC e)+addBindingGroup (Rec ies)    = addHermitBindings [ (i, REC e) | (i,e) <- ies ]++-- | Add the binding for a recursive definition currently under examination.+--   Note that because the expression may later be modified, the context only records the identifier, not the expression.+addDefBinding :: AddBindings c => Id -> c -> c+addDefBinding i = addHermitBinding i SELFREC++-- | Add a list of recursive bindings to the context, except the nth binding in the list.+--   The idea is to exclude the definition being descended into.+addDefBindingsExcept :: AddBindings c => Int -> [(Id,CoreExpr)] -> c -> c+addDefBindingsExcept n ies = addHermitBindings [ (i, REC e) | (m,(i,e)) <- zip [0..] ies, m /= n ]++-- | Add a wildcard binding for a specific case alternative.+addCaseWildBinding :: AddBindings c => (Id,CoreExpr,CoreAlt) -> c -> c+addCaseWildBinding (i,e,(con,vs,_)) = addHermitBinding i (CASEWILD e (con,vs))++-- | Add a lambda bound variable to a context.+--   All that is known is the variable, which may shadow something.+--   If so, we don't worry about that here, it is instead checked during inlining.+addLambdaBinding :: AddBindings c => Var -> c -> c+addLambdaBinding v = addHermitBinding v LAM++-- | Add the variables bound by a 'DataCon' in a case.+--   They are all bound at the same depth.+addAltBindings :: AddBindings c => [Var] -> c -> c+addAltBindings vs = addHermitBindings [ (v, CASEALT) | v <- vs ]++-- | Add a universally quantified type variable to a context.+addForallBinding :: AddBindings c => TyVar -> c -> c+addForallBinding v = addHermitBinding v FORALL++------------------------------------------------------------------------++-- | A class of contexts that stores the set of variables in scope that have been bound during the traversal.+class BoundVars c where+  boundVars :: c -> VarSet++instance BoundVars VarSet where+  boundVars :: VarSet -> VarSet+  boundVars = id++-- | List all variables bound in the context that match the given name.+findBoundVars :: BoundVars c => TH.Name -> c -> VarSet+findBoundVars nm = filterVarSet (cmpTHName2Var nm) . boundVars+++-- | A class of contexts from which HERMIT bindings can be retrieved.+class BoundVars c => ReadBindings c where+  hermitDepth    :: c -> BindingDepth+  hermitBindings :: c -> Map Var HermitBinding++-- | Determine if a variable is bound in a context.+boundIn :: ReadBindings c => Var -> c -> Bool+boundIn i c = i `member` hermitBindings c++-- | Lookup the binding for a variable in a context.+lookupHermitBinding :: (ReadBindings c, Monad m) => Var -> c -> m HermitBinding+lookupHermitBinding v = maybe (fail "binding not found in HERMIT context.") return . lookup v . hermitBindings++-- | Lookup the depth of a variable's binding in a context.+lookupHermitBindingDepth :: (ReadBindings c, Monad m) => Var -> c -> m BindingDepth+lookupHermitBindingDepth v = liftM fst . lookupHermitBinding v++-- | Lookup the binding for a variable in a context, ensuring it was bound at the specified depth.+lookupHermitBindingSite :: (ReadBindings c, Monad m) => Var -> BindingDepth -> c -> m HermitBindingSite+lookupHermitBindingSite v depth c = do (d,bnd) <- lookupHermitBinding v c+                                       guardMsg (d == depth) "lookupHermitBinding succeeded, but depth does not match.  The variable has probably been shadowed."+                                       return bnd++------------------------------------------------------------------------++-- | A class of contexts that store GHC rewrite rules.+class HasCoreRules c where+  hermitCoreRules :: c -> [CoreRule]++instance HasCoreRules [CoreRule] where+  hermitCoreRules :: [CoreRule] -> [CoreRule]+  hermitCoreRules = id++------------------------------------------------------------------------++-- | A class of contexts that store the Global Reader Environment.+class HasGlobalRdrEnv c where+  hermitGlobalRdrEnv :: c -> GlobalRdrEnv++instance HasGlobalRdrEnv GlobalRdrEnv where+  hermitGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv+  hermitGlobalRdrEnv = id++------------------------------------------------------------------------++type AbsolutePathH = AbsolutePath Crumb+type LocalPathH = LocalPath Crumb++-- | The HERMIT context, containing all bindings in scope and the current location in the AST.+--   The bindings here are lazy by choice, so that we can avoid the cost+--   of building the context if we never use it.+data HermitC = HermitC+        { hermitC_bindings       :: Map Var HermitBinding   -- ^ All (important) bindings in scope.+        , hermitC_depth          :: BindingDepth            -- ^ The depth of the most recent bindings.+        , hermitC_path           :: AbsolutePathH           -- ^ The 'AbsolutePath' to the current node from the root.+        , hermitC_globalRdrEnv   :: GlobalRdrEnv            -- ^ The top-level lexical environment.+        , hermitC_coreRules      :: [CoreRule]              -- ^ GHC rewrite RULES.+        }++------------------------------------------------------------------------++-- | Create the initial HERMIT 'HermitC' by providing a 'ModGuts'.+initHermitC :: ModGuts -> HermitC+initHermitC modGuts = HermitC+                        { hermitC_bindings      = empty+                        , hermitC_depth         = 0+                        , hermitC_path          = mempty+                        , hermitC_globalRdrEnv  = mg_rdr_env modGuts+                        , hermitC_coreRules     = mg_rules modGuts ++ other_rules+                        }++    where other_rules :: [CoreRule]+          other_rules = mg_binds modGuts >>= bindToVarExprs >>= (idCoreRules . fst)++------------------------------------------------------------------------++-- | Retrieve the 'AbsolutePath' to the current node, from the HERMIT context.+instance ReadPath HermitC Crumb where+  absPath :: HermitC -> AbsolutePath Crumb+  absPath = hermitC_path++-- | Extend the 'AbsolutePath' stored in the HERMIT context.+instance ExtendPath HermitC Crumb where+  (@@) :: HermitC -> Crumb -> HermitC+  c @@ n = c { hermitC_path = hermitC_path c @@ n }++------------------------------------------------------------------------++instance AddBindings HermitC where+  addHermitBindings :: [(Var,HermitBindingSite)] -> HermitC -> HermitC+  addHermitBindings vbs c = let nextDepth = succ (hermitC_depth c)+                                vhbs      = [ (v, (nextDepth,b)) | (v,b) <- vbs ]+                             in c { hermitC_bindings = fromList vhbs `union` hermitC_bindings c+                                  , hermitC_depth    = nextDepth+                                  }++------------------------------------------------------------------------++instance BoundVars HermitC where+  boundVars :: HermitC -> VarSet+  boundVars =  mkVarSet . keys . hermitC_bindings++instance ReadBindings HermitC where+  hermitDepth :: HermitC -> BindingDepth+  hermitDepth = hermitC_depth++  hermitBindings :: HermitC -> Map Var HermitBinding+  hermitBindings = hermitC_bindings++------------------------------------------------------------------------++instance HasCoreRules HermitC where+  hermitCoreRules :: HermitC -> [CoreRule]+  hermitCoreRules = hermitC_coreRules++------------------------------------------------------------------------++instance HasGlobalRdrEnv HermitC where+  hermitGlobalRdrEnv :: HermitC -> GlobalRdrEnv+  hermitGlobalRdrEnv = hermitC_globalRdrEnv++------------------------------------------------------------------------

@@ -0,0 +1,549 @@+{-# LANGUAGE CPP, LambdaCase #-}+module HERMIT.Core+          (+          -- * Generic Data Type+            CoreProg(..)+          , CoreDef(..)+          , CoreTickish+          -- * Equality+          -- | We define both syntactic equality and alpha equality.++          -- ** Syntactic Equality+          , progSyntaxEq+          , bindSyntaxEq+          , defSyntaxEq+          , exprSyntaxEq+          , altSyntaxEq+          , typeSyntaxEq+          , coercionSyntaxEq++          -- ** Alpha Equality+          , progAlphaEq+          , bindAlphaEq+          , defAlphaEq+          , exprAlphaEq+          , altAlphaEq+          , typeAlphaEq+          , coercionAlphaEq++          -- * Conversions to/from 'Core'+          , defsToRecBind+          , defToIdExpr+          , progToBinds+          , bindsToProg+          , bindToVarExprs++          -- * Collecting variable bindings+          , progIds+          , bindVars+          , defId+          , altVars++          -- * Collecting free variables+          -- $freeVarsNote+          , freeVarsProg+          , freeVarsBind+          , freeVarsDef+          , freeVarsExpr+          , freeVarsAlt+          , freeVarsType+          , freeVarsCoercion+          , localFreeVarsExpr+          , freeIdsExpr+          , localFreeIdsExpr++          -- * Utilities+          , isCoArg+          , exprKindOrType+          , exprTypeM+          , endoFunType+          , splitFunTypeM+          , funArgResTypes+          , funsWithInverseTypes+          , appCount+          , mapAlts++          -- * Crumbs+          , Crumb(..)+          , showCrumbs+--          , crumbToDeprecatedInt+          , deprecatedLeftSibling+          , deprecatedRightSibling+) where++import Control.Monad ((>=>))++import Language.KURE.Combinators.Monad+import Language.KURE.MonadCatch++import HERMIT.GHC++import Data.List (intercalate)++-----------------------------------------------------------------------++-- | Unlike everything else, there is no synonym for 'Tickish' 'Id' provided by GHC, so we define one.+type CoreTickish = Tickish Id++---------------------------------------------------------------------++-- | A program is a telescope of nested binding groups.+--   That is, each binding scopes over the remainder of the program.+--   In GHC Core, programs are encoded as ['CoreBind'].+--   This data type is isomorphic.+data CoreProg = ProgNil                     -- ^ An empty program.+              | ProgCons CoreBind CoreProg  -- ^ A binding group and the program it scopes over.++infixr 5 `ProgCons`++-- | Get the list of bindings in a program.+progToBinds :: CoreProg -> [CoreBind]+progToBinds ProgNil         = []+progToBinds (ProgCons bd p) = bd : progToBinds p+-- recursive, don't inline++-- | Build a program from a list of bindings.+--   Note that bindings earlier in the list are considered scope over bindings later in the list.+bindsToProg :: [CoreBind] -> CoreProg+bindsToProg = foldr ProgCons ProgNil+{-# INLINE bindsToProg #-}++-- | Extract the list of identifier/expression pairs from a binding group.+bindToVarExprs :: CoreBind -> [(Var,CoreExpr)]+bindToVarExprs (NonRec v e) = [(v,e)]+bindToVarExprs (Rec bds)    = bds+{-# INLINE bindToVarExprs #-}++-- | A (potentially recursive) definition is an identifier and an expression.+--   In GHC Core, recursive definitions are encoded as ('Id', 'CoreExpr') pairs.+--   This data type is isomorphic.+data CoreDef = Def Id CoreExpr++-- | Convert a definition to an identifier/expression pair.+defToIdExpr :: CoreDef -> (Id,CoreExpr)+defToIdExpr (Def v e) = (v,e)+{-# INLINE defToIdExpr #-}++-- | Convert a list of recursive definitions into an (isomorphic) recursive binding group.+defsToRecBind :: [CoreDef] -> CoreBind+defsToRecBind = Rec . map defToIdExpr+{-# INLINE defsToRecBind #-}++-----------------------------------------------------------------------++-- Syntactic Equality++-- | Syntactic Equality of programs.+progSyntaxEq :: CoreProg -> CoreProg -> Bool+progSyntaxEq ProgNil ProgNil                       = True+progSyntaxEq (ProgCons bnd1 p1) (ProgCons bnd2 p2) = bindSyntaxEq bnd1 bnd2 && progSyntaxEq p1 p2+progSyntaxEq _ _                                   = False++-- | Syntactic Equality of binding groups.+bindSyntaxEq :: CoreBind -> CoreBind -> Bool+bindSyntaxEq (NonRec v1 e1) (NonRec v2 e2) = v1 == v2 && exprSyntaxEq e1 e2+bindSyntaxEq (Rec ies1)     (Rec ies2)     = all2 (\ (i1,e1) (i2,e2) -> i1 == i2 && exprSyntaxEq e1 e2) ies1 ies2+bindSyntaxEq _              _              = False++-- | Syntactic Equality of recursive definitions.+defSyntaxEq :: CoreDef -> CoreDef -> Bool+defSyntaxEq (Def i1 e1) (Def i2 e2) = i1 == i2 && exprSyntaxEq e1 e2++-- | Syntactic Equality of expressions.+exprSyntaxEq :: CoreExpr -> CoreExpr -> Bool+exprSyntaxEq (Var i1)             (Var i2)             = i1 == i2+exprSyntaxEq (Lit l1)             (Lit l2)             = l1 == l2+exprSyntaxEq (App f1 e1)          (App f2 e2)          = exprSyntaxEq f1 f2 && exprSyntaxEq e1 e2+exprSyntaxEq (Lam v1 e1)          (Lam v2 e2)          = v1 == v2 && exprSyntaxEq e1 e2+exprSyntaxEq (Let b1 e1)          (Let b2 e2)          = bindSyntaxEq b1 b2 && exprSyntaxEq e1 e2+exprSyntaxEq (Case s1 w1 ty1 as1) (Case s2 w2 ty2 as2) = w1 == w2 && exprSyntaxEq s1 s2 && all2 altSyntaxEq as1 as2 && typeSyntaxEq ty1 ty2+exprSyntaxEq (Cast e1 co1)        (Cast e2 co2)        = exprSyntaxEq e1 e2 && coercionSyntaxEq co1 co2+exprSyntaxEq (Tick t1 e1)         (Tick t2 e2)         = t1 == t2 && exprSyntaxEq e1 e2+exprSyntaxEq (Type ty1)           (Type ty2)           = typeSyntaxEq ty1 ty2+exprSyntaxEq (Coercion co1)       (Coercion co2)       = coercionSyntaxEq co1 co2+exprSyntaxEq _                    _                    = False++-- | Syntactic Equality of case alternatives.+altSyntaxEq :: CoreAlt -> CoreAlt -> Bool+altSyntaxEq (c1,vs1,e1) (c2,vs2,e2) = c1 == c2 && vs1 == vs2 && exprSyntaxEq e1 e2++-- | Syntactic Equality of 'Type's.+typeSyntaxEq :: Type -> Type -> Bool+typeSyntaxEq (TyVarTy v1)      (TyVarTy v2)         = v1 == v2+typeSyntaxEq (LitTy l1)        (LitTy l2)           = l1 == l2+typeSyntaxEq (AppTy t1 ty1)    (AppTy t2 ty2)       = typeSyntaxEq t1 t2 && typeSyntaxEq ty1 ty2+typeSyntaxEq (FunTy t1 ty1)    (FunTy t2 ty2)       = typeSyntaxEq t1 t2 && typeSyntaxEq ty1 ty2+typeSyntaxEq (ForAllTy v1 ty1) (ForAllTy v2 ty2)    = v1 == v2 && typeSyntaxEq ty1 ty2+typeSyntaxEq (TyConApp c1 ts1) (TyConApp c2 ts2)    = c1 == c2 && all2 typeSyntaxEq ts1 ts2+typeSyntaxEq _                 _                    = False++-- | 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 (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+coercionSyntaxEq (InstCo co1 ty1)        (InstCo co2 ty2)        = coercionSyntaxEq co1 co2 && typeSyntaxEq ty1 ty2+coercionSyntaxEq _                       _                       = False++-----------------------------------------------------------------------++-- Alpha Equality++-- | Alpha equality of programs.+progAlphaEq :: CoreProg -> CoreProg -> Bool+progAlphaEq ProgNil ProgNil                       = True+progAlphaEq (ProgCons bnd1 p1) (ProgCons bnd2 p2) = bindVars bnd1 == bindVars bnd2 && bindAlphaEq bnd1 bnd2 && progAlphaEq p1 p2+progAlphaEq _ _                                   = False++-- The ideas for this function are directly extracted from+-- the GHC function, CoreUtils.eqExprX+-- | Alpha equality of binding groups.+bindAlphaEq :: CoreBind -> CoreBind -> Bool+bindAlphaEq (NonRec _ e1) (NonRec _ e2) = exprAlphaEq e1 e2+bindAlphaEq (Rec ps1)     (Rec ps2)     = all2 (eqExprX id_unf env) rs1 rs2+  where+    id_unf _   = noUnfolding      -- Don't expand+    (bs1,rs1)  = unzip ps1+    (bs2,rs2)  = unzip ps2+    inScopeSet = mkInScopeSet $ exprsFreeVars (rs1 ++ rs2)+    env        = rnBndrs2 (mkRnEnv2 inScopeSet) bs1 bs2+bindAlphaEq _ _ = False++-- | Alpha equality of recursive definitions.+defAlphaEq :: CoreDef -> CoreDef -> Bool+defAlphaEq d1 d2 = defsToRecBind [d1] `bindAlphaEq` defsToRecBind [d2]++-- | Alpha equality of expressions.+exprAlphaEq :: CoreExpr -> CoreExpr -> Bool+exprAlphaEq e1 e2 = eqExpr (mkInScopeSet $ exprsFreeVars [e1, e2]) e1 e2++-- The ideas for this function are directly extracted from+-- the GHC function, CoreUtils.eqExprX+-- | Alpha equality of case alternatives.+altAlphaEq :: CoreAlt -> CoreAlt -> Bool+altAlphaEq (c1,vs1,e1) (c2,vs2,e2) = c1 == c2 && eqExprX id_unf env e1 e2+  where+    id_unf _    = noUnfolding      -- Don't expand+    inScopeSet  = mkInScopeSet $ exprsFreeVars [e1,e2]+    env         = rnBndrs2 (mkRnEnv2 inScopeSet) vs1 vs2++-- | Alpha equality of types.+typeAlphaEq :: Type -> Type -> Bool+typeAlphaEq = eqType++-- | Alpha equality of coercions.+coercionAlphaEq :: Coercion -> Coercion -> Bool+coercionAlphaEq = coreEqCoercion++-----------------------------------------------------------------------++-- | List all identifiers bound at the top-level in a program.+progIds :: CoreProg -> [Id]+progIds = \case+             ProgNil        -> []+             ProgCons bnd p -> bindVars bnd ++ progIds p++-- | List all variables bound in a binding group.+bindVars :: CoreBind -> [Var]+bindVars = \case+              NonRec v _ -> [v]+              Rec ds     -> map fst ds++-- | Return the identifier bound by a recursive definition.+defId :: CoreDef -> Id+defId (Def i _) = i++-- | List the variables bound by a case alternative.+altVars :: CoreAlt -> [Var]+altVars (_,vs,_) = vs++-----------------------------------------------------------------------++-- $freeVarsNote+-- The GHC Function exprFreeVars defined in "CoreFVs" only returns *locally-defined* free variables.+-- In HERMIT, this is typically not what we want, so we define our own functions.+-- We reuse some of the functionality in "CoreFVs", but alas much of it is not exposed, so we have to reimplement some of it.++-- | Find all free variables in an expression.+freeVarsExpr :: CoreExpr -> VarSet+freeVarsExpr = exprSomeFreeVars (const True)++-- | Find all free identifiers in an expression.+freeIdsExpr :: CoreExpr -> IdSet+freeIdsExpr = exprSomeFreeVars isId++-- | Find all locally defined free variables in an expression.+localFreeVarsExpr :: CoreExpr -> VarSet+localFreeVarsExpr = exprSomeFreeVars isLocalVar++-- | Find all locally defined free identifiers in an expression.+localFreeIdsExpr :: CoreExpr -> VarSet+localFreeIdsExpr = exprSomeFreeVars isLocalId+++-- | Find all free identifiers in a binding group, which excludes any variables bound in the group.+freeVarsBind :: CoreBind -> VarSet+freeVarsBind (NonRec v e) = freeVarsExpr e `unionVarSet` varTypeTyVars v+freeVarsBind (Rec defs)   = let (bs,es) = unzip defs+                             in delVarSetList (unionVarSets $ map freeVarsExpr es) bs+                                `unionVarSet`  unionVarSets (map varTypeTyVars bs)++-- | Find all free variables is a recursive definition, which excludes the bound variable.+freeVarsDef :: CoreDef -> VarSet+freeVarsDef (Def v e) = delVarSet (freeVarsExpr e) v `unionVarSet` varTypeTyVars v++-- | Find all free variables in a case alternative, which excludes any variables bound in the alternative.+freeVarsAlt :: CoreAlt -> VarSet+freeVarsAlt (_,bs,e) = delVarSetList (freeVarsExpr e `unionVarSet` unionVarSets (map varTypeTyVars bs)) bs++-- | Find all free variables in a program.+freeVarsProg :: CoreProg -> VarSet+freeVarsProg = \case+                  ProgNil        -> emptyVarSet+                  ProgCons bnd p -> freeVarsBind bnd `unionVarSet` delVarSetList (freeVarsProg p) (bindVars bnd)++-- | Find all free variables in a type.+freeVarsType :: Type -> TyVarSet+freeVarsType = tyVarsOfType++-- | Find all free variables in a coercion.+freeVarsCoercion :: Coercion -> VarSet+freeVarsCoercion = tyCoVarsOfCo++-----------------------------------------------------------------------++-- | GHC's 'exprType' function throws an error if applied to a 'Type'.+--   This function returns the 'Kind' of a 'Type', but otherwise behaves as 'exprType'.+exprKindOrType :: CoreExpr -> KindOrType+exprKindOrType (Type t)  = typeKind t+exprKindOrType e         = exprType e++-- | GHC's 'exprType' function throws an error if applied to a 'Type'.+--   This function catches that case as failure in an arbitrary monad.+exprTypeM :: Monad m => CoreExpr -> m Type+exprTypeM (Type _) = fail "exprTypeM failed: expression is a type, so does not have a type."+exprTypeM e        = return (exprType e)++-- | Returns @True@ iff the expression is a 'Coercion' expression at its top level.+isCoArg :: CoreExpr -> Bool+isCoArg (Coercion {}) = True+isCoArg _             = False++-----------------------------------------------------------------------++-- | Count the number of nested applications.+appCount :: CoreExpr -> Int+appCount (App e1 _) = appCount e1 + 1+appCount _          = 0+-- don't inline, recursive++-----------------------------------------------------------------------++-- | Map a function over the RHS of each case alternative.+mapAlts :: (CoreExpr -> CoreExpr) -> [CoreAlt] -> [CoreAlt]+mapAlts f alts = [ (ac, vs, f e) | (ac, vs, e) <- alts ]++-----------------------------------------------------------------------++-- | Return the domain/codomain type of an endofunction expression.+endoFunType :: Monad m => CoreExpr -> m Type+endoFunType f = do (ty1,ty2) <- funArgResTypes f+                   guardMsg (eqType ty1 ty2) ("argument and result types differ.")+                   return ty1++-- | Return the domain and codomain types of a function type, if it is a function type.+splitFunTypeM :: Monad m => Type -> m (Type,Type)+splitFunTypeM = maybe (fail "not a function type.") return . splitFunTy_maybe++-- | Return the domain and codomain types of a function expression.+funArgResTypes :: Monad m => CoreExpr -> m (Type,Type)+funArgResTypes = exprTypeM >=> splitFunTypeM++-- | Check two expressions have types @a -> b@ and @b -> a@, returning @(a,b)@.+funsWithInverseTypes :: MonadCatch m => CoreExpr -> CoreExpr -> m (Type,Type)+funsWithInverseTypes f g = do (fdom,fcod) <- funArgResTypes f+                              (gdom,gcod) <- funArgResTypes g+                              setFailMsg "functions do not have inverse types." $+                                do guardM (eqType fdom gcod)+                                   guardM (eqType gdom fcod)+                                   return (fdom,fcod)++-----------------------------------------------------------------------++-- | Crumbs record a path through the tree, using descriptive constructor names.+data Crumb =+           -- ModGuts+             ModGuts_Prog+           -- Prog+           | ProgCons_Head | ProgCons_Tail+           -- Bind+           | NonRec_RHS | NonRec_Var+           | Rec_Def Int+           -- Def+           | Def_Id | Def_RHS+           -- Expr+           | Var_Id+           | Lit_Lit+           | App_Fun | App_Arg+           | Lam_Var | Lam_Body+           | Let_Bind | Let_Body+           | Case_Scrutinee | Case_Binder | Case_Type | Case_Alt Int+           | Cast_Expr | Cast_Co+           | Tick_Tick | Tick_Expr+           | Type_Type+           | Co_Co+           -- Alt+           | Alt_Con | Alt_Var Int | Alt_RHS+           -- Type+           | TyVarTy_TyVar+           | LitTy_TyLit+           | AppTy_Fun | AppTy_Arg+           | TyConApp_TyCon | TyConApp_Arg Int+           | FunTy_Dom | FunTy_CoDom+           | ForAllTy_Var | ForAllTy_Body+           -- Coercion+           | Refl_Type+           | TyConAppCo_TyCon | TyConAppCo_Arg Int+           | AppCo_Fun | AppCo_Arg+           | ForAllCo_TyVar | ForAllCo_Body+           | CoVarCo_CoVar+           | AxiomInstCo_Axiom | AxiomInstCo_Index | AxiomInstCo_Arg Int+           | UnsafeCo_Left | UnsafeCo_Right+           | SymCo_Co+           | TransCo_Left | TransCo_Right+           | NthCo_Int | NthCo_Co+           | InstCo_Co | InstCo_Type+           | LRCo_LR | LRCo_Co+           deriving (Eq,Read,Show)+           -- TODO: Write a prettier Show instance+++showCrumbs :: [Crumb] -> String+showCrumbs crs = "[" ++ intercalate ", " (map showCrumb crs) ++ "]"++-- Note, these should match the external names in HERMIT.Primitive.Navigation.Crumbs+showCrumb :: Crumb -> String+showCrumb = \case+               ModGuts_Prog   -> "prog"+               ProgCons_Head  -> "prog-head"+               ProgCons_Tail  -> "prog-tail"+               NonRec_RHS     -> "nonrec-rhs"+               Rec_Def n      -> "rec-def " ++ show n+               Def_RHS        -> "def-rhs"+               App_Fun        -> "app-fun"+               App_Arg        -> "app-arg"+               Lam_Body       -> "lam-body"+               Let_Bind       -> "let-bind"+               Let_Body       -> "let-body"+               Case_Scrutinee -> "case-expr"+               Case_Type      -> "case-type"+               Case_Alt n     -> "case-alt " ++ show n+               Cast_Expr      -> "cast-expr"+               Cast_Co        -> "cast-co"+               Tick_Expr      -> "tick-expr"+               Alt_RHS        -> "alt-rhs"+               Type_Type      -> "type"+               Co_Co          -> "coercion"+               -- Types+               AppTy_Fun      -> "appTy-fun"+               AppTy_Arg      -> "appTy-arg"+               TyConApp_Arg n -> "tyCon-arg " ++ show n+               FunTy_Dom      -> "fun-dom"+               FunTy_CoDom    -> "fun-cod"+               ForAllTy_Body  -> "forall-body"+               -- Coercions+               Refl_Type         -> "refl-type"+               TyConAppCo_Arg n  -> "coCon-arg " ++ show n+               AppCo_Fun         -> "appCo-fun"+               AppCo_Arg         -> "appCo-arg"+               ForAllCo_Body     -> "coForall-body"+               AxiomInstCo_Arg n -> "axiom-inst " ++ show n+               UnsafeCo_Left     -> "unsafe-left"+               UnsafeCo_Right    -> "unsafe-right"+               SymCo_Co          -> "sym-co"+               TransCo_Left      -> "trans-left"+               TransCo_Right     -> "trans-right"+               NthCo_Co          -> "nth-co"+               InstCo_Co         -> "inst-co"+               InstCo_Type       -> "inst-type"+               LRCo_Co           -> "lr-co"++               _              -> "Warning: Crumb should not be in use!  This is probably Neil's fault."++{-+-- | Earlier versions of HERMIT used 'Int' as the crumb type.+--   This function maps a 'Crumb' back to that corresponding 'Int', for backwards compatibility purposes.+crumbToDeprecatedInt :: Crumb -> Maybe Int+crumbToDeprecatedInt = \case+                          ModGuts_Prog   -> Just 0+                          ProgCons_Bind  -> Just 0+                          ProgCons_Tail  -> Just 1+                          NonRec_RHS     -> Just 0+                          NonRec_Var     -> Nothing+                          Rec_Def n      -> Just n+                          Def_Id         -> Nothing+                          Def_RHS        -> Just 0+                          App_Fun        -> Just 0+                          App_Arg        -> Just 1+                          Lam_Var        -> Nothing+                          Lam_Body       -> Just 0+                          Let_Bind       -> Just 0+                          Let_Body       -> Just 1+                          Case_Scrutinee -> Just 0+                          Case_Binder    -> Nothing+                          Case_Type      -> Nothing+                          Case_Alt n     -> Just (n + 1)+                          Cast_Expr      -> Just 0+                          Cast_Co        -> Nothing+                          Tick_Tick      -> Nothing+                          Tick_Expr      -> Just 0+                          Type_Type      -> Nothing+                          Co_Co          -> Nothing+                          Alt_Con        -> Nothing+                          Alt_Var _      -> Nothing+                          Alt_RHS        -> Just 0+-}+-- | Converts a 'Crumb' into the 'Crumb' pointing to its left-sibling, if a such a 'Crumb' exists.+--   This is for backwards compatibility purposes with the old Int representation.+deprecatedLeftSibling :: Crumb -> Maybe Crumb+deprecatedLeftSibling = \case+                           ProgCons_Tail       -> Just ProgCons_Head+                           Rec_Def n | n > 0   -> Just (Rec_Def (n-1))+                           App_Arg             -> Just App_Fun+                           Let_Body            -> Just Let_Bind+                           Case_Alt n | n == 0 -> Just Case_Scrutinee+                                      | n >  0 -> Just (Case_Alt (n-1))+                           _                   -> Nothing++-- | Converts a 'Crumb' into the 'Crumb' pointing to its right-sibling, if a such a 'Crumb' exists.+--   This is for backwards compatibility purposes with the old Int representation.+deprecatedRightSibling :: Crumb -> Maybe Crumb+deprecatedRightSibling = \case+                           ProgCons_Head       -> Just ProgCons_Tail+                           Rec_Def n           -> Just (Rec_Def (n+1))+                           App_Fun             -> Just App_Arg+                           Let_Bind            -> Just Let_Body+                           Case_Scrutinee      -> Just (Case_Alt 0)+                           Case_Alt n          -> Just (Case_Alt (n+1))+                           _                   -> Nothing+++-----------------------------------------------------------------------

@@ -0,0 +1,92 @@+{-# LANGUAGE ScopedTypeVariables #-}++module HERMIT.Dictionary+    ( -- * The HERMIT Dictionary+      externals+    , module HERMIT.Dictionary.AlphaConversion+    , module HERMIT.Dictionary.Common+    , module HERMIT.Dictionary.Composite+    , module HERMIT.Dictionary.Debug+    , module HERMIT.Dictionary.FixPoint+    , module HERMIT.Dictionary.Fold+    , module HERMIT.Dictionary.Function+    , module HERMIT.Dictionary.GHC+    , module HERMIT.Dictionary.Inline+    , module HERMIT.Dictionary.Local+    , module HERMIT.Dictionary.Navigation+    , module HERMIT.Dictionary.New+    , module HERMIT.Dictionary.Query+    , module HERMIT.Dictionary.Reasoning+    , module HERMIT.Dictionary.Undefined+    , module HERMIT.Dictionary.Unfold+    , module HERMIT.Dictionary.Unsafe+    , module HERMIT.Dictionary.WorkerWrapper.Fix+    , module HERMIT.Dictionary.WorkerWrapper.FixResult+    ) where++import HERMIT.External++-- Since you cannot re-export qualified modules, we import everything *twice*.+import           HERMIT.Dictionary.AlphaConversion hiding (externals)+import qualified HERMIT.Dictionary.AlphaConversion as Alpha+import           HERMIT.Dictionary.Common -- TODO: deal with this module+import           HERMIT.Dictionary.Composite hiding (externals)+import qualified HERMIT.Dictionary.Composite as Composite+import           HERMIT.Dictionary.Debug hiding (externals)+import qualified HERMIT.Dictionary.Debug as Debug+import           HERMIT.Dictionary.FixPoint hiding (externals)+import qualified HERMIT.Dictionary.FixPoint as FixPoint+import           HERMIT.Dictionary.Fold hiding (externals)+import qualified HERMIT.Dictionary.Fold as Fold+import           HERMIT.Dictionary.Function hiding (externals)+import qualified HERMIT.Dictionary.Function as Function+import           HERMIT.Dictionary.GHC hiding (externals)+import qualified HERMIT.Dictionary.GHC as GHC+import           HERMIT.Dictionary.Inline hiding (externals)+import qualified HERMIT.Dictionary.Inline as Inline+import qualified HERMIT.Dictionary.Kure as Kure -- This *only* exports externals, so we don't re-export it.+import           HERMIT.Dictionary.Local hiding (externals)+import qualified HERMIT.Dictionary.Local as Local+import           HERMIT.Dictionary.Navigation hiding (externals)+import qualified HERMIT.Dictionary.Navigation as Navigation+import           HERMIT.Dictionary.New hiding (externals)+import qualified HERMIT.Dictionary.New as New+import           HERMIT.Dictionary.Query hiding (externals)+import qualified HERMIT.Dictionary.Query as Query+import           HERMIT.Dictionary.Reasoning hiding (externals)+import qualified HERMIT.Dictionary.Reasoning as Reasoning+import           HERMIT.Dictionary.Undefined hiding (externals)+import qualified HERMIT.Dictionary.Undefined as Undefined+import           HERMIT.Dictionary.Unfold hiding (externals)+import qualified HERMIT.Dictionary.Unfold as Unfold+import           HERMIT.Dictionary.Unsafe hiding (externals)+import qualified HERMIT.Dictionary.Unsafe as Unsafe+import           HERMIT.Dictionary.WorkerWrapper.Fix hiding (externals)+import qualified HERMIT.Dictionary.WorkerWrapper.Fix as WorkerWrapperFix+import           HERMIT.Dictionary.WorkerWrapper.FixResult hiding (externals)+import qualified HERMIT.Dictionary.WorkerWrapper.FixResult as WorkerWrapperFixResult++--------------------------------------------------------------------------++-- | List of all 'External's provided by HERMIT.+externals :: [External]+externals =+       Alpha.externals+    ++ Composite.externals+    ++ Debug.externals+    ++ FixPoint.externals+    ++ Fold.externals+    ++ Function.externals+    ++ GHC.externals+    ++ Inline.externals+    ++ Kure.externals+    ++ Local.externals+    ++ Navigation.externals+    ++ New.externals+    ++ Query.externals+    ++ Reasoning.externals+    ++ Undefined.externals+    ++ Unfold.externals+    ++ Unsafe.externals+    ++ WorkerWrapperFix.externals+    ++ WorkerWrapperFixResult.externals

@@ -0,0 +1,324 @@+{-# 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+         -- ** Shadow Detection and Unshadowing+       , unshadowR+       , visibleVarsT+       , freshNameGenT+       , freshNameGenAvoiding+       , replaceVarR+       )+where++import Control.Applicative+import Control.Arrow+import Control.Monad (liftM, liftM2)+import Data.Char (isDigit)+import Data.List (intersect)+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Monoid++import HERMIT.Core+import HERMIT.Context+import HERMIT.Monad+import HERMIT.Kure+import HERMIT.External+import HERMIT.GHC++import HERMIT.Dictionary.GHC hiding (externals)+import HERMIT.Dictionary.Common++import qualified Language.Haskell.TH as TH++import Prelude hiding (exp)++-----------------------------------------------------------------------++-- | Externals for alpha-renaming.+externals :: [External]+externals = map (.+ Deep)+         [  external "alpha" (alphaR :: RewriteH Core)+               [ "Renames the bound variables at the current node."]+         ,  external "alpha-lam" (promoteExprR . alphaLamR . Just :: TH.Name -> RewriteH Core)+               [ "Renames the bound variable in a Lambda expression to the given name."]+         ,  external "alpha-lam" (promoteExprR  (alphaLamR Nothing) :: RewriteH Core)+               [ "Renames the bound variable in a Lambda expression."]+         ,  external "alpha-case-binder" (promoteExprR . alphaCaseBinderR . Just :: TH.Name -> RewriteH Core)+               [ "Renames the binder in a Case expression to the given name."]+         ,  external "alpha-case-binder" (promoteExprR (alphaCaseBinderR Nothing) :: RewriteH Core)+               [ "Renames the binder in a Case expression."]+         ,  external "alpha-alt" (promoteAltR alphaAltR :: RewriteH Core)+               [ "Renames all binders in a Case alternative."]+         ,  external "alpha-alt" (promoteAltR . alphaAltWithR :: [TH.Name] -> RewriteH Core)+               [ "Renames all binders in a Case alternative using the user-provided list of new names."]+         ,  external "alpha-case" (promoteExprR alphaCaseR :: RewriteH Core)+               [ "Renames all binders in a Case alternative."]+         ,  external "alpha-let" (promoteExprR . alphaLetWithR :: [TH.Name] -> RewriteH Core)+               [ "Renames the bound variables in a Let expression using a list of suggested names."]+         ,  external "alpha-let" (promoteExprR alphaLetR :: RewriteH Core)+               [ "Renames the bound variables in a Let expression."]+         ,  external "alpha-top" (promoteProgR . alphaProgConsWithR :: [TH.Name] -> RewriteH Core)+               [ "Renames the bound identifiers in the top-level binding group at the head of the program using a list of suggested names."]+         -- ,  external "alpha-top" (promoteProgR alphaCons)+         --       [ "Renames the bound identifiers in the top-level binding at the head of the program."]+         -- ,  external "alpha-program" (promoteProgR alphaProg)+         --       [ "Renames identifiers bound at the top-level of the program."]+         ,  external "unshadow" (unshadowR :: RewriteH Core)+                [ "Rename local variables with manifestly unique names (x, x0, x1, ...)."]+         ]++-----------------------------------------------------------------------+--+-- freshNameGen is a function used in conjunction with cloneVarH, which clones an existing 'Var'.+-- But, what name should the new Id have?+-- cloneVarH generates a new Unique -- so we are positive that the new Var will be new,+-- but freshNameGen tries to assign a Name that will be meaningful to the user, and+-- not shadow other names in scope.+-- So,  we start with the name of the original Id, and add an integer suffix+--  x  goes to x0 or x1 or ...+-- and we do not want this newly generated name to shadow either:+-- 1.  Any free variable name in the active Expr; or+-- 2.  Any bound variables in context.++-- | List all visible identifiers (in the expression or the context).+visibleVarsT :: (BoundVars c, Monad m) => Translate c m CoreExpr VarSet+visibleVarsT = liftM2 unionVarSet boundVarsT (arr freeVarsExpr)++-- | If a name is provided replace the string with that,+--   otherwise modify the string making sure to /not/ clash with any visible variables.+freshNameGenT :: (BoundVars c, Monad m) => Maybe TH.Name -> Translate c m CoreExpr (String -> String)+freshNameGenT mn = freshNameGenAvoiding mn `liftM` visibleVarsT++-- | Use the optional argument if given, otherwise generate a new name avoiding clashes with the list of variables.+freshNameGenAvoiding :: Maybe TH.Name -> VarSet -> (String -> String)+freshNameGenAvoiding mn vs str = maybe (inventNames vs str) TH.nameBase mn++-- | Invent a new String based on the old one, but avoiding clashing with the given list of identifiers.+inventNames :: VarSet -> String -> String+inventNames curr old = head+                     [ nm+                     | nm <- old : [ base ++ show uq | uq <- [start ..] :: [Int] ]+                     , nm `notElem` names+                     ]+   where+           names = map uqName (varSetElems curr)+           nums = reverse $ takeWhile isDigit (reverse old)+           baseLeng = length $ drop (length nums) old+           base = take baseLeng old+           start = case reads nums of+                     [(v,_)] -> v + 1+                     _       -> 0+++-- | Remove all variables from the first set that 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++-- | Lifted version of 'shadowedBy'.+--   Additionally, it fails if no shadows are found.+shadowedByT :: MonadCatch m => Translate c m a VarSet -> Translate c m a VarSet -> Translate c m a VarSet+shadowedByT t1 t2 = setFailMsg "No shadows detected." $ (liftM2 shadowedBy t1 t2) >>> acceptR (not . isEmptyVarSet)++-- | Rename local variables with manifestly unique names (x, x0, x1, ...).+--   Does not rename top-level definitions.+unshadowR :: forall c. (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core+unshadowR = setFailMsg "No shadows to eliminate." $+           anytdR (promoteExprR unshadowExpr <+ promoteAltR unshadowAlt)++  where+    unshadowExpr :: Rewrite c HermitM CoreExpr+    unshadowExpr = do vs <- shadowedByT (mkVarSet <$> (letVarsT <+ (return <$> (caseWildIdT <+ lamVarT))))+                                        (unionVarSet <$> boundVarsT <*> arr freeVarsExpr)+                      alphaLamR Nothing <+ alphaLetVarsR (varSetElems vs) <+ alphaCaseBinderR Nothing++    unshadowAlt :: Rewrite c HermitM CoreAlt+    unshadowAlt = do vs <- shadowedByT (arr (mkVarSet . altVars))+                                       (unionVarSet <$> boundVarsT <*> arr freeVarsAlt)+                     alphaAltVarsR (varSetElems vs)++-----------------------------------------------------------------------++-- Maybe this should be defined elsewhere.++-- | Replace all occurrences of a specified variable.+--   Arguments are the variable to replace and the replacement variable, respectively.+replaceVarR :: (ExtendPath c Crumb, AddBindings c, Injection a Core, MonadCatch m) => Var -> Var -> Rewrite c m a+replaceVarR v v' = extractR $ tryR $ substR v $ varToCoreExpr v'++-- | Given a variable to replace, and a replacement, produce a 'Var' @->@ 'Var' function that+--   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')]++-- | 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)++-----------------------------------------------------------------------++-- | Alpha rename a lambda binder.  Optionally takes a suggested new name.+alphaLamR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr+alphaLamR mn = setFailMsg (wrongFormForAlpha "Lam v e") $+              do (v, nameModifier) <- lamT idR (freshNameGenT mn) (,)+                 v' <- constT (cloneVarH nameModifier v)+                 lamAnyR (arr $ replaceVar v v') (replaceVarR v v')++-----------------------------------------------------------------------++-- | Alpha rename a case binder.  Optionally takes a suggested new name.+alphaCaseBinderR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr+alphaCaseBinderR mn = setFailMsg (wrongFormForAlpha "Case e v ty alts") $+                     do Case _ v _ _ <- idR+                        nameModifier <- freshNameGenT mn+                        v' <- constT (cloneVarH nameModifier v)+                        caseAnyR idR (return v') idR (\ _ -> replaceVarR v v')++-----------------------------------------------------------------------++-- | Rename the specified variable in a case alternative.  Optionally takes a suggested new name.+alphaAltVarR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Var -> Rewrite c HermitM CoreAlt+alphaAltVarR mn v =+  do nameModifier <- altT idR (\ _ -> idR) (freshNameGenT mn) (\ _ _ nameGen -> nameGen)+     v' <- constT (cloneVarH nameModifier v)+     altAnyR (fail "") (\ _ -> arr (replaceVar v v')) (replaceVarR v v')++-- | Rename the specified variables in a case alternative, using the suggested names where provided.+alphaAltVarsWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Var)] -> Rewrite c HermitM CoreAlt+alphaAltVarsWithR = andR . map (uncurry alphaAltVarR)++-- | Rename the variables bound in a case alternative with the given list of suggested names.+alphaAltWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM 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, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM 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, AddBindings c, BoundVars c) => Rewrite c HermitM CoreAlt+alphaAltR = arr altVars >>= alphaAltVarsR++-----------------------------------------------------------------------++-- | Rename all identifiers bound in a case expression.+alphaCaseR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM 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, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr+alphaLetNonRecR mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $+                    do (v, nameModifier) <- letNonRecT idR mempty (freshNameGenT mn) (\ v () nameMod -> (v, nameMod))+                       v' <- constT (cloneVarH nameModifier 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, AddBindings c, BoundVars c) => Maybe TH.Name -> [Var] -> Rewrite c HermitM CoreExpr+alphaLetNonRecVarsR mn vs = whenM ((`elem` vs) <$> letNonRecVarT) (alphaLetNonRecR mn)++-- | Rename the specified identifier bound in a recursive let.  Optionally takes a suggested new name.+alphaLetRecIdR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Id -> Rewrite c HermitM CoreExpr+alphaLetRecIdR mn v = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $+                     do usedVars <- unionVarSet <$> boundVarsT+                                                <*> letRecT (\ _ -> defT idR (arr freeVarsExpr) (flip extendVarSet)) (arr freeVarsExpr) (\ bndfvs vs -> unionVarSets (vs:bndfvs))+                        v' <- constT (cloneVarH (freshNameGenAvoiding mn usedVars) v)+                        letRecDefAnyR (\ _ -> (arr (replaceVar v v'), replaceVarR v v')) (replaceVarR v v')++-- | Rename the specified identifiers in a recursive let, using the suggested names where provided.+alphaLetRecIdsWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Id)] -> Rewrite c HermitM CoreExpr+alphaLetRecIdsWithR = andR . map (uncurry alphaLetRecIdR)++-- | Rename the identifiers bound in a Let with the given list of suggested names.+alphaLetWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreExpr+alphaLetWithR ns = alphaLetNonRecR (listToMaybe ns)+                  <+ (letRecIdsT >>= (alphaLetRecIdsWithR . zip (map Just ns)))++-- | Rename the specified variables bound in a let.+alphaLetVarsR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM 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, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+alphaLetR = letVarsT >>= alphaLetVarsR++-----------------------------------------------------------------------++-- | Alpha rename a non-recursive top-level binder.  Optionally takes a suggested new name.+alphaProgConsNonRecR :: (ExtendPath c Crumb, AddBindings c) => TH.Name -> Rewrite c HermitM CoreProg+alphaProgConsNonRecR n = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $+                    do ProgCons (NonRec v _) _ <- idR+                       v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v)+                       consNonRecAnyR (return v') idR (replaceVarR v v')++-- -- | Alpha rename a non-recursive top-level binder if the identifier appears in the argument list.  Optionally takes a suggested new name.+-- alphaConsNonRecIds :: Maybe TH.Name -> [Id] -> Rewrite c m CoreProg+-- alphaConsNonRecIds mn vs = whenM ((`elem` vs) <$> consNonRecIdT) (alphaConsNonRec mn)++-- | Rename the specified identifier bound in a recursive top-level binder.  Optionally takes a suggested new name.+alphaProgConsRecIdR :: (ExtendPath c Crumb, AddBindings c) => TH.Name -> Id -> Rewrite c HermitM CoreProg+alphaProgConsRecIdR n v =  setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $+                      do v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v)+                         consRecDefAnyR (\ _ -> (arr (replaceVar v v'), replaceVarR v v')) (replaceVarR v v')++-- | Rename the specified identifiers in a recursive top-level binding at the head of a program, using the suggested names where provided.+alphaProgConsRecIdsWithR :: (ExtendPath c Crumb, AddBindings c) => [(TH.Name,Id)] -> Rewrite c HermitM CoreProg+alphaProgConsRecIdsWithR = andR . map (uncurry alphaProgConsRecIdR)++-- | 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, AddBindings c) => [TH.Name] -> Rewrite c HermitM CoreProg+alphaProgConsWithR []     = fail "At least one new name must be provided."+alphaProgConsWithR (n:ns) = alphaProgConsNonRecR n <+ (progConsRecIdsT >>= (alphaProgConsRecIdsWithR . zip (n:ns)))++-- -- | Rename the specified variables bound in the top-level binding at the head of the program.+-- alphaConsIds :: [Id] -> Rewrite c m CoreProg+-- alphaConsIds vs = alphaConsNonRecIds Nothing vs <+ alphaConsRecIdsWith (zip (repeat Nothing) vs)++-- -- | Rename all identifiers bound in the top-level binding at the head of the program.+-- alphaCons :: Rewrite c m CoreProg+-- alphaCons = consIdsT >>= alphaConsIds++-----------------------------------------------------------------------++-- -- | Rename all identifiers bound at the top-level.+-- alphaProg :: Rewrite c m CoreProg+-- alphaProg = progNilT ProgNil <+ (alphaCons >>> progConsAllR idR alphaProg)++-----------------------------------------------------------------------++-- | Alpha rename any bindings at this node.  Note: does not rename case alternatives unless invoked on the alternative.+alphaR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core+alphaR = setFailMsg "Cannot alpha-rename here." $+           promoteExprR (alphaLamR Nothing <+ alphaCaseBinderR Nothing <+ alphaLetR)+        <+ promoteAltR alphaAltR++-----------------------------------------------------------------------++wrongFormForAlpha :: String -> String+wrongFormForAlpha s = "Cannot alpha-rename, " ++ wrongExprForm s++-----------------------------------------------------------------------

@@ -0,0 +1,251 @@+{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleContexts, LambdaCase #-}++-- | Note: this module should NOT export externals. It is for common+--   transformations needed by the other primitive modules.+module HERMIT.Dictionary.Common+    ( -- * Utility Transformations+      applyInContextT+      -- ** Finding function calls.+    , callT+    , callPredT+    , callNameT+    , callSaturatedT+    , callNameG+    , callDataConT+    , callDataConNameT+    , callsR+    , callsT+      -- ** Collecting variable bindings+    , progConsIdsT+    , progConsRecIdsT+    , progConsNonRecIdT+    , nonRecVarT+    , recIdsT+    , lamVarT+    , letVarsT+    , letRecIdsT+    , letNonRecVarT+    , caseVarsT+    , caseWildIdT+    , caseAltVarsT+      -- ** Finding variables bound in the Context+    , boundVarsT+    , findBoundVarT+    , findIdT+    , findId+    , varBindingDepthT+    , varIsOccurrenceOfT+    , exprIsOccurrenceOfT+      -- Miscellaneous+    , wrongExprForm+    )++where++import Data.List+import Data.Monoid++import Control.Arrow++import HERMIT.Kure+import HERMIT.Core+import HERMIT.Context+import HERMIT.GHC++import qualified Language.Haskell.TH as TH++------------------------------------------------------------------------------++-- | Apply a transformation to a value in the current context.+applyInContextT :: Translate c m a b -> a -> Translate c m x b+applyInContextT t a = contextonlyT $ \ c -> apply t c a++-- Note: this is the same as: return a >>> t++------------------------------------------------------------------------------++-- | Lift GHC's collectArgs+callT :: Monad m => Translate c m CoreExpr (CoreExpr, [CoreExpr])+callT = contextfreeT $ \ e -> case e of+                                Var {} -> return (e, [])+                                App {} -> return (collectArgs e)+                                _      -> fail "not an application or variable occurence."++callPredT :: Monad m => (Id -> [CoreExpr] -> Bool) -> Translate c m CoreExpr (CoreExpr, [CoreExpr])+callPredT p = do+    call@(Var i, args) <- callT+    guardMsg (p i args) "predicate failed."+    return call++-- | Succeeds if we are looking at an application of given function+--   returning zero or more arguments to which it is applied.+callNameT :: MonadCatch m => TH.Name -> Translate c m CoreExpr (CoreExpr, [CoreExpr])+callNameT nm = setFailMsg ("callNameT failed: not a call to '" ++ show nm ++ ".") $+    callPredT (const . cmpTHName2Var nm)++-- | Succeeds if we are looking at a fully saturated function call.+callSaturatedT :: Monad m => Translate c m CoreExpr (CoreExpr, [CoreExpr])+callSaturatedT = callPredT (\ i args -> idArity i == length args)+-- TODO: probably better to calculate arity based on Id's type, as+--       idArity is conservatively set to zero by default.++-- | Succeeds if we are looking at an application of given function+callNameG :: MonadCatch m => TH.Name -> Translate c m CoreExpr ()+callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >>= \_ -> constT (return ())++-- | Succeeds if we are looking at an application of a data constructor.+callDataConT :: MonadCatch m => Translate c m CoreExpr (DataCon, [Type], [CoreExpr])+callDataConT = prefixFailMsg "callDataConT failed:" $+#if __GLASGOW_HASKELL__ > 706+    do mb <- contextfreeT $ \ e -> let in_scope = mkInScopeSet (mkVarEnv [ (v,v) | v <- 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 => TH.Name -> Translate c m CoreExpr (DataCon, [Type], [CoreExpr])+callDataConNameT nm = do+    res@(dc,_,_) <- callDataConT+    guardMsg (cmpTHName2Name nm (dataConName dc)) "wrong datacon."+    return res++-- | Apply a rewrite to all applications of a given function in a top-down manner, pruning on success.+callsR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Rewrite c m CoreExpr -> Rewrite c m Core+callsR nm rr = prunetdR (promoteExprR $ callNameG nm >> rr)++-- | Apply a translate to all applications of a given function in a top-down manner,+--   pruning on success, collecting the results.+callsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Translate c m CoreExpr b -> Translate c m Core [b]+callsT nm t = collectPruneT (promoteExprT $ callNameG nm >> t)++------------------------------------------------------------------------------++-- | List the identifiers bound by the top-level binding group at the head of the program.+progConsIdsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreProg [Id]+progConsIdsT = progConsT (arr bindVars) mempty (\ vs () -> vs)++-- | List the identifiers bound by a recursive top-level binding group at the head of the program.+progConsRecIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg [Id]+progConsRecIdsT = progConsT recIdsT mempty (\ vs () -> vs)++-- | Return the identifier bound by a non-recursive top-level binding at the head of the program.+progConsNonRecIdT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg Id+progConsNonRecIdT = progConsT nonRecVarT mempty (\ v () -> v)++-- | Return the variable bound by a non-recursive let expression.+nonRecVarT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreBind Var+nonRecVarT = nonRecT idR mempty (\ v () -> v)++-- | List all identifiers bound in a recursive binding group.+recIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind [Id]+recIdsT = recT (\ _ -> arr defId) id++-- | Return the variable bound by a lambda expression.+lamVarT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var+lamVarT = lamT idR mempty (\ v () -> v)++-- | List the variables bound by a let expression.+letVarsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreExpr [Var]+letVarsT = letT (arr bindVars) mempty (\ vs () -> vs)++-- | List the identifiers bound by a recursive let expression.+letRecIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Id]+letRecIdsT = letT recIdsT mempty (\ vs () -> vs)++-- | Return the variable bound by a non-recursive let expression.+letNonRecVarT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var+letNonRecVarT = letT nonRecVarT mempty (\ v () -> v)++-- | List all variables bound by a case expression (in the alternatives and the wildcard binder).+caseVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Var]+caseVarsT = caseT mempty idR mempty (\ _ -> arr altVars) (\ () v () vss -> v : nub (concat vss))++-- | Return the case wildcard binder.+caseWildIdT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Id+caseWildIdT = caseT mempty idR mempty (\ _ -> idR) (\ () i () _ -> i)++-- | List the variables bound by all alternatives in a case expression.+caseAltVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [[Var]]+caseAltVarsT = caseT mempty mempty mempty (\ _ -> arr altVars) (\ () () () vss -> vss)++------------------------------------------------------------------------------++-- | Find the depth of a variable's binding.+varBindingDepthT :: (ReadBindings c, Monad m) => Var -> Translate c m g BindingDepth+varBindingDepthT v = contextT >>= lookupHermitBindingDepth v++-- | Determine if the current variable matches the given variable, and is bound at the specified depth (helpful to detect shadowing).+varIsOccurrenceOfT :: (ExtendPath c Crumb, ReadBindings c, Monad m) => Var -> BindingDepth -> Translate c m Var Bool+varIsOccurrenceOfT v d = readerT $ \ v' -> if v == v'+                                             then varBindingDepthT v >>^ (== d)+                                             else return False++-- | Determine if the current expression is an occurrence of the given variable, bound at the specified depth (helpful to detect shadowing).+exprIsOccurrenceOfT :: (ExtendPath c Crumb, ReadBindings c, Monad m) => Var -> BindingDepth -> Translate c m CoreExpr Bool+exprIsOccurrenceOfT v d = varT $ varIsOccurrenceOfT v d++-- | Lifted version of 'boundVars'.+boundVarsT :: (BoundVars c, Monad m) => Translate c m a VarSet+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) => TH.Name -> Translate c m a Var+findBoundVarT nm = prefixFailMsg ("Cannot resolve name " ++ show 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."++-- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.+findIdT :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m, MonadCatch m) => TH.Name -> Translate c m a Id+findIdT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $+             contextonlyT (findId nm)++findId :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m) => TH.Name -> c -> m Id+findId nm c = case varSetElems (findBoundVars nm c) of+                []         -> findIdMG nm c+                [v]        -> return v+                _ : _ : _  -> fail "multiple matching variables in scope."++findIdMG :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m) => TH.Name -> c -> m Id+findIdMG nm c =+    case filter isValName $ findNamesFromTH (hermitGlobalRdrEnv c) nm of+      []  -> findIdBuiltIn nm+      [n] -> lookupId n+      ns  -> do dynFlags <- getDynFlags+                fail $ "multiple matches found:\n" ++ intercalate ", " (map (showPpr dynFlags) ns)++findIdBuiltIn :: forall m. Monad m => TH.Name -> m Id+findIdBuiltIn = go . show+    where go ":"     = dataConId consDataCon+          go "[]"    = dataConId nilDataCon++          go "True"  = return trueDataConId+          go "False" = return falseDataConId++          go "<"     = return ltDataConId+          go "=="    = return eqDataConId+          go ">"     = return gtDataConId++          go "I#"    = dataConId intDataCon++          go "()"    = return unitDataConId+          -- TODO: add more as needed+          --       http://www.haskell.org/ghc/docs/latest/html/libraries/ghc/TysWiredIn.html+          go _   = fail "variable not in scope."++          dataConId :: DataCon -> m Id+          dataConId = return . dataConWorkId++------------------------------------------------------------------------------++-- | Constructs a common error message.+--   Argument 'String' should be the desired form of the expression.+wrongExprForm :: String -> String+wrongExprForm form = "Expression does not have the form: " ++ form++------------------------------------------------------------------------------

@@ -0,0 +1,148 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}++module HERMIT.Dictionary.Composite+    ( externals+    , unfoldBasicCombinatorR+    , simplifyR+    , bashUsingR+    , bashR+    , bashExtendedWithR+    , bashDebugR+    )+where++import Control.Arrow++import HERMIT.Context+import HERMIT.Core+import HERMIT.GHC+import HERMIT.Monad+import HERMIT.Kure+import HERMIT.External++import HERMIT.Dictionary.Debug hiding (externals)+import HERMIT.Dictionary.GHC hiding (externals)+import HERMIT.Dictionary.Inline hiding (externals)+import HERMIT.Dictionary.Local hiding (externals)+import HERMIT.Dictionary.Unfold hiding (externals)++import qualified Language.Haskell.TH as TH++------------------------------------------------------------------------------------------------------++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." ]+    , external "simplify" (simplifyR :: RewriteH Core)+        [ "innermost (unfold-basic-combinator <+ beta-reduce-plus <+ safe-let-subst <+ case-reduce <+ let-elim)" ]+    , external "bash" (bashR :: RewriteH Core)+        bashHelp .+ Eval .+ Deep .+ Loop+    , external "bash-extended-with" (bashExtendedWithR :: [RewriteH Core] -> RewriteH Core)+        [ "Run \"bash\" extended with an additional rewrite.",+          "Note: be sure that the new rewrite either fails or makes progress, else this may loop."+        ] .+ Eval .+ Deep .+ Loop+    , external "bash-debug" (bashDebugR :: RewriteH Core)+        [ "verbose bash - most useful with set-auto-corelint True" ] .+ Eval .+ Deep .+ Loop+    ]++------------------------------------------------------------------------------------------------------++basicCombinators :: [String]+basicCombinators = ["$",".","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'.+--   This is intended to be used as a component of simplification traversals such as 'simplifyR' or 'bashR'.+unfoldBasicCombinatorR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+unfoldBasicCombinatorR = setFailMsg "unfold-basic-combinator failed." $+     unfoldNamesR (map TH.mkName basicCombinators)++simplifyR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core+simplifyR = setFailMsg "Simplify failed: nothing to simplify." $+    innermostR (   promoteBindR recToNonrecR+                <+ promoteExprR ( unfoldBasicCombinatorR+                               <+ betaReducePlusR+                               <+ letNonRecSubstSafeR+                               <+ caseReduceR+                               <+ letElimR )+               )++------------------------------------------------------------------------------------------------------++bashR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core+bashR = bashUsingR (map fst bashComponents)++bashExtendedWithR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core+bashExtendedWithR rs = bashUsingR (rs ++ map fst bashComponents)++bashDebugR :: RewriteH Core+bashDebugR = bashUsingR $ map (\ (r,nm) -> r >>> observeR 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, AddBindings c, 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++ --   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 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.+-}++bashHelp :: [String]+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, AddBindings c, ReadBindings c) => [(Rewrite c HermitM Core, String)]+bashComponents =+  [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr")    -- ??+    (promoteExprR betaReduceR, "beta-reduce")                        -- O(1)+  , (promoteExprR caseReduceR, "case-reduce")                        -- O(n)+  , (promoteExprR caseReduceIdR, "case-reduce-id")                   -- O(n)+  , (promoteExprR caseElimSeqR, "case-elim-seq")+  , (promoteExprR unfoldBasicCombinatorR, "unfold-basic-combinator") -- O(n)+  , (promoteExprR inlineCaseAlternativeR, "inline-case-alternative") -- O(n)+  , (promoteExprR etaReduceR, "eta-reduce")                          -- O(n)+--  , (promoteBindR recToNonrecR, "rec-to-nonrec")                     -- O(n) -- subsumed by occurrence analysis+  , (promoteExprR letNonRecSubstSafeR, "let-nonrec-subst-safe")      -- O(n)+  , (promoteExprR caseFloatAppR, "case-float-app")                   -- O(n)+  , (promoteExprR caseFloatCaseR, "case-float-case")                 -- O(n)+  , (promoteExprR caseFloatLetR, "case-float-let")                   -- O(n) but usually O(1)+  , (promoteExprR caseFloatCastR, "case-float-cast")                 -- O(1)+--  , (promoteExprR letElimR, "let-elim")  -- O(n^2) -- Subsumed by occurrence analysis.+  , (promoteExprR letFloatAppR, "let-float-app")                     -- O(n)+  , (promoteExprR letFloatArgR, "let-float-arg")                     -- O(n)+  , (promoteExprR letFloatLamR, "let-float-lam")                     -- O(n)+  , (promoteExprR letFloatLetR, "let-float-let")                     -- O(n)+  , (promoteExprR letFloatCaseR, "let-float-case")                   -- O(n)+  , (promoteExprR letFloatCastR, "let-float-cast")                   -- O(1)+  , (promoteProgR letFloatTopR, "let-float-top")                     -- O(n)+  , (promoteExprR castElimReflR, "cast-elim-refl")                   -- O(1)+  , (promoteExprR castElimSymR, "cast-elim-sym")                     -- O(1)+--  , (promoteExprR dezombifyR, "dezombify")                           -- O(1) -- performed at the end+  ]++------------------------------------------------------------------------------------------------------+

@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts #-}+module HERMIT.Dictionary.Debug+       ( -- * Debugging Dictionarys+         externals+       , bracketR+       , observeR+       , observeFailureR+       , traceR+       )+where++import Control.Arrow++import HERMIT.Kure+import HERMIT.External+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" ]+         ]++-- | If the 'Rewrite' fails, print out the 'Core', with a message.+observeFailureR :: Injection a CoreTC => String -> RewriteH a -> RewriteH 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++-- | Just say something, every time the rewrite is done.+traceR :: String -> RewriteH a+traceR msg = sideEffectR $ \ _ _ -> sendDebugMessage $ DebugTick msg++-- | Show before and after a rewrite.+bracketR :: Injection a CoreTC => String -> RewriteH a -> RewriteH a+bracketR msg rr = do+    -- Be careful to only run the rr once, in case it has side effects.+    (e,r) <- idR &&& attemptM rr+    either fail (\ e' -> do _ <- return e >>> observeR before+                            return e' >>> observeR after) r+    where before = msg ++ " (before)"+          after  = msg ++ " (after)"+-- attemptM :: MonadCatch m => m a -> m (Either String a)