hermit 0.1.6.0 → 0.1.8.0
raw patch · 71 files changed
+4690/−1985 lines, 71 filesdep +arraydep +hermitdep +operationaldep −aesondep −textdep ~ghcdep ~kure
Dependencies added: array, hermit, operational, transformers
Dependencies removed: aeson, text
Dependency ranges changed: ghc, kure
Files
- dist/build/Language/HERMIT/Parser.hs +730/−0
- dist/build/Language/HERMIT/ParserCore.hs +601/−0
- driver/Main.hs +23/−29
- examples/WWSplitTactic.hss +1/−1
- examples/concatVanishes/ConcatVanishes.hss +1/−9
- examples/concatVanishes/Flatten.hs +1/−6
- examples/concatVanishes/QSort.hs +3/−8
- examples/concatVanishes/Rev.hs +2/−6
- examples/evaluation/Eval.hs +0/−3
- examples/evaluation/Eval.hss +2/−2
- examples/factorial/Fac.hs +2/−2
- examples/factorial/Fac.hss +3/−1
- examples/fib-stream/Fib.hs +0/−2
- examples/fib-stream/Fib.hss +1/−1
- examples/fib-tuple/Fib.hs +2/−6
- examples/fib-tuple/Fib.hss +6/−5
- examples/flatten/Flatten.hs +1/−6
- examples/flatten/Flatten.hss +17/−34
- examples/flatten/HList.hs +0/−19
- examples/hanoi/Hanoi.hs +1/−4
- examples/hanoi/Hanoi.hss +6/−5
- examples/last/Last.hs +1/−3
- examples/last/Last.hss +13/−16
- examples/mean/Mean.hs +2/−4
- examples/mean/Mean.hss +5/−1
- examples/qsort/HList.hs +0/−14
- examples/qsort/QSort.hs +1/−6
- examples/qsort/QSort.hss +21/−28
- examples/reverse/HList.hs +0/−11
- examples/reverse/Reverse.hs +3/−11
- examples/reverse/Reverse.hss +19/−28
- examples/reverse/ReverseWW.hss +0/−29
- hermit.cabal +32/−24
- src/HERMIT.hs +2/−7
- src/HERMIT/Driver.hs +16/−0
- src/Language/HERMIT/Context.hs +16/−3
- src/Language/HERMIT/Core.hs +44/−16
- src/Language/HERMIT/Dictionary.hs +27/−27
- src/Language/HERMIT/Expr.hs +0/−218
- src/Language/HERMIT/External.hs +40/−5
- src/Language/HERMIT/GHC.hs +9/−1
- src/Language/HERMIT/Interp.hs +15/−2
- src/Language/HERMIT/Kernel/Scoped.hs +49/−35
- src/Language/HERMIT/Kure.hs +124/−17
- src/Language/HERMIT/Monad.hs +25/−14
- src/Language/HERMIT/Optimize.hs +149/−0
- src/Language/HERMIT/Parser.y +188/−0
- src/Language/HERMIT/ParserCore.y +178/−0
- src/Language/HERMIT/Plugin.hs +100/−35
- src/Language/HERMIT/PrettyPrinter.hs +0/−351
- src/Language/HERMIT/PrettyPrinter/AST.hs +14/−13
- src/Language/HERMIT/PrettyPrinter/Clean.hs +225/−100
- src/Language/HERMIT/PrettyPrinter/Common.hs +418/−0
- src/Language/HERMIT/PrettyPrinter/GHC.hs +10/−10
- src/Language/HERMIT/PrettyPrinter/JSON.hs +0/−71
- src/Language/HERMIT/Primitive/AlphaConversion.hs +95/−87
- src/Language/HERMIT/Primitive/Common.hs +152/−27
- src/Language/HERMIT/Primitive/FixPoint.hs +344/−153
- src/Language/HERMIT/Primitive/Fold.hs +29/−24
- src/Language/HERMIT/Primitive/GHC.hs +96/−58
- src/Language/HERMIT/Primitive/Inline.hs +60/−5
- src/Language/HERMIT/Primitive/Kure.hs +15/−1
- src/Language/HERMIT/Primitive/Local.hs +41/−40
- src/Language/HERMIT/Primitive/Local/Case.hs +130/−73
- src/Language/HERMIT/Primitive/Local/Cast.hs +115/−0
- src/Language/HERMIT/Primitive/Local/Let.hs +128/−61
- src/Language/HERMIT/Primitive/Navigation.hs +10/−3
- src/Language/HERMIT/Primitive/New.hs +51/−68
- src/Language/HERMIT/Primitive/Unfold.hs +110/−60
- src/Language/HERMIT/Shell/Command.hs +136/−76
- src/Language/HERMIT/Syntax.hs +29/−0
+ dist/build/Language/HERMIT/Parser.hs view
@@ -0,0 +1,730 @@+{-# 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+import qualified Data.Array as Happy_Data_Array+import qualified GHC.Exts as Happy_GHC_Exts++-- parser produced by Happy Version 1.18.10++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 '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+ | isIdFirstChar c = let (i,s') = span isIdChar s+ in fmap (Ident i:) $ lexer s'+ | isInfixId c = let (op,s') = span isInfixId s+ in fmap (InfixOp op:) $ lexer s'+lexer s = 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 isInfixId nm || isIdFirstChar (head nm) && all (isIdChar) (tail nm)) = "'" ++ nm+ | otherwise = "'\"" ++ concatMap escape nm ++ "\""+ where escape '\"' = "\\\""+ escape c = [c]+unparseExprH (CmdName nm)+ | nm == "{" = "{ "+ | nm == "}" = " }"+ | all isIdChar nm = nm+ | otherwise = show nm -- with quotes+unparseExprH (AppH (AppH (CmdName nm) e1) e2)+ | all isInfixId 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@(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.
+ dist/build/Language/HERMIT/ParserCore.hs view
@@ -0,0 +1,601 @@+{-# OPTIONS_GHC -w #-}+{-# OPTIONS -fglasgow-exts -cpp #-}+{-# LANGUAGE CPP #-}+module Language.HERMIT.ParserCore (parseCore) where++import Control.Monad.Reader+import Data.Char (isSpace, isAlpha, isAlphaNum, isDigit)++import GhcPlugins++import Language.HERMIT.Context+import Language.HERMIT.External+import Language.HERMIT.Monad+import Language.HERMIT.Primitive.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.18.10++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 :: [Token] -> CoreParseM 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'+ | isIdFirstChar c = let (i,s') = span isIdChar s+ in fmap (Tname i:) $ lexer s'+ | isInfixId c = let (op,s') = span isInfixId s+ in fmap (Tname op:) $ lexer s'+lexer s = Left $ "lexer: no match on " ++ s++---------------------------------------------++-- | Chars that are valid in identifiers anywhere.+isIdFirstChar :: Char -> Bool+isIdFirstChar c = c `elem` "_$[]:.=" || isAlpha c++-- | Chars that are valid in identifiers, but not as the first character.+isIdChar :: Char -> Bool+isIdChar c = isAlphaNum c || c `elem` "#-'" || isIdFirstChar c++-- | Chars that are valid in infix operators.+isInfixId :: Char -> Bool+isInfixId c = c `elem` "+*/._-:<>"++parseCore :: CoreString -> HermitC -> HermitM CoreExpr+parseCore (CoreString s) c =+ case lexer s of+ 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@(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.
driver/Main.hs view
@@ -2,19 +2,15 @@ module Main where +import HERMIT.Driver+ import System.Environment import System.Process import System.Exit -import Paths_hermit as P-import Data.Version- import Data.List (isPrefixOf) import System.Directory (doesFileExist) -hermit_version :: String-hermit_version = "HERMIT v" ++ showVersion P.version- usage :: IO () usage = putStrLn $ unlines [hermit_version@@ -24,15 +20,15 @@ ," hermit File.hs [HERMIT_ARGS] [+module_name [MOD_ARGS]]* [-- [ghc-args]]" ,"" ,"examples: hermit Foo.hs Foo.hss"- ," hermit Foo.hs -p6 +main:Main Foo.hss"- ," hermit Foo.hs +main:Main Foo.hss resume"- ," hermit Foo.hs +main:Main Foo.hss +other:Other Bar.hss"+ ," hermit Foo.hs -p6 +Main Foo.hss"+ ," hermit Foo.hs +Main Foo.hss resume"+ ," hermit Foo.hs +Main Foo.hss +Other.Module.Name Bar.hss" ," hermit Foo.hs -- -ddump-simpl -ddump-to-file" ,"" ,"If a module name is not supplied, the module main:Main is assumed." ,"" ,"HERMIT_ARGS"- ," -pN : where 0 <= N < 18 is the position in the pipeline in which HERMIT should run, 0 being at the beginning"+ ," -opt=MODULE : where MODULE is the module containing a HERMIT optimization plugin" ,"" ,"MOD_ARGS" ," SCRIPTNAME : name of script file to run for this module"@@ -46,9 +42,9 @@ main1 :: [String] -> IO () main1 [] = usage-main1 [file_nm,script_nm] = do+main1 args@[file_nm,script_nm] = do e <- doesFileExist script_nm- if e then main4 file_nm [] [("main:Main", [script_nm])] [] else usage+ if e then main4 file_nm [] [("Main", [script_nm])] [] else main2 args main1 other = main2 other main2 (file_nm:rest) = case span (/= "--") rest of@@ -64,26 +60,24 @@ sepMods (('+':mod_nm):rest) = (mod_nm, mod_opts) : sepMods next where (mod_opts, next) = span (not . isPrefixOf "+") rest -main4 file_nm hermit_args [] ghc_args = main4 file_nm hermit_args [("main:Main", [])] ghc_args+main4 file_nm hermit_args [] ghc_args = main4 file_nm hermit_args [("Main", [])] ghc_args main4 file_nm hermit_args module_args ghc_args = do putStrLn $ "[starting " ++ hermit_version ++ " on " ++ file_nm ++ "]"- let cmds =- [ file_nm- , "-fforce-recomp"- , "-O2"- , "-dcore-lint"- , "-fsimple-list-literals"--- , "-v0"- , "-fplugin=HERMIT"- ] ++- [ "-fplugin-opt=HERMIT:" ++ opt- | opt <- hermit_args- ] ++- [ "-fplugin-opt=HERMIT:" ++ m_nm ++ ":" ++ opt- | (m_nm, m_opts) <- module_args- , opt <- "" : m_opts- ] ++ ghc_args+ let (pluginName, hermit_args') = getPlugin hermit_args+ cmds = file_nm : ghcFlags +++ [ "-fplugin=" ++ pluginName ] +++ [ "-fplugin-opt=" ++ pluginName ++ ":" ++ opt | opt <- hermit_args' ] +++ [ "-fplugin-opt=" ++ pluginName ++ ":" ++ m_nm ++ ":" ++ opt+ | (m_nm, m_opts) <- module_args+ , opt <- "" : m_opts+ ] ++ ghc_args putStrLn $ "% ghc " ++ unwords cmds (_,_,_,r) <- createProcess $ proc "ghc" cmds ex <- waitForProcess r exitWith ex++getPlugin :: [String] -> (String, [String])+getPlugin = go "HERMIT" []+ 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
examples/WWSplitTactic.hss view
@@ -10,7 +10,7 @@ { 1; let-intro 'w } let-float-arg { rhs-of 'w- unfold 'fix ; alpha-let 'work+ unfold 'fix ; alpha-let ['work] simplify } let-subst
examples/concatVanishes/ConcatVanishes.hss view
@@ -1,15 +1,7 @@-flatten-module-consider let-{ consider def ; fix-intro }-safe-let-subst-unfold-rule "ww"-any-call (unfold '.)+ww-split-param 1 [|wrap|] [|unwrap|] any-call (unfold 'wrap) one-td (unfold 'unwrap) any-call (unfold '.) innermost (bash >+> push 'repH >+> unfold-rule "repH ++" >+> unfold-rule "repH (:)" >+> apply-rule ". id" >+> apply-rule "id ." >+> unfold-rule "repH []" >+> unfold-rule "[] ++" >+> unfold-rule "[] ++" >+> unfold-rule "(:) ++") any-td (unfold-rule "rep-abs-fusion")-{ consider app ; unfold 'fix ; alpha-let 'work }-bash any-call (unfold 'absH)-try unshadow
examples/concatVanishes/Flatten.hs view
@@ -5,18 +5,13 @@ data Tree a = Node (Tree a) (Tree a) | Leaf a -{-# INLINE unwrap #-} unwrap :: (Tree a -> [a]) -> (Tree a -> H a) unwrap f = repH . f -{-# INLINE wrap #-} wrap :: (Tree a -> H a) -> (Tree a -> [a]) wrap g = absH . g -{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}-{-# RULES "inline-fix" forall f . fix f = let w = f w in w #-}---- flatten :: Tree a -> [a]+flatten :: Tree a -> [a] flatten (Leaf a) = [a] flatten (Node l r) = flatten l ++ flatten r
examples/concatVanishes/QSort.hs view
@@ -6,18 +6,13 @@ data Tree a = Node (Tree a) (Tree a) | Leaf a -{-# INLINE unwrap #-}-unwrap :: ([a] -> [a]) -> ([a] -> H a)+unwrap :: ([a] -> [a]) -> ([a] -> H a) unwrap f = repH . f -{-# INLINE wrap #-}-wrap :: ([a] -> H a) -> ([a] -> [a])+wrap :: ([a] -> H a) -> ([a] -> [a]) wrap g = absH . g -{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}-{-# RULES "inline-fix" forall f . fix f = let w = f w in w #-}---- qsort :: Ord a => [a] -> [a]+qsort :: Ord a => [a] -> [a] qsort [] = [] qsort (a:as) = qsort bs ++ [a] ++ qsort cs where
examples/concatVanishes/Rev.hs view
@@ -3,20 +3,16 @@ import HList import Data.Function (fix) -{-# INLINE unwrap #-} unwrap :: ([a] -> [a]) -> ([a] -> H a) unwrap f = repH . f -{-# INLINE wrap #-} wrap :: ([a] -> H a) -> ([a] -> [a]) wrap g = absH . g -{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}---- rev :: [a] -> [a]+rev :: [a] -> [a] rev [] = [] rev (y:ys) = rev ys ++ [y] main :: IO ()-main = print $ length $ rev [1..15000]+main = print $ rev [1..10]
examples/evaluation/Eval.hs view
@@ -26,8 +26,5 @@ wrap :: (Expr -> (Int -> Mint) -> Mint -> Mint) -> Expr -> Mint wrap h e = h e Just Nothing -{-# RULES "ww" forall f. fix f = wrap (fix (unwrap . f . wrap)) #-}-{-# RULES "fusion" forall w. unwrap (wrap w) = w #-} -- has precondition- main :: IO () main = print (eval $ Val 5)
examples/evaluation/Eval.hss view
@@ -1,6 +1,6 @@ flatten-module consider 'eval-load "../WWSplitTactic.hss"+ww-split [| wrap |] [| unwrap |] {rhs-of 'work eta-expand 'e ; 0 eta-expand 's ; 0@@ -13,7 +13,7 @@ consider case ; 2 ; 0 ; abstract 'n } any-bu (fold 'unwrap)- any-bu (unfold-rule "fusion")+ any-bu (foreward (ww-fusion [| wrap |] [|unwrap|] [|work|])) } simplify any-call (unfold 'wrap)
examples/factorial/Fac.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE MagicHash #-} +module Main where+ import Prelude hiding ((*),(-)) import GHC.Exts import Data.Function(fix)@@ -14,8 +16,6 @@ wrap :: (Int# -> Int#) -> Int -> Int wrap h (I# x) = I# (h x)--{-# RULES "ww" forall f. fix f = wrap (fix (unwrap . f . wrap)) #-} main :: IO () main = print (fac 10)
examples/factorial/Fac.hss view
@@ -1,6 +1,6 @@ flatten-module consider 'fac-load "../WWSplitTactic.hss"+ww-split [| wrap |] [| unwrap |] {rhs-of 'work eta-expand 'x one-td (unfold 'unwrap)@@ -16,5 +16,7 @@ simplify innermost case-float-case }+simplify+innermost (case-float <+ case-reduce) simplify { consider let ; 1 ; eta-expand 'n ; any-call (unfold 'wrap) }
examples/fib-stream/Fib.hs view
@@ -17,7 +17,5 @@ unwrap :: (Nat -> a) -> Stream a unwrap f = map f nats -{-# RULES "ww" forall f. fix f = wrap (fix (unwrap . f . wrap)) #-}- main :: IO () main = print (fromNat $ fib $ toNat 30)
examples/fib-stream/Fib.hss view
@@ -1,7 +1,7 @@ flatten-module consider 'fib {- load "../WWSplitTactic.hss"+ ww-split [| wrap Nat |] [| unwrap Nat |] {rhs-of 'work unfold 'unwrap any-call (unfold 'f)
examples/fib-tuple/Fib.hs view
@@ -1,15 +1,11 @@+module Main where+ -- so we can fix-intro import Data.Function (fix) --- so we can let-tuple-import GHC.Tuple- import Prelude hiding ((+)) data Nat = Z | S Nat--{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}-{-# RULES "precondition" forall w . wrap (unwrap w) = w #-} (+) :: Nat -> Nat -> Nat Z + n = n
examples/fib-tuple/Fib.hss view
@@ -3,12 +3,12 @@ { -load "../WWSplitTactic.hss"+ww-split [| wrap |] [| unwrap |] consider 'work ; remember origwork -- work = unwrap (f (wrap work)) -down ; eta-expand 'n+0 ; eta-expand 'n -- work n = unwrap (f (wrap work)) n @@ -16,7 +16,7 @@ -- work n = (f (wrap work) n, f (wrap work) (n+1)) -down ; case-split-inline 'n+0 ; case-split-inline 'n -- work 0 = (f (wrap work) 0, f (wrap work) 1) -- work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+2))@@ -33,14 +33,15 @@ -- work 0 = (0, 1) -- work (n+1) = (f (wrap work) (n+1), wrap (unwrap (f (wrap work))) (n+1) + wrap (unwrap (f (wrap work))) n) -any-bu (unfold-rule precondition)+any-bu (foreward (ww-assumption-A [| wrap |] [| unwrap |])) -- work 0 = (0, 1) -- work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+1) + f (wrap work) n) { 1 ; 1 ; let-intro 'x } { 0 ; 1 ; let-intro 'y }-innermost (let-float-arg <+ let-float-app)+innermost let-float+try (reorder-lets ['x,'y]) one-td (fold 'y) let-tuple 'xy
examples/flatten/Flatten.hs view
@@ -5,18 +5,13 @@ data Tree a = Node (Tree a) (Tree a) | Leaf a -{-# INLINE unwrap #-} unwrap :: (Tree a -> [a]) -> (Tree a -> H a) unwrap f = repH . f -{-# INLINE wrap #-} wrap :: (Tree a -> H a) -> (Tree a -> [a]) wrap g = absH . g -{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}-{-# RULES "inline-fix" forall f . fix f = let w = f w in w #-}---- flatten :: Tree a -> [a]+flatten :: Tree a -> [a] flatten (Leaf a) = [a] flatten (Node l r) = flatten l ++ flatten r
examples/flatten/Flatten.hss view
@@ -1,37 +1,20 @@ flatten-module consider 'flatten-{- consider 'flatten- fix-intro- 0- unfold-rule "ww"- any-call (unfold '.)- any-call (unfold 'wrap)- any-call (unfold 'unwrap)- any-call (unfold '.)- bash- unshadow- any-bu case-float-arg- {- consider case- any-bu (apply-rule "repH ++")- bash- any-bu (unfold-rule "rep-abs-fusion")- {- 2- 0- unfold-rule "repH (:)"- one-td (unfold-rule "repH []")- unfold-rule "(.) id"- }- }- {- consider app- unfold 'fix- alpha-let 'work- }-}+ww-split-param 1 [|wrap|] [|unwrap|] bash-try unshadow-one-td (unfold 'absH)-+{consider lam ; alpha-lam 't}+any-call (unfold 'wrap)+any-call (unfold 'unwrap)+simplify+{rhs-of 'work+ 0+ 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+}+any-call (unfold 'absH)
examples/flatten/HList.hs view
@@ -14,26 +14,7 @@ absH :: H a -> [a] absH f = f [] --- These two we may get for free via INLINE-{-# RULES "repH" forall xs . repH xs = (xs ++) #-}-{-# RULES "absH" forall f . absH f = f [] #-}- -- The "Algebra" for repH {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} {-# RULES "repH []" repH [] = id #-} {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}---- Should be in the "List" module-{-# RULES "(:) ++" forall x xs ys . (x:xs) ++ ys = x : (xs ++ ys) #-}-{-# RULES "[] ++" forall xs . [] ++ xs = xs #-}---- Should be somewhere else-{-# RULES "(.) id" forall f . f . id = f #-}---- has preconditon-{-# RULES "rep-abs-fusion" forall h . repH (absH h) = h #-}-----
examples/hanoi/Hanoi.hs view
@@ -1,11 +1,10 @@ module Main where -import Criterion.Main+-- import Criterion.Main import Control.Monad (forM_) import Data.Function (fix)-import GHC.Tuple data Nat = Z | S Nat @@ -39,8 +38,6 @@ -- [ bench "4" $ whnf hanoi 4 -- ] -{-# RULES "ww" forall work. fix work = wrap (fix (unwrap . work . wrap)) #-}-{-# RULES "pc" forall w. wrap (unwrap w) = w #-} {-# RULES "++ []" forall l. l ++ [] = l #-} {-# RULES "[] ++" forall l. [] ++ l = l #-}
examples/hanoi/Hanoi.hss view
@@ -2,7 +2,7 @@ -- do the w/w split consider 'hanoi-{ load "../WWSplitTactic.hss" }+{ ww-split [| wrap |] [| unwrap |] } { consider 'work remember origwork@@ -18,7 +18,7 @@ { 2 ; down ; case-split-inline 'a { 1 ; any-call (unfold 'f) ; simplify any-call (unfold origwork)- any-call (unfold-rule pc)+ any-call (foreward (ww-assumption-A [| wrap |] [| unwrap |])) any-call (unfold 'f) simplify any-call (unfold-rule "[] ++")@@ -27,13 +27,13 @@ { 2 ; any-call (unfold 'f) ; simplify any-call (unfold origwork)- any-call (unfold-rule pc)+ any-call (foreward (ww-assumption-A [| wrap |] [| unwrap |])) any-call (unfold 'f)- simplify+ innermost let-subst ; simplify -- recursion decrements by two, so must do this again any-call (unfold origwork)- any-call (unfold-rule pc)+ any-call (foreward (ww-assumption-A [| wrap |] [| unwrap |])) -- time to let intro -- need a "occurance 'work" like consider@@ -46,6 +46,7 @@ { 1 ; 1 ; 0 ; 1 ; let-intro 'w } } innermost let-float+ try (reorder-lets ['u,'v,'w]) any-call (fold 'u) any-call (fold 'v) any-call (fold 'w)
examples/last/Last.hs view
@@ -10,9 +10,7 @@ wrap f [] = error "wrap _ []" wrap f (a:as) = f a as -{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}---- last :: [a] -> a+last :: [a] -> a last [] = error "last []" last [a] = a last (_:a:as) = last (a:as)
examples/last/Last.hss view
@@ -1,20 +1,17 @@ flatten-module consider 'last-{consider 'last- load "../WWSplitTactic.hss"- {rhs-of 'work- eta-expand 'b- 0- eta-expand 'bs- 0- unfold 'unwrap- unfold 'f- case-reduce- consider app- unfold 'wrap- case-reduce- }+ww-split-param 1 [|wrap|] [|unwrap|]+{rhs-of 'work+ eta-expand 'b+ 0+ eta-expand 'bs+ 0+ unfold 'unwrap+ unfold 'f+ bash+ consider app+ unfold 'wrap+ bash }-simplify any-call (unfold 'wrap)-+bash
examples/mean/Mean.hs view
@@ -1,8 +1,6 @@-import Prelude hiding (sum, length)+module Main where --- so we can let-tuple-import Data.Tuple-import GHC.Tuple+import Prelude hiding (sum, length) {-# NOINLINE mean #-} mean :: [Int] -> Int
examples/mean/Mean.hss view
@@ -2,6 +2,7 @@ { 1 ; let-intro 'l } { 0 ; 1 ; let-intro 's } innermost let-float+ try (reorder-lets ['s,'l]) let-tuple 'sl { 0 ; abstract 'xs ; 0 ; let-intro 'sumlength } }@@ -15,10 +16,13 @@ any-call (unfold 'sum) any-call (unfold 'length) simplify- 2 ; 0+ 2+ alpha-alt ['y,'ys]+ 0 { 1 ; 1 ; let-intro 'l } { 0 ; 1 ; 1 ; let-intro 's } innermost let-float+ try (reorder-lets ['s,'l]) let-tuple 'sl { 0 ; fold sumlen } }
examples/qsort/HList.hs view
@@ -14,24 +14,10 @@ absH :: H a -> [a] absH f = f [] --- These two we may get for free via INLINE-{-# RULES "repH" forall xs . repH xs = (xs ++) #-}-{-# RULES "absH" forall f . absH f = f [] #-}- -- The "Algebra" for repH {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} {-# RULES "repH []" repH [] = id #-} {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}---- Should be in the "List" module-{-# RULES "(:) ++" forall x xs ys . (x:xs) ++ ys = x : (xs ++ ys) #-}-{-# RULES "[] ++" forall xs . [] ++ xs = xs #-}---- Should be somewhere else-{-# RULES "(.) id" forall f . f . id = f #-}---- has preconditon-{-# RULES "rep-abs-fusion" forall h . repH (absH h) = h #-}
examples/qsort/QSort.hs view
@@ -6,18 +6,13 @@ data Tree a = Node (Tree a) (Tree a) | Leaf a -{-# INLINE unwrap #-} unwrap :: ([a] -> [a]) -> ([a] -> H a) unwrap f = repH . f -{-# INLINE wrap #-} wrap :: ([a] -> H a) -> ([a] -> [a]) wrap g = absH . g -{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}-{-# RULES "inline-fix" forall f . fix f = let w = f w in w #-}---- qsort :: Ord a => [a] -> [a]+qsort :: Ord a => [a] -> [a] qsort [] = [] qsort (a:as) = qsort bs ++ [a] ++ qsort cs where
examples/qsort/QSort.hss view
@@ -1,36 +1,29 @@ flatten-module consider 'qsort-{- consider 'qsort- fix-intro- 0- unfold-rule "ww"- any-call (unfold '.)- any-call (unfold 'wrap)- any-call (unfold 'unwrap)- any-call (unfold '.)- bash+ww-split-param 1 [|wrap|] [|unwrap|]+bash+{consider lam ; alpha-lam 't}+any-call (unfold 'wrap)+any-call (unfold 'unwrap)+simplify+{rhs-of 'work+ alpha-lam 'xs any-td case-float-arg+ 0+ eta-expand 'acc bash- {- consider case- any-td (unfold-rule "repH ++")- any-td (unfold-rule "rep-abs-fusion")- any-td (unfold-rule "repH (:)")- any-td (unfold-rule "repH []")- any-call (unfold '.)- bash- { consider let- repeat let-subst -- maybe if we folded the (.) then safe-let-subst would fire and this would be unneccassary- }- any-td (unfold-rule "(.) id")+ {consider case ; consider case ; 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 }-}-{- consider app- unfold 'fix- alpha-let 'work+ any-call (unfold-rule "repH []")+ any-call (unfold 'id) }-bash one-td (unfold 'absH)
examples/reverse/HList.hs view
@@ -14,21 +14,10 @@ absH :: H a -> [a] absH f = f [] --- These two we may get for free via INLINE-{-# RULES "repH" forall xs . repH xs = (xs ++) #-}-{-# RULES "absH" forall f . absH f = f [] #-}- -- The "Algebra" for repH {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} {-# RULES "repH []" repH [] = id #-} {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}---- Should be in the "List" module-{-# RULES "(:) ++" forall x xs ys . (x:xs) ++ ys = x : (xs ++ ys) #-}-{-# RULES "[] ++" forall xs . [] ++ xs = xs #-}---- has preconditon-{-# RULES "rep-abs-fusion" forall h . repH (absH h) = h #-}
examples/reverse/Reverse.hs view
@@ -1,25 +1,17 @@ module Main where -import Criterion.Main import HList import Data.Function (fix) -{-# INLINE unwrap #-} unwrap :: ([a] -> [a]) -> ([a] -> H a) unwrap f = repH . f -{-# INLINE wrap #-} wrap :: ([a] -> H a) -> ([a] -> [a]) wrap g = absH . g -{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-}-{-# RULES "inline-fix" forall f . fix f = let w = f w in w #-}---- rev :: [a] -> [a]+rev :: [a] -> [a] rev [] = [] rev (x:xs) = rev xs ++ [x] -main = defaultMain- [ bench (show n) $ whnf (\n -> sum $ rev [1..n]) n- | n <- take 8 $ [50,100..]- ]+main :: IO ()+main = print $ rev "hello"
examples/reverse/Reverse.hss view
@@ -1,30 +1,21 @@--- set-renderer latex--- set-renderer unicode-console--- unicode-terminal- flatten-module---- This is the outer rev, with the big lambda consider 'rev- consider 'rev- fix-intro- any-call (unfold-rule "ww")- any-call (unfold '.)- any-call (unfold 'wrap)- any-call (unfold 'unwrap)- any-call (unfold '.)- unshadow ; bash- any-bu case-float-arg- any-bu (apply-rule "repH ++") ; bash- any-bu (apply-rule "repH []") ; bash- any-bu (unfold-rule "rep-abs-fusion")-- -- This is just a setup to all completion- { consider case ; eta-expand 'ys ; any-bu case-float-app }- any-call (unfold 'repH)- any-call (unfold '.)- any-call (unfold-rule "(:) ++")- any-call (unfold-rule "[] ++")- any-call (unfold 'fix) ; bash- unshadow- any-call (unfold 'absH)+ww-split-param 1 [|wrap|] [|unwrap|]+bash+{consider lam ; alpha-lam 't}+any-call (unfold 'wrap)+any-call (unfold 'unwrap)+simplify+{rhs-of 'work+ alpha-lam 'ys+ 0+ 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)+}+any-call (unfold 'absH)
− examples/reverse/ReverseWW.hss
@@ -1,29 +0,0 @@-flatten-module-consider 'rev-{consider 'rev- load "../WWSplitTactic.hss"- {rhs-of 'work- any-call (unfold 'wrap)- any-call (unfold 'f)- any-call (unfold 'unwrap)- any-call (unfold '.)- simplify- alpha-lam 'ys- {0- eta-expand 'acc- innermost case-float- one-td (unfold-rule "repH []")- one-td (unfold 'id)- one-td (unfold-rule "repH ++")- one-td (unfold-rule "rep-abs-fusion")- one-td (unfold 'repH)- any-call (unfold '.)- any-call (unfold-rule "(:) ++")- any-call (unfold-rule "[] ++")- }- }-}-any-call (unfold 'wrap)-any-call (unfold '.)-any-call (unfold 'absH)-simplify
hermit.cabal view
@@ -1,5 +1,5 @@ Name: hermit-Version: 0.1.6.0+Version: 0.1.8.0 Synopsis: Haskell Equational Reasoning Model-to-Implementation Tunnel Description: HERMIT uses Haskell to express semi-formal models,@@ -13,8 +13,6 @@ . * Command line completion is ad hoc at the moment. .- * Parser needs to be reimplemented with a parsing library.- . * log command prints linearly, even if command history is a tree. . * The fold rewrite can only fold syntactically alpha-equivalent (up to@@ -38,12 +36,12 @@ . @ $ hermit Reverse.hs Reverse.hss resume- [starting HERMIT v0.1.6.0 on Reverse.hs]- % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:main:Main: -fplugin-opt=HERMIT:main:Main:resume+ [starting HERMIT v0.1.8.0 on Reverse.hs]+ % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:Main:Reverse.hss -fplugin-opt=HERMIT:Main:resume [1 of 2] Compiling HList ( HList.hs, HList.o ) Loading package ghc-prim ... linking ... done. ...- Loading package hermit-0.1.6.0 ... linking ... done.+ Loading package hermit-0.1.8.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) Linking Reverse ... $ ./Reverse@@ -54,24 +52,24 @@ . @ $ hermit Reverse.hs- [starting HERMIT v0.1.6.0 on Reverse.hs]- % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:main:Main:+ [starting HERMIT v0.1.8.0 on Reverse.hs]+ % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:Main: [1 of 2] Compiling HList ( HList.hs, HList.o ) Loading package ghc-prim ... linking ... done. ...- Loading package hermit-0.1.6.0 ... linking ... done.+ Loading package hermit-0.1.8.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) module main:Main where- \ \ rev ∷ ∀ a . [] a -> [] a- \ \ unwrap ∷ ∀ a . ([] a -> [] a) -> [] a -> H a- \ \ wrap ∷ ∀ a . ([] a -> H a) -> [] a -> [] a+ \ \ rev ∷ ∀ a . [a] -> [a]+ \ \ unwrap ∷ ∀ a . ([a] -> [a]) -> [a] -> H a+ \ \ wrap ∷ ∀ a . ([a] -> H a) -> [a] -> [a] \ \ main ∷ IO () \ \ main ∷ IO () hermit\<0\> ... @ .- To resume compile, use resume.+ To resume compilation, use resume. . @ ...@@ -124,43 +122,48 @@ examples/reverse/HList.hs examples/reverse/Reverse.hs examples/reverse/Reverse.hss- examples/reverse/ReverseWW.hss Library ghc-options: -Wall -fno-warn-orphans Build-Depends: base >= 4 && < 5,- aeson >= 0.6.0.2, ansi-terminal >= 0.5.5,+ array, containers >= 0.5.0.0, data-default >= 0.5.0,- ghc == 7.6.*,+ ghc >= 7.6, haskeline >= 0.7.0.3,- kure >= 2.6.14,+ kure >= 2.6.22, marked-pretty >= 0.1, mtl >= 2.1.2,+ operational >= 0.2.2.1, stm >= 2.4, template-haskell >= 2.8.0.0,- text >= 0.11.2.3+ transformers default-language: Haskell2010 Exposed-modules: HERMIT+ HERMIT.Driver Language.HERMIT.Context Language.HERMIT.Core Language.HERMIT.Dictionary- Language.HERMIT.Expr Language.HERMIT.External+ Language.HERMIT.GHC+ Language.HERMIT.Interp Language.HERMIT.Kernel Language.HERMIT.Kernel.Scoped Language.HERMIT.Kure- Language.HERMIT.Interp Language.HERMIT.Monad+ Language.HERMIT.Optimize+ Language.HERMIT.Parser+ Language.HERMIT.ParserCore Language.HERMIT.Plugin Language.HERMIT.Primitive.AlphaConversion+ Language.HERMIT.Primitive.Common Language.HERMIT.Primitive.Debug Language.HERMIT.Primitive.FixPoint Language.HERMIT.Primitive.Fold@@ -170,31 +173,36 @@ 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.New Language.HERMIT.Primitive.Unfold - Language.HERMIT.PrettyPrinter Language.HERMIT.PrettyPrinter.AST Language.HERMIT.PrettyPrinter.Clean+ Language.HERMIT.PrettyPrinter.Common Language.HERMIT.PrettyPrinter.GHC- Language.HERMIT.PrettyPrinter.JSON Language.HERMIT.Shell.Command Other-modules:- Language.HERMIT.GHC+ Language.HERMIT.Syntax - Language.HERMIT.Primitive.Common+ Paths_hermit Hs-Source-Dirs: src Executable hermit Build-Depends: base >= 4 && < 5, directory >= 1.2.0.0,+ hermit, process default-language: Haskell2010 Main-Is: Main.hs Hs-Source-Dirs: driver Ghc-Options:++source-repository head+ type: git+ location: git://github.com/ku-fpg/hermit.git
src/HERMIT.hs view
@@ -2,12 +2,7 @@ import GhcPlugins -import Language.HERMIT.Shell.Command as Dispatch-import Language.HERMIT.Plugin-import System.Console.Haskeline (defaultBehavior)+import Language.HERMIT.Optimize plugin :: Plugin-plugin = hermitPlugin interactive--interactive :: HermitPass-interactive opts modGuts = Dispatch.commandLine opts defaultBehavior modGuts+plugin = optimize $ \ options -> phase 0 $ interactive [] options
+ src/HERMIT/Driver.hs view
@@ -0,0 +1,16 @@+module HERMIT.Driver where++import Data.Version+import Paths_hermit as P++hermit_version :: String +hermit_version = "HERMIT v" ++ showVersion P.version++ghcFlags :: [String]+ghcFlags = [ "-fforce-recomp"+ , "-O2"+ , "-dcore-lint"+ , "-fsimple-list-literals"+ , "-fexpose-all-unfoldings"+-- , "-v0"+ ]
src/Language/HERMIT/Context.hs view
@@ -47,6 +47,7 @@ hermitBindingDepth (LAM d) = d hermitBindingDepth (BIND d _ _) = d hermitBindingDepth (CASE d _ _) = d+{-# INLINE hermitBindingDepth #-} ------------------------------------------------------------------------ @@ -66,14 +67,16 @@ instance PathContext HermitC where absPath :: HermitC -> AbsolutePath absPath = hermitPath+ {-# INLINE absPath #-} (@@) :: HermitC -> Int -> HermitC c @@ n = c { hermitPath = hermitPath c @@ n }-+ {-# INLINE (@@) #-} -- | Create the initial HERMIT 'HermitC' by providing a 'ModGuts'. initHermitC :: ModGuts -> HermitC initHermitC modGuts = HermitC empty 0 rootAbsPath modGuts+{-# INLINE initHermitC #-} ------------------------------------------------------------------------ @@ -88,6 +91,7 @@ in c { hermitBindings = newBds , hermitDepth = nextDepth }+{-# INLINE addBinding #-} -- | Add the bindings for a specific case alternative. addCaseBinding :: (Id,CoreExpr,CoreAlt) -> HermitC -> HermitC@@ -95,6 +99,7 @@ in c { hermitBindings = insert v (CASE nextDepth e (con,vs)) (hermitBindings c) , hermitDepth = nextDepth }+{-# INLINE addCaseBinding #-} -- | Add a lambda bound variable to a context. -- All that is known is the variable, which may shadow something.@@ -104,34 +109,42 @@ in c { hermitBindings = insert v (LAM nextDepth) (hermitBindings c) , hermitDepth = nextDepth }+{-# INLINE addLambdaBinding #-} --- | Add the identifiers bound by a 'DataCon' in a case. Like lambda bindings,+-- | Add the variables bound by a 'DataCon' in a case. Like lambda bindings, -- in that we know nothing about them, but all bound at the same depth, -- so we cannot just fold 'addLambdaBinding' over the list.-addAltBindings :: [Id] -> HermitC -> HermitC+addAltBindings :: [Var] -> HermitC -> HermitC addAltBindings vs c = let nextDepth = succ (hermitDepth c) in c { hermitBindings = foldr (\ v bds -> insert v (LAM nextDepth) bds) (hermitBindings c) vs , hermitDepth = nextDepth }+{-# INLINE addAltBindings #-}+-- TODO: Is treating case-alternative bindings as lambda bindings okay?+-- There's no issues with lambda bindings being sequential and case-alternative bindings being in parallel? ------------------------------------------------------------------------ -- | Lookup the binding for a variable in a context. lookupHermitBinding :: Var -> HermitC -> Maybe HermitBinding lookupHermitBinding n env = lookup n (hermitBindings env)+{-# INLINE lookupHermitBinding #-} -- | List all the variables bound in a context. boundVars :: HermitC -> [Var] boundVars = keys . hermitBindings+{-# INLINE boundVars #-} -- | Determine if a variable is bound in a context. boundIn :: Var -> HermitC -> Bool boundIn i c = i `elem` boundVars c+{-# INLINE boundIn #-} ------------------------------------------------------------------------ -- | List all variables bound in the context that match the given name. findBoundVars :: TH.Name -> HermitC -> [Var] findBoundVars nm = filter (cmpTHName2Var nm) . boundVars+{-# INLINE findBoundVars #-} ------------------------------------------------------------------------
src/Language/HERMIT/Core.hs view
@@ -13,16 +13,19 @@ , bindsToProg , bindToIdExprs -- * Utilities- , isType- , typeExprToType+ , isCoArg , exprTypeOrKind+ , endoFunType+ , funArgResTypes+ , funsWithInverseTypes , appCount ) where -import Data.Maybe(isJust)- import GhcPlugins +import Language.KURE.Combinators.Monad+import Language.KURE.MonadCatch+ --------------------------------------------------------------------- -- $typenote@@ -55,16 +58,19 @@ 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. bindToIdExprs :: CoreBind -> [(Id,CoreExpr)] bindToIdExprs (NonRec v e) = [(v,e)] bindToIdExprs (Rec bds) = bds+{-# INLINE bindToIdExprs #-} -- | A (potentially recursive) definition is an identifier and an expression. -- In GHC Core, recursive definitions are encoded as ('Id', 'CoreExpr') pairs.@@ -74,10 +80,12 @@ -- | 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 #-} ----------------------------------------------------------------------- @@ -86,29 +94,49 @@ ----------------------------------------------------------------------- --- TODO: I don't know what to do about Coercions here, because I don't understand them.---- | Succeeds if the expression is either a 'Type' or type 'Var'.-isType :: CoreExpr -> Bool-isType = isJust . typeExprToType---- | Convert a 'CoreExpr' expression that \is\ a 'Type' into a 'Type'.-typeExprToType :: CoreExpr -> Maybe Type-typeExprToType (Type t) = Just t-typeExprToType (Var v) | isTKVar v = Just (mkTyVarTy v)-typeExprToType _ = Nothing- -- | GHC's 'exprType' function throws an error if applied to a 'Type' (but, inconsistently, return a 'Kind' if applied to a type variable). -- This function returns the 'Kind' of a 'Type', but otherwise behaves as 'exprType'. exprTypeOrKind :: CoreExpr -> Type exprTypeOrKind (Type t) = typeKind t exprTypeOrKind e = exprType e+{-# INLINE exprTypeOrKind #-} +-- | Returns @True@ iff the expression is a 'Coercion' expression at its top level.+isCoArg :: CoreExpr -> Bool+isCoArg (Coercion {}) = True+isCoArg _ = False+{-# INLINE isCoArg #-}+ ----------------------------------------------------------------------- -- | Count the number of nested applications. appCount :: CoreExpr -> Int appCount (App e1 _) = appCount e1 + 1 appCount _ = 0+{-# INLINE appCount #-}++-----------------------------------------------------------------------++-- | 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+{-# INLINE endoFunType #-}++-- | Return the domain and codomain types of a function expression.+funArgResTypes :: Monad m => CoreExpr -> m (Type,Type)+funArgResTypes e = maybe (fail "not a function type.") return (splitFunTy_maybe $ exprType e)+{-# INLINE funArgResTypes #-}++-- | 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)+{-# INLINE funsWithInverseTypes #-} -----------------------------------------------------------------------
src/Language/HERMIT/Dictionary.hs view
@@ -1,13 +1,14 @@ {-# LANGUAGE GADTs, ScopedTypeVariables #-} module Language.HERMIT.Dictionary- ( -- * The HERMIT Dictionary- -- | This is the main namespace. Things tend to be untyped, because the API is accessed via (untyped) names.- Dictionary- , all_externals- , dictionary- , pp_dictionary-) where+ ( -- * The HERMIT Dictionary+ -- | This is the main namespace. Things tend to be untyped, because the API is accessed via (untyped) names.+ Dictionary+ , all_externals+ , dictionary+ , pp_dictionary+ , metaCmd+ ) where -- import Data.Default (def) import Data.Dynamic@@ -18,20 +19,19 @@ import Language.HERMIT.Kure import Language.HERMIT.External -import qualified Language.HERMIT.Primitive.Kure as Kure-import qualified Language.HERMIT.Primitive.Navigation as Navigation-import qualified Language.HERMIT.Primitive.Inline as Inline-import qualified Language.HERMIT.Primitive.Local as Local-import qualified Language.HERMIT.Primitive.New as New+import qualified Language.HERMIT.Primitive.AlphaConversion as Alpha import qualified Language.HERMIT.Primitive.Debug as Debug-import qualified Language.HERMIT.Primitive.GHC as GHC import qualified Language.HERMIT.Primitive.FixPoint as FixPoint import qualified Language.HERMIT.Primitive.Fold as Fold+import qualified Language.HERMIT.Primitive.GHC as GHC+import qualified Language.HERMIT.Primitive.Inline as Inline+import qualified Language.HERMIT.Primitive.Kure as Kure+import qualified Language.HERMIT.Primitive.Local as Local+import qualified Language.HERMIT.Primitive.Navigation as Navigation+import qualified Language.HERMIT.Primitive.New as New import qualified Language.HERMIT.Primitive.Unfold as Unfold-import qualified Language.HERMIT.Primitive.AlphaConversion as Alpha --import Language.HERMIT.PrettyPrinter+import Language.HERMIT.PrettyPrinter.Common import qualified Language.HERMIT.PrettyPrinter.AST as AST import qualified Language.HERMIT.PrettyPrinter.Clean as Clean import qualified Language.HERMIT.PrettyPrinter.GHC as GHCPP@@ -43,17 +43,17 @@ type Dictionary = Map String [Dynamic] prim_externals :: [External]-prim_externals- = Kure.externals- ++ Navigation.externals- ++ Inline.externals- ++ Local.externals- ++ Debug.externals- ++ New.externals- ++ FixPoint.externals- ++ Fold.externals- ++ Unfold.externals- ++ Alpha.externals+prim_externals =+ Alpha.externals+ ++ Debug.externals+ ++ FixPoint.externals+ ++ Fold.externals+ ++ Inline.externals+ ++ Kure.externals+ ++ Local.externals+ ++ Navigation.externals+ ++ New.externals+ ++ Unfold.externals -- The GHC.externals here is a bit of a hack. Not sure about this -- | Augment a list of 'External's by adding all of HERMIT's primitive 'External's, plus any GHC RULES pragmas in the module.
− src/Language/HERMIT/Expr.hs
@@ -1,218 +0,0 @@-module Language.HERMIT.Expr- ( -- * HERMIT Expressions-- -- | This is the /untyped/ command and control language for HERMIT.- ExprH(..)- , StmtH(..)- , parseExprH- , parseStmtsH- , unparseExprH- , unparseStmtH- , unparseStmtsH- , numStmtsH- ) where--import Control.Applicative ((<$>))-import Data.Char-import Data.List--------------------------------------------------- | A simple expression language AST, for things parsed from 'String' or JSON structures.-data ExprH- = SrcName String -- ^ Variable names (refers to source code).- | CmdName String -- ^ Commands (to be looked up in 'Language.HERMIT.Dictionary').- | AppH ExprH ExprH -- ^ Application.- deriving (Eq, Show)---- | Nested lists to represent scoping structure.-data StmtH expr- = ExprH expr- | ScopeH [StmtH expr]- deriving Show--data Box e = InfixableExpr e | Box e deriving Show--------------------------------------------------- TODO: This is a quick hack that's better than just saying "N"; I have no idea how accurate this is.---- | Count the total number of statements.-numStmtH :: StmtH expr -> Int-numStmtH (ExprH _) = 1-numStmtH (ScopeH ss) = numStmtsH ss---- | Count the total number of statements.-numStmtsH :: [StmtH expr] -> Int-numStmtsH = sum . map numStmtH-------------------------------------------------unparseExprH :: ExprH -> String-unparseExprH (SrcName nm) = "'" ++ nm-unparseExprH (CmdName nm)- | all isId nm = nm- | otherwise = show nm -- with quotes-unparseExprH (AppH (AppH (CmdName nm) e1) e2)- | all isInfixId nm- = unparseAtom e1 ++ " " ++ nm ++ " " ++ unparseAtom e2-unparseExprH (AppH e1 e2) = unparseExprH e1 ++ " " ++ unparseAtom e2--unparseAtom :: ExprH -> String-unparseAtom e@(AppH {}) = "(" ++ unparseExprH e ++ ")"-unparseAtom e = unparseExprH e---unparseStmtH :: StmtH ExprH -> String-unparseStmtH (ExprH expr) = unparseExprH expr-unparseStmtH (ScopeH stmts) = "{ " ++ unparseStmtsH stmts ++ "}"--unparseStmtsH :: [StmtH ExprH] -> String-unparseStmtsH stmts = intercalate " ; " (map unparseStmtH stmts)--------------------------------------------------- Cheap and cheerful parser. Pretty hacky for now--parse :: ReadS a -> String -> Either String a-parse p str = case p str of- (a,rest) : _ | all isSpace rest -> Right a- _ -> Left $ "User error, cannot parse: " ++ str--many :: ReadS a -> ReadS [a]-many p inp =- some p inp ++- [ ([], inp) ]--some :: ReadS a -> ReadS [a]-some p inp =- [ (x:xs,inp2)- | (x,inp1) <- p inp- , (xs,inp2) <- many p inp1- ]--bind :: ReadS a -> (a -> ReadS b) -> ReadS b-bind m k inp =- [ (b,inp2)- | (a,inp1) <- m inp- , (b,inp2) <- k a inp1- ]---------------------------------------------------- | Parse an expression.-parseExprH :: String -> Either String ExprH-parseExprH = parse parseExprH1---- | Parse a list of statements, seperated by semicolons.-parseStmtsH :: String -> Either String [StmtH ExprH]-parseStmtsH = parse parseExprsH'-------------------------------------------------parseExprsH' :: ReadS [StmtH ExprH]-parseExprsH' inp =- (many (item ";") `bind` \ _ -> -- another hack- (parseTopExprH1 `bind` (\ a ->- (many (item ";") `bind` \ _ -> -- complete hack, needed fixed with real parser- (parseExprsH' `bind` (\ as ->- (\ inp' -> [(a:as,inp')]))))))) inp ++ [ ([], inp) ]----parseTopExprH1 :: ReadS (StmtH ExprH)-parseTopExprH1 inp =- (parseExprH1 `bind` \ es inp1 -> [(ExprH es,inp1)]) inp ++- [ (ScopeH es,inp3)- | ("{",inp1) <- parseToken inp- , (es,inp2) <- parseExprsH' inp1- , ("}",inp3) <- parseToken inp2- ]---parseExprH0 :: ReadS (Box ExprH)-parseExprH0 inp =- [ (Box (CmdName str),inp1)- | (str,inp1) <- parseToken inp- , isAlphaNum (head str) || head str == ':' -- commands can start with : -- This can probably be removed now, as we no longer start commands with :- , all isId (tail str)- ] ++- [ (InfixableExpr (CmdName str),inp1)- | (str,inp1) <- parseToken inp- , all isInfixId str- ] ++- [ (Box (SrcName str),inp2)- | ("'",inp1) <- parseToken inp- , (str,inp2) <- parseToken inp1- ] ++- [ (Box (CmdName $ chomp '"' str),inp1)- | (str@('"':_),inp1) <- lex inp- ] ++- [ (Box e,inp3)- | ("(",inp1) <- parseToken inp- , (e,inp2) <- parseExprH1 inp1- , (")",inp3) <- parseToken inp2- ]- where chomp _ [] = []- chomp ch s@(c:cs) | c == ch && last cs == ch = init cs- | otherwise = s--parseExprH1 :: ReadS ExprH-parseExprH1 = some parseExprH0 `bind` \ es inp ->- case mkAppH es id [] of- Nothing -> []- Just r -> [(r,inp)]---- TODO: Assoc to the right, want assoc to the left.-mkAppH :: [Box ExprH] -> (ExprH -> ExprH) -> [ExprH] -> Maybe ExprH-mkAppH (Box e:es) ops rs = mkAppH es ops (rs ++ [e])-mkAppH (InfixableExpr e:es) ops rs = maybe Nothing (\ lhs ->- mkAppH es (ops . AppH (AppH e lhs)) []- ) (mkAppH' rs)-mkAppH [] ops rs = ops <$> mkAppH' rs--mkAppH' :: [ExprH] -> Maybe ExprH-mkAppH' (r:rs) = Just $ foldl AppH r rs-mkAppH' [] = Nothing----mkAppH (e:es) = foldl AppH (f e) (map f es)--- where f (InfixableExpr e) = e--- f (Box e) = e---item :: String -> ReadS ()-item str inp =- [ ((),rest)- | (tok,rest) <- parseToken inp- , tok == str- ]--parseToken :: ReadS String-parseToken [] = []-parseToken ('\n':cs) = [(";",cs)] -- yes, really-parseToken ('(' :cs) = [("(",cs)]-parseToken (')' :cs) = [(")",cs)]-parseToken ('{' :cs) = [("{",cs)]-parseToken ('}' :cs) = [("}",cs)]-parseToken (';' :cs) = [(";",cs)]-parseToken ('\'':cs) = [("'",cs)]-parseToken ('\"':cs) = [("\"",cs)]-parseToken (c :cs) | isSpace c = parseToken cs- | c == ':' = [let (a,b) = span isId cs in (c:a,b) ]- | isAlphaNum c = [span isId (c:cs)]- | isInfixId c = [span isInfixId (c:cs)]-parseToken _ = []-------------------------------------------------isId :: Char -> Bool-isId c = isAlphaNum c || c `elem` "_-'"--isInfixId :: Char -> Bool-isInfixId c = c `elem` "+*/._-:<>"--------------------------------------------------
src/Language/HERMIT/External.hs view
@@ -27,12 +27,16 @@ , TagBox(..) , IntBox(..) , RewriteCoreBox(..)+ , BiRewriteCoreBox(..) , TranslateCoreStringBox(..) , TranslateCoreCheckBox(..) , NameBox(..)+ , CoreString(..)+ , CoreBox(..) , TranslateCorePathBox(..) , StringBox(..)-+ , NameListBox(..)+ , StringListBox(..) ) where import Data.Map hiding (map)@@ -74,7 +78,8 @@ | VersionControl -- ^ Version control. | Bash -- ^ Commands that are run by 'Language.HERMIT.Dictionary.bash'. | Context -- ^ A command that uses its context, such as inline-+ | Unsafe -- ^ Commands that are either not type safe (may cause core lint to fail),+ -- or allow behavior-altering changes. | TODO -- ^ TODO: check before the release. | Unimplemented -- ^ Something is not finished yet, do not use.@@ -109,7 +114,7 @@ [ (Shell, "Shell-specific commands") , (Eval, "The arrow of evaluation (reduces a term)") , (KURE, "Commands the directly reflect the KURE DSL")- , (Loop, "Command may operate multiple times")+ , (Loop, "Command may operate multiple times") , (Deep, "Command may make a deep change, can be O(n)") , (Shallow, "Command operates on local nodes only, O(1)") , (Navigation, "Navigate via focus, or directional command")@@ -120,8 +125,9 @@ , (PreCondition, "Operation has a (perhaps undocumented) precondition") , (Debug, "Commands specifically to help debugging") , (VersionControl,"Version Control for Core Syntax")- , (Bash, "Commands that run as part of the bash command.")- , (Context, "Commands that use their context, like inlining")+ , (Bash, "Commands that run as part of the bash command")+ , (Context, "Commands that use their context, such as inlining")+ , (Unsafe, "Commands that are not type safe (may cause core lint to fail), or allow behavior-altering changes") , (TODO, "TO BE assessed before a release") , (Unimplemented,"Something is not finished yet; do not used")@@ -279,6 +285,14 @@ box = RewriteCoreBox unbox (RewriteCoreBox i) = i +data BiRewriteCoreBox = BiRewriteCoreBox (BiRewriteH Core) deriving Typeable++instance Extern (BiRewriteH Core) where+ type Box (BiRewriteH Core) = BiRewriteCoreBox+ box = BiRewriteCoreBox+ unbox (BiRewriteCoreBox i) = i++ data TranslateCoreStringBox = TranslateCoreStringBox (TranslateH Core String) deriving Typeable instance Extern (TranslateH Core String) where@@ -307,7 +321,14 @@ box = TranslateCorePathBox unbox (TranslateCorePathBox i) = i +newtype CoreString = CoreString { unCoreString :: String }+data CoreBox = CoreBox CoreString deriving Typeable +instance Extern CoreString where+ type Box CoreString = CoreBox+ box = CoreBox+ unbox (CoreBox i) = i+ data StringBox = StringBox String deriving Typeable instance Extern String where@@ -316,3 +337,17 @@ unbox (StringBox i) = i -----------------------------------------------------------------++data NameListBox = NameListBox [TH.Name] deriving Typeable++instance Extern [TH.Name] where+ type Box [TH.Name] = NameListBox+ box = NameListBox+ unbox (NameListBox l) = l++data StringListBox = StringListBox [String] deriving Typeable++instance Extern [String] where+ type Box [String] = StringListBox+ box = StringListBox+ unbox (StringListBox l) = l
src/Language/HERMIT/GHC.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Language.HERMIT.GHC ( -- * GHC Imports -- | Things that have been copied from GHC, or imported directly, for various reasons.@@ -28,7 +29,9 @@ import Panic (GhcException(ProgramError), throwGhcException) import CoreArity +#if __GLASGOW_HASKELL__ <= 706 import Data.Maybe (isJust)+#endif import qualified Language.Haskell.TH as TH --------------------------------------------------------------------------@@ -109,7 +112,12 @@ has_caf_info = not (mayHaveCafRefs caf_info) str_info = strictnessInfo info- has_strictness = isJust str_info+ has_strictness = +#if __GLASGOW_HASKELL__ > 706+ True+#else+ isJust str_info+#endif unf_info = unfoldingInfo info has_unf = hasSomeUnfolding unf_info
src/Language/HERMIT/Interp.hs view
@@ -7,7 +7,7 @@ , interpExprH ) where -import Control.Monad (liftM2)+import Control.Monad (liftM, liftM2) import Data.Char import Data.Dynamic@@ -16,7 +16,7 @@ import qualified Language.Haskell.TH as TH import Language.HERMIT.External-import Language.HERMIT.Expr+import Language.HERMIT.Parser -- | Interpret an 'ExprH' by looking up the appropriate 'Dynamic'(s) in the provided 'Data.Map', then interpreting the 'Dynamic'(s) with the provided 'Interp's, returning the first interpretation to succeed (or an error string if none succeed). interpExprH :: M.Map String [Dynamic] -> [Interp a] -> ExprH -> Either String a@@ -47,8 +47,21 @@ interpExpr :: M.Map String [Dynamic] -> ExprH -> Either String [Dynamic] interpExpr = interpExpr' False +-- input: list length n, each elem is a variable length list of possible interpretations+-- output: variable length list, each elem is list of length n+fromDynList :: [[Dynamic]] -> [[Dynamic]]+fromDynList [] = [[]]+fromDynList (hs:dynss) = [ h:t | h <- hs, t <- fromDynList dynss ]++toBoxedList :: (Extern a, Typeable b) => [[Dynamic]] -> ([a] -> b) -> [Dynamic]+toBoxedList dyns boxCon = [ toDyn $ boxCon (map unbox l) | dl <- dyns, Just l <- [mapM fromDynamic dl] ]+ interpExpr' :: Bool -> M.Map String [Dynamic] -> ExprH -> Either String [Dynamic] interpExpr' _ _ (SrcName str) = return [ toDyn $ NameBox $ TH.mkName str ]+interpExpr' _ _ (CoreH str) = return [ toDyn $ CoreBox (CoreString str) ]+interpExpr' _ env (ListH exprs) = do dyns <- liftM fromDynList $ mapM (interpExpr' True env) exprs+ return $ toBoxedList dyns NameListBox+ ++ toBoxedList dyns StringListBox interpExpr' rhs env (CmdName str) -- An Int is either a Path, or will be interpreted specially later. | all isDigit str = let i = read str in
src/Language/HERMIT/Kernel/Scoped.hs view
@@ -12,7 +12,7 @@ import Control.Arrow import Control.Concurrent.STM-import Control.Exception.Base (bracketOnError)+import Control.Exception (bracketOnError, catch, SomeException) import qualified Data.IntMap as I @@ -70,16 +70,19 @@ -- | An alternative HERMIT kernel, that provides scoping. data ScopedKernel = ScopedKernel- { resumeS :: SAST -> IO ()+ { resumeS :: SAST -> IO (KureM ()) , abortS :: IO () , applyS :: SAST -> RewriteH Core -> HermitMEnv -> IO (KureM SAST) , queryS :: forall a . SAST -> TranslateH Core a -> HermitMEnv -> IO (KureM a)- , deleteS :: SAST -> IO ()+ , deleteS :: SAST -> IO (KureM ()) , listS :: IO [SAST]- , pathS :: SAST -> IO [Path]+ , pathS :: SAST -> IO (KureM [Path]) , modPathS :: SAST -> (LocalPath -> LocalPath) -> HermitMEnv -> IO (KureM SAST)- , beginScopeS :: SAST -> IO SAST- , endScopeS :: SAST -> IO SAST+ , beginScopeS :: SAST -> IO (KureM SAST)+ , endScopeS :: SAST -> IO (KureM SAST)+ -- means of accessing the underlying kernel, obviously for unsafe purposes+ , kernelS :: Kernel+ , toASTS :: SAST -> IO (KureM AST) } -- | A /handle/ for an 'AST' combined with scoping information.@@ -91,9 +94,14 @@ get :: Monad m => Int -> SASTStore -> m (AST, [LocalPath], LocalPath) get sAst m = maybe (fail "scopedKernel: invalid SAST") return (I.lookup sAst m) -safeTakeTMVar :: TMVar a -> (a -> IO b) -> IO b-safeTakeTMVar mvar = bracketOnError (atomically $ takeTMVar mvar) (atomically . putTMVar mvar)+-- | Ensures that the TMVar is replaced when an error is thrown, and all exceptions are lifted into KureM failures.+safeTakeTMVar :: TMVar a -> (a -> IO b) -> IO (KureM b)+safeTakeTMVar mvar = catchFails . bracketOnError (atomically $ takeTMVar mvar) (atomically . putTMVar mvar) +-- | Lifts exceptions into KureM failures.+catchFails :: IO a -> IO (KureM a)+catchFails io = (io >>= (return.return)) `catch` (\e -> return $ fail $ show (e :: SomeException))+ -- | Start a HERMIT client by providing an IO function that takes the initial 'ScopedKernel' and inital 'SAST' handle. -- The 'Modguts' to 'CoreM' Modguts' function required by GHC Plugins is returned. scopedKernel :: (ScopedKernel -> SAST -> IO ()) -> ModGuts -> CoreM ModGuts@@ -101,17 +109,13 @@ store <- newTMVarIO $ I.fromList [(0,(initAST, [], emptyLocalPath))] key <- newTMVarIO (1::Int) - let failCleanup :: SASTStore -> String -> IO (KureM a)- failCleanup m msg = atomically $ do putTMVar store m- return $ fail msg- let newKey = do k <- takeTMVar key putTMVar key (k+1) return k skernel = ScopedKernel- { resumeS = \ (SAST sAst) -> do+ { resumeS = \ (SAST sAst) -> catchFails $ do m <- atomically $ readTMVar store (ast,_,_) <- get sAst m resumeK kernel ast@@ -121,19 +125,26 @@ applyK kernel ast (focusR (pathStackToLens base rel) rr) env >>= runKureM (\ ast' -> atomically $ do k <- newKey putTMVar store $ I.insert k (ast', base, rel) m- return $ return $ SAST k)- (failCleanup m)- , queryS = \ (SAST sAst) t env -> do+ return $ SAST k)+ fail+ , queryS = \ (SAST sAst) t env -> catchFails $ do m <- atomically $ readTMVar store (ast, base, rel) <- get sAst m queryK kernel ast (focusT (pathStackToLens base rel) t) env- , deleteS = \ (SAST sAst) -> atomically $ do- m <- takeTMVar store- putTMVar store $ I.delete sAst m+ >>= runKureM return fail+ , deleteS = \ (SAST sAst) -> safeTakeTMVar store $ \ m -> do+ (ast,_,_) <- get sAst m+ let m' = I.delete sAst m+ fst3 (x,_,_) = x+ asts = I.foldr ((:) . fst3) [] m'+ if ast `elem` asts+ then return ()+ else deleteK kernel ast+ atomically $ putTMVar store m' , listS = do m <- atomically $ readTMVar store return [ SAST sAst | sAst <- I.keys m ]- , pathS = \ (SAST sAst) -> atomically $ do- m <- readTMVar store+ , pathS = \ (SAST sAst) -> catchFails $ do+ m <- atomically $ readTMVar store (_, base, rel) <- get sAst m return $ localPaths2Paths (rel : base) , modPathS = \ (SAST sAst) f env -> safeTakeTMVar store $ \ m -> do@@ -141,27 +152,30 @@ let rel' = f rel queryK kernel ast (testLensT (pathStackToLens base rel')) env >>= runKureM (\ b -> if rel == rel'- then failCleanup m "Path is unchanged, nothing to do."+ then fail "Path is unchanged, nothing to do." else if b then atomically $ do k <- newKey putTMVar store $ I.insert k (ast, base, rel') m- return (return $ SAST k)- else failCleanup m "Invalid path created.")- (failCleanup m)- , beginScopeS = \ (SAST sAst) -> atomically $ do- m <- takeTMVar store+ return $ SAST k+ else fail "Invalid path created.")+ fail+ , beginScopeS = \ (SAST sAst) -> safeTakeTMVar store $ \m -> do (ast, base, rel) <- get sAst m- k <- newKey- putTMVar store $ I.insert k (ast, rel : base, emptyLocalPath) m- return $ SAST k- , endScopeS = \ (SAST sAst) -> atomically $ do- m <- takeTMVar store+ atomically $ do k <- newKey+ putTMVar store $ I.insert k (ast, rel : base, emptyLocalPath) m+ return $ SAST k+ , endScopeS = \ (SAST sAst) -> safeTakeTMVar store $ \m -> do (ast, base, _) <- get sAst m case base of [] -> fail "Scoped Kernel: no scope to end."- rel : base' -> do k <- newKey- putTMVar store $ I.insert k (ast, base', rel) m- return $ SAST k+ rel : base' -> atomically $ do k <- newKey+ putTMVar store $ I.insert k (ast, base', rel) m+ return $ SAST k+ , kernelS = kernel+ , toASTS = \ (SAST sAst) -> catchFails $ do+ m <- atomically $ readTMVar store+ (ast, _, _) <- get sAst m+ return ast } callback skernel $ SAST 0
src/Language/HERMIT/Kure.hs view
@@ -6,11 +6,13 @@ -- | All the required functionality of KURE is exported here, so other modules do not need to import KURE directly. module Language.KURE+ , module Language.KURE.BiTranslate , module Language.KURE.Lens -- * Synonyms -- | In HERMIT, 'Translate', 'Rewrite' and 'Lens' always operate on the same context and monad. , TranslateH , RewriteH+ , BiRewriteH , LensH -- * Congruence combinators -- ** Modguts@@ -53,6 +55,8 @@ , promoteDefR , promoteExprR , promoteAltR+ -- ** BiRewrite Promotions+ , promoteExprBiR -- ** Translate Promotions , promoteModGutsT , promoteProgT@@ -66,6 +70,7 @@ import GhcPlugins hiding (empty) import Language.KURE+import Language.KURE.BiTranslate import Language.KURE.Lens import Language.HERMIT.Core@@ -78,6 +83,7 @@ type TranslateH a b = Translate HermitC HermitM a b type RewriteH a = Rewrite HermitC HermitM a+type BiRewriteH a = BiRewrite HermitC HermitM a type LensH a b = Lens HermitC HermitM a b -- I find it annoying that Applicative is not a superclass of Monad.@@ -95,60 +101,72 @@ inject :: ModGuts -> Core inject = GutsCore+ {-# INLINE inject #-} project :: Core -> Maybe ModGuts project (GutsCore guts) = Just guts project _ = Nothing+ {-# INLINE project #-} instance Injection CoreProg Core where inject :: CoreProg -> Core inject = ProgCore+ {-# INLINE inject #-} project :: Core -> Maybe CoreProg project (ProgCore bds) = Just bds project _ = Nothing+ {-# INLINE project #-} instance Injection CoreBind Core where inject :: CoreBind -> Core inject = BindCore+ {-# INLINE inject #-} project :: Core -> Maybe CoreBind project (BindCore bnd) = Just bnd project _ = Nothing+ {-# INLINE project #-} instance Injection CoreDef Core where inject :: CoreDef -> Core inject = DefCore+ {-# INLINE inject #-} project :: Core -> Maybe CoreDef project (DefCore def) = Just def project _ = Nothing+ {-# INLINE project #-} instance Injection CoreAlt Core where inject :: CoreAlt -> Core inject = AltCore+ {-# INLINE inject #-} project :: Core -> Maybe CoreAlt project (AltCore expr) = Just expr project _ = Nothing+ {-# INLINE project #-} instance Injection CoreExpr Core where inject :: CoreExpr -> Core inject = ExprCore+ {-# INLINE inject #-} project :: Core -> Maybe CoreExpr project (ExprCore expr) = Just expr project _ = Nothing+ {-# INLINE project #-} --------------------------------------------------------------------- @@ -190,25 +208,30 @@ allRexpr :: MonadCatch m => Rewrite HermitC m CoreExpr allRexpr = readerT $ \case- App _ _ -> appAllR (extractR r) (extractR r)- Lam _ _ -> lamR (extractR r)- Let _ _ -> letAllR (extractR r) (extractR r)+ App _ _ -> appAllR (extractR r) (extractR r)+ Lam _ _ -> lamR (extractR r)+ Let _ _ -> letAllR (extractR r) (extractR r) Case _ _ _ _ -> caseAllR (extractR r) (const $ extractR r) Cast _ _ -> castR (extractR r) Tick _ _ -> tickR (extractR r) _ -> idR {-# INLINE allRexpr #-} +-- NOTE: I tried telling GHC to inline allR and compilation hit the (default) simplifier tick limit.+-- TODO: Investigate whether that was achieving useful optimisations.+ --------------------------------------------------------------------- -- | Translate a module. -- Slightly different to the other congruence combinators: it passes in /all/ of the original to the reconstruction function. modGutsT :: Monad m => Translate HermitC m CoreProg a -> (ModGuts -> a -> b) -> Translate HermitC m ModGuts b modGutsT t f = translate $ \ c guts -> f guts <$> apply t (c @@ 0) (bindsToProg $ mg_binds guts)+{-# INLINE modGutsT #-} -- | Rewrite the 'CoreProg' child of a module. modGutsR :: Monad m => Rewrite HermitC m CoreProg -> Rewrite HermitC m ModGuts modGutsR r = modGutsT r (\ guts p -> guts {mg_binds = progToBinds p})+{-# INLINE modGutsR #-} --------------------------------------------------------------------- @@ -217,24 +240,29 @@ progNilT b = contextfreeT $ \case ProgNil -> return b ProgCons _ _ -> fail "not an empty program node."+{-# INLINE progNilT #-} -- | Translate a program of the form: ('CoreBind' @:@ 'CoreProg') progConsT :: Monad m => Translate HermitC m CoreBind a1 -> Translate HermitC m CoreProg a2 -> (a1 -> a2 -> b) -> Translate HermitC m CoreProg b progConsT t1 t2 f = translate $ \ c -> \case ProgCons bd p -> f <$> apply t1 (c @@ 0) bd <*> apply t2 (addBinding bd c @@ 1) p _ -> fail "not a non-empty program node."+{-# INLINE progConsT #-} -- | Rewrite all children of a program of the form: ('CoreBind' @:@ 'CoreProg') progConsAllR :: Monad m => Rewrite HermitC m CoreBind -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg progConsAllR r1 r2 = progConsT r1 r2 ProgCons+{-# INLINE progConsAllR #-} -- | Rewrite any children of a program of the form: ('CoreBind' @:@ 'CoreProg') progConsAnyR :: MonadCatch m => Rewrite HermitC m CoreBind -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg progConsAnyR r1 r2 = unwrapAnyR $ progConsAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE progConsAnyR #-} -- | Rewrite one child of a program of the form: ('CoreBind' @:@ 'CoreProg') progConsOneR :: MonadCatch m => Rewrite HermitC m CoreBind -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg progConsOneR r1 r2 = unwrapOneR $ progConsAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE progConsOneR #-} --------------------------------------------------------------------- @@ -243,10 +271,12 @@ nonRecT t f = translate $ \ c -> \case NonRec v e -> f v <$> apply t (c @@ 0) e _ -> fail "not a non-recursive binding-group node."+{-# INLINE nonRecT #-} -- | Rewrite the 'CoreExpr' child of a binding group of the form: @NonRec@ 'Var' 'CoreExpr' nonRecR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreBind nonRecR r = nonRecT r NonRec+{-# INLINE nonRecR #-} -- | Translate a binding group of the form: @Rec@ ['CoreDef'] recT :: Monad m => (Int -> Translate HermitC m CoreDef a) -> ([a] -> b) -> Translate HermitC m CoreBind b@@ -257,83 +287,96 @@ | ((v,e),n) <- zip bds [0..] ] _ -> fail "not a recursive binding-group node."+{-# INLINE recT #-} -- | Rewrite all children of a binding group of the form: @Rec@ ['CoreDef'] recAllR :: Monad m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreBind recAllR rs = recT rs defsToRecBind+{-# INLINE recAllR #-} -- | Rewrite any children of a binding group of the form: @Rec@ ['CoreDef'] recAnyR :: MonadCatch m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreBind recAnyR rs = unwrapAnyR $ recAllR (wrapAnyR . rs)+{-# INLINE recAnyR #-} -- | Rewrite one child of a binding group of the form: @Rec@ ['CoreDef'] recOneR :: MonadCatch m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreBind recOneR rs = unwrapOneR $ recAllR (wrapOneR . rs)+{-# INLINE recOneR #-} --------------------------------------------------------------------- -- | Translate a recursive definition of the form: @Def@ 'Id' 'CoreExpr' defT :: Monad m => Translate HermitC m CoreExpr a -> (Id -> a -> b) -> Translate HermitC m CoreDef b defT t f = translate $ \ c (Def v e) -> f v <$> apply t (c @@ 0) e+{-# INLINE defT #-} -- | Rewrite the 'CoreExpr' child of a recursive definition of the form: @Def@ 'Id' 'CoreExpr' defR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreDef defR r = defT r Def+{-# INLINE defR #-} --------------------------------------------------------------------- --- | Translate a case alternative of the form: ('AltCon', ['Id'], 'CoreExpr')-altT :: Monad m => Translate HermitC m CoreExpr a -> (AltCon -> [Id] -> a -> b) -> Translate HermitC m CoreAlt b-altT t f = translate $ \ c (con,bs,e) -> f con bs <$> apply t (addAltBindings bs c @@ 0) e+-- | Translate a case alternative of the form: ('AltCon', ['Var'], 'CoreExpr')+altT :: Monad m => Translate HermitC m CoreExpr a -> (AltCon -> [Var] -> a -> b) -> Translate HermitC m CoreAlt b+altT t f = translate $ \ c (con,vs,e) -> f con vs <$> apply t (addAltBindings vs c @@ 0) e+{-# INLINE altT #-} -- | Rewrite the 'CoreExpr' child of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr') altR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreAlt altR r = altT r (,,)+{-# INLINE altR #-} --------------------------------------------------------------------- --- | Translate an expression of the form: @Var@ 'Var'-varT :: Monad m => (Var -> b) -> Translate HermitC m CoreExpr b+-- | Translate an expression of the form: @Var@ 'Id'+varT :: Monad m => (Id -> b) -> Translate HermitC m CoreExpr b varT f = contextfreeT $ \case Var v -> return (f v) _ -> fail "not a variable node."+{-# INLINE varT #-} -- | Translate an expression of the form: @Lit@ 'Literal' litT :: Monad m => (Literal -> b) -> Translate HermitC m CoreExpr b litT f = contextfreeT $ \case Lit x -> return (f x) _ -> fail "not a literal node."-+{-# INLINE litT #-} -- | Translate an expression of the form: @App@ 'CoreExpr' 'CoreExpr' appT :: Monad m => Translate HermitC m CoreExpr a1 -> Translate HermitC m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate HermitC m CoreExpr b appT t1 t2 f = translate $ \ c -> \case App e1 e2 -> f <$> apply t1 (c @@ 0) e1 <*> apply t2 (c @@ 1) e2 _ -> fail "not an application node."+{-# INLINE appT #-} -- | Rewrite all children of an expression of the form: @App@ 'CoreExpr' 'CoreExpr' appAllR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr appAllR r1 r2 = appT r1 r2 App+{-# INLINE appAllR #-} -- | Rewrite any children of an expression of the form: @App@ 'CoreExpr' 'CoreExpr' appAnyR :: MonadCatch m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr appAnyR r1 r2 = unwrapAnyR $ appAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE appAnyR #-} -- | Rewrite one child of an expression of the form: @App@ 'CoreExpr' 'CoreExpr' appOneR :: MonadCatch m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr appOneR r1 r2 = unwrapOneR $ appAllR (wrapOneR r1) (wrapOneR r2)-+{-# INLINE appOneR #-} -- | Translate an expression of the form: @Lam@ 'Var' 'CoreExpr' lamT :: Monad m => Translate HermitC m CoreExpr a -> (Var -> a -> b) -> Translate HermitC m CoreExpr b lamT t f = translate $ \ c -> \case Lam v e -> f v <$> apply t (addLambdaBinding v c @@ 0) e _ -> fail "not a lambda node."+{-# INLINE lamT #-} -- | Rewrite the 'CoreExpr' child of an expression of the form: @Lam@ 'Var' 'CoreExpr' lamR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr lamR r = lamT r Lam-+{-# INLINE lamR #-} -- | Translate an expression of the form: @Let@ 'CoreBind' 'CoreExpr' letT :: Monad m => Translate HermitC m CoreBind a1 -> Translate HermitC m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate HermitC m CoreExpr b@@ -342,18 +385,22 @@ -- If the bindings are recursive, they will be added to the context by recT. f <$> apply t1 (c @@ 0) bds <*> apply t2 (addBinding bds c @@ 1) e _ -> fail "not a let node."+{-# INLINE letT #-} -- | Rewrite all children of an expression of the form: @Let@ 'CoreBind' 'CoreExpr' letAllR :: Monad m => Rewrite HermitC m CoreBind -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr letAllR r1 r2 = letT r1 r2 Let+{-# INLINE letAllR #-} -- | Rewrite any children of an expression of the form: @Let@ 'CoreBind' 'CoreExpr' letAnyR :: MonadCatch m => Rewrite HermitC m CoreBind -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr letAnyR r1 r2 = unwrapAnyR $ letAnyR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE letAnyR #-} -- | Rewrite one child of an expression of the form: @Let@ 'CoreBind' 'CoreExpr' letOneR :: MonadCatch m => Rewrite HermitC m CoreBind -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr letOneR r1 r2 = unwrapOneR $ letOneR (wrapOneR r1) (wrapOneR r2)+{-# INLINE letOneR #-} -- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']@@ -366,51 +413,60 @@ | (alt,n) <- zip alts [0..] ] _ -> fail "not a case node."+{-# INLINE caseT #-} -- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt'] caseAllR :: Monad m => Rewrite HermitC m CoreExpr -> (Int -> Rewrite HermitC m CoreAlt) -> Rewrite HermitC m CoreExpr caseAllR r rs = caseT r rs Case+{-# INLINE caseAllR #-} -- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt'] caseAnyR :: MonadCatch m => Rewrite HermitC m CoreExpr -> (Int -> Rewrite HermitC m CoreAlt) -> Rewrite HermitC m CoreExpr caseAnyR r rs = unwrapAnyR $ caseAllR (wrapAnyR r) (wrapAnyR . rs)+{-# INLINE caseAnyR #-} -- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt'] caseOneR :: MonadCatch m => Rewrite HermitC m CoreExpr -> (Int -> Rewrite HermitC m CoreAlt) -> Rewrite HermitC m CoreExpr caseOneR r rs = unwrapOneR $ caseAllR (wrapOneR r) (wrapOneR . rs)-+{-# INLINE caseOneR #-} -- | Translate an expression of the form: @Cast@ 'CoreExpr' 'Coercion' castT :: Monad m => Translate HermitC m CoreExpr a -> (a -> Coercion -> b) -> Translate HermitC m CoreExpr b castT t f = translate $ \ c -> \case Cast e cast -> f <$> apply t (c @@ 0) e <*> return cast _ -> fail "not a cast node."+{-# INLINE castT #-} -- | Rewrite the 'CoreExpr' child of an expression of the form: @Cast@ 'CoreExpr' 'Coercion' castR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr castR r = castT r Cast+{-# INLINE castR #-} -- | Translate an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr' tickT :: Monad m => Translate HermitC m CoreExpr a -> (CoreTickish -> a -> b) -> Translate HermitC m CoreExpr b tickT t f = translate $ \ c -> \case Tick tk e -> f tk <$> apply t (c @@ 0) e _ -> fail "not a tick node."+{-# INLINE tickT #-} -- | Rewrite the 'CoreExpr' child of an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr' tickR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr tickR r = tickT r Tick+{-# INLINE tickR #-} -- | Translate an expression of the form: @Type@ 'Type' typeT :: Monad m => (Type -> b) -> Translate HermitC m CoreExpr b typeT f = contextfreeT $ \case Type t -> return (f t) _ -> fail "not a type node."+{-# INLINE typeT #-} -- | Translate an expression of the form: @Coercion@ 'Coercion' coercionT :: Monad m => (Coercion -> b) -> Translate HermitC m CoreExpr b coercionT f = contextfreeT $ \case Coercion co -> return (f co) _ -> fail "not a coercion node."+{-# INLINE coercionT #-} --------------------------------------------------------------------- @@ -419,188 +475,239 @@ -- | Translate a binding group of the form: @Rec@ [('Id', 'CoreExpr')] recDefT :: Monad m => (Int -> Translate HermitC m CoreExpr a1) -> ([(Id,a1)] -> b) -> Translate HermitC m CoreBind b recDefT ts = recT (\ n -> defT (ts n) (,))+{-# INLINE recDefT #-} -- | Rewrite all children of a binding group of the form: @Rec@ [('Id', 'CoreExpr')] recDefAllR :: Monad m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreBind recDefAllR rs = recAllR (\ n -> defR (rs n))+{-# INLINE recDefAllR #-} -- | Rewrite any children of a binding group of the form: @Rec@ [('Id', 'CoreExpr')] recDefAnyR :: MonadCatch m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreBind recDefAnyR rs = recAnyR (\ n -> defR (rs n))+{-# INLINE recDefAnyR #-} -- | Rewrite one child of a binding group of the form: @Rec@ [('Id', 'CoreExpr')] recDefOneR :: MonadCatch m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreBind recDefOneR rs = recOneR (\ n -> defR (rs n))+{-# INLINE recDefOneR #-} -- | Translate a program of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg' consNonRecT :: Monad m => Translate HermitC m CoreExpr a1 -> Translate HermitC m CoreProg a2 -> (Var -> a1 -> a2 -> b) -> Translate HermitC m CoreProg b consNonRecT t1 t2 f = progConsT (nonRecT t1 (,)) t2 (uncurry f)+{-# INLINE consNonRecT #-} -- | Rewrite all children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg' consNonRecAllR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg consNonRecAllR r1 r2 = progConsAllR (nonRecR r1) r2+{-# INLINE consNonRecAllR #-} -- | Rewrite any children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg' consNonRecAnyR :: MonadCatch m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg consNonRecAnyR r1 r2 = progConsAnyR (nonRecR r1) r2+{-# INLINE consNonRecAnyR #-} -- | Rewrite one child of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg' consNonRecOneR :: MonadCatch m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg consNonRecOneR r1 r2 = progConsOneR (nonRecR r1) r2+{-# INLINE consNonRecOneR #-} -- | Translate an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg' consRecT :: Monad m => (Int -> Translate HermitC m CoreDef a1) -> Translate HermitC m CoreProg a2 -> ([a1] -> a2 -> b) -> Translate HermitC m CoreProg b consRecT ts t = progConsT (recT ts id) t+{-# INLINE consRecT #-} -- | Rewrite all children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg' consRecAllR :: Monad m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg consRecAllR rs r = progConsAllR (recAllR rs) r+{-# INLINE consRecAllR #-} -- | Rewrite any children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg' consRecAnyR :: MonadCatch m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg consRecAnyR rs r = progConsAnyR (recAnyR rs) r+{-# INLINE consRecAnyR #-} -- | Rewrite one child of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg' consRecOneR :: MonadCatch m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg consRecOneR rs r = progConsOneR (recOneR rs) r+{-# INLINE consRecOneR #-} -- | Translate an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg' consRecDefT :: Monad m => (Int -> Translate HermitC m CoreExpr a1) -> Translate HermitC m CoreProg a2 -> ([(Id,a1)] -> a2 -> b) -> Translate HermitC m CoreProg b consRecDefT ts t = consRecT (\ n -> defT (ts n) (,)) t+{-# INLINE consRecDefT #-} -- | Rewrite all children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg' consRecDefAllR :: Monad m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg consRecDefAllR rs r = consRecAllR (\ n -> defR (rs n)) r+{-# INLINE consRecDefAllR #-} -- | Rewrite any children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg' consRecDefAnyR :: MonadCatch m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg consRecDefAnyR rs r = consRecAnyR (\ n -> defR (rs n)) r+{-# INLINE consRecDefAnyR #-} -- | Rewrite one child of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg' consRecDefOneR :: MonadCatch m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreProg -> Rewrite HermitC m CoreProg consRecDefOneR rs r = consRecOneR (\ n -> defR (rs n)) r+{-# INLINE consRecDefOneR #-} -- | Translate an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' letNonRecT :: Monad m => Translate HermitC m CoreExpr a1 -> Translate HermitC m CoreExpr a2 -> (Var -> a1 -> a2 -> b) -> Translate HermitC m CoreExpr b letNonRecT t1 t2 f = letT (nonRecT t1 (,)) t2 (uncurry f)+{-# INLINE letNonRecT #-} -- | Rewrite all children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' letNonRecAllR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr letNonRecAllR r1 r2 = letAllR (nonRecR r1) r2+{-# INLINE letNonRecAllR #-} -- | Rewrite any children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' letNonRecAnyR :: MonadCatch m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr letNonRecAnyR r1 r2 = letAnyR (nonRecR r1) r2+{-# INLINE letNonRecAnyR #-} -- | Rewrite one child of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' letNonRecOneR :: MonadCatch m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr letNonRecOneR r1 r2 = letOneR (nonRecR r1) r2+{-# INLINE letNonRecOneR #-} -- | Translate an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr' letRecT :: Monad m => (Int -> Translate HermitC m CoreDef a1) -> Translate HermitC m CoreExpr a2 -> ([a1] -> a2 -> b) -> Translate HermitC m CoreExpr b letRecT ts t = letT (recT ts id) t+{-# INLINE letRecT #-} -- | Rewrite all children of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr' letRecAllR :: Monad m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr letRecAllR rs r = letAllR (recAllR rs) r+{-# INLINE letRecAllR #-} -- | Rewrite any children of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr' letRecAnyR :: MonadCatch m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr letRecAnyR rs r = letAnyR (recAnyR rs) r+{-# INLINE letRecAnyR #-} -- | Rewrite one child of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr' letRecOneR :: MonadCatch m => (Int -> Rewrite HermitC m CoreDef) -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr letRecOneR rs r = letOneR (recOneR rs) r+{-# INLINE letRecOneR #-} -- | Translate an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr' letRecDefT :: Monad m => (Int -> Translate HermitC m CoreExpr a1) -> Translate HermitC m CoreExpr a2 -> ([(Id,a1)] -> a2 -> b) -> Translate HermitC m CoreExpr b letRecDefT ts t = letRecT (\ n -> defT (ts n) (,)) t+{-# INLINE letRecDefT #-} -- | Rewrite all children of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr' letRecDefAllR :: Monad m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr letRecDefAllR rs r = letRecAllR (\ n -> defR (rs n)) r+{-# INLINE letRecDefAllR #-} -- | Rewrite any children of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr' letRecDefAnyR :: MonadCatch m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr letRecDefAnyR rs r = letRecAnyR (\ n -> defR (rs n)) r+{-# INLINE letRecDefAnyR #-} -- | Rewrite one child of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr' letRecDefOneR :: MonadCatch m => (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreExpr -> Rewrite HermitC m CoreExpr letRecDefOneR rs r = letRecOneR (\ n -> defR (rs n)) r+{-# INLINE letRecDefOneR #-} --- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Id'], 'CoreExpr')]-caseAltT :: Monad m => Translate HermitC m CoreExpr a1 -> (Int -> Translate HermitC m CoreExpr a2) -> (a1 -> Id -> Type -> [(AltCon,[Id],a2)] -> b) -> Translate HermitC m CoreExpr b+-- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]+caseAltT :: Monad m => Translate HermitC m CoreExpr a1 -> (Int -> Translate HermitC m CoreExpr a2) -> (a1 -> Id -> Type -> [(AltCon,[Var],a2)] -> b) -> Translate HermitC m CoreExpr b caseAltT t ts = caseT t (\ n -> altT (ts n) (,,))+{-# INLINE caseAltT #-} --- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Id'], 'CoreExpr')]+-- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')] caseAltAllR :: Monad m => Rewrite HermitC m CoreExpr -> (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreExpr caseAltAllR t ts = caseAllR t (\ n -> altR (ts n))+{-# INLINE caseAltAllR #-} --- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Id'], 'CoreExpr')]+-- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')] caseAltAnyR :: MonadCatch m => Rewrite HermitC m CoreExpr -> (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreExpr caseAltAnyR t ts = caseAnyR t (\ n -> altR (ts n))+{-# INLINE caseAltAnyR #-} --- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Id'], 'CoreExpr')]+-- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')] caseAltOneR :: MonadCatch m => Rewrite HermitC m CoreExpr -> (Int -> Rewrite HermitC m CoreExpr) -> Rewrite HermitC m CoreExpr caseAltOneR t ts = caseOneR t (\ n -> altR (ts n))+{-# INLINE caseAltOneR #-} --------------------------------------------------------------------- -- | Promote a rewrite on 'ModGuts' to a rewrite on 'Core'. promoteModGutsR :: Monad m => Rewrite HermitC m ModGuts -> Rewrite HermitC m Core promoteModGutsR = promoteWithFailMsgR "This rewrite can only succeed at the module level."+{-# INLINE promoteModGutsR #-} -- | Promote a rewrite on 'CoreProg' to a rewrite on 'Core'. promoteProgR :: Monad m => Rewrite HermitC m CoreProg -> Rewrite HermitC m Core promoteProgR = promoteWithFailMsgR "This rewrite can only succeed at program nodes (the top-level)."+{-# INLINE promoteProgR #-} -- | Promote a rewrite on 'CoreBind' to a rewrite on 'Core'. promoteBindR :: Monad m => Rewrite HermitC m CoreBind -> Rewrite HermitC m Core promoteBindR = promoteWithFailMsgR "This rewrite can only succeed at binding group nodes."+{-# INLINE promoteBindR #-} -- | Promote a rewrite on 'CoreDef' to a rewrite on 'Core'. promoteDefR :: Monad m => Rewrite HermitC m CoreDef -> Rewrite HermitC m Core promoteDefR = promoteWithFailMsgR "This rewrite can only succeed at recursive definition nodes."+{-# INLINE promoteDefR #-} -- | Promote a rewrite on 'CoreAlt' to a rewrite on 'Core'. promoteAltR :: Monad m => Rewrite HermitC m CoreAlt -> Rewrite HermitC m Core promoteAltR = promoteWithFailMsgR "This rewrite can only succeed at case alternative nodes."+{-# INLINE promoteAltR #-} -- | Promote a rewrite on 'CoreExpr' to a rewrite on 'Core'. promoteExprR :: Monad m => Rewrite HermitC m CoreExpr -> Rewrite HermitC m Core promoteExprR = promoteWithFailMsgR "This rewrite can only succeed at expression nodes."+{-# INLINE promoteExprR #-} --------------------------------------------------------------------- +-- | Promote a bidirectional rewrite on 'CoreExpr' to a bidirectional rewrite on 'Core'.+promoteExprBiR :: Monad m => BiRewrite HermitC m CoreExpr -> BiRewrite HermitC m Core+promoteExprBiR b = bidirectional (promoteExprR $ forewardT b) (promoteExprR $ backwardT b)+{-# INLINE promoteExprBiR #-}++---------------------------------------------------------------------+ -- | Promote a translate on 'ModGuts' to a translate on 'Core'. promoteModGutsT :: Monad m => Translate HermitC m ModGuts b -> Translate HermitC m Core b promoteModGutsT = promoteWithFailMsgT "This translate can only succeed at the module level."+{-# INLINE promoteModGutsT #-} -- | Promote a translate on 'CoreProg' to a translate on 'Core'. promoteProgT :: Monad m => Translate HermitC m CoreProg b -> Translate HermitC m Core b promoteProgT = promoteWithFailMsgT "This translate can only succeed at program nodes (the top-level)."+{-# INLINE promoteProgT #-} -- | Promote a translate on 'CoreBind' to a translate on 'Core'. promoteBindT :: Monad m => Translate HermitC m CoreBind b -> Translate HermitC m Core b promoteBindT = promoteWithFailMsgT "This translate can only succeed at binding group nodes."+{-# INLINE promoteBindT #-} -- | Promote a translate on 'CoreDef' to a translate on 'Core'. promoteDefT :: Monad m => Translate HermitC m CoreDef b -> Translate HermitC m Core b promoteDefT = promoteWithFailMsgT "This translate can only succeed at recursive definition nodes."+{-# INLINE promoteDefT #-} -- | Promote a translate on 'CoreAlt' to a translate on 'Core'. promoteAltT :: Monad m => Translate HermitC m CoreAlt b -> Translate HermitC m Core b promoteAltT = promoteWithFailMsgT "This translate can only succeed at case alternative nodes."+{-# INLINE promoteAltT #-} -- | Promote a translate on 'CoreExpr' to a translate on 'Core'. promoteExprT :: Monad m => Translate HermitC m CoreExpr b -> Translate HermitC m Core b promoteExprT = promoteWithFailMsgT "This translate can only succeed at expression nodes."+{-# INLINE promoteExprT #-} ---------------------------------------------------------------------
src/Language/HERMIT/Monad.hs view
@@ -41,7 +41,7 @@ ---------------------------------------------------------------------------- --- | A label for individual defintions.+-- | A label for individual definitions. type Label = String -- | A store of saved definitions.@@ -55,57 +55,71 @@ runHermitM :: HermitM a -> HermitMEnv -> DefStash -> CoreM (KureM (DefStash, a)) runHermitM (HermitM f) = f+{-# INLINE runHermitM #-} -- | Get the stash of saved definitions. getStash :: HermitM DefStash getStash = HermitM (\ _ s -> return $ return (s, s))+{-# INLINE getStash #-} -- | Replace the stash of saved definitions. putStash :: DefStash -> HermitM () putStash s = HermitM (\ _ _ -> return $ return (s, ()))+{-# INLINE putStash #-} sendDebugMessage :: DebugMessage -> HermitM () sendDebugMessage msg = do env <- HermitM $ \ ch s -> return $ return (s, ch) hs_debugChan env msg+{-# INLINE sendDebugMessage #-} -- | Save a definition for future use. saveDef :: Label -> CoreDef -> HermitM () saveDef l d = getStash >>= (insert l d >>> putStash)+{-# INLINE saveDef #-} -- | Lookup a previously saved definition. lookupDef :: Label -> HermitM CoreDef lookupDef l = getStash >>= (lookup l >>> maybe (fail "Definition not found.") return)+{-# INLINE lookupDef #-} -- | Eliminator for 'HermitM'. runHM :: HermitMEnv -> DefStash -> (DefStash -> a -> CoreM b) -> (String -> CoreM b) -> HermitM a -> CoreM b runHM env s success failure ma = runHermitM ma env s >>= runKureM (\ (a,b) -> success a b) failure+{-# INLINE runHM #-} ---------------------------------------------------------------------------- instance Functor HermitM where fmap :: (a -> b) -> HermitM a -> HermitM b fmap = liftM+ {-# INLINE fmap #-} instance Applicative HermitM where pure :: a -> HermitM a pure = return+ {-# INLINE pure #-} (<*>) :: HermitM (a -> b) -> HermitM a -> HermitM b (<*>) = ap+ {-# INLINE (<*>) #-} instance Monad HermitM where return :: a -> HermitM a return a = HermitM $ \ _ s -> return (return (s,a))+ {-# INLINE return #-} (>>=) :: HermitM a -> (a -> HermitM b) -> HermitM b (HermitM gcm) >>= f = HermitM $ \ env -> gcm env >=> runKureM (\ (s', a) -> runHermitM (f a) env s') (return . fail)+ {-# INLINE (>>=) #-} fail :: String -> HermitM a fail msg = HermitM $ \ _ _ -> return (fail msg)+ {-# INLINE fail #-} instance MonadCatch HermitM where catchM :: HermitM a -> (String -> HermitM a) -> HermitM a (HermitM gcm) `catchM` f = HermitM $ \ env s -> gcm env s >>= runKureM (return.return) (\ msg -> runHermitM (f msg) env s)+ {-# INLINE catchM #-} ---------------------------------------------------------------------------- @@ -113,51 +127,46 @@ liftCoreM :: CoreM a -> HermitM a liftCoreM ma = HermitM $ \ _ s -> do a <- ma return (return (s,a))+{-# INLINE liftCoreM #-} instance MonadIO HermitM where liftIO :: IO a -> HermitM a liftIO = liftCoreM . liftIO+ {-# INLINE liftIO #-} instance MonadUnique HermitM where getUniqueSupplyM :: HermitM UniqSupply getUniqueSupplyM = liftCoreM getUniqueSupplyM+ {-# INLINE getUniqueSupplyM #-} instance MonadThings HermitM where lookupThing :: Name -> HermitM TyThing lookupThing = liftCoreM . lookupThing+ {-# INLINE lookupThing #-} instance HasDynFlags HermitM where getDynFlags :: HermitM DynFlags getDynFlags = liftCoreM getDynFlags+ {-# INLINE getDynFlags #-} ---------------------------------------------------------------------------- newName :: String -> HermitM Name newName name = do uq <- getUniqueM return $ mkSystemVarName uq $ mkFastString name+{-# INLINE newName #-} -- | Make a unique identifier for a specified type based on a provided name. newIdH :: String -> Type -> HermitM Id newIdH name ty = do name' <- newName name return $ mkLocalId name' ty+{-# INLINE newIdH #-} -- | Make a unique type variable for a specified kind based on a provided name. newTyVarH :: String -> Kind -> HermitM TyVar newTyVarH name kind = do name' <- newName name return $ mkTyVar name' kind---- Not sure whether this would be useful or not.--- Make either a new identifier of a given type, or type variable of a given kind.--- Note that as 'Id' and 'TyVar' are synonyms of 'Var', and 'Kind' is a synonym of 'Type',--- the choice is determined entirely by the 'Either' constructor.--- newVarH :: String -> Either Type Kind -> HermitM Var--- newVarH name = either (newIdH name) (newTypeVarH name)---- Make either a new identifier of a given type, or type variable of a given kind,--- and wrap it in a 'Var' or 'Type' constructor, respectively.--- newVarExprH :: String -> Either Type Kind -> HermitM CoreExpr--- newVarExprH str (Left ty) = Var <$> newIdH str ty--- newVarExprH str (Right k) = (Type . mkTyVarTy) <$> newTypeVarH str k+{-# INLINE newTyVarH #-} -- | This gives an new version of a 'Var', with the same info, and a new textual name. cloneVarH :: (String -> String) -> Var -> HermitM Var@@ -168,6 +177,7 @@ if isTyVar v then newTyVarH name ty else newIdH name ty+{-# INLINE cloneVarH #-} ---------------------------------------------------------------------------- @@ -179,5 +189,6 @@ mkHermitMEnv debugger = HermitMEnv { hs_debugChan = debugger }+{-# INLINE mkHermitMEnv #-} ----------------------------------------------------------------------------
+ src/Language/HERMIT/Optimize.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE KindSignatures, GADTs #-}+module Language.HERMIT.Optimize+ ( -- * The HERMIT Plugin+ optimize+ -- ** Running translations+ , query+ , run+ -- ** Using the shell+ , interactive+ , display+ , setPretty+ , setPrettyOptions+ -- ** Active modifiers+ , at+ , phase+ , after+ , before+ , allPhases+ ) where++import GhcPlugins hiding (singleton, liftIO, display)+import qualified GhcPlugins as GHC++import Control.Monad.Operational+import Control.Monad.State hiding (guard)++import Data.Default++import Language.HERMIT.Core+import Language.HERMIT.External hiding (Query, Shell)+import Language.HERMIT.Kernel.Scoped+import Language.HERMIT.Kure+import Language.HERMIT.Monad+import Language.HERMIT.Plugin+import Language.HERMIT.PrettyPrinter.Common+import qualified Language.HERMIT.PrettyPrinter.Clean as Clean+import qualified Language.HERMIT.Shell.Command as Shell++import System.Console.Haskeline (defaultBehavior)+import System.IO (stdout)++data OInst :: * -> * where+ RR :: RewriteH Core -> OInst ()+ Query :: TranslateH Core a -> OInst a+ Shell :: [External] -> [CommandLineOption] -> OInst ()+ Guard :: (PhaseInfo -> Bool) -> OM () -> OInst ()+ -- with some refactoring of the interpreter I'm pretty sure+ -- we can make Focus polymorphic+ Focus :: TranslateH Core Path -> OM () -> OInst ()++-- using operational, but would we nice to use Neil's constrained-normal package!+type OM a = ProgramT OInst (StateT InterpState IO) a++optimize :: ([CommandLineOption] -> OM ()) -> Plugin+optimize f = hermitPlugin $ \ phaseInfo -> runOM phaseInfo . f++data InterpState = + InterpState { isAST :: SAST+ , isPretty :: PrettyOptions -> PrettyH Core+ , isPrettyOptions :: PrettyOptions+ -- TODO: remove once shell can return+ , shellHack :: Maybe ([External], [CommandLineOption]) + }+type InterpM a = StateT InterpState IO a++runOM :: PhaseInfo -> OM () -> ModGuts -> CoreM ModGuts+runOM phaseInfo opt = scopedKernel $ \ kernel initSAST ->+ let env = mkHermitMEnv $ GHC.liftIO . debug+ debug (DebugTick msg) = putStrLn msg+ debug (DebugCore msg _c _e) = putStrLn $ "Core: " ++ msg++ errorAbortIO err = putStrLn err >> abortS kernel+ errorAbort = liftIO . errorAbortIO++ initState = InterpState initSAST Clean.corePrettyH def Nothing++ eval :: Path -> ProgramT OInst (StateT InterpState IO) () -> InterpM ()+ eval path comp = do+ sast <- gets isAST+ v <- viewT comp+ case v of+ Return _ -> return ()+ RR rr :>>= k -> liftIO (applyS kernel sast (pathR path (extractR rr)) env)+ >>= runKureM (\sast' -> modify (\s -> s { isAST = sast' }))+ errorAbort >> eval path (k ())+ Query tr :>>= k -> liftIO (queryS kernel sast (pathT path (extractT tr)) env)+ >>= runKureM (eval path . k) errorAbort+ -- TODO: rework shell so it can return to k+ -- this will significantly simplify this code+ -- as we can just call the shell directly here+ Shell es os :>>= _k -> modify (\s -> s { shellHack = Just (es,os) })+ -- liftIO $ Shell.interactive os defaultBehavior es kernel sast+ -- calling the shell directly causes indefinite MVar problems+ -- because the state monad never finishes (I think)+ Guard p m :>>= k -> when (p phaseInfo) (eval path m) >> eval path (k ())+ Focus tp m :>>= k -> liftIO (queryS kernel sast (extractT tp) env)+ >>= runKureM (flip eval m) errorAbort >> eval path (k ())++ in do st <- execStateT (eval [] opt) initState+ let sast = isAST st+ maybe (liftIO (resumeS kernel sast) >>= runKureM return errorAbortIO)+ (\(es,os) -> liftIO $ Shell.interactive os defaultBehavior es kernel sast)+ (shellHack st)++interactive :: [External] -> [CommandLineOption] -> OM ()+interactive es os = singleton $ Shell es os++run :: RewriteH Core -> OM ()+run = singleton . RR++query :: TranslateH Core a -> OM a+query = singleton . Query++----------------------------- guards ------------------------------++guard :: (PhaseInfo -> Bool) -> OM () -> OM ()+guard p = singleton . Guard p++at :: TranslateH Core Path -> OM () -> OM ()+at tp = singleton . Focus tp++phase :: Int -> OM () -> OM ()+phase n = guard ((n ==) . phaseNum)++after :: CorePass -> OM () -> OM ()+after cp = guard (\phaseInfo -> case phasesDone phaseInfo of+ [] -> False+ xs -> last xs == cp)++before :: CorePass -> OM () -> OM ()+before cp = guard (\phaseInfo -> case phasesLeft phaseInfo of+ (x:_) | cp == x -> True+ _ -> False)++allPhases :: OM () -> OM ()+allPhases = guard (const True)++----------------------------- other ------------------------------++display :: OM ()+display = do+ po <- gets isPrettyOptions+ gets isPretty >>= query . ($ po) >>= liftIO . Shell.unicodeConsole stdout po++setPretty :: (PrettyOptions -> PrettyH Core) -> OM ()+setPretty pp = modify $ \s -> s { isPretty = pp }++setPrettyOptions :: PrettyOptions -> OM ()+setPrettyOptions po = modify $ \s -> s { isPrettyOptions = po }
+ src/Language/HERMIT/Parser.y view
@@ -0,0 +1,188 @@+{+module Language.HERMIT.Parser+ ( parseStmtsH+ , unparseExprH+ , numStmtsH+ , ExprH(..)+ ) where++import Data.Char (isSpace)+import Data.List (intercalate)++import Language.HERMIT.Syntax+}++%name parser+%tokentype { Token }+%error { parseError }+%monad { Either String } { >>= } { return }++%token+ '(' { ParenLeft }+ ')' { ParenRight }+ '{' { ScopeStart }+ '}' { ScopeEnd }+ '[' { ListStart }+ ',' { ListDelim }+ ']' { ListEnd }+ ';' { StmtEnd }+ '\'' { Tick }+ core { CoreString $$ }+ quoted { Quote $$ }+ ident { Ident $$ }+ infixop { InfixOp $$ }++%%++scoped : '{' scoped { CmdName "{" : $2 }+ | '}' scoped { CmdName "}" : $2 }+ | slist { $1 }++slist : stmts { $1 }+ | {- empty -} { [] }++-- | Be really liberal about where ';' can be!+-- Recall that newlines are lexed as ';'+stmts : ExprH { [$1] }+ | ExprH '}' scoped { [$1, CmdName "}"] ++ $3 }+ | ExprH ';' scoped { $1 : $3 }+ | ';' scoped { $2 }++-- | Top level expression term.+-- Infix operators bind less tightly than application.+ExprH : e2 infixop ExprH { AppH (AppH (CmdName $2) $1) $3 }+ | e2 { $1 }++-- | Expressions without infix operators in them.+e2 : e2 arg { AppH $1 $2 }+ | arg { $1 }++-- | Expressions that can be arguments in an application.+arg : '\'' ident { SrcName $2 }+ | '\'' infixop { SrcName $2 }+ | '\'' quoted { SrcName $2 }+ | quoted { CmdName $1 }+ | core { CoreH $1 }+ | '[' elist ']' { ListH $2 }+ | '(' ExprH ')' { $2 }+ | ident { CmdName $1 }++elist : exprs { $1 }+ | {- empty -} { [] }++exprs : ExprH { [$1] }+ | ExprH ',' exprs { $1 : $3 }+{++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+ | isIdFirstChar c = let (i,s') = span isIdChar s+ in fmap (Ident i:) $ lexer s'+ | isInfixId c = let (op,s') = span isInfixId s+ in fmap (InfixOp op:) $ lexer s'+lexer s = 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 isInfixId nm || isIdFirstChar (head nm) && all (isIdChar) (tail nm)) = "'" ++ nm+ | otherwise = "'\"" ++ concatMap escape nm ++ "\""+ where escape '\"' = "\\\""+ escape c = [c]+unparseExprH (CmdName nm)+ | nm == "{" = "{ "+ | nm == "}" = " }"+ | all isIdChar nm = nm+ | otherwise = show nm -- with quotes+unparseExprH (AppH (AppH (CmdName nm) e1) e2)+ | all isInfixId 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++---------------------------------------------++}
+ src/Language/HERMIT/ParserCore.y view
@@ -0,0 +1,178 @@+{+{-# LANGUAGE CPP #-}+module Language.HERMIT.ParserCore (parseCore) where++import Control.Monad.Reader+import Data.Char (isSpace, isAlpha, isAlphaNum, isDigit)++import GhcPlugins++import Language.HERMIT.Context+import Language.HERMIT.External+import Language.HERMIT.Monad+import Language.HERMIT.Primitive.Common++import Language.KURE.MonadCatch (prefixFailMsg)++import Language.Haskell.TH as TH+}++%name parser+%tokentype { Token }+%error { parseError }+%monad { CoreParseM } { >>= } { return }++%token+ '%forall' { Tforall }+ '%rec' { Trec }+ '%let' { Tlet }+ '%in' { Tin }+ '%case' { Tcase }+ '%of' { Tof }+ '%cast' { Tcast }+ '%note' { Tnote }+ '%external' { Texternal }+ '%local' { Tlocal }+ '%_' { Twild }+ '(' { Toparen }+ ')' { Tcparen }+ '{' { Tobrace }+ '}' { Tcbrace }+ '#' { Thash}+ '=' { Teq }+ ':' { Tcolon }+ '::' { Tcoloncolon }+ ':=:' { Tcoloneqcolon }+ '*' { Tstar }+ '->' { Tarrow }+ '\\' { Tlambda}+ '@' { Tat }+ '.' { Tdot }+ '?' { Tquestion}+ ';' { Tsemicolon }+ NAME { Tname $$ }+ CNAME { Tcname $$ }+ INTEGER { Tinteger $$ }+ RATIONAL { Trational $$ }+ STRING { Tstring $$ }+ CHAR { Tchar $$ }++%%++-- | Top level expression term.+expr : app { $1 }++app : app arg { App $1 $2 }+ | arg { $1 }++arg : '(' expr ')' { $2 }+ | '(' ')' {% lookupName "()" Var }+ | var { $1 }+ | intlit { $1 }+ | strlit { $1 }++intlit : INTEGER {% mkIntExpr' $1 } -- mkIntLit makes a primitive Int#++strlit : STRING {% lift $ mkStringExpr $1 }++var : NAME {% lookupName $1 varToCoreExpr }+{++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 :: [Token] -> CoreParseM 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'+ | isIdFirstChar c = let (i,s') = span isIdChar s+ in fmap (Tname i:) $ lexer s'+ | isInfixId c = let (op,s') = span isInfixId s+ in fmap (Tname op:) $ lexer s'+lexer s = Left $ "lexer: no match on " ++ s++---------------------------------------------++-- | Chars that are valid in identifiers anywhere.+isIdFirstChar :: Char -> Bool+isIdFirstChar c = c `elem` "_$[]:.=" || isAlpha c++-- | Chars that are valid in identifiers, but not as the first character.+isIdChar :: Char -> Bool+isIdChar c = isAlphaNum c || c `elem` "#-'" || isIdFirstChar c++-- | Chars that are valid in infix operators.+isInfixId :: Char -> Bool+isInfixId c = c `elem` "+*/._-:<>"++parseCore :: CoreString -> HermitC -> HermitM CoreExpr+parseCore (CoreString s) c =+ case lexer s of+ Left msg -> fail msg+ Right tokens -> runReaderT (parser tokens) c+}
src/Language/HERMIT/Plugin.hs view
@@ -1,28 +1,19 @@ module Language.HERMIT.Plugin- ( -- * The HERMIT Plugin- HermitPass- , hermitPlugin-) where+ ( -- * The HERMIT Plugin+ HermitPass+ , hermitPlugin+ , CorePass(..)+ , getCorePass+ , ghcPasses+ , PhaseInfo(..)+ ) where import GhcPlugins import Data.List import System.IO -import Data.Char (isDigit)-import Data.Default- -- | Given a list of 'CommandLineOption's, produce the 'ModGuts' to 'ModGuts' function required to build a plugin.-type HermitPass = [CommandLineOption] -> ModGuts -> CoreM ModGuts--data Options = Options { pass :: Int }--instance Default Options where- def = Options { pass = 0 }--parse :: [String] -> Options -> Options-parse (('-':'p':n):rest) o | all isDigit n = parse rest $ o { pass = read n }-parse (_:rest) o = parse rest o -- unknown option-parse [] o = o+type HermitPass = PhaseInfo -> [CommandLineOption] -> ModGuts -> CoreM ModGuts -- | Build a hermit plugin. This mainly handles the per-module options. hermitPlugin :: HermitPass -> Plugin@@ -35,28 +26,102 @@ -- This is a bit of a hack; otherwise we lose what we've not seen liftIO $ hSetBuffering stdout NoBuffering - dynFlags <- getDynFlags-- let (m_opts, h_opts) = partition (isInfixOf ":") opts- hermit_opts = parse h_opts def- myPass = CoreDoPluginPass "HERMIT" $ modFilter dynFlags hp m_opts- -- at front, for now- allPasses = insertAt (pass hermit_opts) myPass todos+ let (m_opts, _h_opts) = partition (isInfixOf ":") opts+ passes = map getCorePass todos+ allPasses = foldr (\ (n,p,seen,notyet) r -> mkPass n seen notyet : p : r)+ [mkPass (length todos) passes []]+ (zip4 [0..] todos (inits passes) (tails passes))+ mkPass n ps ps' = CoreDoPluginPass ("HERMIT" ++ show n) $ modFilter hp (PhaseInfo n ps ps') m_opts return allPasses -- | Determine whether to act on this module, choose plugin pass.-modFilter :: DynFlags -> HermitPass -> HermitPass-modFilter dynFlags hp opts guts | null modOpts && not (null opts) = return guts -- don't process this module- | otherwise = hp modOpts guts- where modOpts = filterOpts dynFlags opts guts+-- NB: we have the ability to stick module info in the phase info here+modFilter :: HermitPass -> HermitPass+modFilter hp pInfo opts guts + | null modOpts && not (null opts) = return guts -- don't process this module+ | otherwise = hp pInfo (filter (not . null) modOpts) guts+ where modOpts = filterOpts opts guts -- | Filter options to those pertaining to this module, stripping module prefix.-filterOpts :: DynFlags -> [CommandLineOption] -> ModGuts -> [CommandLineOption]-filterOpts dynFlags opts guts = [ drop len nm | nm <- opts, modName `isPrefixOf` nm ]- where modName = showPpr dynFlags $ mg_module guts+filterOpts :: [CommandLineOption] -> ModGuts -> [CommandLineOption]+filterOpts opts guts = [ drop len nm | nm <- opts, modName `isPrefixOf` nm ]+ where modName = moduleNameString $ moduleName $ mg_module guts len = length modName + 1 -- for the colon -insertAt :: Int -> a -> [a] -> [a]-insertAt n x xs = pre ++ (x : suf)- where (pre,suf) = splitAt n xs+data CorePass = FloatInwards+ | LiberateCase+ | PrintCore+ | StaticArgs+ | Strictness+ | WorkerWrapper+ | Specialising+ | SpecConstr+ | CSE+ | Vectorisation+ | Desugar+ | DesugarOpt+ | Tidy+ | Prep+ | Simplify+ | FloatOutwards+ | RuleCheck+ | Passes -- these should be flattened out in practice+ | PluginPass String+ | NoOp+ | Unknown+ deriving (Read, Show, Eq)++ghcPasses :: [(CorePass, CoreToDo)]+ghcPasses = [ (FloatInwards , CoreDoFloatInwards)+ , (LiberateCase , CoreLiberateCase)+ , (PrintCore , CoreDoPrintCore)+ , (StaticArgs , CoreDoStaticArgs)+ , (Strictness , CoreDoStrictness)+ , (WorkerWrapper, CoreDoWorkerWrapper)+ , (Specialising , CoreDoSpecialising)+ , (SpecConstr , CoreDoSpecConstr)+ , (CSE , CoreCSE)+ , (Vectorisation, CoreDoVectorisation)+ , (Desugar , CoreDesugar) -- Right after desugaring, no simple optimisation yet!+ , (DesugarOpt , CoreDesugarOpt) -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces+ , (Tidy , CoreTidy)+ , (Prep , CorePrep)+ , (NoOp , CoreDoNothing)+ ]++-- The following are not allowed yet because they required options.+-- CoreDoSimplify {- The core-to-core simplifier. -} Int {- Max iterations -} SimplifierMode+-- CoreDoFloatOutwards FloatOutSwitches+-- CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules matching this string+-- CoreDoPasses [CoreToDo] -- lists of these things++getCorePass :: CoreToDo -> CorePass+getCorePass CoreDoFloatInwards = FloatInwards+getCorePass CoreLiberateCase = LiberateCase+getCorePass CoreDoPrintCore = PrintCore+getCorePass CoreDoStaticArgs = StaticArgs+getCorePass CoreDoStrictness = Strictness+getCorePass CoreDoWorkerWrapper = WorkerWrapper+getCorePass CoreDoSpecialising = Specialising+getCorePass CoreDoSpecConstr = SpecConstr+getCorePass CoreCSE = CSE+getCorePass CoreDoVectorisation = Vectorisation+getCorePass CoreDesugar = Desugar+getCorePass CoreDesugarOpt = DesugarOpt+getCorePass CoreTidy = Tidy+getCorePass CorePrep = Prep+getCorePass (CoreDoSimplify {}) = Simplify+getCorePass (CoreDoFloatOutwards {}) = FloatOutwards+getCorePass (CoreDoRuleCheck {}) = RuleCheck+getCorePass (CoreDoPasses {}) = Passes -- these should be flattened out in practice+getCorePass (CoreDoPluginPass nm _) = PluginPass nm+getCorePass CoreDoNothing = NoOp+-- getCorePass _ = Unknown++data PhaseInfo = + PhaseInfo { phaseNum :: Int+ , phasesDone :: [CorePass]+ , phasesLeft :: [CorePass]+ }+ deriving (Read, Show, Eq)
− src/Language/HERMIT/PrettyPrinter.hs
@@ -1,351 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module Language.HERMIT.PrettyPrinter where--import GhcPlugins hiding ((<>))--import Text.PrettyPrint.MarkedHughesPJ as PP-import Language.HERMIT.Kure-import Language.HERMIT.Core-import Control.Arrow-import Data.Monoid hiding ((<>))-import Data.Default-import Data.Char-import qualified Data.Map as M-import System.IO----- A HERMIT document-type DocH = MDoc HermitMark---- These are the zero-width marks on the document-data HermitMark- = PushAttr Attr- | PopAttr- deriving Show---- These are the attributes-data Attr = PathAttr Path- | Color SyntaxForColor- | SpecialFont- deriving Show--data SyntaxForColor -- (suggestion)- = KeywordColor -- bold- | SyntaxColor- | VarColor- | TypeColor- | LitColor- deriving Show--attr :: Attr -> DocH -> DocH-attr a p = mark (PushAttr a) <> p <> mark PopAttr---- Hack, till we get 'PathAttr' working properly--- The problem is that attributes span over multiple lines,--- messing up the latex output--attrP :: Path -> DocH -> DocH-attrP _ doc = doc -- attr . PathAttr--varColor :: DocH -> DocH-varColor = attr (Color VarColor)--keywordColor :: DocH -> DocH-keywordColor = attr (Color KeywordColor)--markColor :: SyntaxForColor -> DocH -> DocH-markColor = attr . Color--specialFont :: DocH -> DocH-specialFont = attr SpecialFont---type PrettyH a = TranslateH a DocH---- These are *recommendations* to the pretty printer.--data PrettyOptions = PrettyOptions- { po_fullyQualified :: Bool -- Do you show fully qualified names?- , po_exprTypes :: ShowOption -- Do you hide types, and type arguments, as <>?- , po_typesForBinders :: ShowOption -- Do you give the types for all bindings?- , po_highlight :: Maybe Path -- This region should be highlighted (for sub-expression)- , po_depth :: Maybe Int -- below this depth are ..., Nothing => infinite- , po_notes :: Bool -- ^ notes might be added to output- , po_ribbon :: Float- , po_width :: Int- } deriving Show--data ShowOption = Show | Abstract | Omit- deriving (Eq, Ord, Show, Read)--instance Default PrettyOptions where- def = PrettyOptions- { po_fullyQualified = False- , po_exprTypes = Abstract- , po_typesForBinders = Omit- , po_highlight = Nothing- , po_depth = Nothing- , po_notes = False- , po_ribbon = 1.2- , po_width = 80- }----------------------------------------------------------------------- The characters for special symbols, which have a special alphabet--data SpecialSymbol- = LambdaSymbol- | TypeOfSymbol- | RightArrowSymbol- | TypeSymbol- | TypeBindSymbol- | ForallSymbol- deriving (Show, Eq, Ord, Bounded, Enum)--class RenderSpecial a where- renderSpecial :: SpecialSymbol -> a---instance RenderSpecial Char where- renderSpecial LambdaSymbol = '\\' -- lambda- renderSpecial TypeOfSymbol = ':' -- ::- renderSpecial RightArrowSymbol = '>' -- ->- renderSpecial TypeSymbol = 'T' -- <<type>>>- renderSpecial TypeBindSymbol = 'a' -- a- renderSpecial ForallSymbol = 'F' -- forall--newtype ASCII = ASCII String--instance Monoid ASCII where- mempty = ASCII ""- mappend (ASCII xs) (ASCII ys) = ASCII (xs ++ ys)--instance RenderSpecial ASCII where- renderSpecial LambdaSymbol = ASCII "\\" -- lambda- renderSpecial TypeOfSymbol = ASCII "::" -- ::- renderSpecial RightArrowSymbol = ASCII "->" -- ->- renderSpecial TypeSymbol = ASCII "*" -- <<type>>>- renderSpecial TypeBindSymbol = ASCII "*" -- a- renderSpecial ForallSymbol = ASCII "\\/"--newtype Unicode = Unicode Char--instance RenderSpecial Unicode where- renderSpecial LambdaSymbol = Unicode '\x03BB'- renderSpecial TypeOfSymbol = Unicode '\x2237' -- called PROPORTION- renderSpecial RightArrowSymbol = Unicode '\x2192'- renderSpecial TypeSymbol = Unicode '\x25b2'- renderSpecial TypeBindSymbol = Unicode '\x25B9'- renderSpecial ForallSymbol = Unicode '\x2200'--newtype LaTeX = LaTeX String--instance Monoid LaTeX where- mempty = LaTeX ""- mappend (LaTeX xs) (LaTeX ys) = LaTeX (xs ++ ys)--instance RenderSpecial LaTeX where- renderSpecial LambdaSymbol = LaTeX "\\ensuremath{\\lambda}"- renderSpecial TypeOfSymbol = LaTeX ":\\!:" -- too wide- renderSpecial RightArrowSymbol = LaTeX "\\ensuremath{\\shortrightarrow}"- renderSpecial TypeSymbol = LaTeX "\\ensuremath{\\blacktriangle}"- renderSpecial TypeBindSymbol = LaTeX "\\ensuremath{\\triangleright}"- renderSpecial ForallSymbol = LaTeX "\\ensuremath{\\forall}"---newtype HTML = HTML String--instance Monoid HTML where- mempty = HTML ""- mappend (HTML xs) (HTML ys) = HTML (xs ++ ys)--instance RenderSpecial HTML where- renderSpecial LambdaSymbol = HTML "λ"- renderSpecial TypeOfSymbol = HTML "∷"- renderSpecial RightArrowSymbol = HTML "→"- renderSpecial TypeSymbol = HTML "▲"- renderSpecial TypeBindSymbol = HTML "▹"- renderSpecial ForallSymbol = HTML "∀"---renderSpecialFont :: (RenderSpecial a) => Char -> Maybe a-renderSpecialFont = fmap renderSpecial . flip M.lookup specialFontMap--specialFontMap :: M.Map Char SpecialSymbol-specialFontMap = M.fromList- [ (renderSpecial s,s)- | s <- [minBound..maxBound]- ]---class (RenderSpecial a, Monoid a) => RenderCode a where- rStart :: a- rStart = mempty- rEnd :: a- rEnd = mempty-- rDoHighlight :: Bool -> [Attr] -> a- rPutStr :: String -> a----- This is what the pretty printer can see-data PrettyState = PrettyState- { prettyPath :: Path- , prettyColor :: Maybe SyntaxForColor- }----stackToPrettyState :: [Attr] -> PrettyState---stackToPrettyState =--renderCode :: RenderCode a => PrettyOptions -> DocH -> a-renderCode opts doc = rStart `mappend` PP.fullRender PP.PageMode w rib marker (\ _ -> rEnd) doc []- where- -- options- w = po_width opts- rib = po_ribbon opts-- marker :: RenderCode a => PP.TextDetails HermitMark -> ([Attr] -> a) -> ([Attr]-> a)- marker m rest cols@(SpecialFont:_) = case m of- PP.Chr ch -> special [ch] `mappend` rest cols- PP.Str str -> special str `mappend` rest cols- PP.PStr str -> special str `mappend` rest cols- PP.Mark (PopAttr) ->- let (_:cols') = cols in rDoHighlight False cols' `mappend` rest cols'- PP.Mark (PushAttr _) -> error "renderCode: can not have marks inside special symbols"- marker m rest cols = case m of- PP.Chr ch -> rPutStr [ch] `mappend` rest cols- PP.Str str -> rPutStr str `mappend` rest cols- PP.PStr str -> rPutStr str `mappend` rest cols- PP.Mark (PushAttr a) ->- let cols' = a : cols in rDoHighlight True cols' `mappend` rest cols'- PP.Mark (PopAttr) -> do- let (_:cols') = cols in rDoHighlight False cols' `mappend` rest cols'-- special txt = mconcat [ code | Just code <- map renderSpecialFont txt ]----- Other options for pretty printing:--- * Does a top level program should function names, or complete listings?---- This is the hacky old pretty printer, using the new API-ghcCorePrettyH :: PrettyH Core-ghcCorePrettyH =- promoteT (ppModule :: PrettyH ModGuts)- <+ promoteT (ppProg :: PrettyH CoreProg)- <+ promoteT (ppH :: PrettyH CoreBind)- <+ promoteT (ppDef :: PrettyH CoreDef)- <+ promoteT (ppH :: PrettyH CoreExpr)- <+ promoteT (ppH :: PrettyH CoreAlt)- where-- ppH :: (Outputable a) => PrettyH a- ppH = contextfreeT $ \e -> do- dynFlags <- getDynFlags- return $ PP.text $ showSDoc dynFlags $ ppr e-- ppModule :: PrettyH ModGuts- ppModule = mg_module ^>> ppH-- ppProg :: PrettyH CoreProg- ppProg = progToBinds ^>> ppH-- ppDef :: PrettyH CoreDef- ppDef = defToIdExpr ^>> ppH---- arr (PP.text . ppr . mg_module)----- Moving the renders back into the core hermit-----------------------------------------------------------------------------------coreRenders :: [(String,Handle -> PrettyOptions -> DocH -> IO ())]-coreRenders =- [ ("latex", \ h w doc -> do- let pretty = latexToString $ renderCode w doc- hPutStr h pretty)- , ("html", \ h w doc -> do- let HTML pretty = renderCode w doc- hPutStr h pretty)- , ("ascii", \ h w doc -> do- let (ASCII pretty) = renderCode w doc- hPutStrLn h pretty)- , ("debug", \ h w doc -> do- let (DebugPretty pretty) = renderCode w doc- hPutStrLn h pretty)- ]--latexVerbatim :: String -> LaTeX -> LaTeX-latexVerbatim str (LaTeX v) = LaTeX (str ++ v)--latexToString :: LaTeX -> String-latexToString (LaTeX orig) = unlines $ map trunkSpaces $ lines orig where- trunkSpaces txt = case span isSpace txt of- ([],rest) -> rest- (pre,rest) -> "\\hspace{" ++ show (length pre) ++ "\\hermitspace}" ++ rest--instance RenderCode LaTeX where- rPutStr txt = LaTeX txt-- rDoHighlight False _ = LaTeX "}"- rDoHighlight _ [] = LaTeX $ "{"- rDoHighlight _ (Color col:_) = LaTeX $ "{" ++ case col of- KeywordColor -> "\\color{hermit:keyword}" -- blue- SyntaxColor -> "\\color{hermit:syntax}" -- red- VarColor -> ""- TypeColor -> "\\color{hermit:type}" -- green- LitColor -> "\\color{hermit:lit}" -- cyan- rDoHighlight o (_:rest) = rDoHighlight o rest-- rEnd = LaTeX "\n" -- \\end{Verbatim}"--{- | Use css to do the colors- -- - > <style type="text/css">- - > .hermit-syntax {- - > color: red;- - > </style>- -}--instance RenderCode HTML where- rPutStr txt = HTML txt-- rDoHighlight False _ = HTML "</span>"- rDoHighlight _ [] = HTML $ "<span>"- rDoHighlight _ (Color col:_) = HTML $ case col of- KeywordColor -> "<span class=\"hermit-keyword\">" -- blue- SyntaxColor -> "<span class=\"hermit-syntax\">" -- red- VarColor -> "<span>"- TypeColor -> "<span class=\"hermit-type\">" -- green- LitColor -> "<span class=\"hermit-lit\">" -- cyan- rDoHighlight o (_:rest) = rDoHighlight o rest- rEnd = HTML "\n"---instance RenderCode ASCII where- rPutStr txt = ASCII txt-- rDoHighlight _ _ = ASCII ""-- rEnd = ASCII "\n"--data DebugPretty = DebugPretty String--instance RenderSpecial DebugPretty where- renderSpecial sym = DebugPretty ("{" ++ show sym ++ "}")--instance Monoid DebugPretty where- mempty = DebugPretty ""- mappend (DebugPretty xs) (DebugPretty ys) = DebugPretty $ xs ++ ys--instance RenderCode DebugPretty where- rStart = DebugPretty "(START)\n"-- rPutStr txt = DebugPretty txt-- rDoHighlight True stk = DebugPretty $ show (True,stk)- rDoHighlight False stk = DebugPretty $ show (False,stk)-- rEnd = DebugPretty "(END)\n"-
src/Language/HERMIT/PrettyPrinter/AST.hs view
@@ -1,5 +1,9 @@ -- | Output the raw Expr constructors. Helpful for writing pattern matching rewrites.-module Language.HERMIT.PrettyPrinter.AST where+module Language.HERMIT.PrettyPrinter.AST+ ( -- * HERMIT's AST Pretty-Printer for GHC Core+ corePrettyH+ )+where import Control.Arrow hiding ((<+>)) @@ -9,19 +13,14 @@ import qualified GhcPlugins as GHC import Language.HERMIT.Kure import Language.HERMIT.Core-import Language.HERMIT.PrettyPrinter+import Language.HERMIT.PrettyPrinter.Common import Text.PrettyPrint.MarkedHughesPJ as PP -listify :: (MDoc a -> MDoc a -> MDoc a) -> [MDoc a] -> MDoc a-listify _ [] = text "[]"-listify op (d:ds) = op (text "[ " <> d) (foldr (\e es -> op (text ", " <> e) es) (text "]") ds)---- | like vcat and hcat, only make the list syntax explicit-vlist, hlist :: [MDoc a] -> MDoc a-vlist = listify ($$)-hlist = listify (<+>)+--------------------------------------------------------------------------- +-- | Pretty print a fragment of GHC Core using HERMIT's \"AST\" pretty printer.+-- This displays the tree of constructors using nested indentation. corePrettyH :: PrettyOptions -> PrettyH Core corePrettyH opts = do dynFlags <- constT GHC.getDynFlags@@ -44,10 +43,10 @@ ppCoreProg = translate $ \ c -> fmap vlist . sequenceA . map (apply ppCoreBind c) . progToBinds ppCoreExpr :: PrettyH GHC.CoreExpr- ppCoreExpr = varT (\i -> text "Var" <+> varColor (ppSDoc i))+ ppCoreExpr = varT (\i -> text "Var" <+> idColor (ppSDoc i)) <+ litT (\i -> text "Lit" <+> ppSDoc i) <+ appT ppCoreExpr ppCoreExpr (\ a b -> text "App" $$ nest 2 (cat [parens a, parens b]))- <+ lamT ppCoreExpr (\ v e -> text "Lam" <+> varColor (ppSDoc v) $$ nest 2 (parens e))+ <+ lamT ppCoreExpr (\ v e -> text "Lam" <+> idColor (ppSDoc v) $$ nest 2 (parens e)) <+ letT ppCoreBind ppCoreExpr (\ b e -> text "Let" $$ nest 2 (cat [parens b, parens e])) <+ caseT ppCoreExpr (const ppCoreAlt) (\s b ty alts -> text "Case" $$ nest 2 (parens s)@@ -70,7 +69,7 @@ -- GHC uses a tuple, which we print here. The CoreDef type is our doing. ppCoreDef :: PrettyH CoreDef- ppCoreDef = defT ppCoreExpr $ \ i e -> parens $ varColor (ppSDoc i) <> text "," <> e+ ppCoreDef = defT ppCoreExpr $ \ i e -> parens $ idColor (ppSDoc i) <> text "," <> e promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr) <+ promoteT (ppCoreProg :: PrettyH CoreProg)@@ -78,3 +77,5 @@ <+ promoteT (ppCoreDef :: PrettyH CoreDef) <+ promoteT (ppModGuts :: PrettyH GHC.ModGuts) <+ promoteT (ppCoreAlt :: PrettyH GHC.CoreAlt)++---------------------------------------------------------------------------
src/Language/HERMIT/PrettyPrinter/Clean.hs view
@@ -1,30 +1,32 @@--- | Output the raw Expr constructors. Helpful for writing pattern matching rewrites.-module Language.HERMIT.PrettyPrinter.Clean where+{-# LANGUAGE CPP, LambdaCase #-} +module Language.HERMIT.PrettyPrinter.Clean+ ( -- * HERMIT's Clean Pretty-Printer for GHC Core+ corePrettyH+ )+where+ import Control.Monad (ap) import Control.Arrow hiding ((<+>)) import Data.Char (isSpace) import Data.Traversable (sequenceA) + import qualified GhcPlugins as GHC++import Language.HERMIT.Syntax import Language.HERMIT.Kure import Language.HERMIT.Core-import Language.HERMIT.PrettyPrinter+import Language.HERMIT.PrettyPrinter.Common import Language.HERMIT.GHC import TypeRep (TyLit(..))+import Pair import Text.PrettyPrint.MarkedHughesPJ as PP -listify :: (MDoc a -> MDoc a -> MDoc a) -> [MDoc a] -> MDoc a-listify _ [] = text "[]"-listify op (d:ds) = op (text "[ " <> d) (foldr (\e es -> op (text ", " <> e) es) (text "]") ds)---- | like vcat and hcat, only make the list syntax explicit-vlist, hlist :: [MDoc a] -> MDoc a-vlist = listify ($$)-hlist = listify (<+>)+------------------------------------------------------------------------------------------------ data RetExpr = RetLam [DocH] DocH@@ -48,27 +50,67 @@ keyword = markColor KeywordColor . text ppParens :: DocH -> DocH-ppParens p = symbol '(' <> p <> symbol ')' -- :: markColor SyntaxColor+ppParens p = symbol '(' <> p <> symbol ')' -atomExpr :: RetExpr -> DocH-atomExpr (RetAtom e) = e-atomExpr other = ppParens (normalExpr other)+normalExprWithParens :: RetExpr -> DocH+normalExprWithParens (RetAtom e) = e+normalExprWithParens RetEmpty = empty+normalExprWithParens (RetApp d []) = d+normalExprWithParens other = ppParens (normalExpr other) +normalExprWithParensExceptApp :: RetExpr -> DocH+normalExprWithParensExceptApp e@(RetApp _ _) = normalExpr e+normalExprWithParensExceptApp e = normalExprWithParens e+ normalExpr :: RetExpr -> DocH-normalExpr (RetLam vs e0) = hang (specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e0-normalExpr (RetLet vs e0) = sep [ keyword "let" <+> vcat vs, keyword "in" <+> e0 ]-normalExpr (RetApp fn xs) = sep [ hsep (fn : map atomExpr (takeWhile isAtom xs))- , nest 2 (sep (map atomExpr (dropWhile isAtom xs))) ]-normalExpr (RetExpr e0) = e0-normalExpr (RetAtom e0) = e0-normalExpr (RetEmpty) = empty+normalExpr (RetLam vs e) = hang (specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e+normalExpr (RetLet vs e) = sep [ keyword "let" <+> vcat vs, keyword "in" <+> e ]+normalExpr (RetApp fn xs) = let (xs1,xs2) = span isAtom xs+ in sep [ hsep (fn : map normalExpr xs1)+ , nest 2 (sep $ map normalExprWithParens xs2) ]+normalExpr (RetExpr e) = e+normalExpr (RetAtom e) = e+normalExpr (RetEmpty) = empty +coChar :: Char -> DocH+coChar = coercionColor . char++coSymbol :: SpecialSymbol -> DocH+coSymbol = coercionColor . specialFont . char . renderSpecial++castSymbol :: DocH+castSymbol = coSymbol CastSymbol++coercionSymbol :: DocH+coercionSymbol = coSymbol CoercionSymbol++coercionBindSymbol :: DocH+coercionBindSymbol = coSymbol CoercionBindSymbol++coText :: String -> DocH+coText = coercionColor . text++coKeyword :: String -> DocH+coKeyword = coText -- An alternative would be keyword.++tySymbol :: SpecialSymbol -> DocH+tySymbol = typeColor . specialFont . char . renderSpecial+ typeSymbol :: DocH-typeSymbol = markColor TypeColor (specialFont $ char $ renderSpecial TypeSymbol)+typeSymbol = tySymbol TypeSymbol typeBindSymbol :: DocH-typeBindSymbol = markColor TypeColor (specialFont $ char $ renderSpecial TypeBindSymbol)+typeBindSymbol = tySymbol TypeBindSymbol +typeArrow :: DocH+typeArrow = tySymbol RightArrowSymbol++tyText :: String -> DocH+tyText = typeColor . text++------------------------------------------------------------------------------------------------++-- | Pretty print a fragment of GHC Core using HERMIT's \"Clean\" pretty printer. corePrettyH :: PrettyOptions -> PrettyH Core corePrettyH opts = do dynFlags <- constT GHC.getDynFlags@@ -80,47 +122,68 @@ optional (Just d) k = k d ppVar :: GHC.Var -> DocH- ppVar = ppName . GHC.varName+ ppVar v = ppName (varColor v) (GHC.varName v) - ppName :: GHC.Name -> DocH- ppName = ppName' True+ varColor :: GHC.Var -> SyntaxForColor+ varColor var | GHC.isTyVar var = TypeColor+ | GHC.isCoVar var = CoercionColor+ | otherwise = IdColor - ppVar' :: Bool -> GHC.Var -> DocH- ppVar' useVarColor = ppName' useVarColor . GHC.varName+ ppName :: SyntaxForColor -> GHC.Name -> DocH+ ppName color nm = let name = GHC.occNameString (GHC.nameOccName nm)+ doc = markColor color (text name)+ in if all isInfixId name+ then ppParens doc+ else doc - ppName' :: Bool -> GHC.Name -> DocH- ppName' useVarColor nm- | isInfix name = ppParens $ markColor color $ text name- | otherwise = markColor color $ text name- where name = GHC.occNameString $ GHC.nameOccName $ nm- isInfix = all (\ n -> n `elem` "!@#$%^&*-._+=:?/\\<>'")- color = if useVarColor then VarColor else TypeColor+ ppLitTy :: TyLit -> DocH+ ppLitTy tylit = typeColor $ text $ case tylit of+ NumTyLit i -> show i+ StrTyLit fs -> show fs - ppLitTy :: Bool -> TyLit -> DocH- ppLitTy useVarColor tylit = markColor color $ text $ case tylit of- NumTyLit i -> show i- StrTyLit fs -> show fs- where color = if useVarColor then VarColor else TypeColor+ ppTyCon :: GHC.TyCon -> DocH+ ppTyCon = ppName TypeColor . GHC.getName + ppTyConCo :: GHC.TyCon -> DocH+ ppTyConCo = ppName CoercionColor . GHC.getName + ppTypeMode :: GHC.Type -> RetExpr+ ppTypeMode t = case po_exprTypes opts of+ Omit -> RetEmpty+ Abstract -> RetAtom typeSymbol+ _ -> ppCoreType t++ ppCoercionMode :: GHC.Coercion -> RetExpr+ ppCoercionMode co = case po_coercions opts of+ Omit -> RetEmpty+ Abstract -> RetAtom coercionSymbol+ Show -> ppCoreCoercion co+ Kind -> RetExpr (coercionSymbol <+> specialSymbol TypeOfSymbol <+> ppCoKind co)+ -- binders are vars that is bound by lambda or case, etc. ppBinder :: GHC.Var -> Maybe DocH ppBinder var | GHC.isTyVar var = case po_exprTypes opts of- Abstract -> Just $ typeBindSymbol- Omit -> Nothing- _ -> Just $ ppVar' False var- | otherwise = Just $ ppVar var+ Omit -> Nothing+ Abstract -> Just typeBindSymbol+ _ -> Just (ppVar var)+ | GHC.isCoVar var = case po_coercions opts of+ Omit -> Nothing+ Abstract -> Just coercionBindSymbol+ Show -> Just (ppVar var)+ Kind -> Just $ ppParens (coercionBindSymbol <+> specialSymbol TypeOfSymbol <+> ppCoKind (GHC.CoVarCo var))+ -- TODO: refactor this to be more systematic. It should be possible to request type sigs for all type bindings.+ | otherwise = Just $ ppVar var -- Use for any GHC structure, the 'showSDoc' prefix is to remind us -- that we are eliding infomation here.- ppSDoc :: (GHC.Outputable a) => a -> MDoc b+ ppSDoc :: GHC.Outputable a => a -> MDoc b ppSDoc = toDoc . (if hideNotes then id else ("showSDoc: " ++)) . GHC.showSDoc dynFlags . GHC.ppr where toDoc s | any isSpace s = parens (text s) | otherwise = text s ppModGuts :: PrettyH GHC.ModGuts ppModGuts = arr $ \ m -> hang (keyword "module" <+> ppSDoc (GHC.mg_module m) <+> keyword "where") 2- (vcat [ (optional (ppBinder v) (\b -> b <+> specialSymbol TypeOfSymbol <+> normalExpr (ppCoreType True (GHC.idType v))))+ (vcat [ (optional (ppBinder v) (\b -> b <+> specialSymbol TypeOfSymbol <+> normalExpr (ppCoreType $ GHC.idType v))) | bnd <- GHC.mg_binds m , v <- case bnd of GHC.NonRec f _ -> [f]@@ -135,19 +198,24 @@ ppCoreExpr :: PrettyH GHC.CoreExpr ppCoreExpr = ppCoreExprR >>^ normalExpr - appendArg xs (RetEmpty) = xs- appendArg xs e = xs ++ [e]+ ppApp :: RetExpr -> RetExpr -> RetExpr+ ppApp e1 e2 = case e1 of+ RetApp f xs -> RetApp f (snocNonEmpty xs e2)+ _ -> case e2 of -- if there are no (displayed) args then don't parenthesise+ RetEmpty -> e1+ args -> RetApp (normalExprWithParens e1) (snocNonEmpty [] args) - appendBind Nothing xs = xs- appendBind (Just v) xs = v : xs+ snocNonEmpty :: [RetExpr] -> RetExpr -> [RetExpr]+ snocNonEmpty xs RetEmpty = xs+ snocNonEmpty xs e = xs ++ [e] ppCoreExprR :: TranslateH GHC.CoreExpr RetExpr ppCoreExprR = ppCoreExprPR `ap` rootPathT ppCoreExprPR :: TranslateH GHC.CoreExpr (Path -> RetExpr) ppCoreExprPR = lamT ppCoreExprR (\ v e _ -> case e of- RetLam vs e0 -> RetLam (appendBind (ppBinder v) vs) e0- _ -> RetLam (appendBind (ppBinder v) []) (normalExpr e))+ RetLam vs e0 -> RetLam (consMaybe (ppBinder v) vs) e0+ _ -> RetLam (consMaybe (ppBinder v) []) (normalExpr e)) <+ letT ppCoreBind ppCoreExprR (\ bd e _ -> case e of@@ -175,71 +243,120 @@ ) - <+ appT ppCoreExprR ppCoreExprR- (\ e1 e2 _ -> case e1 of- RetApp f xs -> RetApp f (appendArg xs e2)- _ -> case e2 of -- if our only args are types, and they are omitted, don't paren- RetEmpty -> e1- args -> RetApp (atomExpr e1) (appendArg [] args))+ <+ appT ppCoreExprR ppCoreExprR (\ e1 e2 _ -> ppApp e1 e2)++ <+ caseT ppCoreExpr (const ppCoreAlt) (\ s b _ alts p -> RetExpr $ attrP p ((keyword "case" <+> s <+> keyword "of" <+> optional (ppBinder b) id) $$ nest 2 (vcat alts))) <+ varT (\ i p -> RetAtom (attrP p $ ppVar i)) <+ litT (\ i p -> RetAtom (attrP p $ ppSDoc i))- <+ typeT (\ t p -> case po_exprTypes opts of- Show -> case ppCoreType False t of- RetAtom d -> RetAtom $ attrP p d- RetExpr d -> RetExpr $ attrP p d- _ -> error "not possible!"- Abstract -> RetAtom (attrP p $ typeSymbol)- Omit -> RetEmpty)- <+ (ppCoreExpr0 >>^ \ e p -> RetExpr (attrP p e))+ <+ typeT (\ t p -> attrPAtomExpr p $ ppTypeMode t)+ <+ coercionT (\ co p -> attrPAtomExpr p $ ppCoercionMode co)+ <+ castT ppCoreExprR (\ e co p -> let e' = normalExprWithParensExceptApp e+ in case ppCoercionMode co of+ RetEmpty -> e+ RetAtom pCo -> RetExpr $ attrP p (e' <+> castSymbol <+> pCo)+ pCo -> RetExpr $ attrP p (e' <+> castSymbol <+> normalExprWithParensExceptApp pCo)+ )+ <+ tickT ppCoreExpr (\ i e p -> RetExpr $ attrP p (text "Tick" $$ nest 2 (ppSDoc i <+> parens e))) - ppCoreType :: Bool -> GHC.Type -> RetExpr- ppCoreType isTySig = go- where go (TyVarTy v) = RetAtom $ ppVar' isTySig v- go (LitTy tylit) = RetAtom $ ppLitTy isTySig tylit- go (AppTy t1 t2) = RetExpr $ normalExpr (go t1) <+> normalExpr (go t2)- go (TyConApp tyCon tys)- | GHC.isFunTyCon tyCon, [ty1,ty2] <- tys = go (FunTy ty1 ty2)- | GHC.isTupleTyCon tyCon = case map (normalExpr . go) tys of+ attrPAtomExpr :: Path -> RetExpr -> RetExpr+ attrPAtomExpr p (RetAtom d) = RetAtom (attrP p d)+ attrPAtomExpr p (RetExpr d) = RetExpr (attrP p d)+ attrPAtomExpr _ e = e++ ppCoreType :: GHC.Type -> RetExpr+ ppCoreType (TyVarTy v) = RetAtom (ppVar v)+ ppCoreType (LitTy tylit) = RetAtom (ppLitTy tylit)+ ppCoreType (AppTy t1 t2) = let e1 = ppCoreType t1+ e2 = ppCoreType t2+ in ppApp e1 e2+ ppCoreType (FunTy ty1 ty2) = RetExpr $ normalExprWithParensExceptApp (ppCoreType ty1) <+> typeArrow <+> normalExpr (ppCoreType ty2)+ ppCoreType (ForAllTy v ty) = RetExpr $ specialSymbol ForallSymbol <+> ppVar v <+> symbol '.' <+> normalExpr (ppCoreType ty)+ ppCoreType (TyConApp tyCon tys)+ | GHC.isFunTyCon tyCon, [ty1,ty2] <- tys = ppCoreType (FunTy ty1 ty2)+ | tyCon == GHC.listTyCon = RetAtom $ tyText "[" <> (case map (normalExpr . ppCoreType) tys of+ [] -> empty+ t:_ -> t ) <> tyText "]"+ | GHC.isTupleTyCon tyCon = case map (normalExpr . ppCoreType) tys of [] -> RetAtom $ tyText "()" ds -> RetAtom $ tyText "(" <> (foldr1 (\d r -> d <> tyText "," <+> r) ds) <> tyText ")"- | otherwise = RetAtom $ ppName' isTySig (GHC.getName tyCon) <+> sep (map (normalExpr . go) tys) -- has spaces, but we never want parens- go (FunTy ty1 ty2) = RetExpr $ atomExpr (go ty1) <+> tyText "->" <+> normalExpr (go ty2)- go (ForAllTy v ty) = RetExpr $ specialSymbol ForallSymbol <+> ppVar' isTySig v <+> symbol '.' <+> normalExpr (go ty)+ | otherwise = RetApp (ppTyCon tyCon) (map ppCoreType tys) - tyText = if isTySig then text else markColor TypeColor . text+ ppCoreCoercion :: GHC.Coercion -> RetExpr+ ppCoreCoercion (GHC.Refl t) = let refl = coKeyword "refl"+ in case po_exprTypes opts of+ Omit -> RetAtom refl+ _ -> RetExpr (refl <+> normalExprWithParens (ppTypeMode t))+ ppCoreCoercion (GHC.CoVarCo v) = RetAtom (ppVar v)+ ppCoreCoercion (GHC.SymCo co) = RetExpr (coKeyword "sym" <+> normalExprWithParens (ppCoreCoercion co))+ ppCoreCoercion (GHC.ForAllCo v co) = let e = ppCoreCoercion co+ in case po_exprTypes opts of+ Omit -> e+ _ -> RetExpr (specialSymbol ForallSymbol <+> optional (ppBinder v) (\d -> d <+> symbol '.' <+> normalExprWithParensExceptApp e))+ ppCoreCoercion (GHC.TransCo co1 co2) = RetExpr (normalExprWithParensExceptApp (ppCoreCoercion co1) <+> coChar ';' <+> normalExprWithParensExceptApp (ppCoreCoercion co2))+ ppCoreCoercion (GHC.UnsafeCo t1 t2) = RetExpr (ppTypePairCoercion t1 t2)+ ppCoreCoercion (GHC.NthCo n co) = RetExpr (coKeyword "nth" <+> coText (show n) <+> normalExprWithParens (ppCoreCoercion co))+ ppCoreCoercion (GHC.InstCo co t) = let e = ppCoreCoercion co+ in case po_exprTypes opts of+ Omit -> e+ _ -> RetExpr (normalExprWithParensExceptApp e <+> coChar '@' <+> normalExprWithParensExceptApp (ppTypeMode t))+ ppCoreCoercion (GHC.TyConAppCo tc cs) = RetApp (ppTyConCo tc) (map ppCoreCoercion cs)+ ppCoreCoercion (GHC.AppCo co1 co2) = let e1 = ppCoreCoercion co1+ e2 = ppCoreCoercion co2+ in ppApp e1 e2+#if __GLASGOW_HASKELL__ > 706+ -- TODO: Figure out how to properly pp new branched Axioms and Left/Right Coercions+ ppCoreCoercion (GHC.AxiomInstCo ax idx cs) = RetApp (coercionColor $ ppSDoc ax) (RetAtom (ppSDoc idx) : map ppCoreCoercion cs)+ ppCoreCoercion (GHC.LRCo lr co) = RetApp (coercionColor $ ppSDoc lr) [ppCoreCoercion co]+#else+ ppCoreCoercion (GHC.AxiomInstCo ax cs) = RetApp (coercionColor $ ppSDoc ax) (map ppCoreCoercion cs) -- TODO: add pretty printer for Coercion Axioms+#endif - ppCoreExpr0 :: PrettyH GHC.CoreExpr- ppCoreExpr0 = caseT ppCoreExpr (const ppCoreAlt) (\ s b _ty alts ->- (keyword "case" <+> s <+> keyword "of" <+> optional (ppBinder b) id) $$- nest 2 (vcat alts))- <+ castT ppCoreExpr (\e co -> text "Cast" $$ nest 2 ((parens e) <+> ppSDoc co))- <+ tickT ppCoreExpr (\i e -> text "Tick" $$ nest 2 (ppSDoc i <+> parens e))- -- <+ typeT (\ty -> text "Type" <+> nest 2 (ppSDoc ty))- <+ coercionT (\co -> text "Coercion" $$ nest 2 (ppSDoc co))+ ppTypePairCoercion :: Type -> Type -> DocH+ ppTypePairCoercion t1 t2 = normalExprWithParensExceptApp (ppTypeMode t1) <+> coChar '~' <+> normalExprWithParensExceptApp (ppTypeMode t2) + ppCoKind :: GHC.Coercion -> DocH+ ppCoKind = uncurry ppTypePairCoercion . unPair . GHC.coercionKind++ ppCoreTypeSig :: PrettyH GHC.CoreExpr+ ppCoreTypeSig = arr (\case+ GHC.Coercion c -> ppCoKind c+ e -> normalExpr $ ppCoreType $ GHC.exprType e)+ ppCoreBind :: PrettyH GHC.CoreBind- ppCoreBind = nonRecT ppCoreExprR ppDefFun+ ppCoreBind = nonRecT (ppCoreExprR &&& ppCoreTypeSig) ppDefFun <+ recT (const ppCoreDef) (\ bnds -> keyword "rec" <+> vcat bnds) ppCoreAlt :: PrettyH GHC.CoreAlt- ppCoreAlt = altT ppCoreExpr $ \ con ids e -> case con of- GHC.DataAlt dcon -> hang (ppName (GHC.dataConName dcon) <+> ppIds ids) 2 e- GHC.LitAlt lit -> hang (ppSDoc lit <+> ppIds ids) 2 e- GHC.DEFAULT -> symbol '_' <+> ppIds ids <+> e- where- ppIds ids | null ids = specialSymbol RightArrowSymbol- | otherwise = hsep (map (flip optional id . ppBinder) ids) <+> specialSymbol RightArrowSymbol+ ppCoreAlt = altT ppCoreExpr $ \ con vs e -> let ppVars = if null vs+ then specialSymbol RightArrowSymbol+ else hsep (map (flip optional id . ppBinder) vs) <+> specialSymbol RightArrowSymbol+ in case con of+ GHC.DataAlt dcon -> hang (ppName IdColor (GHC.dataConName dcon) <+> ppVars) 2 e+ GHC.LitAlt lit -> hang (ppSDoc lit <+> ppVars) 2 e+ GHC.DEFAULT -> symbol '_' <+> ppVars <+> e -- GHC uses a tuple, which we print here. The CoreDef type is our doing. ppCoreDef :: PrettyH CoreDef- ppCoreDef = defT ppCoreExprR ppDefFun+ ppCoreDef = defT (ppCoreExprR &&& ppCoreTypeSig) ppDefFun - ppDefFun :: GHC.Id -> RetExpr -> DocH- ppDefFun i e = case e of+ ppDefFun :: GHC.Var -> (RetExpr, DocH) -> DocH+ ppDefFun v (e,ty) = case po_exprTypes opts of+ Show -> if GHC.isCoVar v+ then let coTySig = specialSymbol TypeOfSymbol <+> ty+ in case po_coercions opts of+ Omit -> empty+ Show -> (ppVar v <+> coTySig) $+$ body+ _ -> (coercionBindSymbol <+> coTySig)+ else (ppVar v <+> specialSymbol TypeOfSymbol <+> ty) $+$ body+ Omit -> if GHC.isTyVar v+ then empty+ else body+ _ -> body+ where+ pre = optional (ppBinder v) (<+> symbol '=')+ body = case e of RetLam vs e0 -> hang (pre <+> specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e0 _ -> hang pre 2 (normalExpr e)- where- pre = optional (ppBinder i) (<+> symbol '=') promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr) <+ promoteT (ppCoreProg :: PrettyH CoreProg)@@ -247,3 +364,11 @@ <+ promoteT (ppCoreDef :: PrettyH CoreDef) <+ promoteT (ppModGuts :: PrettyH GHC.ModGuts) <+ promoteT (ppCoreAlt :: PrettyH GHC.CoreAlt)++------------------------------------------------------------------------------------------------++consMaybe :: Maybe a -> [a] -> [a]+consMaybe Nothing as = as+consMaybe (Just a) as = a : as++------------------------------------------------------------------------------------------------
+ src/Language/HERMIT/PrettyPrinter/Common.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeFamilies #-}++module Language.HERMIT.PrettyPrinter.Common where++import Control.Arrow hiding ((<+>))++import Data.Char+import Data.Default+import Data.Monoid hiding ((<>))+import qualified Data.Map as M+import Data.Typeable++import GhcPlugins hiding ((<>),(<+>),($$))++import Language.HERMIT.Core+import Language.HERMIT.External+import Language.HERMIT.Kure++import System.IO++import Text.PrettyPrint.MarkedHughesPJ as PP++-- A HERMIT document+type DocH = MDoc HermitMark++-- newtype wrapper for proper instance selection+newtype TranslateDocH a = TranslateDocH { unTranslateDocH :: PrettyH a -> TranslateH a DocH }++data TranslateCoreDocHBox = TranslateCoreDocHBox (TranslateDocH Core) deriving Typeable++instance Extern (TranslateDocH Core) where+ type Box (TranslateDocH Core) = TranslateCoreDocHBox+ box = TranslateCoreDocHBox+ unbox (TranslateCoreDocHBox i) = i++-- These are the zero-width marks on the document+data HermitMark+ = PushAttr Attr+ | PopAttr+ deriving Show++-- These are the attributes+data Attr = PathAttr Path+ | Color SyntaxForColor+ | SpecialFont+ deriving Show++data SyntaxForColor -- (suggestion)+ = KeywordColor -- bold+ | SyntaxColor+ | IdColor+ | CoercionColor+ | TypeColor+ | LitColor+ deriving Show++attr :: Attr -> DocH -> DocH+attr a p = mark (PushAttr a) <> p <> mark PopAttr++-- Hack, till we get 'PathAttr' working properly+-- The problem is that attributes span over multiple lines,+-- messing up the latex output++attrP :: Path -> DocH -> DocH+attrP _ doc = doc -- attr . PathAttr++idColor :: DocH -> DocH+idColor = markColor IdColor++typeColor :: DocH -> DocH+typeColor = markColor TypeColor++coercionColor :: DocH -> DocH+coercionColor = markColor CoercionColor+++keywordColor :: DocH -> DocH+keywordColor = markColor KeywordColor++markColor :: SyntaxForColor -> DocH -> DocH+markColor = attr . Color++specialFont :: DocH -> DocH+specialFont = attr SpecialFont+++type PrettyH a = TranslateH a DocH++-- These are *recommendations* to the pretty printer.++data PrettyOptions = PrettyOptions+ { po_fullyQualified :: Bool -- Do you show fully qualified names?+ , po_exprTypes :: ShowOption -- Do you hide types, and type arguments, as <>?+ , po_coercions :: ShowOption -- Do you hide coercions?+ , po_typesForBinders :: ShowOption -- Do you give the types for all bindings?+ , po_highlight :: Maybe Path -- This region should be highlighted (for sub-expression)+ , po_depth :: Maybe Int -- below this depth are ..., Nothing => infinite+ , po_notes :: Bool -- ^ notes might be added to output+ , po_ribbon :: Float+ , po_width :: Int+ } deriving Show++data ShowOption = Show | Abstract | Omit | Kind deriving (Eq, Ord, Show, Read)++-- Types don't have a Kind showing option.+updateTypeShowOption :: ShowOption -> PrettyOptions -> PrettyOptions+updateTypeShowOption Kind po = po+updateTypeShowOption opt po = po { po_exprTypes = opt }++updateCoShowOption :: ShowOption -> PrettyOptions -> PrettyOptions+updateCoShowOption opt po = po { po_coercions = opt }++instance Default PrettyOptions where+ def = PrettyOptions+ { po_fullyQualified = False+ , po_exprTypes = Abstract+ , po_coercions = Abstract+ , po_typesForBinders = Omit+ , po_highlight = Nothing+ , po_depth = Nothing+ , po_notes = False+ , po_ribbon = 1.2+ , po_width = 80+ }++-----------------------------------------------------------------++-- The characters for special symbols, which have a special alphabet++data SpecialSymbol+ = LambdaSymbol+ | TypeOfSymbol+ | RightArrowSymbol+ | CastSymbol+ | CoercionSymbol+ | CoercionBindSymbol+ | TypeSymbol+ | TypeBindSymbol+ | ForallSymbol+ deriving (Show, Eq, Ord, Bounded, Enum)++class RenderSpecial a where+ renderSpecial :: SpecialSymbol -> a+++-- This instance is special. It is used as an index, forming an association list.+-- Thus all of the rhs must be distinct characters.+-- Think of RenderSpecial as a special font.+instance RenderSpecial Char where+ renderSpecial LambdaSymbol = '\\' -- lambda+ renderSpecial TypeOfSymbol = ':' -- ::+ renderSpecial RightArrowSymbol = '>' -- ->+ renderSpecial CastSymbol = '#' -- "|>"+ renderSpecial CoercionSymbol = 'C' -- <<coercion>>>+ renderSpecial CoercionBindSymbol = 'c' -- <<coercion>>>+ renderSpecial TypeSymbol = 'T' -- <<type>>>+ renderSpecial TypeBindSymbol = 't' -- <<type binding>>+ renderSpecial ForallSymbol = 'F' -- forall++newtype ASCII = ASCII String++instance Monoid ASCII where+ mempty = ASCII ""+ mappend (ASCII xs) (ASCII ys) = ASCII (xs ++ ys)++instance RenderSpecial ASCII where+ renderSpecial LambdaSymbol = ASCII "\\" -- lambda+ renderSpecial TypeOfSymbol = ASCII "::" -- ::+ renderSpecial RightArrowSymbol = ASCII "->" -- ->+ renderSpecial CastSymbol = ASCII "|>" -- "|>"+ renderSpecial CoercionSymbol = ASCII "~#" -- <<coercion>>>+ renderSpecial CoercionBindSymbol = ASCII "~#" -- <<coercion binding>>>+ renderSpecial TypeSymbol = ASCII "*" -- <<type>>>+ renderSpecial TypeBindSymbol = ASCII "*" -- <<type binding>>>+ renderSpecial ForallSymbol = ASCII "\\/"++newtype Unicode = Unicode Char++instance RenderSpecial Unicode where+ renderSpecial LambdaSymbol = Unicode '\x03BB'+ renderSpecial TypeOfSymbol = Unicode '\x2237' -- called PROPORTION+ renderSpecial RightArrowSymbol = Unicode '\x2192'+ renderSpecial CastSymbol = Unicode '\x25B9'+ renderSpecial CoercionSymbol = Unicode '\x25A0'+ renderSpecial CoercionBindSymbol = Unicode '\x25A1'+ renderSpecial TypeSymbol = Unicode '\x25b2'+ renderSpecial TypeBindSymbol = Unicode '\x25b3'+ renderSpecial ForallSymbol = Unicode '\x2200'++newtype LaTeX = LaTeX String++instance Monoid LaTeX where+ mempty = LaTeX ""+ mappend (LaTeX xs) (LaTeX ys) = LaTeX (xs ++ ys)++instance RenderSpecial LaTeX where+ renderSpecial LambdaSymbol = LaTeX "\\ensuremath{\\lambda}"+ renderSpecial TypeOfSymbol = LaTeX ":\\!:" -- too wide+ renderSpecial RightArrowSymbol = LaTeX "\\ensuremath{\\shortrightarrow}"+ renderSpecial CastSymbol = LaTeX "\\ensuremath{\\triangleright}"+ renderSpecial CoercionSymbol = LaTeX "\\ensuremath{\\blacksquare}"+ renderSpecial CoercionBindSymbol = LaTeX "\\ensuremath{\\square}"+ renderSpecial TypeSymbol = LaTeX "\\ensuremath{\\blacktriangle}"+ renderSpecial TypeBindSymbol = LaTeX "\\ensuremath{\\vartriangle}"+ renderSpecial ForallSymbol = LaTeX "\\ensuremath{\\forall}"+++newtype HTML = HTML String++instance Monoid HTML where+ mempty = HTML ""+ mappend (HTML xs) (HTML ys) = HTML (xs ++ ys)++instance RenderSpecial HTML where+ renderSpecial LambdaSymbol = HTML "λ"+ renderSpecial TypeOfSymbol = HTML "∷"+ renderSpecial RightArrowSymbol = HTML "→"+ renderSpecial CastSymbol = HTML "▹"+ renderSpecial CoercionSymbol = HTML "■"+ renderSpecial CoercionBindSymbol = HTML "□"+ renderSpecial TypeSymbol = HTML "▲"+ renderSpecial TypeBindSymbol = HTML "△"+ renderSpecial ForallSymbol = HTML "∀"+++renderSpecialFont :: RenderSpecial a => Char -> Maybe a+renderSpecialFont = fmap renderSpecial . flip M.lookup specialFontMap++specialFontMap :: M.Map Char SpecialSymbol+specialFontMap = M.fromList+ [ (renderSpecial s,s)+ | s <- [minBound..maxBound]+ ]+++class (RenderSpecial a, Monoid a) => RenderCode a where+ rStart :: a+ rStart = mempty+ rEnd :: a+ rEnd = mempty++ rDoHighlight :: Bool -> [Attr] -> a+ rPutStr :: String -> a+++-- This is what the pretty printer can see+data PrettyState = PrettyState+ { prettyPath :: Path+ , prettyColor :: Maybe SyntaxForColor+ }++--stackToPrettyState :: [Attr] -> PrettyState+--stackToPrettyState =++renderCode :: RenderCode a => PrettyOptions -> DocH -> a+renderCode opts doc = rStart `mappend` PP.fullRender PP.PageMode w rib marker (\ _ -> rEnd) doc []+ where+ -- options+ w = po_width opts+ rib = po_ribbon opts++ marker :: RenderCode a => PP.TextDetails HermitMark -> ([Attr] -> a) -> ([Attr]-> a)+ marker m rest cols@(SpecialFont:_) = case m of+ PP.Chr ch -> special [ch] `mappend` rest cols+ PP.Str str -> special str `mappend` rest cols+ PP.PStr str -> special str `mappend` rest cols+ PP.Mark (PopAttr) ->+ let (_:cols') = cols in rDoHighlight False cols' `mappend` rest cols'+ PP.Mark (PushAttr _) -> error "renderCode: can not have marks inside special symbols"+ marker m rest cols = case m of+ PP.Chr ch -> rPutStr [ch] `mappend` rest cols+ PP.Str str -> rPutStr str `mappend` rest cols+ PP.PStr str -> rPutStr str `mappend` rest cols+ PP.Mark (PushAttr a) ->+ let cols' = a : cols in rDoHighlight True cols' `mappend` rest cols'+ PP.Mark (PopAttr) -> do+ let (_:cols') = cols in rDoHighlight False cols' `mappend` rest cols'++ special txt = mconcat [ code | Just code <- map renderSpecialFont txt ]+++-- Other options for pretty printing:+-- * Does a top level program should function names, or complete listings?++-- This is the hacky old pretty printer, using the new API+ghcCorePrettyH :: PrettyH Core+ghcCorePrettyH =+ promoteT (ppModule :: PrettyH ModGuts)+ <+ promoteT (ppProg :: PrettyH CoreProg)+ <+ promoteT (ppH :: PrettyH CoreBind)+ <+ promoteT (ppDef :: PrettyH CoreDef)+ <+ promoteT (ppH :: PrettyH CoreExpr)+ <+ promoteT (ppH :: PrettyH CoreAlt)+ where++ ppH :: (Outputable a) => PrettyH a+ ppH = contextfreeT $ \e -> do+ dynFlags <- getDynFlags+ return $ PP.text $ showSDoc dynFlags $ ppr e++ ppModule :: PrettyH ModGuts+ ppModule = mg_module ^>> ppH++ ppProg :: PrettyH CoreProg+ ppProg = progToBinds ^>> ppH++ ppDef :: PrettyH CoreDef+ ppDef = defToIdExpr ^>> ppH++-- arr (PP.text . ppr . mg_module)++--- Moving the renders back into the core hermit++-------------------------------------------------------------------------------++coreRenders :: [(String,Handle -> PrettyOptions -> DocH -> IO ())]+coreRenders =+ [ ("latex", \ h w doc -> do+ let pretty = latexToString $ renderCode w doc+ hPutStr h pretty)+ , ("html", \ h w doc -> do+ let HTML pretty = renderCode w doc+ hPutStr h pretty)+ , ("ascii", \ h w doc -> do+ let (ASCII pretty) = renderCode w doc+ hPutStrLn h pretty)+ , ("debug", \ h w doc -> do+ let (DebugPretty pretty) = renderCode w doc+ hPutStrLn h pretty)+ ]++latexVerbatim :: String -> LaTeX -> LaTeX+latexVerbatim str (LaTeX v) = LaTeX (str ++ v)++latexToString :: LaTeX -> String+latexToString (LaTeX orig) = unlines $ map trunkSpaces $ lines orig where+ trunkSpaces txt = case span isSpace txt of+ ([],rest) -> rest+ (pre,rest) -> "\\hspace{" ++ show (length pre) ++ "\\hermitspace}" ++ rest++instance RenderCode LaTeX where+ rPutStr txt = LaTeX txt++ rDoHighlight False _ = LaTeX "}"+ rDoHighlight _ [] = LaTeX $ "{"+ rDoHighlight _ (Color col:_) = LaTeX $ "{" ++ case col of+ KeywordColor -> "\\color{hermit:keyword}" -- blue+ SyntaxColor -> "\\color{hermit:syntax}" -- red+ IdColor -> ""+ CoercionColor -> "\\color{hermit:coercion}" -- yellow+ TypeColor -> "\\color{hermit:type}" -- green+ LitColor -> "\\color{hermit:lit}" -- cyan+ rDoHighlight o (_:rest) = rDoHighlight o rest++ rEnd = LaTeX "\n" -- \\end{Verbatim}"++{- | Use css to do the colors+ -+ - > <style type="text/css">+ - > .hermit-syntax {+ - > color: red;+ - > </style>+ -}++instance RenderCode HTML where+ rPutStr txt = HTML txt++ rDoHighlight False _ = HTML "</span>"+ rDoHighlight _ [] = HTML $ "<span>"+ rDoHighlight _ (Color col:_) = HTML $ case col of+ KeywordColor -> "<span class=\"hermit-keyword\">" -- blue+ SyntaxColor -> "<span class=\"hermit-syntax\">" -- red+ IdColor -> "<span>"+ CoercionColor -> "<span class=\"hermit-coercion\">" -- yellow+ TypeColor -> "<span class=\"hermit-type\">" -- green+ LitColor -> "<span class=\"hermit-lit\">" -- cyan+ rDoHighlight o (_:rest) = rDoHighlight o rest+ rEnd = HTML "\n"+++instance RenderCode ASCII where+ rPutStr txt = ASCII txt++ rDoHighlight _ _ = ASCII ""++ rEnd = ASCII "\n"++data DebugPretty = DebugPretty String++instance RenderSpecial DebugPretty where+ renderSpecial sym = DebugPretty ("{" ++ show sym ++ "}")++instance Monoid DebugPretty where+ mempty = DebugPretty ""+ mappend (DebugPretty xs) (DebugPretty ys) = DebugPretty $ xs ++ ys++instance RenderCode DebugPretty where+ rStart = DebugPretty "(START)\n"++ rPutStr txt = DebugPretty txt++ rDoHighlight True stk = DebugPretty $ show (True,stk)+ rDoHighlight False stk = DebugPretty $ show (False,stk)++ rEnd = DebugPretty "(END)\n"++-------------------------------------------------------------------------------++listify :: (MDoc a -> MDoc a -> MDoc a) -> [MDoc a] -> MDoc a+listify _ [] = PP.text "[]"+listify op (d:ds) = op (PP.text "[ " <> d) (foldr (\e es -> op (PP.text ", " <> e) es) (PP.text "]") ds)++-- | like vcat and hcat, only make the list syntax explicit+vlist, hlist :: [MDoc a] -> MDoc a+vlist = listify ($$)+hlist = listify (<+>)++-------------------------------------------------------------------------------
src/Language/HERMIT/PrettyPrinter/GHC.hs view
@@ -1,5 +1,9 @@ -- | Output the raw Expr constructors. Helpful for writing pattern matching rewrites.-module Language.HERMIT.PrettyPrinter.GHC where+module Language.HERMIT.PrettyPrinter.GHC+ ( -- * GHC's standard Pretty-Printer for GHC Core+ corePrettyH+ )+where import Control.Arrow hiding ((<+>)) @@ -8,19 +12,13 @@ import qualified GhcPlugins as GHC import Language.HERMIT.Kure import Language.HERMIT.Core-import Language.HERMIT.PrettyPrinter+import Language.HERMIT.PrettyPrinter.Common import Text.PrettyPrint.MarkedHughesPJ as PP -listify :: (MDoc a -> MDoc a -> MDoc a) -> [MDoc a] -> MDoc a-listify _ [] = text "[]"-listify op (d:ds) = op (text "[ " <> d) (foldr (\e es -> op (text ", " <> e) es) (text "]") ds)---- | like vcat and hcat, only make the list syntax explicit-vlist, hlist :: [MDoc a] -> MDoc a-vlist = listify ($$)-hlist = listify (<+>)+--------------------------------------------------------------------------- +-- | This pretty printer is just a reflection of GHC's standard pretty printer. corePrettyH :: PrettyOptions -> PrettyH Core corePrettyH opts = do dynFlags <- constT GHC.getDynFlags@@ -58,3 +56,5 @@ <+ promoteT (ppCoreDef :: PrettyH CoreDef) <+ promoteT (ppModGuts :: PrettyH GHC.ModGuts) <+ promoteT (ppCoreAlt :: PrettyH GHC.CoreAlt)++---------------------------------------------------------------------------
− src/Language/HERMIT/PrettyPrinter/JSON.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | JSON pretty printer-module Language.HERMIT.PrettyPrinter.JSON where--import Control.Arrow--import Data.Aeson-import Data.Aeson.Types-import qualified Data.Text as T--import qualified GhcPlugins as GHC-import Language.HERMIT.Kure-import Language.HERMIT.Core-import Language.HERMIT.PrettyPrinter--corePrettyH :: PrettyOptions -> TranslateH Core Value-corePrettyH _opts = do- dynFlags <- constT GHC.getDynFlags-- let mkCon :: String -> Pair- mkCon con = "con" .= con-- -- Use for any GHC structure, the 'showSDoc' prefix is to remind us- -- that we are eliding infomation here.- ppSDoc :: (GHC.Outputable a) => a -> Value- ppSDoc = String . T.pack . GHC.showPpr dynFlags-- ppModGuts :: TranslateH GHC.ModGuts Value- ppModGuts = arr (ppSDoc . GHC.mg_module)-- -- DocH is not a monoid.- -- GHC uses a list, which we print here. The CoreProg type is our doing.- ppCoreProg :: TranslateH CoreProg Value- ppCoreProg = translate $ \ c -> fmap toJSON . mapM (apply ppCoreBind c) . progToBinds-- ppCoreExpr :: TranslateH GHC.CoreExpr Value- ppCoreExpr = varT (\i -> object [mkCon "Var", "value" .= ppSDoc i])- <+ litT (\i -> object [mkCon "Lit", "value" .= ppSDoc i])- <+ appT ppCoreExpr ppCoreExpr (\ a b -> object [mkCon "App", "lhs" .= a, "rhs" .= b])- <+ lamT ppCoreExpr (\ v e -> object [mkCon "Lam", "var" .= ppSDoc v, "body" .= e])- <+ letT ppCoreBind ppCoreExpr (\ b e -> object [mkCon "Let", "binds" .= b, "exp" .= e])- <+ caseT ppCoreExpr (const ppCoreAlt) (\s b ty alts ->- object [ mkCon "Case"- , "s" .= s- , "caseBndr" .= ppSDoc b- , "type" .= ppSDoc ty- , "alts" .= alts ])- <+ castT ppCoreExpr (\e co -> object [mkCon "Cast", "exp" .= e, "cast" .= ppSDoc co])- <+ tickT ppCoreExpr (\i e -> object [mkCon "Tick", "tick" .= ppSDoc i, "exp" .= e])- <+ typeT (\ty -> object [mkCon "Type", "type" .= ppSDoc ty])- <+ coercionT (\co -> object [mkCon "Coercion", "coercion" .= ppSDoc co])-- ppCoreBind :: TranslateH GHC.CoreBind Value- ppCoreBind = nonRecT ppCoreExpr (\i e -> object [mkCon "NonRec", "var" .= ppSDoc i, "exp" .= e])- <+ recT (const ppCoreDef) (\bnds -> object [mkCon "Rec", "binds" .= bnds])-- ppCoreAlt :: TranslateH GHC.CoreAlt Value- ppCoreAlt = altT ppCoreExpr $ \ con ids e -> object [ mkCon "Alt"- , "altcon" .= ppSDoc con- , "ids" .= map ppSDoc ids- , "exp" .= e ]-- ppCoreDef :: TranslateH CoreDef Value- ppCoreDef = defT ppCoreExpr $ \ i e -> object [mkCon "CoreDef", "var" .= ppSDoc i, "exp" .= e]-- promoteT ppCoreExpr- <+ promoteT ppCoreProg- <+ promoteT ppCoreBind- <+ promoteT ppCoreDef- <+ promoteT ppModGuts- <+ promoteT ppCoreAlt
src/Language/HERMIT/Primitive/AlphaConversion.hs view
@@ -6,15 +6,14 @@ , alpha , alphaLam , alphaCaseBinder- , alphaAltIds+ , alphaAltWith+ , alphaAltVars , alphaAlt , alphaCase+ , alphaLetWith , alphaLetVars- , alphaLetRecIds- , alphaLetOne , alphaLet- , alphaConsOne- , alphaCons+ , alphaConsWith -- ** Shadow Detection and Unshadowing , unshadow , visibleVarsT@@ -30,6 +29,7 @@ import Control.Arrow import Data.Char (isDigit) import Data.List (nub)+import Data.Maybe (fromMaybe, listToMaybe) import Data.Monoid import Language.HERMIT.Core@@ -50,28 +50,32 @@ externals :: [External] externals = map (.+ Deep) [ external "alpha" alpha- [ "renames the bound variables at the current node."]+ [ "Renames the bound variables at the current node."] , external "alpha-lam" (promoteExprR . alphaLam . Just)- [ "renames the bound variable in a Lambda expression to the given name."]+ [ "Renames the bound variable in a Lambda expression to the given name."] , external "alpha-lam" (promoteExprR $ alphaLam Nothing)- [ "renames the bound variable in a Lambda expression."]+ [ "Renames the bound variable in a Lambda expression."] , external "alpha-case-binder" (promoteExprR . alphaCaseBinder . Just)- [ "renames the binder in a Case expression to the given name."]+ [ "Renames the binder in a Case expression to the given name."] , external "alpha-case-binder" (promoteExprR $ alphaCaseBinder Nothing)- [ "renames the binder in a Case expression."]+ [ "Renames the binder in a Case expression."] , external "alpha-alt" (promoteAltR alphaAlt)- [ "renames all binders in a Case alternative."]+ [ "Renames all binders in a Case alternative."]+ , external "alpha-alt" (promoteAltR . alphaAltWith)+ [ "Renames all binders in a Case alternative using the user-provided list of new names."] , external "alpha-case" (promoteExprR alphaCase)- [ "renames all binders in a Case alternative."]- , external "alpha-let" (promoteExprR . alphaLetOne . Just)- [ "renames the bound variable in a Let expression with one binder to the given name."]+ [ "Renames all binders in a Case alternative."]+ , external "alpha-let" (promoteExprR . alphaLetWith)+ [ "Renames the bound variables in a Let expression using a list of suggested names."] , external "alpha-let" (promoteExprR alphaLet)- [ "renames the bound variables in a Let expression."]- , external "alpha-top" (promoteProgR . alphaConsOne . Just)- [ "renames the bound variable in a top-level binding with one binder to the given name."]- , external "alpha-top" (promoteProgR alphaCons)- [ "renames the bound variables in a top-level binding."]- , external "unshadow" unshadow+ [ "Renames the bound variables in a Let expression."]+ , external "alpha-top" (promoteProgR . alphaConsWith)+ [ "Renames the bound identifiers in the top-level binding group at the head of the program using a list of suggested names."]+ -- , external "alpha-top" (promoteProgR alphaCons)+ -- [ "Renames the bound identifiers in the top-level binding at the head of the program."]+ -- , external "alpha-program" (promoteProgR alphaProg)+ -- [ "Renames identifiers bound at the top-level of the program."]+ , external "unshadow" unshadow [ "Rename local variables with manifestly unique names (x, x0, x1, ...)."] ] @@ -97,7 +101,7 @@ freshNameGenT :: Maybe TH.Name -> TranslateH CoreExpr (String -> String) freshNameGenT mn = freshNameGenAvoiding mn <$> visibleVarsT --- | A generalisation of 'freshNameGen' that operates on any node, but only avoids name clashes with the results of the argument translation.+-- | Use the optional argument if given, otherwise generate a new name avoiding clashes with the list of variables. freshNameGenAvoiding :: Maybe TH.Name -> [Var] -> (String -> String) freshNameGenAvoiding mn vs str = maybe (inventNames vs str) TH.nameBase mn @@ -128,32 +132,38 @@ shadowedByT t1 t2 = setFailMsg "No shadows detected." $ (shadowedBy <$> t1 <*> t2) >>> acceptR (not . null) -- | Rename local variables with manifestly unique names (x, x0, x1, ...).--- Does not rename top-level definitions (though this may change in the future).+-- Does not rename top-level definitions. unshadow :: RewriteH Core unshadow = setFailMsg "No shadows to eliminate." $ anytdR (promoteExprR unshadowExpr <+ promoteAltR unshadowAlt) where unshadowExpr :: RewriteH CoreExpr- unshadowExpr = do vs <- shadowedByT (boundVarsT `mappend` freeVarsT) (letVarsT <+ fmap return (caseWildVarT <+ lamVarT))- alphaLam Nothing <+ alphaLetRecIds vs <+ alphaLetNonRec Nothing <+ alphaCaseBinder Nothing+ unshadowExpr = do vs <- shadowedByT (boundVarsT `mappend` freeVarsT) (letVarsT <+ fmap return (caseWildIdT <+ lamVarT))+ alphaLam Nothing <+ alphaLetVars vs <+ alphaCaseBinder Nothing unshadowAlt :: RewriteH CoreAlt- unshadowAlt = shadowedByT altVarsT (boundVarsT `mappend` altFreeVarsT) >>= alphaAltIds+ unshadowAlt = shadowedByT altVarsT (boundVarsT `mappend` altFreeVarsT) >>= alphaAltVars ----------------------------------------------------------------------- -- | Replace all occurrences of a specified variable. -- Arguments are the variable to replace and the replacement variable, respectively. replaceVarR :: (Injection a Core) => Var -> Var -> RewriteH a-replaceVarR v v' = extractR $ tryR $ substR v (Var v')+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 in 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' i = if v == i then v' else i+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.@@ -175,19 +185,28 @@ ----------------------------------------------------------------------- --- | Rename the specified identifier in a case alternative. Optionally takes a suggested new name.-alphaAltId :: Maybe TH.Name -> Id -> RewriteH CoreAlt-alphaAltId mn v = do nameModifier <- altT (freshNameGenT mn) (\ _ _ nameGen -> nameGen)- v' <- constT (cloneVarH nameModifier v)- altT (replaceVarR v v') (\ con vs e -> (con, map (replaceVar v v') vs, e))+-- | Rename the specified variable in a case alternative. Optionally takes a suggested new name.+alphaAltVar :: Maybe TH.Name -> Var -> RewriteH CoreAlt+alphaAltVar mn v = do nameModifier <- altT (freshNameGenT mn) (\ _ _ nameGen -> nameGen)+ v' <- constT (cloneVarH nameModifier v)+ altT (replaceVarR v v') (\ con vs e -> (con, map (replaceVar v v') vs, e)) --- | Rename the specified identifiers in a case alternative.-alphaAltIds :: [Id] -> RewriteH CoreAlt-alphaAltIds = andR . map (alphaAltId Nothing)+-- | Rename the specified variables in a case alternative, using the suggested names where provided.+alphaAltVarsWith :: [(Maybe TH.Name,Var)] -> RewriteH CoreAlt+alphaAltVarsWith = andR . map (uncurry alphaAltVar) +-- | Rename the variables bound in a case alternative with the given list of suggested names.+alphaAltWith :: [TH.Name] -> RewriteH CoreAlt+alphaAltWith ns = do vs <- altVarsT+ alphaAltVarsWith $ zip (map Just ns) vs++-- | Rename the specified variables in a case alternative.+alphaAltVars :: [Var] -> RewriteH CoreAlt+alphaAltVars = alphaAltVarsWith . zip (repeat Nothing)+ -- | Rename all identifiers bound in a case alternative. alphaAlt :: RewriteH CoreAlt-alphaAlt = altVarsT >>= alphaAltIds+alphaAlt = altVarsT >>= alphaAltVars ----------------------------------------------------------------------- @@ -219,84 +238,73 @@ (replaceVarR v v') (\ bs e -> Let (Rec $ (map.first) (replaceVar v v') bs) e) --- | Rename the specified identifiers bound in a recursive let.-alphaLetRecIds :: [Id] -> RewriteH CoreExpr-alphaLetRecIds = andR . map (alphaLetRecId Nothing)+-- | Rename the specified identifiers in a recursive let, using the suggested names where provided.+alphaLetRecIdsWith :: [(Maybe TH.Name,Id)] -> RewriteH CoreExpr+alphaLetRecIdsWith = andR . map (uncurry alphaLetRecId) +-- | Rename the identifiers bound in a Let with the given list of suggested names.+alphaLetWith :: [TH.Name] -> RewriteH CoreExpr+alphaLetWith ns = alphaLetNonRec (listToMaybe ns)+ <+ (letRecIdsT >>= (alphaLetRecIdsWith . zip (map Just ns)))+ -- | Rename the specified variables bound in a let. alphaLetVars :: [Var] -> RewriteH CoreExpr-alphaLetVars vs = alphaLetNonRecVars Nothing vs <+ alphaLetRecIds vs---- | Rename all identifiers bound in a recursive let.-alphaLetRec :: RewriteH CoreExpr-alphaLetRec = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $- letRecVarsT >>= alphaLetRecIds---- | Rename the identifier bound in a recursive let with a single recursively bound identifier. Optionally takes a suggested new name.-alphaLetRecOne :: Maybe TH.Name -> RewriteH CoreExpr-alphaLetRecOne mn = setFailMsg (wrongFormForAlpha "Let (Rec [(v,e1)]) e2") $- do Let (Rec [(v, _)]) _ <- idR- alphaLetRecId mn v---- | Rename the identifier bound in a let with a single bound identifier. Optionally takes a suggested new name.-alphaLetOne :: Maybe TH.Name -> RewriteH CoreExpr-alphaLetOne mn = alphaLetNonRec mn <+ alphaLetRecOne mn+alphaLetVars vs = alphaLetNonRecVars Nothing vs <+ alphaLetRecIdsWith (zip (repeat Nothing) vs) -- | Rename all identifiers bound in a Let. alphaLet :: RewriteH CoreExpr-alphaLet = alphaLetRec <+ alphaLetNonRec Nothing+alphaLet = letVarsT >>= alphaLetVars ----------------------------------------------------------------------- -- | Alpha rename a non-recursive top-level binder. Optionally takes a suggested new name.-alphaConsNonRec :: Maybe TH.Name -> RewriteH CoreProg-alphaConsNonRec mn = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $- do ProgCons (NonRec v _) _ <- idR- nameModifier <- consNonRecT (freshNameGenT mn) idR (\ _ nameGen _ -> nameGen)- v' <- constT (cloneVarH nameModifier v)- consNonRecT idR (replaceVarR v v') (\ _ e1 e2 -> ProgCons (NonRec v' e1) e2)+alphaConsNonRec :: TH.Name -> RewriteH CoreProg+alphaConsNonRec n = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $+ do ProgCons (NonRec v _) _ <- idR+ v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v)+ consNonRecT idR (replaceVarR v v') (\ _ e1 e2 -> ProgCons (NonRec v' e1) e2) +-- -- | Alpha rename a non-recursive top-level binder if the identifier appears in the argument list. Optionally takes a suggested new name.+-- alphaConsNonRecIds :: Maybe TH.Name -> [Id] -> RewriteH CoreProg+-- alphaConsNonRecIds mn vs = whenM ((`elem` vs) <$> consNonRecIdT) (alphaConsNonRec mn)+ -- | Rename the specified identifier bound in a recursive top-level binder. Optionally takes a suggested new name.-alphaConsRecId :: Maybe TH.Name -> Id -> RewriteH CoreProg-alphaConsRecId mn v = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $- do usedVars <- boundVarsT `mappend`- progConsT recVarsT (return ()) (\ vs () -> vs) `mappend`- consRecDefT (\ _ -> freeVarsT) idR (\ bndfvs _ -> concatMap snd bndfvs)- v' <- constT (cloneVarH (freshNameGenAvoiding mn usedVars) v)+alphaConsRecId :: TH.Name -> Id -> RewriteH CoreProg+alphaConsRecId n v = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $+ do v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v) consRecDefT (\ _ -> replaceVarR v v') (replaceVarR v v') (\ bs e -> ProgCons (Rec $ (map.first) (replaceVar v v') bs) e) --- | Rename the specified identifiers bound in a program node containing a recursive binding group.-alphaConsRecIds :: [Id] -> RewriteH CoreProg-alphaConsRecIds = andR . map (alphaConsRecId Nothing)+-- | Rename the specified identifiers in a recursive top-level binding at the head of a program, using the suggested names where provided.+alphaConsRecIdsWith :: [(TH.Name,Id)] -> RewriteH CoreProg+alphaConsRecIdsWith = andR . map (uncurry alphaConsRecId) --- | Rename all identifiers bound in a recursive top-level binder.-alphaConsRec :: RewriteH CoreProg-alphaConsRec = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $- progConsT recVarsT mempty (\ vs () -> vs) >>= alphaConsRecIds+-- | Rename the identifiers bound in the top-level binding at the head of the program with the given list of suggested names.+alphaConsWith :: [TH.Name] -> RewriteH CoreProg+alphaConsWith [] = fail "At least one new name must be provided."+alphaConsWith (n:ns) = alphaConsNonRec n <+ (consRecIdsT >>= (alphaConsRecIdsWith . zip (n:ns))) --- | Rename the identifier bound in a recursive top-level binder with a single recursively bound identifier. Optionally takes a suggested new name.-alphaConsRecOne :: Maybe TH.Name -> RewriteH CoreProg-alphaConsRecOne mn = setFailMsg (wrongFormForAlpha "ProgCons (Rec [Def v e]) p") $- do ProgCons (Rec [(v, _)]) _ <- idR- alphaConsRecId mn v+-- -- | Rename the specified variables bound in the top-level binding at the head of the program.+-- alphaConsIds :: [Id] -> RewriteH CoreProg+-- alphaConsIds vs = alphaConsNonRecIds Nothing vs <+ alphaConsRecIdsWith (zip (repeat Nothing) vs) --- | Rename the identifier bound in a top-level binder with a single bound identifier. Optionally takes a suggested new name.-alphaConsOne :: Maybe TH.Name -> RewriteH CoreProg-alphaConsOne mn = alphaConsNonRec mn <+ alphaConsRecOne mn+-- -- | Rename all identifiers bound in the top-level binding at the head of the program.+-- alphaCons :: RewriteH CoreProg+-- alphaCons = consIdsT >>= alphaConsIds --- | Rename all identifiers bound in a Let.-alphaCons :: RewriteH CoreProg-alphaCons = alphaConsRec <+ alphaConsNonRec Nothing+----------------------------------------------------------------------- +-- -- | Rename all identifiers bound at the top-level.+-- alphaProg :: RewriteH CoreProg+-- alphaProg = progNilT ProgNil <+ (alphaCons >>> progConsAllR idR alphaProg)+ ----------------------------------------------------------------------- -- | Alpha rename any bindings at this node. Note: does not rename case alternatives unless invoked on the alternative. alpha :: RewriteH Core alpha = setFailMsg "Cannot alpha-rename here." $ promoteExprR (alphaLam Nothing <+ alphaCaseBinder Nothing <+ alphaLet)- <+ promoteProgR alphaCons <+ promoteAltR alphaAlt -----------------------------------------------------------------------
src/Language/HERMIT/Primitive/Common.hs view
@@ -2,26 +2,43 @@ -- transformations needed by the other primitive modules. module Language.HERMIT.Primitive.Common ( -- * Utility Transformations+ applyInContextT+ -- ** Finding function calls.+ , callT+ , callPredT+ , callNameT+ , callSaturatedT+ , callNameG+ , callDataConT+ , callDataConNameT+ , callsR+ , callsT -- ** Collecting variables bound at a Node- progVarsT+ , progIdsT+ , consIdsT+ , consRecIdsT+ , consNonRecIdT , bindVarsT , nonRecVarT- , recVarsT- , defVarT+ , recIdsT+ , defIdT , lamVarT , letVarsT- , letRecVarsT+ , letRecIdsT , letNonRecVarT , caseVarsT- , caseWildVarT+ , caseWildIdT , caseAltVarsT , altVarsT -- ** Finding variables bound in the Context , boundVarsT , findBoundVarT , findIdT- -- ** Error Message Generators+ , findId+ -- ** Miscallaneous , wrongExprForm+ , nodups+ , mapAlts ) where@@ -35,30 +52,104 @@ import Language.HERMIT.Core import Language.HERMIT.Context import Language.HERMIT.GHC+import Language.HERMIT.Monad 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 a b+applyInContextT t a = contextonlyT $ \ c -> apply t c a++------------------------------------------------------------------------------++-- | Lift GHC's collectArgs+callT :: TranslateH CoreExpr (CoreExpr, [CoreExpr])+callT = do+ e <- idR+ case e of+ Var {} -> return (e, [])+ App {} -> return (collectArgs e)+ _ -> fail "not an application or variable occurence."++callPredT :: (Id -> [CoreExpr] -> Bool) -> TranslateH 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 :: TH.Name -> TranslateH CoreExpr (CoreExpr, [CoreExpr])+callNameT nm = setFailMsg ("callNameT: not a call to " ++ show nm) $+ callPredT (const . cmpTHName2Var nm)++-- | Succeeds if we are looking at a fully saturated function call.+callSaturatedT :: TranslateH CoreExpr (CoreExpr, [CoreExpr])+callSaturatedT = callPredT (\ i args -> idArity i == length args)+-- TODO: probably better to calculate arity based on Id's type, as+-- idArity is conservatively set to zero by default.++-- | Succeeds if we are looking at an application of given function+callNameG :: TH.Name -> TranslateH CoreExpr ()+callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >>= \_ -> constT (return ())++-- | Succeeds if we are looking at an application of a data constructor.+callDataConT :: TranslateH CoreExpr (DataCon, [Type], [CoreExpr])+callDataConT = prefixFailMsg "callDataConT failed:" $+ contextfreeT (return . exprIsConApp_maybe idUnfolding)+ >>= maybe (fail "not a datacon application.") return++-- | Succeeds if we are looking at an application of a named data constructor.+callDataConNameT :: TH.Name -> TranslateH CoreExpr (DataCon, [Type], [CoreExpr])+callDataConNameT nm = do+ res@(dc,_,_) <- callDataConT+ guardMsg (cmpTHName2Name nm (dataConName dc)) "wrong datacon."+ return res++-- | Apply a rewrite to all applications of a given function in a top-down manner, pruning on success.+callsR :: TH.Name -> RewriteH CoreExpr -> RewriteH Core+callsR nm rr = prunetdR (promoteExprR $ callNameG nm >> rr)++-- | Apply a translate to all applications of a given function in a top-down manner,+-- pruning on success, collecting the results.+callsT :: TH.Name -> TranslateH CoreExpr b -> TranslateH Core [b]+callsT nm t = collectPruneT (promoteExprT $ callNameG nm >> t)++------------------------------------------------------------------------------+ -- | List all identifiers bound at the top-level in a program.-progVarsT :: TranslateH CoreProg [Id]-progVarsT = progNilT [] <+ progConsT bindVarsT progVarsT (++)+progIdsT :: TranslateH CoreProg [Id]+progIdsT = progNilT [] <+ progConsT bindVarsT progIdsT (++) --- | List all identifiers bound in a binding group.+-- | List the identifiers bound by the top-level binding group at the head of the program.+consIdsT :: TranslateH CoreProg [Id]+consIdsT = progConsT bindVarsT mempty (\ vs () -> vs)++-- | List the identifiers bound by a recursive top-level binding group at the head of the program.+consRecIdsT :: TranslateH CoreProg [Id]+consRecIdsT = progConsT recIdsT mempty (\ vs () -> vs)++-- | Return the identifier bound by a non-recursive top-level binding at the head of the program.+consNonRecIdT :: TranslateH CoreProg Id+consNonRecIdT = progConsT nonRecVarT mempty (\ v () -> v)++-- | List all variables bound in a binding group. bindVarsT :: TranslateH CoreBind [Var]-bindVarsT = fmap return nonRecVarT <+ recVarsT+bindVarsT = fmap return nonRecVarT <+ recIdsT -- | Return the variable bound by a non-recursive let expression. nonRecVarT :: TranslateH CoreBind Var nonRecVarT = nonRecT mempty (\ v () -> v) -- | List all identifiers bound in a recursive binding group.-recVarsT :: TranslateH CoreBind [Id]-recVarsT = recT (\ _ -> defVarT) id+recIdsT :: TranslateH CoreBind [Id]+recIdsT = recT (\ _ -> defIdT) id -- | Return the identifier bound by a recursive definition.-defVarT :: TranslateH CoreDef Id-defVarT = defT mempty (\ v () -> v)+defIdT :: TranslateH CoreDef Id+defIdT = defT mempty (\ v () -> v) -- | Return the variable bound by a lambda expression. lamVarT :: TranslateH CoreExpr Var@@ -68,9 +159,9 @@ letVarsT :: TranslateH CoreExpr [Var] letVarsT = letT bindVarsT mempty (\ vs () -> vs) --- | List the variables bound by a recursive let expression.-letRecVarsT :: TranslateH CoreExpr [Var]-letRecVarsT = letT recVarsT mempty (\ vs () -> vs)+-- | List the identifiers bound by a recursive let expression.+letRecIdsT :: TranslateH CoreExpr [Id]+letRecIdsT = letT recIdsT mempty (\ vs () -> vs) -- | Return the variable bound by a non-recursive let expression. letNonRecVarT :: TranslateH CoreExpr Var@@ -81,8 +172,8 @@ caseVarsT = caseT mempty (\ _ -> altVarsT) (\ () v _ vss -> v : nub (concat vss)) -- | Return the case wildcard binder.-caseWildVarT :: TranslateH CoreExpr Var-caseWildVarT = caseT mempty (\ _ -> return ()) (\ () v _ _ -> v)+caseWildIdT :: TranslateH CoreExpr Id+caseWildIdT = caseT mempty (\ _ -> return ()) (\ () v _ _ -> v) -- | List the variables bound by all alternatives in a case expression. caseAltVarsT :: TranslateH CoreExpr [[Var]]@@ -112,20 +203,44 @@ -- | Lookup the name in the 'HermitC' first, then, failing that, in GHC's global reader environment. findIdT :: TH.Name -> TranslateH a Id findIdT nm = prefixFailMsg ("Cannot resolve name " ++ TH.nameBase nm ++ ", ") $- do c <- contextT- case findBoundVars nm c of- [] -> findIdMG nm- [v] -> return v- _ : _ : _ -> fail "multiple matching variables in scope."+ contextonlyT (findId nm) -findIdMG :: TH.Name -> TranslateH a Id-findIdMG nm = contextonlyT $ \ c ->+findId :: TH.Name -> HermitC -> HermitM Id+findId nm c = case findBoundVars nm c of+ [] -> findIdMG nm c+ [v] -> return v+ _ : _ : _ -> fail "multiple matching variables in scope."++findIdMG :: TH.Name -> HermitC -> HermitM Id+findIdMG nm c = case filter isValName $ findNameFromTH (mg_rdr_env $ hermitModGuts c) nm of- [] -> fail $ "variable not in scope."+ [] -> findIdBuiltIn nm [n] -> lookupId n ns -> do dynFlags <- getDynFlags fail $ "multiple matches found:\n" ++ intercalate ", " (map (showPpr dynFlags) ns) +findIdBuiltIn :: TH.Name -> HermitM Id+findIdBuiltIn = go . TH.nameBase+ 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 -> HermitM Id+ dataConId = return . dataConWorkId+ ------------------------------------------------------------------------------ -- | Constructs a common error message.@@ -134,3 +249,13 @@ wrongExprForm form = "Expression does not have the form: " ++ form ------------------------------------------------------------------------------++-- | Determine if a list contains no duplicated elements.+nodups :: Eq a => [a] -> Bool+nodups as = length as == length (nub as)++------------------------------------------------------------------------------++mapAlts :: (CoreExpr -> CoreExpr) -> [CoreAlt] -> [CoreAlt]+mapAlts f alts = [ (ac, vs, f e) | (ac, vs, e) <- alts ]+
src/Language/HERMIT/Primitive/FixPoint.hs view
@@ -1,7 +1,17 @@-module Language.HERMIT.Primitive.FixPoint where+module Language.HERMIT.Primitive.FixPoint+ ( -- * Operations on the Fixed Point Operator (fix)+ -- | Note that many of these operations require 'Data.Function.fix' to be in scope.+ Language.HERMIT.Primitive.FixPoint.externals+ -- ** Rewrites and BiRewrites on Fixed Points+ , fixIntro+ , fixComputationRule+ , rollingRule+ )+where import GhcPlugins as GHC hiding (varName) +import Control.Applicative import Control.Arrow import Language.HERMIT.Core@@ -9,206 +19,387 @@ import Language.HERMIT.Kure import Language.HERMIT.External import Language.HERMIT.GHC-import Language.HERMIT.Primitive.GHC++import Language.HERMIT.Primitive.AlphaConversion import Language.HERMIT.Primitive.Common+import Language.HERMIT.Primitive.GHC import Language.HERMIT.Primitive.Local-import Language.HERMIT.Primitive.AlphaConversion+import Language.HERMIT.Primitive.Navigation import Language.HERMIT.Primitive.New -- TODO: Sort out heirarchy+import Language.HERMIT.Primitive.Unfold import qualified Language.Haskell.TH as TH +-------------------------------------------------------------------------------------------------- +-- | Externals for manipulating fixed points, and for the worker/wrapper transformation. externals :: [External]-externals = map ((.+ Experiment) . (.+ TODO))+externals = map (.+ Experiment) [ external "fix-intro" (promoteDefR fixIntro :: RewriteH Core)- [ "rewrite a recursive binding into a non-recursive binding using fix" ]- , external "fix-spec" (promoteExprR fixSpecialization :: RewriteH Core)- [ "specialize a fix with a given argument"] .+ Shallow- , external "ww-fac-test" ((\ wrap unwrap -> promoteExprR $ workerWrapperFacTest wrap unwrap) :: TH.Name -> TH.Name -> RewriteH Core)- [ "Under construction "- ] .+ Introduce .+ Context .+ Experiment .+ PreCondition- , external "ww-split-test" ((\ wrap unwrap -> promoteDefR $ workerWrapperSplitTest wrap unwrap) :: TH.Name -> TH.Name -> RewriteH Core)- [ "Under construction "- ] .+ Introduce .+ Context .+ Experiment .+ PreCondition+ [ "rewrite a recursive binding into a non-recursive binding using fix"+ ] .+ Introduce .+ Context+ , external "fix-computation" ((promoteExprBiR fixComputationRule) :: BiRewriteH Core)+ [ "Fixed-Point Computation Rule",+ "fix t f <==> f (fix t f)"+ ]+ , external "rolling-rule" ((promoteExprBiR rollingRule) :: BiRewriteH Core)+ [ "Rolling Rule",+ "fix tyA (\\ a -> f (g a)) <==> f (fix tyB (\\ b -> g (f b))"+ ]+ -- , external "fix-spec" (promoteExprR fixSpecialization :: RewriteH Core)+ -- [ "specialize a fix with a given argument"] .+ Shallow+ , external "ww-factorisation" ((\ wrap unwrap -> promoteExprBiR $ workerWrapperFac wrap unwrap) :: CoreString -> CoreString -> BiRewriteH Core)+ [ "Worker/Wrapper Factorisation",+ "For any \"f :: a -> a\", and given \"wrap :: b -> a\" and \"unwrap :: a -> b\" as arguments, then",+ "fix tyA f <==> wrap (fix tyB (\\ b -> unwrap (f (wrap b))))",+ "Note: the pre-condition \"fix tyA (\\ a -> wrap (unwrap (f a))) == fix tyA f\" is expected to hold."+ ] .+ Introduce .+ Context .+ PreCondition+ , external "ww-fusion" ((\ wrap unwrap work -> promoteExprBiR $ workerWrapperFusion wrap unwrap work) :: CoreString -> CoreString -> CoreString -> BiRewriteH Core)+ [ "Worker/Wrapper Fusion",+ "Given \"wrap :: b -> a\", \"unwrap :: a -> b\" and \"work :: b\" as arguments, then",+ "unwrap (wrap work) <==> work",+ "Note: the pre-conditions \"fix tyA (\\ a -> wrap (unwrap (f a))) == fix tyA f\"",+ " and \"work == fix (\\ b -> unwrap (f (wrap)))\" are expected to hold."+ ] .+ Introduce .+ Context .+ PreCondition+ , external "ww-split" ((\ wrap unwrap -> promoteDefR $ workerWrapperSplit wrap unwrap) :: CoreString -> CoreString -> RewriteH Core)+ [ "Worker/Wrapper Split",+ "For any \"g :: a\", and given \"wrap :: b -> a\" and \"unwrap :: a -> b\" as arguments, then",+ "g = expr ==> g = let f = \\ g -> expr",+ " in let work = unwrap (f (wrap work))",+ " in wrap work",+ "Note: the pre-condition \"fix a (wrap . unwrap . f) == fix a f\" is expected to hold."+ ] .+ Introduce .+ Context .+ PreCondition+ , external "ww-split-param" ((\ n wrap unwrap -> promoteDefR $ workerWrapperSplitParam n wrap unwrap) :: Int -> CoreString -> CoreString -> RewriteH Core)+ [ "Worker/Wrapper Split - Type Paramater Variant",+ "For any \"g :: forall t1 t2 .. tn . a\", and given \"wrap :: forall t1 t2 .. tn . b -> a\" and \"unwrap :: forall t1 t2 .. tn . a -> b\" as arguments, then",+ "g = expr ==> g = \\ t1 t2 .. tn -> let f = \\ g -> expr t1 t2 .. tn",+ " in let work = unwrap t1 t2 .. tn (f (wrap t1 t2 ..tn work))",+ " in wrap t1 t2 .. tn work"+ ] .+ Introduce .+ Context .+ PreCondition .+ TODO .+ Experiment+ , external "ww-assumption-A" ((\ wrap unwrap -> promoteExprBiR $ wwA wrap unwrap) :: CoreString -> CoreString -> BiRewriteH Core)+ [ "Worker/Wrapper Assumption A",+ "For a \"wrap :: b -> a\" and an \"unwrap :: b -> a\", then",+ "wrap (unwrap x) <==> x",+ "Note: only use this if it's true!"+ ] .+ Context .+ PreCondition+ , external "ww-assumption-B" ((\ wrap unwrap f -> promoteExprBiR $ wwB wrap unwrap f) :: CoreString -> CoreString -> CoreString -> BiRewriteH Core)+ [ "Worker/Wrapper Assumption B",+ "For a \"wrap :: b -> a\", an \"unwrap :: b -> a\", and an \"f :: a -> a\" then",+ "wrap (unwrap (f x)) <==> f x",+ "Note: only use this if it's true!"+ ] .+ Context .+ PreCondition+ , external "ww-assumption-C" ((\ wrap unwrap f -> promoteExprBiR $ wwC wrap unwrap f) :: CoreString -> CoreString -> CoreString -> BiRewriteH Core)+ [ "Worker/Wrapper Assumption C",+ "For a \"wrap :: b -> a\", an \"unwrap :: b -> a\", and an \"f :: a -> a\" then",+ "fix t (\\ x -> wrap (unwrap (f x))) <==> fix t f",+ "Note: only use this if it's true!"+ ] .+ Context .+ PreCondition ] -fixLocation :: String-fixLocation = "Data.Function.fix"--findFixId :: TranslateH a Id-findFixId = findIdT (TH.mkName fixLocation)--guardIsFixId :: Id -> TranslateH a ()-guardIsFixId v = do fixId <- findFixId- guardMsg (v == fixId) (var2String v ++ " does not match " ++ fixLocation)-+-------------------------------------------------------------------------------------------------- --- | f = e ==> f = fix (\ f -> e)+-- | @f = e@ ==\> @f = fix (\\ f -> e)@ fixIntro :: RewriteH CoreDef-fixIntro = prefixFailMsg "Fix introduction failed: " $- do Def f e <- idR- fixId <- findFixId- constT $ do f' <- cloneVarH id f- let coreFix = App (App (Var fixId) (Type (idType f)))- emptySub = mkEmptySubst (mkInScopeSet (exprFreeVars e))- sub = extendSubst emptySub f (Var f')- return $ Def f (coreFix (Lam f' (substExpr (text "fixIntro") sub e)))+fixIntro = prefixFailMsg "fix introduction failed: " $+ do Def f _ <- idR+ f' <- constT $ cloneVarH id f+ Def f <$> (mkFix =<< (defT (extractR $ substR f $ varToCoreExpr f') (\ _ e' -> Lam f' e'))) --- ironically, this is an instance of worker/wrapper itself.+-------------------------------------------------------------------------------------------------- -fixSpecialization :: RewriteH CoreExpr-fixSpecialization = do+-- | @fix ty f@ \<==\> @f (fix ty f)@+fixComputationRule :: BiRewriteH CoreExpr+fixComputationRule = bidirectional computationL computationR+ where+ computationL :: RewriteH CoreExpr+ computationL = prefixFailMsg "fix computation rule failed: " $+ do (_,f) <- isFixExpr+ fixf <- idR+ return (App f fixf) - -- fix (t::*) (f :: t -> t) (a :: t) :: t- App (App (App (Var fixId) (Type _)) _) _ <- idR -- TODO: couldn't that Type be a Var? Might be better to use my "isType" fucntion.+ computationR :: RewriteH CoreExpr+ computationR = prefixFailMsg "fix computation rule failed: " $+ do App f fixf <- idR+ (_,f') <- isFixExpr <<< constant fixf+ guardMsg (exprEqual f f') "external function does not match internal expression"+ return fixf - guardIsFixId fixId -- guardMsg (fx == fixId) "fixSpecialization only works on fix" - let rr :: RewriteH CoreExpr- rr = multiEtaExpand [TH.mkName "f",TH.mkName "a"]+-- | @fix tyA (\\ a -> f (g a))@ \<==\> @f (fix tyB (\\ b -> g (f b))@+rollingRule :: BiRewriteH CoreExpr+rollingRule = bidirectional rollingRuleL rollingRuleR+ where+ rollingRuleL :: RewriteH CoreExpr+ rollingRuleL = prefixFailMsg "rolling rule failed: " $+ withPatFailMsg wrongFixBody $+ do (tyA, Lam a (App f (App g (Var a')))) <- isFixExpr+ guardMsg (a == a') wrongFixBody+ (tyA',tyB) <- funsWithInverseTypes g f+ guardMsg (eqType tyA tyA') "Type mismatch: this shouldn't have happened, report this as a bug."+ res <- rollingRuleResult tyB g f+ return (App f res) - sub :: RewriteH Core- sub = pathR [0,1] (promoteR rr)- -- be careful this does not loop (it should not)- extractR sub >>> fixSpecialization'+ rollingRuleR :: RewriteH CoreExpr+ rollingRuleR = prefixFailMsg "(reversed) rolling rule failed: " $+ withPatFailMsg "not an application." $+ do App f fx <- idR+ withPatFailMsg wrongFixBody $+ do (tyB, Lam b (App g (App f' (Var b')))) <- isFixExpr <<< constant fx+ guardMsg (b == b') wrongFixBody+ guardMsg (exprEqual f f') "external function does not match internal expression"+ (tyA,tyB') <- funsWithInverseTypes g f+ guardMsg (eqType tyB tyB') "Type mismatch: this shouldn't have happened, report this as a bug."+ rollingRuleResult tyA f g + rollingRuleResult :: Type -> CoreExpr -> CoreExpr -> TranslateH z CoreExpr+ rollingRuleResult ty f g = do x <- constT (newIdH "x" ty)+ mkFix (Lam x (App f (App g (Var x)))) -fixSpecialization' :: RewriteH CoreExpr-fixSpecialization' =- do- -- In normal form now- App (App (App (Var fx) fixTyE)- (Lam _ (Lam v2 (App (App e _) _a2)))- )- a <- idR+ wrongFixBody :: String+ wrongFixBody = "body of fix does not have the form: Lam v (App f (App g (Var v)))" - t <- case typeExprToType fixTyE of- Nothing -> fail "first argument to fix is not a type, this shouldn't have happened."- Just ty -> return ty+-------------------------------------------------------------------------------------------------- - t' <- case typeExprToType a of- Just t2 -> return (applyTy t t2)- Nothing -> fail "Not a type variable." -- TODO: I think this entire functions needs revisiting and cleaning up. What's going on with all the dead-code (which I've commented out now).--- Var a2 -> mkAppTy t (exprType t2)--- mkAppTy t t'+-- ironically, this is an instance of worker/wrapper itself. +-- fixSpecialization :: RewriteH CoreExpr+-- fixSpecialization = do - -- TODO: t2' isn't used anywhere -- which means that a2 is never used ???--- let t2' = case a2 of--- Type t2 -> applyTy t t2--- Var a2 -> mkAppTy t (exprType t2)--- mkAppTy t t'+-- -- fix (t::*) (f :: t -> t) (a :: t) :: t+-- App (App (App (Var fixId) (Type _)) _) _ <- idR +-- guardIsFixId fixId - v3 <- constT $ newIdH "f" t' -- (funArgTy t')- v4 <- constT $ newTyVarH "a" (tyVarKind v2)+-- let r :: RewriteH CoreExpr+-- r = multiEtaExpand [TH.mkName "f",TH.mkName "a"] - -- f' :: \/ a -> T [a] -> (\/ b . T [b])- let f' = Lam v4 (Cast (Var v3)- (mkUnsafeCo t' (applyTy t (mkTyVarTy v4))))- let e' = Lam v3 (App (App e f') a)+-- sub :: RewriteH Core+-- sub = pathR [0,1] (promoteR r) - return $ App (App (Var fx) (Type t')) e'+-- App (App (App (Var fx) (Type t))+-- (Lam _ (Lam v2 (App (App e _) _a2)))+-- )+-- (Type t2) <- extractR sub -- In normal form now +-- constT $ do let t' = applyTy t t2 --- introSpecialisedPolyFun :: TH.Name -> TH.Name -> RewriteH CoreExpr--- introSpecialisedPolyFun funNm ty = do funId <- lookupMatchingVarT funNm--- tyVar <- lookupMatchingVarT ty+-- v3 <- newIdH "f" t'+-- v4 <- newTyVarH "a" (tyVarKind v2) +-- -- f' :: \/ a -> T [a] -> (\/ b . T [b])+-- let f' = Lam v4 (Cast (Var v3) (mkUnsafeCo t' (applyTy t (mkTyVarTy v4))))+-- e' = Lam v3 (App (App e f') (Type t2)) +-- return $ App (App (Var fx) (Type t')) e' -workerWrapperFacTest :: TH.Name -> TH.Name -> RewriteH CoreExpr-workerWrapperFacTest wrapNm unwrapNm = do wrapId <- findBoundVarT wrapNm- unwrapId <- findBoundVarT unwrapNm- monomorphicWorkerWrapperFac (Var wrapId) (Var unwrapId) -workerWrapperSplitTest :: TH.Name -> TH.Name -> RewriteH CoreDef-workerWrapperSplitTest wrapNm unwrapNm = do wrapId <- findBoundVarT wrapNm- unwrapId <- findBoundVarT unwrapNm- monomorphicWorkerWrapperSplit (Var wrapId) (Var unwrapId)-+-------------------------------------------------------------------------------------------------- --- monomorphicWorkerWrapperFac :: Id -> Id -> RewriteH CoreExpr--- monomorphicWorkerWrapperFac wrapId unwrapId = -- let wrapTy = idType wrapId--- -- unwrapTy = idType unwrapId--- -- (wrapForallTyVars, wrapMainTy) = splitForAllTys wrapTy--- -- (unwrapForallTyVars, unwrapMainTy) = splitForAllTys unwrapTy+-- | For any @f :: a -> a@, and given @wrap :: b -> a@ and @unwrap :: a -> b@ as arguments, then+-- @fix tyA f@ \<==\> @wrap (fix tyB (\\ b -> unwrap (f (wrap b))))@+workerWrapperFacBR :: CoreExpr -> CoreExpr -> BiRewriteH CoreExpr+workerWrapperFacBR wrap unwrap = beforeBiR (wrapUnwrapTypes wrap unwrap)+ (\ (tyA,tyB) -> bidirectional (wwL tyA tyB) wwR)+ where+ wwL :: Type -> Type -> RewriteH CoreExpr+ wwL tyA tyB = prefixFailMsg "worker/wrapper factorisation failed: " $+ do (tA,f) <- isFixExpr+ guardMsg (eqType tyA tA) ("wrapper/unwrapper types do not match fix body type.")+ b <- constT (newIdH "x" tyB)+ fx <- mkFix (Lam b (App unwrap (App f (App wrap (Var b)))))+ return $ App wrap fx --- -- in -- In progress: above are not used yet.--- workerWrapperFac (Var wrapId) (Var unwrapId)--- -- workerWrapperFac (mkTyApps (Var wrapId) wrapForallTys)--- -- (mkTyApps (Var unwrapId) unwrapForallTys)+ wwR :: RewriteH CoreExpr+ wwR = prefixFailMsg "(reverse) worker/wrapper factorisation failed: " $+ withPatFailMsg "not an application." $+ do App wrap2 fx <- idR+ withPatFailMsg wrongFixBody $+ do (_, Lam b (App unwrap1 (App f (App wrap1 (Var b'))))) <- isFixExpr <<< constant fx+ guardMsg (b == b') wrongFixBody+ guardMsg (exprEqual wrap wrap2) "given wrapper does not match applied function."+ guardMsg (exprEqual wrap wrap1) "given wrapper does not match wrapper in body of fix."+ guardMsg (exprEqual unwrap unwrap1) "given unwrapper does not match unwrapper in body of fix."+ mkFix f --- workerWrapperFac (Var wrapId) (Var unwrapId)--- splitForAllTys :: Type -> ([TyVar], Type)+ wrongFixBody :: String+ wrongFixBody = "body of fix does not have the form Lam b (App unwrap (App f (App wrap (Var b))))" --- monomorphicWorkerWrapperSplit :: Id -> Id -> RewriteH CoreDef--- monomorphicWorkerWrapperSplit wrapId unwrapId = workerWrapperSplit (Var wrapId) (Var unwrapId)+-- | For any @f :: a -> a@, and given @wrap :: b -> a@ and @unwrap :: a -> b@ as arguments, then+-- @fix tyA f@ \<==\> @wrap (fix tyB (\\ b -> unwrap (f (wrap b))))@+workerWrapperFac :: CoreString -> CoreString -> BiRewriteH CoreExpr+workerWrapperFac = parse2beforeBiR workerWrapperFacBR --- substTyWith :: [TyVar] -> [Type] -> Type -> Type--- mkTyApps :: Expr b -> [Type] -> Expr b+-------------------------------------------------------------------------------------------------- --- I assume there are GHC functions to do this, but I can't find them.--- in progress--- unifyTyVars :: [TyVar] -- | forall quantified type variables--- -> Type -- | type containing forall quantified type variables--- -> Type -- | type to unify with--- -> Maybe [Type] -- | types that the variables have been unified with--- unifyTyVars vs tyGen tySpec = let unifyTyVarsAux tyGen tySpec vs--- in undefined--- unifyTyVarsAux :: Type -> Type -> [(TyVar,[Type])] -> Maybe [(TyVar,[Type])]--- unifyTyVarsAux (TyVarTy v) t = match v t--- unifyTyVarsAux (AppTy s1 s2) (AppTy t1 t2) = match s1 t1 . match s2 t2+-- | Given @wrap :: b -> a@, @unwrap :: a -> b@ and @work :: b@ as arguments, then+-- @unwrap (wrap work)@ \<==\> @work@+workerWrapperFusionBR :: CoreExpr -> CoreExpr -> CoreExpr -> BiRewriteH CoreExpr+workerWrapperFusionBR wrap unwrap work = beforeBiR (prefixFailMsg "worker/wrapper fusion failed: " $+ do (_,tyB) <- wrapUnwrapTypes wrap unwrap+ guardMsg (exprType work `eqType` tyB) "type of worker does not match types of wrap/unwrap."+ )+ (\ () -> bidirectional fusL fusR)+ where+ fusL :: RewriteH CoreExpr+ fusL = prefixFailMsg "worker/wrapper fusion failed: " $+ withPatFailMsg (wrongExprForm "App unwrap (App wrap work)") $+ do App unwrap' (App wrap' work') <- idR+ guardMsg (exprEqual wrap wrap') "given wrapper does not match wrapper in expression."+ guardMsg (exprEqual unwrap unwrap') "given unwrapper does not match unwrapper in expression."+ guardMsg (exprEqual work work') "given worker function does not worker in expression."+ return work + fusR :: RewriteH CoreExpr+ fusR = prefixFailMsg "(reverse) worker/wrapper fusion failed: " $+ do work' <- idR+ guardMsg (exprEqual work work') "given worker function does not match expression."+ return $ App unwrap (App wrap work) --- f :: a -> a--- wrap :: forall x,y..z. b -> a--- unwrap :: forall p,q..r. a -> b--- fix tyA f ==> wrap (fix tyB (\ x -> unwrap (f (wrap (Var x)))))--- Assumes the arguments are monomorphic functions (all type variables have alread been applied)-monomorphicWorkerWrapperFac :: CoreExpr -> CoreExpr -> RewriteH CoreExpr-monomorphicWorkerWrapperFac wrapE unwrapE =- prefixFailMsg "Worker/wrapper Factorisation failed: " $- withPatFailMsg (wrongExprForm "fix type fun") $- do App (App (Var fixId) fixTyE) f <- idR -- fix :: forall a. (a -> a) -> a- guardIsFixId fixId- case typeExprToType fixTyE of- Nothing -> fail "first argument to fix is not a type, this shouldn't have happened."- Just tyA -> case splitFunTy_maybe (exprType wrapE) of- Nothing -> fail "type of wrapper is not a function."- Just (tyB,wrapTyA) -> case splitFunTy_maybe (exprType unwrapE) of- Nothing -> fail "type of unwrapper is not a function."- Just (unwrapTyA,unwrapTyB) -> do guardMsg (eqType wrapTyA unwrapTyA) ("argument type of unwrapper does not match result type of wrapper.")- guardMsg (eqType unwrapTyB tyB) ("argument type of wrapper does not match result type of unwrapper.")- guardMsg (eqType wrapTyA tyA) ("wrapper/unwrapper types do not match expression type.")- x <- constT (newIdH "x" tyB)- return $ App wrapE- (App (App (Var fixId) (Type tyB))- (Lam x (App unwrapE- (App f- (App wrapE- (Var x)- )- )- )- )- )+-- | Given @wrap :: b -> a@, @unwrap :: a -> b@ and @work :: b@ as arguments, then+-- @unwrap (wrap work)@ \<==\> @work@+workerWrapperFusion :: CoreString -> CoreString -> CoreString -> BiRewriteH CoreExpr+workerWrapperFusion = parse3beforeBiR workerWrapperFusionBR +-------------------------------------------------------------------------------------------------- -monomorphicWorkerWrapperSplit :: CoreExpr -> CoreExpr -> RewriteH CoreDef-monomorphicWorkerWrapperSplit wrap unwrap =+-- | \\ wrap unwrap -> (@g = expr@ ==> @g = let f = \\ g -> expr in let work = unwrap (f (wrap work)) in wrap work)@+workerWrapperSplitR :: CoreExpr -> CoreExpr -> RewriteH CoreDef+workerWrapperSplitR wrap unwrap = let f = TH.mkName "f" w = TH.mkName "w" work = TH.mkName "work" fx = TH.mkName "fix" in fixIntro >>> defR ( appAllR idR (letIntro f)- >>> letFloatArg- >>> letAllR idR ( monomorphicWorkerWrapperFac wrap unwrap- >>> appAllR idR (letIntro w)- >>> letFloatArg- >>> letNonRecAllR (unfold fx >>> alphaLetOne (Just work) >>> extractR simplifyR) idR- >>> letSubstR- >>> letFloatArg- )- )+ >>> letFloatArg+ >>> letAllR idR ( forewardT (workerWrapperFacBR wrap unwrap)+ >>> appAllR idR (letIntro w)+ >>> letFloatArg+ >>> letNonRecAllR (unfoldNameR fx >>> alphaLetWith [work] >>> extractR simplifyR) idR+ >>> letSubstR+ >>> letFloatArg+ )+ )++-- | \\ wrap unwrap -> (@g = expr@ ==> @g = let f = \\ g -> expr in let work = unwrap (f (wrap work)) in wrap work)@+workerWrapperSplit :: CoreString -> CoreString -> RewriteH CoreDef+workerWrapperSplit wrapS unwrapS = (parseCoreExprT wrapS &&& parseCoreExprT unwrapS) >>= uncurry workerWrapperSplitR++-- | As 'workerWrapperSplit' but performs the static-argument transformation for @n@ type paramaters first, providing these types as arguments to all calls of wrap and unwrap.+-- This is useful if the expression, and wrap and unwrap, all have a @forall@ type.+workerWrapperSplitParam :: Int -> CoreString -> CoreString -> RewriteH CoreDef+workerWrapperSplitParam 0 = workerWrapperSplit+workerWrapperSplitParam n = \ wrapS unwrapS -> prefixFailMsg "worker/wrapper split (forall variant) failed: " $+ do guardMsg (n == 1) "currently only supports 1 type paramater."+ withPatFailMsg "right-hand-side of definition does not have the form: Lam t e" $+ do Def _ (Lam t _) <- idR+ guardMsg (isTyVar t) "first argument is not a type."+ let splitAtDefR :: RewriteH Core+ splitAtDefR = do p <- considerConstructT Definition+ pathR p $ promoteR $ do wrap <- parseCoreExprT wrapS+ unwrap <- parseCoreExprT unwrapS+ let ty = Type (TyVarTy t)+ workerWrapperSplitR (App wrap ty) (App unwrap ty)+ staticArg >>> extractR splitAtDefR++--------------------------------------------------------------------------------------------------++-- | @wrap (unwrap x)@ \<==\> @x@+wwAssA :: CoreExpr -> CoreExpr -> BiRewriteH CoreExpr+wwAssA wrap unwrap = beforeBiR (wrapUnwrapTypes wrap unwrap) (\ (tyA,_) -> bidirectional wwAL (wwAR tyA))+ where+ wwAL :: RewriteH CoreExpr+ wwAL = withPatFailMsg (wrongExprForm "App wrap (App unwrap x)") $+ do App wrap' (App unwrap' x) <- idR+ guardMsg (exprEqual wrap wrap') "given wrapper does not match wrapper in expression."+ guardMsg (exprEqual unwrap unwrap') "given unwrapper does not match unwrapper in expression."+ return x++ wwAR :: Type -> RewriteH CoreExpr+ wwAR tyA = do x <- idR+ guardMsg (exprType x `eqType` tyA) "type of expression does not match types of wrap/unwrap."+ return $ App wrap (App unwrap x)++-- | @wrap (unwrap x)@ \<==\> @x@+wwA :: CoreString -> CoreString -> BiRewriteH CoreExpr+wwA = parse2beforeBiR wwAssA+++-- | @wrap (unwrap (f x))@ \<==\> @f x@+wwAssB :: CoreExpr -> CoreExpr -> CoreExpr -> BiRewriteH CoreExpr+wwAssB wrap unwrap f = bidirectional wwBL wwBR+ where+ assA :: BiRewriteH CoreExpr+ assA = wwAssA wrap unwrap++ wwBL :: RewriteH CoreExpr+ wwBL = withPatFailMsg (wrongExprForm "App wrap (App unwrap (App f x))") $+ do App _ (App _ (App f' _)) <- idR+ guardMsg (exprEqual f f') "given body function does not match expression."+ forewardT assA++ wwBR :: RewriteH CoreExpr+ wwBR = withPatFailMsg (wrongExprForm "App f x") $+ do App f' _ <- idR+ guardMsg (exprEqual f f') "given body function does not match expression."+ backwardT assA++-- | @wrap (unwrap (f x))@ \<==\> @f x@+wwB :: CoreString -> CoreString -> CoreString -> BiRewriteH CoreExpr+wwB = parse3beforeBiR wwAssB+++-- | @fix t (\ x -> wrap (unwrap (f x)))@ \<==\> @fix t f@+wwAssC :: CoreExpr -> CoreExpr -> CoreExpr -> BiRewriteH CoreExpr+wwAssC wrap unwrap f = beforeBiR isFixExpr (\ _ -> bidirectional wwCL wwCR)+ where+ assB :: BiRewriteH CoreExpr+ assB = wwAssB wrap unwrap f++ wwCL :: RewriteH CoreExpr+ wwCL = appAllR idR (lamR (forewardT assB) >>> etaReduce)++ wwCR :: RewriteH CoreExpr+ wwCR = appAllR idR (etaExpand (TH.mkName "x") >>> lamR (backwardT assB))++-- | @fix t (\ x -> wrap (unwrap (f x)))@ \<==\> @fix t f@+wwC :: CoreString -> CoreString -> CoreString -> BiRewriteH CoreExpr+wwC = parse3beforeBiR wwAssC++--------------------------------------------------------------------------------------------------++-- | Check that the expression has the form "fix t (f :: t -> t)", returning "t" and "f".+isFixExpr :: TranslateH CoreExpr (Type,CoreExpr)+isFixExpr = withPatFailMsg (wrongExprForm "fix t f") $ -- fix :: forall a. (a -> a) -> a+ do App (App (Var fixId) (Type ty)) f <- idR+ fixId' <- findFixId+ guardMsg (fixId == fixId') (var2String fixId ++ " does not match " ++ fixLocation)+ return (ty,f)++wrapUnwrapTypes :: MonadCatch m => CoreExpr -> CoreExpr -> m (Type,Type)+wrapUnwrapTypes wrap unwrap = setFailMsg "given expressions have the wrong types to form a valid wrap/unwrap pair." $+ funsWithInverseTypes unwrap wrap++--------------------------------------------------------------------------------------------------++-- | f ==> fix f+mkFix :: CoreExpr -> TranslateH z CoreExpr+mkFix f = do t <- endoFunType f+ fixId <- findFixId+ return $ mkCoreApps (varToCoreExpr fixId) [Type t, f]++fixLocation :: String+fixLocation = "Data.Function.fix"++findFixId :: TranslateH a Id+findFixId = findIdT (TH.mkName fixLocation)++--------------------------------------------------------------------------------------------------++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)++--------------------------------------------------------------------------------------------------
src/Language/HERMIT/Primitive/Fold.hs view
@@ -3,6 +3,7 @@ externals , foldR , stashFoldR+ , stashFoldAnyR ) where@@ -23,7 +24,7 @@ import Language.HERMIT.GHC import Language.HERMIT.Primitive.GHC hiding (externals)-import Language.HERMIT.Primitive.Unfold hiding (externals)+import Language.HERMIT.Primitive.Inline hiding (externals) import qualified Language.Haskell.TH as TH @@ -33,26 +34,27 @@ externals :: [External] externals =- [ external "fold" (promoteExprR . foldR)- ["fold a definition"- ,""- ,"double :: Int -> Int"- ,"double x = x + x"- ,""- ,"5 + 5 + 6"- ,"any-bu (fold 'double)"- ,"double 5 + 6"- ,""- ,"Note: due to associativity, if you wanted to fold 5 + 6 + 6, "- ,"you first need to apply an associativity rewrite."- ] .+ Context .+ Deep- , external "fold" (promoteExprR . stashFoldR)- ["Fold a remembered definition."] .+ Context .+ Deep- ]+ [ external "fold" (promoteExprR . foldR)+ [ "fold a definition"+ , ""+ , "double :: Int -> Int"+ , "double x = x + x"+ , ""+ , "5 + 5 + 6"+ , "any-bu (fold 'double)"+ , "double 5 + 6"+ , ""+ , "Note: due to associativity, if you wanted to fold 5 + 6 + 6, "+ , "you first need to apply an associativity rewrite." ] .+ Context .+ Deep+ , external "fold" (promoteExprR . stashFoldR)+ [ "Fold a remembered definition." ] .+ Context .+ Deep+ , external "fold-any" (promoteExprR stashFoldAnyR)+ [ "Attempt to fold any of the remembered definitions." ] .+ Context .+ Deep+ ] ------------------------------------------------------------------------ -stashFoldR :: String -> RewriteH CoreExpr+stashFoldR :: Label -> RewriteH CoreExpr stashFoldR label = prefixFailMsg "Fold failed: " $ translate $ \ c e -> do Def i rhs <- lookupDef label@@ -61,6 +63,10 @@ return (fold i rhs e) +stashFoldAnyR :: RewriteH CoreExpr+stashFoldAnyR = setFailMsg "Fold failed: no definitions could be folded." $+ catchesM =<< map stashFoldR <$> (Map.keys <$> constT getStash)+ foldR :: TH.Name -> RewriteH CoreExpr foldR nm = prefixFailMsg "Fold failed: " $ translate $ \ c e -> do@@ -68,12 +74,11 @@ [] -> fail "cannot find name." [i] -> return i is -> fail $ "multiple names match: " ++ intercalate ", " (map var2String is)- either fail- (\(rhs,_d) -> maybe (fail "no match.")- return- (fold i rhs e))- (getUnfolding False False i c)+ (rhs,_d) <- getUnfolding False False i c+ maybe (fail "no match.") return (fold i rhs e) +------------------------------------------------------------------------+ fold :: Id -> CoreExpr -> CoreExpr -> Maybe CoreExpr fold i lam exp = do let (vs,body) = collectBinders lam@@ -86,7 +91,7 @@ let m = Map.fromListWith checkEqual [(k,Just v) | (k,v) <- al ] es <- sequence [ join (Map.lookup v m) | v <- vs ]- return $ mkCoreApps (Var i) es+ return $ mkCoreApps (varToCoreExpr i) es -- Note: Id in the concrete instance is first -- (not the Id found in the definition we are trying to fold).
src/Language/HERMIT/Primitive/GHC.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Language.HERMIT.Primitive.GHC ( -- * GHC-based Transformations -- | This module contains transformations that are reflections of GHC functions, or derived from GHC functions.@@ -11,23 +12,36 @@ , altFreeVarsExclWildT -- ** Substitution , substR+ , substExprR , letSubstR , safeLetSubstR , safeLetSubstPlusR+ -- ** Equality+ , exprEqual+ , exprsEqual+ , coreEqual -- ** Utilities , inScope- , exprEqual , showVars+ , rule , rules+ , lintExprT+ , lintProgramT+ , lintModuleT+ , equivalent ) where import GhcPlugins+import qualified Bag+import qualified CoreLint import qualified OccurAnal+import IOEnv import Control.Arrow import Control.Monad import Data.List (intercalate,mapAccumL,(\\))+import Data.Map (keys) import Language.HERMIT.Core import Language.HERMIT.Context@@ -64,23 +78,30 @@ [ "List the free identifiers in this expression." ] .+ Query .+ Deep , external "deshadow-prog" (promoteProgR deShadowProgR :: RewriteH Core) [ "Deshadow a program." ] .+ Deep- , external "apply-rule" (promoteExprR . rules :: String -> RewriteH Core)+ , external "apply-rule" (promoteExprR . rule :: String -> RewriteH Core) [ "apply a named GHC rule" ] .+ Shallow , external "apply-rule" (rules_help :: TranslateH Core String) [ "list rules that can be used" ] .+ Query+ , external "apply-rules" (promoteExprR . rules :: [String] -> RewriteH Core)+ [ "apply named GHC rules, succeeds if any of the rules succeed" ] .+ Shallow , external "compare-values" compareValues ["compare the rhs of two values."] .+ Query .+ Predicate , external "add-rule" (\ rule_name id_name -> promoteModGutsR (addCoreBindAsRule rule_name id_name)) ["add-rule \"rule-name\" <id> -- adds a new rule that freezes the right hand side of the <id>"] .+ Introduce- , external "cast-elim" (promoteExprR castElimination)- ["cast-elim removes casts"]- .+ Shallow .+ Experiment .+ TODO- , external "add-rule" (\ rule_name id_name -> promoteModGutsR (addCoreBindAsRule rule_name id_name))- ["add-rule \"rule-name\" <id> -- adds a new rule that freezes the right hand side of the <id>"] , external "occur-analysis" (promoteExprR occurAnalyseExprR :: RewriteH Core) ["Performs dependency anlaysis on a CoreExpr.", "This can be useful to simplify a recursive let to a non-recursive let."] .+ Deep+ , external "lintExpr" (promoteExprT lintExprT :: TranslateH Core String)+ ["Runs GHC's Core Lint, which typechecks the current expression."+ ,"Note: this can miss several things that a whole-module core lint will find."+ ,"For instance, running this on the RHS of a binding, the type of the RHS will"+ ,"not be checked against the type of the binding. Running on the whole let expression"+ ,"will catch that however."] .+ Deep .+ Debug .+ Query+ , external "lintProg" (promoteProgT lintProgramT :: TranslateH Core String)+ ["Runs GHC's Core Lint, which typechecks the top level list of bindings."] .+ Deep .+ Debug .+ Query+ , external "lintModule" (promoteModGutsT lintModuleT :: TranslateH Core String)+ ["Runs GHC's Core Lint, which typechecks the current module."] .+ Deep .+ Debug .+ Query ] ------------------------------------------------------------------------@@ -92,35 +113,20 @@ -- | Substitute all occurrences of a variable with an expression, in an expression. substExprR :: Var -> CoreExpr -> RewriteH CoreExpr-substExprR v e = contextfreeT $ \ expr ->- -- The InScopeSet needs to include any free variables appearing in the- -- expression to be substituted. Constructing a NonRec Let expression- -- to pass on to exprFeeVars takes care of this, but ...- -- TODO Is there a better way to do this ???- let emptySub = mkEmptySubst (mkInScopeSet (exprFreeVars (Let (NonRec v e) expr)))- in do- sub <- if isTyVar v- then case e of- Type vty -> return $ extendTvSubst emptySub v vty- Var x -> return $ extendTvSubst emptySub v (mkTyVarTy x)- _ -> fail "substExprR: Var argument is a TyVar, but the expression is not a Type."- else return $ extendSubst emptySub v e- return $ substExpr (text "substR") sub expr+substExprR v e = contextfreeT $ \ expr -> do+ -- The InScopeSet needs to include any free variables appearing in the+ -- expression to be substituted. Constructing a NonRec Let expression+ -- to pass on to exprFeeVars takes care of this, but ...+ -- TODO Is there a better way to do this ???+ let emptySub = mkEmptySubst (mkInScopeSet (exprFreeVars (Let (NonRec v e) expr)))+ return $ substExpr (text "substR") (extendSubst emptySub v e) expr -- | Substitute all occurrences of a variable with an expression, in a program. substTopBindR :: Var -> CoreExpr -> RewriteH CoreProg-substTopBindR v e = contextfreeT $ \ p ->- -- TODO. Do we need to initialize the emptySubst with bindFreeVars?- let emptySub = emptySubst -- mkEmptySubst (mkInScopeSet (exprFreeVars exp))- in do- sub <- if isTyVar v- then case e of- Type vty -> return $ extendTvSubst emptySub v vty- Var x -> return $ extendTvSubst emptySub v (mkTyVarTy x)- _ -> fail "substTopBindR: Var argument is a TyVar, but the expression is not a Type."- else return $ extendSubst emptySub v e- return $ bindsToProg $ snd (mapAccumL substBind sub (progToBinds p))-+substTopBindR v e = contextfreeT $ \ p -> do+ -- TODO. Do we need to initialize the emptySubst with bindFreeVars?+ let emptySub = emptySubst -- mkEmptySubst (mkInScopeSet (exprFreeVars exp))+ return $ bindsToProg $ snd (mapAccumL substBind (extendSubst emptySub v e) (progToBinds p)) -- | (let x = e1 in e2) ==> (e2[e1/x]), -- x must not be free in e1.@@ -146,7 +152,7 @@ safeBind (Lam {}) = True safeBind e@(App {}) = case collectArgs e of- (Var f,args) -> arityOf env f > length (filter (not . isTypeArg) args)+ (Var f,args) -> arityOf env f > length (filter (not . isTyCoArg) args) -- Neil: I've changed this to "not . isTyCoArg" rather than "not . isTypeArg". This may not be the right thing to do though. (other,args) -> case collectBinders other of (bds,_) -> length bds > length args safeBind _ = False@@ -303,10 +309,15 @@ _rough_args = map (const Nothing) args -- rough_args are never used!!! FIX ME! -- Finally, we try match the rules -- trace (showSDoc (ppr fn GhcPlugins.<+> ppr args $$ ppr rs)) $- case lookupRule (const True) (const NoUnfolding) in_scope fn args rs of+#if __GLASGOW_HASKELL__ > 706+ dflags <- getDynFlags+ case lookupRule dflags (const True) (const NoUnfolding) in_scope fn args [r | r <- rs, ru_fn r == idName fn] of+#else+ case lookupRule (const True) (const NoUnfolding) in_scope fn args [r | r <- rs, ru_fn r == idName fn] of+#endif Nothing -> fail "rule not matched"- Just (rule, expr) -> do- let e' = mkApps expr (drop (ruleArity rule) args)+ Just (r, expr) -> do+ let e' = mkApps expr (drop (ruleArity r) args) ifM (liftM (and . map (inScope c)) $ apply freeVarsT c e') (return e') (fail $ unlines ["Resulting expression after rule application contains variables that are not in scope."@@ -317,28 +328,34 @@ inScope c v = (v `boundIn` c) || -- defined in this module case unfoldingInfo (idInfo v) of CoreUnfolding {} -> True -- defined elsewhere+ DFunUnfolding {} -> True _ -> False -- | Lookup a rule and attempt to construct a corresponding rewrite.-rules :: String -> RewriteH CoreExpr-rules r = do- theRules <- getHermitRules- case lookup r theRules of- Nothing -> fail $ "failed to find rule: " ++ show r- Just rr -> rulesToRewriteH rr+rule :: String -> RewriteH CoreExpr+rule r = do+ theRules <- getHermitRules+ case lookup r theRules of+ Nothing -> fail $ "failed to find rule: " ++ show r+ Just rr -> rulesToRewriteH rr +rules :: [String] -> RewriteH CoreExpr+rules = orR . map rule+ getHermitRules :: TranslateH a [(String, [CoreRule])] getHermitRules = translate $ \ env _ -> do rb <- liftCoreM getRuleBase- let other_rules = [ rule+ hscEnv <- liftCoreM getHscEnv+ rb' <- liftM eps_rule_base $ liftIO $ runIOEnv () $ readMutVar (hsc_EPS hscEnv)+ let other_rules = [ r | top_bnds <- mg_binds (hermitModGuts env) , bnd <- case top_bnds of Rec bnds -> map fst bnds NonRec b _ -> [b]- , rule <- idCoreRules bnd+ , r <- idCoreRules bnd ] return [ ( unpackFS (ruleName r), [r] )- | r <- mg_rules (hermitModGuts env) ++ other_rules ++ concat (nameEnvElts rb)+ | r <- mg_rules (hermitModGuts env) ++ other_rules ++ concat (nameEnvElts rb) ++ concat (nameEnvElts rb') ] rules_help :: TranslateH Core String@@ -401,7 +418,17 @@ exprEqual :: CoreExpr -> CoreExpr -> Bool exprEqual e1 e2 = eqExpr (mkInScopeSet $ exprsFreeVars [e1, e2]) e1 e2 +exprsEqual :: [CoreExpr] -> Bool+exprsEqual = equivalent exprEqual +-- Drew: surely this exists generally somewhere?+-- for instance:+-- equivalent ((==) `on` length) :: [[a]] -> Bool+-- checks if all lists have the same length+equivalent :: (a -> a -> Bool) -> [a] -> Bool+equivalent _ [] = True+equivalent eq (x:xs) = all (eq x) xs+ -- The ideas for this function are directly extracted from -- the GHC function, CoreUtils.eqExprX bindEqual :: CoreBind -> CoreBind -> Maybe Bool@@ -452,17 +479,28 @@ ------------------------------------------- --- remove a cast;--- TODO: check for validity of removing this cast-castElimination :: RewriteH CoreExpr-castElimination = do- Cast e _ <- idR- return e+-- | Run the Core Lint typechecker.+-- Fails on errors, with error messages.+-- Succeeds returning warnings.+lintModuleT :: TranslateH ModGuts String+lintModuleT = arr (bindsToProg . mg_binds) >>> lintProgramT -{-- go (Cast e co) | isReflCo co' = go e- | otherwise = Cast (go e) co'- where- co' = optCoercion (getCvSubst subst) co--}+lintProgramT :: TranslateH CoreProg String+lintProgramT = do+ bnds <- arr progToBinds+ dflags <- constT getDynFlags+ let (warns, errs) = CoreLint.lintCoreBindings bnds+ dumpSDocs endMsg = Bag.foldBag (\d r -> d ++ ('\n':r)) (showSDoc dflags) endMsg+ if Bag.isEmptyBag errs+ then return $ dumpSDocs "Core Lint Passed" warns+ else fail $ dumpSDocs "Core Lint Failed" errs +-- | Note: this can miss several things that a whole-module core lint will find.+-- For instance, running this on the RHS of a binding, the type of the RHS will+-- not be checked against the type of the binding. Running on the whole let expression+-- will catch that however.+lintExprT :: TranslateH CoreExpr String+lintExprT = translate $ \ c e -> do+ dflags <- getDynFlags+ maybe (return "Core Lint Passed") (fail . showSDoc dflags)+ $ CoreLint.lintUnfolding noSrcLoc (keys $ hermitBindings c) e
src/Language/HERMIT/Primitive/Inline.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE TupleSections #-} module Language.HERMIT.Primitive.Inline ( -- * Inlining externals+ , getUnfolding , inline , inlineName , inlineScrutinee@@ -11,18 +13,19 @@ where import GhcPlugins+import TcType (tcSplitDFunTy) import Control.Arrow -import Language.HERMIT.Core-import Language.HERMIT.Kure import Language.HERMIT.Context-import Language.HERMIT.GHC+import Language.HERMIT.Core import Language.HERMIT.External+import Language.HERMIT.GHC+import Language.HERMIT.Kure+import Language.HERMIT.Monad import Language.HERMIT.Primitive.Common import Language.HERMIT.Primitive.GHC hiding (externals)-import Language.HERMIT.Primitive.Unfold hiding (externals) import qualified Language.Haskell.TH as TH @@ -76,7 +79,7 @@ prefixFailMsg "Inline failed: " $ withPatFailMsg (wrongExprForm "Var v") $ do (c, Var v) <- exposeT- (e,d) <- getUnfolding scrutinee caseBinderOnly v c+ (e,d) <- constT $ getUnfolding scrutinee caseBinderOnly v c return e >>> (setFailMsg "values in inlined expression have been rebound." $ accepterR (extractT $ ensureDepth d)) @@ -93,8 +96,60 @@ -- traceR $ "greater values (" ++ show d ++ "): " ++ show (filter ((> d) . snd) ds) return $ all (toSnd (<= d)) ds +getUnfolding :: Bool -- ^ Get the scrutinee instead of the patten match (for case binders).+ -> Bool -- ^ Only succeed if this variable is a case binder.+ -> Id -> HermitC -> HermitM (CoreExpr, Int)+getUnfolding scrutinee caseBinderOnly i c =+ case lookupHermitBinding i c of+ Nothing -> if caseBinderOnly+ then fail "not a case binder"+ else case unfoldingInfo (idInfo i) of+ CoreUnfolding { uf_tmpl = uft } -> return (uft, 0)+ DFunUnfolding _arity dc args -> dFunExpr dc args (idType i) >>= return . (,0)+ _ -> fail $ "cannot find unfolding in Env or IdInfo."+ Just (LAM {}) -> fail $ "variable is lambda-bound."+ Just (BIND depth _ e') -> if caseBinderOnly then fail "not a case binder." else return (e', depth)+ Just (CASE depth s coreAlt) -> return $ if scrutinee+ then (s, depth)+ else let tys = tyConAppArgs (idType i)+ in either (,depth) (,depth+1) (alt2Exp s tys coreAlt)++-- | Convert lhs of case alternative to a constructor application expression,+-- or a default expression in the case of the DEFAULT alternative.+-- Accepts a list of types to apply to the constructor before the value args.+--+-- > data T a b = C a b Int+--+-- Pseudocode:+--+-- > alt2Exp (...) [a,b] (C, [x,y,z]) ==> C a b (x::a) (y::b) (z::Int)+--+-- The 'Either' denotes whether we picked the default (scrutinee) or built an expression.+-- This matters for the depth check.+alt2Exp :: CoreExpr -> [Type] -> (AltCon,[Id]) -> Either CoreExpr CoreExpr+alt2Exp d _ (DEFAULT , _ ) = Left d+alt2Exp _ _ (LitAlt l , _ ) = Right $ Lit l+alt2Exp _ tys (DataAlt dc, as) = Right $ mkCoreConApps dc (map Type tys ++ map varToCoreExpr as)+ -- | Get list of possible inline targets. Used by shell for completion. inlineTargets :: TranslateH Core [String] inlineTargets = collectT $ promoteT $ whenM (testM inline) (varT unqualifiedVarName)++-- | Build a CoreExpr for a DFunUnfolding+dFunExpr :: DataCon -> [DFunArg CoreExpr] -> Type -> HermitM CoreExpr+dFunExpr dc args ty = do+ let (_, _, _, tcArgs) = tcSplitDFunTy ty+ (forallTvs, ty') = splitForAllTys ty+ (argTys, _resTy) = splitFunTys ty'++ ids <- mapM (uncurry newIdH) $ zip [ [ch] | ch <- cycle ['a'..'z'] ] argTys+ vars <- mapM (cloneVarH id) forallTvs++ let allVars = varsToCoreExprs $ vars ++ ids++ mkArg (DFunLamArg i) = allVars !! i+ mkArg (DFunPolyArg e) = mkCoreApps e allVars++ return $ mkCoreConApps dc $ map Type tcArgs ++ map mkArg args ------------------------------------------------------------------------
src/Language/HERMIT/Primitive/Kure.hs view
@@ -20,15 +20,21 @@ , external "fail" (fail :: String -> RewriteH Core) [ "a failing rewrite"] , external "<+" ((<+) :: RewriteH Core -> RewriteH Core -> RewriteH Core)- [ "perform the first translate, and then, if it fails, perform the second rewrite" ]+ [ "perform the first rewrite, and then, if it fails, perform the second rewrite" ]+ , external "<+" ((<+) :: TranslateH Core () -> TranslateH Core () -> TranslateH Core ())+ [ "perform the first check, and then, if it fails, perform the second check" ] , external ">>>" ((>>>) :: RewriteH Core -> RewriteH Core -> RewriteH Core) [ "compose rewrites, requiring both to succeed" ]+ , external ">>>" ((>>>) :: BiRewriteH Core -> BiRewriteH Core -> BiRewriteH Core)+ [ "compose bidirectional rewrites, requiring both to succeed" ] , external ">+>" ((>+>) :: RewriteH Core -> RewriteH Core -> RewriteH Core) [ "compose rewrites, allowing one to fail" ] , external "try" (tryR :: RewriteH Core -> RewriteH Core) [ "tries a rewrite, and performs an identity if this rewrite fails" ] , external "repeat" (repeatR :: RewriteH Core -> RewriteH Core) [ "repeats a rewrite until it would fail" ] .+ Loop+ , external "replicate" ((\ n -> andR . replicate n) :: Int -> RewriteH Core -> RewriteH Core)+ [ "repeats a rewrite n times" ] , external "all" (allR :: RewriteH Core -> RewriteH Core) [ "apply a rewrite to all children of the node, requiring success at every child" ] .+ Shallow , external "any" (anyR :: RewriteH Core -> RewriteH Core)@@ -65,6 +71,12 @@ [ "apply a rewrite only if the check succeeds" ] .+ Predicate , external "not" (notM :: TranslateH Core () -> TranslateH Core ()) [ "cause a failing check to succeed, a succeeding check to fail" ] .+ Predicate+ , external "invert" (invertBiT :: BiRewriteH Core -> BiRewriteH Core)+ [ "reverse a bidirectional rewrite" ]+ , external "foreward" (forewardT :: BiRewriteH Core -> RewriteH Core)+ [ "apply a bidirectional rewrite forewards" ]+ , external "backward" (backwardT :: BiRewriteH Core -> RewriteH Core)+ [ "apply a bidirectional rewrite backwards" ] ] ------------------------------------------------------------------------------------@@ -72,9 +84,11 @@ hfocusR :: TranslateH Core Path -> RewriteH Core -> RewriteH Core hfocusR tp r = do p <- tp pathR p r+{-# INLINE hfocusR #-} hfocusT :: TranslateH Core Path -> TranslateH Core String -> TranslateH Core String hfocusT tp t = do p <- tp pathT p t+{-# INLINE hfocusT #-} ------------------------------------------------------------------------------------
src/Language/HERMIT/Primitive/Local.hs view
@@ -1,10 +1,12 @@ module Language.HERMIT.Primitive.Local ( -- * Local Structural Manipulations Language.HERMIT.Primitive.Local.externals- -- ** Let Expressions- , module Language.HERMIT.Primitive.Local.Let -- ** Case Expressions , module Language.HERMIT.Primitive.Local.Case+ -- ** Cast Expressions+ , module Language.HERMIT.Primitive.Local.Cast+ -- ** Let Expressions+ , module Language.HERMIT.Primitive.Local.Let -- ** Miscellaneous , abstract , nonrecToRec@@ -30,13 +32,15 @@ import Language.HERMIT.Primitive.GHC import Language.HERMIT.Primitive.Common-import Language.HERMIT.Primitive.Local.Case-import Language.HERMIT.Primitive.Local.Let+import Language.HERMIT.Primitive.Local.Case hiding (externals)+import qualified Language.HERMIT.Primitive.Local.Case as Case+import Language.HERMIT.Primitive.Local.Cast hiding (externals)+import qualified Language.HERMIT.Primitive.Local.Cast as Cast+import Language.HERMIT.Primitive.Local.Let hiding (externals)+import qualified Language.HERMIT.Primitive.Local.Let as Let import qualified Language.Haskell.TH as TH -import Data.List(nub)- import Control.Arrow ------------------------------------------------------------------------------@@ -45,34 +49,34 @@ -- (Many taken from Chapter 3 of Andre Santos' dissertation.) externals :: [External] externals =- [ external "nonrec-to-rec" (promoteBindR nonrecToRec :: RewriteH Core)- [ "convert a non-recursive binding into a recursive binding group with a single definition."- , "NonRec v e ==> Rec [Def v e]" ]- , external "beta-reduce" (promoteExprR betaReduce :: RewriteH Core)- [ "((\\ v -> E1) E2) ==> let v = E2 in E1"- , "this form of beta-reduction is safe if E2 is an arbitrary"- , "expression (won't duplicate work)" ] .+ Eval .+ Shallow- , external "beta-reduce-plus" (promoteExprR betaReducePlus :: RewriteH Core)- [ "perform one or more beta-reductions."] .+ Eval .+ Shallow .+ Bash- , external "beta-expand" (promoteExprR betaExpand :: RewriteH Core)- [ "(let v = e1 in e2) ==> (\\ v -> e2) e1" ] .+ Shallow- , external "eta-reduce" (promoteExprR etaReduce :: RewriteH Core)- [ "(\\ v -> e1 v) ==> e1" ] .+ Eval .+ Shallow .+ Bash- , external "eta-expand" (promoteExprR . etaExpand :: TH.Name -> RewriteH Core)- [ "\"eta-expand 'v\" performs e1 ==> (\\ v -> e1 v)" ] .+ Shallow .+ Introduce- , external "flatten-module" (promoteModGutsR flattenModule :: RewriteH Core)- ["Flatten all the top-level binding groups in the module to a single recursive binding group.",- "This can be useful if you intend to appply GHC RULES."]- , external "flatten-program" (promoteProgR flattenProgramR :: RewriteH Core)- ["Flatten all the top-level binding groups in a program (list of binding groups) to a single recursive binding group.",- "This can be useful if you intend to appply GHC RULES."]- , external "abstract" (promoteExprR . abstract :: TH.Name -> RewriteH Core)- [ "Abstract over a variable using a lambda.",- "e ==> (\\ x -> e) x"- ] .+ Shallow .+ Introduce .+ Context- ]- ++ letExternals- ++ caseExternals+ [ external "nonrec-to-rec" (promoteBindR nonrecToRec :: RewriteH Core)+ [ "convert a non-recursive binding into a recursive binding group with a single definition."+ , "NonRec v e ==> Rec [Def v e]" ]+ , external "beta-reduce" (promoteExprR betaReduce :: RewriteH Core)+ [ "((\\ v -> E1) E2) ==> let v = E2 in E1"+ , "this form of beta-reduction is safe if E2 is an arbitrary"+ , "expression (won't duplicate work)" ] .+ Eval .+ Shallow+ , external "beta-reduce-plus" (promoteExprR betaReducePlus :: RewriteH Core)+ [ "perform one or more beta-reductions."] .+ Eval .+ Shallow .+ Bash+ , external "beta-expand" (promoteExprR betaExpand :: RewriteH Core)+ [ "(let v = e1 in e2) ==> (\\ v -> e2) e1" ] .+ Shallow+ , external "eta-reduce" (promoteExprR etaReduce :: RewriteH Core)+ [ "(\\ v -> e1 v) ==> e1" ] .+ Eval .+ Shallow .+ Bash+ , external "eta-expand" (promoteExprR . etaExpand :: TH.Name -> RewriteH Core)+ [ "\"eta-expand 'v\" performs e1 ==> (\\ v -> e1 v)" ] .+ Shallow .+ Introduce+ , external "flatten-module" (promoteModGutsR flattenModule :: RewriteH Core)+ [ "Flatten all the top-level binding groups in the module to a single recursive binding group."+ , "This can be useful if you intend to appply GHC RULES." ]+ , external "flatten-program" (promoteProgR flattenProgramR :: RewriteH Core)+ [ "Flatten all the top-level binding groups in a program (list of binding groups) to a single recursive binding group."+ , "This can be useful if you intend to appply GHC RULES." ]+ , external "abstract" (promoteExprR . abstract :: TH.Name -> RewriteH Core)+ [ "Abstract over a variable using a lambda."+ , "e ==> (\\ x -> e) x" ] .+ Shallow .+ Introduce .+ Context+ ]+ ++ Case.externals+ ++ Cast.externals+ ++ Let.externals ------------------------------------------------------------------------------ @@ -165,10 +169,10 @@ contextfreeT $ \ e -> let ty = exprType e in case splitFunTy_maybe ty of Just (argTy, _) -> do v <- newIdH (show nm) argTy- return $ Lam v (App e (Var v))+ return $ Lam v (App e (varToCoreExpr v)) Nothing -> case splitForAllTy_maybe ty of Just (tv,_) -> do v <- newTyVarH (show nm) (tyVarKind tv)- return $ Lam v (App e (Type (mkTyVarTy v)))+ return $ Lam v (App e (varToCoreExpr v)) Nothing -> fail "type of expression is not a function or a forall." -- | Perform multiple eta-expansions.@@ -193,9 +197,6 @@ guardMsg (nodups $ map fst bds) "Top-level bindings contain multiple occurrences of a name." return (Rec bds) -nodups :: Eq a => [a] -> Bool-nodups as = length as == length (nub as)- ------------------------------------------------------------------------------ -- | Abstract over a variable using a lambda.@@ -204,6 +205,6 @@ abstract nm = prefixFailMsg "abstraction failed: " $ do e <- idR v <- findBoundVarT nm- return (App (Lam v e) (Var v))+ return (App (Lam v e) (varToCoreExpr v)) ------------------------------------------------------------------------------
src/Language/HERMIT/Primitive/Local/Case.hs view
@@ -1,12 +1,20 @@+{-# LANGUAGE MultiWayIf #-}+ module Language.HERMIT.Primitive.Local.Case ( -- * Rewrites on Case Expressions- caseExternals+ externals , caseFloatApp , caseFloatArg , caseFloatCase+ , caseFloatCast , caseFloatLet , caseFloat+ , caseUnfloat+ , caseUnfloatApp+ , caseUnfloatArgs , caseReduce+ , caseReduceDatacon+ , caseReduceLiteral , caseSplit , caseSplitInline )@@ -16,6 +24,7 @@ import GhcPlugins import Data.List+import Data.Monoid import Control.Arrow import Language.HERMIT.Core@@ -25,9 +34,9 @@ import Language.HERMIT.External import Language.HERMIT.Primitive.Common-import Language.HERMIT.Primitive.GHC-import Language.HERMIT.Primitive.Inline-import Language.HERMIT.Primitive.AlphaConversion+import Language.HERMIT.Primitive.GHC hiding (externals)+import Language.HERMIT.Primitive.Inline hiding (externals)+import Language.HERMIT.Primitive.AlphaConversion hiding (externals) import qualified Language.Haskell.TH as TH @@ -35,38 +44,47 @@ ------------------------------------------------------------------------------ -- | Externals relating to Case expressions.-caseExternals :: [External]-caseExternals =- [ -- I'm not sure this is possible. In core, v2 can only be a Constructor, Lit, or DEFAULT- -- In the last case, v1 is already inlined in e. So we can't construct v2 as a Var.- -- external "case-elimination" (promoteR $ not_defined "case-elimination" :: RewriteH Core)- -- [ "case v1 of v2 -> e ==> e[v1/v2]" ] .+ Unimplemented .+ Eval- -- -- Again, don't think the lhs of this rule is possible to construct in core.- -- , external "default-binding-elim" (promoteR $ not_defined "default-binding-elim" :: RewriteH Core)- -- [ "case v of ...;w -> e ==> case v of ...;w -> e[v/w]" ] .+ Unimplemented .+ Eval- -- -- Again, don't think the lhs of this rule is possible to construct in core.- -- , external "case-merging" (promoteR $ not_defined "case-merging" :: RewriteH Core)- -- [ "case v of ...; d -> case v of alt -> e ==> case v of ...; alt -> e[v/d]" ] .+ Unimplemented .+ Eval- external "case-float-app" (promoteExprR caseFloatApp :: RewriteH Core)- [ "(case ec of alt -> e) v ==> case ec of alt -> e v" ] .+ Commute .+ Shallow .+ Bash- , external "case-float-arg" (promoteExprR caseFloatArg :: RewriteH Core)- [ "f (case s of alt -> e) ==> case s of alt -> f e" ] .+ Commute .+ Shallow .+ PreCondition- , external "case-float-case" (promoteExprR caseFloatCase :: RewriteH Core)- [ "case (case ec of alt1 -> e1) of alta -> ea ==> case ec of alt1 -> case e1 of alta -> ea" ] .+ Commute .+ Eval .+ Bash- , external "case-float-let" (promoteExprR caseFloatLet :: RewriteH Core)- [ "let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e" ] .+ Commute .+ Shallow .+ Bash- , external "case-float" (promoteExprR caseFloat :: RewriteH Core)- [ "Float a Case whatever the context." ] .+ Commute .+ Shallow .+ PreCondition- , external "case-reduce" (promoteExprR caseReduce :: RewriteH Core)- [ "case-of-known-constructor"- , "case C v1..vn of C w1..wn -> e ==> e[v1/w1..vn/wn]" ] .+ Shallow .+ Eval .+ Bash- , external "case-split" (promoteExprR . caseSplit :: TH.Name -> RewriteH Core)- [ "case-split 'x"- , "e ==> case x of C1 vs -> e; C2 vs -> e, where x is free in e" ]- , external "case-split-inline" (caseSplitInline :: TH.Name -> RewriteH Core)- [ "Like case-split, but additionally inlines the matched constructor "- , "applications for all occurances of the named variable." ]- ]+externals :: [External]+externals =+ [ -- I'm not sure this is possible. In core, v2 can only be a Constructor, Lit, or DEFAULT+ -- In the last case, v1 is already inlined in e. So we can't construct v2 as a Var.+ -- external "case-elimination" (promoteR $ not_defined "case-elimination" :: RewriteH Core)+ -- [ "case v1 of v2 -> e ==> e[v1/v2]" ] .+ Unimplemented .+ Eval+ -- -- Again, don't think the lhs of this rule is possible to construct in core.+ -- , external "case-merging" (promoteR $ not_defined "case-merging" :: RewriteH Core)+ -- [ "case v of ...; d -> case v of alt -> e ==> case v of ...; alt -> e[v/d]" ] .+ Unimplemented .+ Eval+ external "case-float-app" (promoteExprR caseFloatApp :: RewriteH Core)+ [ "(case ec of alt -> e) v ==> case ec of alt -> e v" ] .+ Commute .+ Shallow .+ Bash+ , external "case-float-arg" (promoteExprR caseFloatArg :: RewriteH Core)+ [ "f (case s of alt -> e) ==> case s of alt -> f e" ] .+ Commute .+ Shallow .+ PreCondition+ , external "case-float-case" (promoteExprR caseFloatCase :: RewriteH Core)+ [ "case (case ec of alt1 -> e1) of alta -> ea ==> case ec of alt1 -> case e1 of alta -> ea" ] .+ Commute .+ Eval .+ Bash+ , external "case-float-cast" (promoteExprR caseFloatCast)+ [ "cast (case s of p -> e) co ==> case s of p -> cast e co" ] .+ Shallow .+ Commute .+ Bash+ , external "case-float-let" (promoteExprR caseFloatLet :: RewriteH Core)+ [ "let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e" ] .+ Commute .+ Shallow .+ Bash+ , external "case-float" (promoteExprR caseFloat :: RewriteH Core)+ [ "Float a Case whatever the context." ] .+ Commute .+ Shallow .+ PreCondition+ , external "case-unfloat" (promoteExprR caseUnfloat :: RewriteH Core)+ [ "Unfloat a Case whatever the context." ] .+ Commute .+ Shallow .+ PreCondition+ , external "case-unfloat-args" (promoteExprR caseUnfloatArgs :: RewriteH Core)+ [ "Unfloat a Case whose alternatives are parallel applications of the same function." ] .+ Commute .+ Shallow .+ PreCondition+ , external "case-unfloat-app" (promoteExprR caseUnfloatApp :: RewriteH Core)+ [ "Unfloat a Case whole alternatives are applications of different functions with the same arguments." ] .+ Commute .+ Shallow .+ PreCondition+ , external "case-reduce" (promoteExprR caseReduce :: RewriteH Core)+ [ "case-reduce-datacon <+ case-reduce-literal" ] .+ Shallow .+ Eval .+ Bash+ , external "case-reduce-datacon" (promoteExprR caseReduceDatacon :: RewriteH Core)+ [ "case-of-known-constructor"+ , "case C v1..vn of C w1..wn -> e ==> let { w1 = v1 ; .. ; wn = vn } in e" ] .+ Shallow .+ Eval+ , external "case-reduce-literal" (promoteExprR caseReduceLiteral :: RewriteH Core)+ [ "case L of L -> e ==> e" ] .+ Shallow .+ Eval+ , external "case-split" (promoteExprR . caseSplit :: TH.Name -> RewriteH Core)+ [ "case-split 'x"+ , "e ==> case x of C1 vs -> e; C2 vs -> e, where x is free in e" ]+ , external "case-split-inline" (caseSplitInline :: TH.Name -> RewriteH Core)+ [ "Like case-split, but additionally inlines the matched constructor "+ , "applications for all occurances of the named variable." ]+ ] ------------------------------------------------------------------------------ @@ -75,14 +93,13 @@ caseFloatApp = prefixFailMsg "Case floating from App function failed: " $ do captures <- appT caseAltVarsT freeVarsT (flip (map . intersect))- wildCapture <- appT caseWildVarT freeVarsT elem+ wildCapture <- appT caseWildIdT freeVarsT elem appT ((if not wildCapture then idR else alphaCaseBinder Nothing) >>> caseAllR idR (\i -> if null (captures !! i) then idR else alphaAlt) ) idR (\(Case s b _ty alts) v -> let newTy = exprType (App (case head alts of (_,_,f) -> f) v)- in Case s b newTy [ (c, ids, App f v)- | (c,ids,f) <- alts ])+ in Case s b newTy $ mapAlts (flip App v) alts) -- | @f (case s of alt1 -> e1; alt2 -> e2)@ ==> @case s of alt1 -> f e1; alt2 -> f e2@ -- Only safe if @f@ is strict.@@ -90,14 +107,13 @@ caseFloatArg = prefixFailMsg "Case floating from App argument failed: " $ do captures <- appT freeVarsT caseAltVarsT (map . intersect)- wildCapture <- appT freeVarsT caseWildVarT (flip elem)+ wildCapture <- appT freeVarsT caseWildIdT (flip elem) appT idR ((if not wildCapture then idR else alphaCaseBinder Nothing) >>> caseAllR idR (\i -> if null (captures !! i) then idR else alphaAlt) ) (\f (Case s b _ty alts) -> let newTy = exprType (App f (case head alts of (_,_,e) -> e))- in Case s b newTy [ (c, ids, App f e)- | (c,ids,e) <- alts ])+ in Case s b newTy $ mapAlts (App f) alts) -- | case (case s1 of alt11 -> e11; alt12 -> e12) of alt21 -> e21; alt22 -> e22 -- ==>@@ -110,55 +126,96 @@ captures <- caseT caseAltVarsT (const altFreeVarsExclWildT) (\ vss bndr _ fs -> map (intersect (concatMap ($ bndr) fs)) vss) -- does the binder of the inner case, shadow a free variable in any of the outer case alts? -- notice, caseBinderVarT returns a singleton list- wildCapture <- caseT caseWildVarT (const altFreeVarsExclWildT) (\ innerBndr bndr _ fvs -> innerBndr `elem` concatMap ($ bndr) fvs)+ wildCapture <- caseT caseWildIdT (const altFreeVarsExclWildT) (\ innerBndr bndr _ fvs -> innerBndr `elem` concatMap ($ bndr) fvs) caseT ((if not wildCapture then idR else alphaCaseBinder Nothing) >>> caseAllR idR (\i -> if null (captures !! i) then idR else alphaAlt) ) (const idR)- (\ (Case s1 b1 _ alts1) b2 ty alts2 -> Case s1 b1 ty [ (c1, ids1, Case e1 b2 ty alts2) | (c1, ids1, e1) <- alts1 ])+ (\ (Case s1 b1 _ alts1) b2 ty alts2 -> Case s1 b1 ty $ mapAlts (\s -> Case s b2 ty alts2) alts1) --- | let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e+-- | let v = case s of alt1 -> e1 in e ==> case s of alt1 -> let v = e1 in e caseFloatLet :: RewriteH CoreExpr caseFloatLet = prefixFailMsg "Case floating from Let failed: " $ do vs <- letNonRecT caseAltVarsT idR (\ letVar caseVars _ -> elem letVar $ concat caseVars) let bdsAction = if not vs then idR else nonRecR alphaCase- letT bdsAction idR $ \ (NonRec v (Case s b ty alts)) e -> Case s b ty [ (con, ids, Let (NonRec v ec) e) | (con, ids, ec) <- alts]+ letT bdsAction idR $ \ (NonRec v (Case s b ty alts)) e -> Case s b ty $ mapAlts (flip Let e . NonRec v) alts +-- | cast (case s of p -> e) co ==> case s of p -> cast e co+caseFloatCast :: RewriteH CoreExpr+caseFloatCast = prefixFailMsg "Case float from cast failed: " $+ withPatFailMsg (wrongExprForm "Cast (Case s bnd ty alts) co") $+ do Cast (Case s bnd _ alts) co <- idR+ let alts' = mapAlts (flip Cast co) alts+ return $ Case s bnd (coreAltsType alts') alts' -- | Float a Case whatever the context. caseFloat :: RewriteH CoreExpr caseFloat = setFailMsg "Unsuitable expression for Case floating." $- caseFloatApp <+ caseFloatArg <+ caseFloatCase <+ caseFloatLet+ caseFloatApp <+ caseFloatArg <+ caseFloatCase <+ caseFloatLet <+ caseFloatCast --- | Case-of-known-constructor rewrite.+------------------------------------------------------------------------------++caseUnfloat :: RewriteH CoreExpr+caseUnfloat = setFailMsg "Case unfloating failed." $+ caseUnfloatApp <+ caseUnfloatArgs++caseUnfloatApp :: RewriteH CoreExpr+caseUnfloatApp = fail "caseUnfloatApp: TODO"++caseUnfloatArgs :: RewriteH CoreExpr+caseUnfloatArgs = prefixFailMsg "Case unfloating into arguments failed: " $+ withPatFailMsg (wrongExprForm "Case s v t alts") $+ do Case s wild _ty alts <- idR+ (vss, fs, argss) <- caseT mempty (\_ -> altT callT $ \ _ac vs (fn, args) -> (vs, fn, args))+ (\ () _ _ alts -> unzip3 [ (wild:vs, fn, args) | (vs,fn,args) <- alts ])+ guardMsg (exprsEqual fs) "alternatives are not parallel in function call."+ guardMsg (all null $ zipWith intersect (map coreExprFreeVars fs) vss) "function bound by case binders."+ return $ mkCoreApps (head fs) [ if isTyCoArg (head args)+ then head args -- TODO: is is possible for well-type case to have different+ -- type arguments in different alternatives? Obviously not with+ -- monomorphic types, but maybe with polymorphism?+ else let alts' = [ (ac, vs, arg) | ((ac,vs,_),arg) <- zip alts args ]+ in Case s wild (coreAltsType alts') alts'+ | args <- transpose argss ]++------------------------------------------------------------------------------+ caseReduce :: RewriteH CoreExpr-caseReduce = letTransform >>> tryR (repeatR letSubstR)- where letTransform = prefixFailMsg "Case reduction failed: " $- withPatFailMsg (wrongExprForm "Case e v t alts") $- do Case s binder _ alts <- idR- case isDataCon s of- Nothing -> fail "head of scrutinee is not a data constructor."- Just (dc, args) ->- case [ (bs, rhs) | (DataAlt dc', bs, rhs) <- alts, dc == dc' ] of- [(bs,e')] -> let (tyArgs, valArgs) = span isTypeArg args- tyBndrs = takeWhile isTyVar bs -- it is possible the pattern constructor binds a type- -- if the constructor is existentially quantified- existentials = reverse $ take (length tyBndrs) $ reverse tyArgs- in return $ nestedLets e' $ (binder, s) : zip bs (existentials ++ valArgs)- [] -> fail "no matching alternative."- _ -> fail "more than one matching alternative."+caseReduce = setFailMsg "Unsuitable expression for Case reduction." $+ caseReduceDatacon <+ caseReduceLiteral --- | If expression is a constructor application, return the relevant bits.-isDataCon :: CoreExpr -> Maybe (DataCon, [CoreExpr])-isDataCon expr = case fn of- Var i -> do dc <- isDataConId_maybe i- return (dc, args)- _ -> fail "not a var"- where (fn, args) = collectArgs expr+-- NB: LitAlt cases don't do evaluation+caseReduceLiteral :: RewriteH CoreExpr+caseReduceLiteral = prefixFailMsg "Case reduction failed: " $+ withPatFailMsg (wrongExprForm "Case (Lit l) v t alts") $+ do Case s wild _ alts <- idR+ case exprIsLiteral_maybe idUnfolding s of+ Nothing -> fail "scrutinee is not a literal."+ Just l -> do guardMsg (not (litIsLifted l)) "cannot case-reduce lifted literals" -- see Trac #5603+ case findAlt (LitAlt l) alts of+ Nothing -> fail "no matching alternative."+ Just (_, _, rhs) -> return $ mkCoreLet (NonRec wild (Lit l)) rhs --- | We don't want to use the recursive let here, so nest a bunch of non-recursive lets-nestedLets :: CoreExpr -> [(Id, CoreExpr)] -> CoreExpr-nestedLets = foldr (\(b,rhs) -> Let $ NonRec b rhs)+-- | Case-of-known-constructor rewrite.+caseReduceDatacon :: RewriteH CoreExpr+caseReduceDatacon = prefixFailMsg "Case reduction failed: " $+ withPatFailMsg (wrongExprForm "Case e v t alts")+ go+ where+ go :: RewriteH CoreExpr+ go = do Case e wild _ alts <- idR+ case exprIsConApp_maybe idUnfolding e of+ Nothing -> fail "head of scrutinee is not a data constructor."+ Just (dc, univTys, es) -> case findAlt (DataAlt dc) alts of+ Nothing -> fail "no matching alternative."+ Just (dc', vs, rhs) -> -- dc' is either DEFAULT or dc+ -- NB: It is possible that es contains one or more existentially quantified types.+ let fvss = map coreExprFreeVars $ map Type univTys ++ es+ shadows = [ v | (v,n) <- zip vs [1..], any (elem v) (drop n fvss) ]+ in if | any (elem wild) fvss -> alphaCaseBinder Nothing >>> go+ | not (null shadows) -> caseOneR (fail "scrutinee") (\ _ -> acceptR (\ (dc'',_,_) -> dc'' == dc') >>> alphaAltVars shadows) >>> go+ | null shadows -> return $ flip mkCoreLets rhs $ zipWith NonRec (wild : vs) (e : es)+-- WARNING: The alpha-renaming to avoid variable capture has not been tested. We need testing infrastructure! -- | Case split a free variable in an expression: --
+ src/Language/HERMIT/Primitive/Local/Cast.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE MultiWayIf #-}++module Language.HERMIT.Primitive.Local.Cast+ ( -- * Rewrites on Case Expressions+ externals+ , castElimRefl+ , castElimSym+ , castFloatApp+ , castElimSymPlus -- TODO: revisit+ ) where++import GhcPlugins+import qualified Coercion (substCo, extendTvSubst)+import Pair++import Control.Monad++import Language.HERMIT.Kure+import Language.HERMIT.External++import Language.HERMIT.Primitive.Common++------------------------------------------------------------------------------++-- | Externals relating to Case expressions.+externals :: [External]+externals =+ [ external "cast-elim" (promoteExprR castElim)+ [ "cast-elim-refl <+ cast-elim-sym" ] .+ Shallow .+ Bash+ , external "cast-elim-refl" (promoteExprR castElimRefl)+ [ "cast e co ==> e ; if co is a reflexive coercion" ] .+ Shallow .+ Bash+ , external "cast-elim-sym" (promoteExprR castElimSym)+ [ "removes pairs of symmetric casts" ] .+ Shallow .+ Bash+ , external "cast-elim-sym-plus" (promoteExprR castElimSymPlus)+ [ "removes pairs of symmetric casts possibly separated by let or case forms" ] .+ Deep+ , external "cast-float-app" (promoteExprR castFloatApp)+ [ "(cast e (c1 -> c2)) x ==> cast (e (cast x (sym c1))) c2" ] .+ Shallow+ , external "cast-elim-unsafe" (promoteExprR castElimUnsafe)+ [ "removes casts regardless of whether it is safe to do so" ] .+ Shallow .+ Experiment .+ Unsafe .+ TODO+ ]++------------------------------------------------------------------------------++castElim :: RewriteH CoreExpr+castElim = setFailMsg "Cast elimination failed: " $+ castElimRefl <+ castElimSym++castElimRefl :: RewriteH CoreExpr+castElimRefl = prefixFailMsg "Reflexive cast elimination failed: " $+ withPatFailMsg (wrongExprForm "Cast e co") $+ do Cast e co <- idR+ Pair a b <- return $ coercionKind co+ guardMsg (eqType a b) "not a reflexive coercion."+ return e++castElimSym :: RewriteH CoreExpr+castElimSym = prefixFailMsg "Symmetric cast elimination failed: " $+ withPatFailMsg (wrongExprForm "Cast (Cast e co1) co2") $+ do Cast (Cast e co1) co2 <- idR+ Pair a b <- return $ coercionKind co1+ Pair b' a' <- return $ coercionKind co2+ guardMsg (eqType a a' && eqType b b') "coercions are not symmetric."+ return e++castFloatApp :: RewriteH CoreExpr+castFloatApp = prefixFailMsg "Cast float from application failed: " $+ withPatFailMsg (wrongExprForm "App (Cast e1 co) e2") $+ do App (Cast e1 co) e2 <- idR+ case co of+ TyConAppCo t [c1, c2] -> do+ True <- return (isFunTyCon t)+ return $ Cast (App e1 (Cast e2 (SymCo c1))) c2+ ForAllCo t c2 -> do+ Type x' <- return e2+ return (Cast (App e1 e2) (Coercion.substCo (Coercion.extendTvSubst emptyCvSubst t x') c2))+ _ -> fail "castFloatApp"++-- TODO: revisit+castElimSymPlus :: RewriteH CoreExpr+castElimSymPlus = do+ Cast e c1 <- idR+ let go _ (Var _) = fail "no symmetric casts found"+ go _ (Lit _) = fail "no symmetric casts found"+ go _ (App _ _) = fail "app unimplemented" {- focus [0] (go c1 (add arg)) -}+ go c1 (Lam x body)+ | Just (con, [arg, res]) <- splitTyConAppCo_maybe c1+ , con == funTyCon+ , Pair arg1 arg2 <- coercionKind arg+ , arg1 `eqType` arg2 = do+ body' <- go res body+ return (Lam x body')+ | otherwise = fail "lam unimplemented" {-focus [0] (go c1 (drop arg))-}+ go c1 (Let bs body) = do body' <- go c1 body+ return (Let bs body')+ go c1 (Case scr x _ alts) = do alts' <- sequence [liftM ((,,) c a) (go c1 b) | (c,a,b) <- alts]+ let t' = exprType (case head alts' of (_,_,b) -> b)+ return (Case scr x t' alts')+ go c1 (Cast e c2) = if sym c1 c2 then return e else fail "no symmetric casts found"+ go _ (Tick{}) = fail "unexpected tick"+ go _ (Type{}) = fail "unexpected type"+ go _ (Coercion{}) = fail "unexpected coercion"+ sym c1 c2+ | Pair c11 c12 <- coercionKind c1,+ Pair c21 c22 <- coercionKind c2,+ c11 `eqType` c22, c21 `eqType` c12 = True+ | otherwise = False+ --sym (SymCo c1) c2 = geq c1 c2+ --sym c1 (SymCo c2) = geq c1 c2+ --sym _ _ = False+ go c1 e++castElimUnsafe :: RewriteH CoreExpr+castElimUnsafe = do+ Cast e _ <- idR+ return e
src/Language/HERMIT/Primitive/Local/Let.hs view
@@ -1,26 +1,32 @@ module Language.HERMIT.Primitive.Local.Let ( -- * Rewrites on Let Expressions- letElim- , letExternals+ externals+ , letElim , letIntro , letFloatApp , letFloatArg , letFloatLet , letFloatLam , letFloatCase+ , letFloatCast , letFloatExpr , letFloatLetTop , letNonRecElim , letRecElim , letToCase+ , letUnfloat , letUnfloatApp , letUnfloatCase+ , letUnfloatLam+ , reorderNonRecLets ) where import GhcPlugins -import Control.Category((>>>))+import Control.Applicative+import Control.Arrow+import Control.Monad import Data.List import Data.Monoid@@ -32,61 +38,65 @@ import Language.HERMIT.GHC import Language.HERMIT.Primitive.Common-import Language.HERMIT.Primitive.GHC-import Language.HERMIT.Primitive.AlphaConversion+import Language.HERMIT.Primitive.GHC hiding (externals)+import Language.HERMIT.Primitive.AlphaConversion hiding (externals) import qualified Language.Haskell.TH as TH ------------------------------------------------------------------------------ -- | Externals relating to Let expressions.-letExternals :: [External]-letExternals =- [ external "let-intro" (promoteExprR . letIntro :: TH.Name -> RewriteH Core)- [ "e => (let v = e in v), name of v is provided" ] .+ Shallow .+ Introduce- , external "dead-let-elimination" (promoteExprR letElim :: RewriteH Core)- [ "dead-let-elimination removes an unused let binding."- , "(let v = e1 in e2) ==> e2, if v is not free in e2."- , "condition: let is not-recursive" ] .+ Eval .+ Shallow .+ Bash- , external "dead-code-elimination" (promoteExprR letElim :: RewriteH Core)- [ "Synonym for dead-let-elimination [deprecated]" ] .+ Eval .+ Shallow -- TODO: delete this at some point- -- , external "let-constructor-reuse" (promoteR $ not_defined "constructor-reuse" :: RewriteH Core)- -- [ "let v = C v1..vn in ... C v1..vn ... ==> let v = C v1..vn in ... v ..., fails otherwise" ] .+ Unimplemented .+ Eval- , external "let-float-app" (promoteExprR letFloatApp :: RewriteH Core)- [ "(let v = ev in e) x ==> let v = ev in e x" ] .+ Commute .+ Shallow .+ Bash- , external "let-float-arg" (promoteExprR letFloatArg :: RewriteH Core)- [ "f (let v = ev in e) ==> let v = ev in f e" ] .+ Commute .+ Shallow .+ Bash- , external "let-float-lam" (promoteExprR letFloatLam :: RewriteH Core)- [ "(\\ v1 -> let v2 = e1 in e2) ==> let v2 = e1 in (\\ v1 -> e2), if v1 is not free in e2.",- "If v1 = v2 then v1 will be alpha-renamed."- ] .+ Commute .+ Shallow .+ Bash- , external "let-float-let" (promoteExprR letFloatLet :: RewriteH Core)- [ "let v = (let w = ew in ev) in e ==> let w = ew in let v = ev in e" ] .+ Commute .+ Shallow .+ Bash- , external "let-float-case" (promoteExprR letFloatCase :: RewriteH Core)- [ "case (let v = ev in e) of ... ==> let v = ev in case e of ..." ] .+ Commute .+ Shallow .+ Eval .+ Bash- , external "let-float-top" (promoteProgR letFloatLetTop :: RewriteH Core)- [ "v = (let w = ew in ev) : bds ==> w = ew : v = ev : bds" ] .+ Commute .+ Shallow .+ Bash- , external "let-float" (promoteProgR letFloatLetTop <+ promoteExprR letFloatExpr :: RewriteH Core)- [ "Float a Let whatever the context." ] .+ Commute .+ Shallow .+ Bash- , external "let-to-case" (promoteExprR letToCase :: RewriteH Core)- [ "let v = ev in e ==> case ev of v -> e" ] .+ Commute .+ Shallow .+ PreCondition- -- , external "let-to-case-unbox" (promoteR $ not_defined "let-to-case-unbox" :: RewriteH Core)- -- [ "let v = ev in e ==> case ev of C v1..vn -> let v = C v1..vn in e" ] .+ Unimplemented- , external "let-unfloat" (promoteExprR (letUnfloatApp <+ letUnfloatCase) >+> anybuR (promoteExprR letElim) :: RewriteH Core)- [ "Unfloat a let if possible." ] .+ Commute .+ Shallow- , external "let-unfloat-app" ((promoteExprR letUnfloatApp >+> anybuR (promoteExprR letElim)) :: RewriteH Core)- [ "let v = ev in f a ==> (let v = ev in f) (let v = ev in a)" ] .+ Commute .+ Shallow- , external "let-unfloat-case" ((promoteExprR letUnfloatCase >+> anybuR (promoteExprR letElim)) :: RewriteH Core)- [ "let v = ev in case s of p -> e ==> case (let v = ev in s) of p -> let v = ev in e"- , "if v does not shadow a pattern binder in p" ] .+ Commute .+ Shallow- ]+externals :: [External]+externals =+ [ external "let-intro" (promoteExprR . letIntro :: TH.Name -> RewriteH Core)+ [ "e => (let v = e in v), name of v is provided" ] .+ Shallow .+ Introduce+ , external "dead-let-elimination" (promoteExprR letElim :: RewriteH Core)+ [ "dead-let-elimination removes an unused let binding."+ , "(let v = e1 in e2) ==> e2, if v is not free in e2."+ , "condition: let is not-recursive" ] .+ Eval .+ Shallow .+ Bash+ , external "dead-code-elimination" (promoteExprR letElim :: RewriteH Core)+ [ "Synonym for dead-let-elimination [deprecated]" ] .+ Eval .+ Shallow -- TODO: delete this at some point+-- , external "let-constructor-reuse" (promoteR $ not_defined "constructor-reuse" :: RewriteH Core)+-- [ "let v = C v1..vn in ... C v1..vn ... ==> let v = C v1..vn in ... v ..., fails otherwise" ] .+ Unimplemented .+ Eval+ , external "let-float-app" (promoteExprR letFloatApp :: RewriteH Core)+ [ "(let v = ev in e) x ==> let v = ev in e x" ] .+ Commute .+ Shallow .+ Bash+ , external "let-float-arg" (promoteExprR letFloatArg :: RewriteH Core)+ [ "f (let v = ev in e) ==> let v = ev in f e" ] .+ Commute .+ Shallow .+ Bash+ , external "let-float-lam" (promoteExprR letFloatLam :: RewriteH Core)+ [ "(\\ v1 -> let v2 = e1 in e2) ==> let v2 = e1 in (\\ v1 -> e2), if v1 is not free in e2."+ , "If v1 = v2 then v1 will be alpha-renamed." ] .+ Commute .+ Shallow .+ Bash+ , external "let-float-let" (promoteExprR letFloatLet :: RewriteH Core)+ [ "let v = (let w = ew in ev) in e ==> let w = ew in let v = ev in e" ] .+ Commute .+ Shallow .+ Bash+ , external "let-float-case" (promoteExprR letFloatCase :: RewriteH Core)+ [ "case (let v = ev in e) of ... ==> let v = ev in case e of ..." ] .+ Commute .+ Shallow .+ Eval .+ Bash+ , external "let-float-cast" (promoteExprR letFloatCast)+ [ "cast (let bnds in e) co ==> let bnds in cast e co" ] .+ Shallow+ , external "let-float-top" (promoteProgR letFloatLetTop :: RewriteH Core)+ [ "v = (let w = ew in ev) : bds ==> w = ew : v = ev : bds" ] .+ Commute .+ Shallow .+ Bash+ , external "let-float" (promoteProgR letFloatLetTop <+ promoteExprR letFloatExpr :: RewriteH Core)+ [ "Float a Let whatever the context." ] .+ Commute .+ Shallow .+ Bash+ , external "let-to-case" (promoteExprR letToCase :: RewriteH Core)+ [ "let v = ev in e ==> case ev of v -> e" ] .+ Commute .+ Shallow .+ PreCondition+-- , external "let-to-case-unbox" (promoteR $ not_defined "let-to-case-unbox" :: RewriteH Core)+-- [ "let v = ev in e ==> case ev of C v1..vn -> let v = C v1..vn in e" ] .+ Unimplemented+ , external "let-unfloat" (promoteExprR letUnfloat >+> anybuR (promoteExprR letElim) :: RewriteH Core)+ [ "Unfloat a let if possible." ] .+ Commute .+ Shallow+ , external "let-unfloat-app" ((promoteExprR letUnfloatApp >+> anybuR (promoteExprR letElim)) :: RewriteH Core)+ [ "let v = ev in f a ==> (let v = ev in f) (let v = ev in a)" ] .+ Commute .+ Shallow+ , external "let-unfloat-case" ((promoteExprR letUnfloatCase >+> anybuR (promoteExprR letElim)) :: RewriteH Core)+ [ "let v = ev in case s of p -> e ==> case (let v = ev in s) of p -> let v = ev in e"+ , "if v does not shadow a pattern binder in p" ] .+ Commute .+ Shallow+ , external "reorder-lets" (promoteExprR . reorderNonRecLets :: [TH.Name] -> RewriteH Core)+ [ "Re-order a sequence of nested non-recursive let bindings."+ , "The argument list should contain the let-bound variables, in the desired order." ]+ ] ------------------------------------------------------------------------------------------- -- | e => (let v = e in v), name of v is provided letIntro :: TH.Name -> RewriteH CoreExpr letIntro nm = prefixFailMsg "Let-introduction failed: " $- contextfreeT $ \ e -> do guardMsg (not $ isType e) "let expressions may not return a type."+ contextfreeT $ \ e -> do guardMsg (not $ isTypeArg e) "let expressions may not return a type." v <- newIdH (show nm) (exprTypeOrKind e) return $ Let (NonRec v e) (Var v) @@ -97,10 +107,10 @@ -- (let v = E1 in E2) => E2, if v is not free in E2 letNonRecElim :: RewriteH CoreExpr letNonRecElim = prefixFailMsg "Dead-let-elimination failed: " $- withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $- do Let (NonRec v _) e <- idR- guardMsg (v `notElem` coreExprFreeVars e) "let-bound variable appears in the expression."- return e+ withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $+ do Let (NonRec v _) e <- idR+ guardMsg (v `notElem` coreExprFreeVars e) "let-bound variable appears in the expression."+ return e -- TODO: find the GHC way to do this, as this implementation will be defeated by mutual recursion -- | Remove all unused recursive let bindings in the current group.@@ -124,7 +134,7 @@ letToCase = prefixFailMsg "Converting Let to Case failed: " $ withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $ do Let (NonRec v ev) _ <- idR- guardMsg (not $ isType ev) "cannot case on a type."+ guardMsg (not $ isTyCoArg ev) "cannot case on a type or coercion." nameModifier <- freshNameGenT Nothing caseBndr <- constT (cloneVarH nameModifier v) letT mempty (replaceVarR v caseBndr) $ \ () e' -> Case ev caseBndr (varType v) [(DEFAULT, [], e')]@@ -175,29 +185,86 @@ (const idR) (\ (Let bnds e) wild ty alts -> Let bnds (Case e wild ty alts)) +-- | @cast (let bnds in e) co ==> let bnds in cast e co@+letFloatCast :: RewriteH CoreExpr+letFloatCast = prefixFailMsg "Let floating from Cast failed: " $+ withPatFailMsg (wrongExprForm "Cast (Let bnds e) co") $+ do Cast (Let bnds e) co <- idR+ return (Let bnds (Cast e co))+ -- | Float a Let through an expression, whatever the context. letFloatExpr :: RewriteH CoreExpr letFloatExpr = setFailMsg "Unsuitable expression for Let floating." $- letFloatApp <+ letFloatArg <+ letFloatLet <+ letFloatLam <+ letFloatCase+ letFloatArg <+ letFloatApp <+ letFloatLet <+ letFloatLam <+ letFloatCase <+ letFloatCast -- | NonRec v (Let (NonRec w ew) ev) `ProgCons` p ==> NonRec w ew `ProgCons` NonRec v ev `ProgCons` p letFloatLetTop :: RewriteH CoreProg letFloatLetTop = prefixFailMsg "Let floating to top level failed: " $ withPatFailMsg (wrongExprForm "NonRec v (Let (NonRec w ew) ev) `ProgCons` p") $ do NonRec v (Let (NonRec w ew) ev) `ProgCons` p <- idR- guardMsg (not $ isType ew) "type bindings are not allowed at the top level."+ guardMsg (not $ isTyCoArg ew) "type and coercion bindings are not allowed at the top level." return (NonRec w ew `ProgCons` NonRec v ev `ProgCons` p) ------------------------------------------------------------------------------------------- +letUnfloat :: RewriteH CoreExpr+letUnfloat = letUnfloatCase <+ letUnfloatApp <+ letUnfloatLam+ letUnfloatCase :: RewriteH CoreExpr-letUnfloatCase = prefixFailMsg "Let unfloating from case failed: " $ do- Let bnds (Case s w ty alts) <- idR- captured <- letT bindVarsT caseVarsT intersect- guardMsg (null captured) "let bindings would capture case pattern bindings."- return $ Case (Let bnds s) w ty [ (ac, vs, Let bnds e) | (ac, vs, e) <- alts ]+letUnfloatCase = prefixFailMsg "Let unfloating from case failed: " $+ withPatFailMsg (wrongExprForm "Let bnds (Case s w ty alts)") $+ do Let bnds (Case s w ty alts) <- idR+ captured <- letT bindVarsT caseVarsT intersect+ guardMsg (null captured) "let bindings would capture case pattern bindings."+ return $ Case (Let bnds s) w ty $ mapAlts (Let bnds) alts letUnfloatApp :: RewriteH CoreExpr-letUnfloatApp = prefixFailMsg "Let unfloating from app failed: " $ do- Let bnds (App e1 e2) <- idR- return $ App (Let bnds e1) (Let bnds e2)+letUnfloatApp = prefixFailMsg "Let unfloating from app failed: " $+ withPatFailMsg (wrongExprForm "Let bnds (App e1 e2)") $+ do Let bnds (App e1 e2) <- idR+ return $ App (Let bnds e1) (Let bnds e2)++letUnfloatLam :: RewriteH CoreExpr+letUnfloatLam = prefixFailMsg "Let unfloating from lambda failed: " $+ withPatFailMsg (wrongExprForm "Let bnds (Lam v e)") $+ do Let bnds (Lam v e) <- idR+ safe <- letT bindVarsT lamVarT $ flip notElem+ guardMsg safe "let bindings would capture lambda binding."+ return $ Lam v $ Let bnds e++-------------------------------------------------------------------------------------------++-- | Re-order a sequence of nested non-recursive let bindings.+-- The argument list should contain the let-bound variables, in the desired order.+reorderNonRecLets :: [TH.Name] -> RewriteH CoreExpr+reorderNonRecLets ns = prefixFailMsg "Reorder lets failed: " $+ do guardMsg (not $ null ns) "no names given."+ guardMsg (nodups ns) "duplicate names given."+ e <- idR+ (ves,x) <- setFailMsg "insufficient non-recursive lets." $ takeNonRecLets (length ns) e+ guardMsg (noneFreeIn ves) "some of the bound variables appear in the right-hand-sides."+ e' <- mkNonRecLets <$> mapM (lookupName ves) ns <*> pure x+ guardMsg (not $ exprEqual e e') "bindings already in specified order."+ return e'++ where+ takeNonRecLets :: Monad m => Int -> CoreExpr -> m ([(Var,CoreExpr)],CoreExpr)+ takeNonRecLets 0 x = return ([],x)+ takeNonRecLets n (Let (NonRec v1 e1) x) = first ((v1,e1):) `liftM` takeNonRecLets (n-1) x+ takeNonRecLets _ _ = fail "insufficient non-recursive lets."++ noneFreeIn :: [(Var,CoreExpr)] -> Bool+ noneFreeIn ves = let (vs,es) = unzip ves+ in all (`notElem` concatMap coreExprFreeVars es) vs++ lookupName :: Monad m => [(Var,CoreExpr)] -> TH.Name -> m (Var,CoreExpr)+ lookupName ves nm = case filter (cmpTHName2Var nm . fst) ves of+ [] -> fail $ "name " ++ show nm ++ " not matched."+ [ve] -> return ve+ _ -> fail $ "multiple matches for " ++ show nm ++ "."++ mkNonRecLets :: [(Var,CoreExpr)] -> CoreExpr -> CoreExpr+ mkNonRecLets [] x = x+ mkNonRecLets ((v,e):ves) x = Let (NonRec v e) (mkNonRecLets ves x)++-------------------------------------------------------------------------------------------
@@ -6,8 +6,10 @@ , bindingGroupOf , considerName , rhsOf- , considerables , considerTargets+ , Considerable(..)+ , considerables+ , considerConstructT ) where @@ -65,7 +67,7 @@ namedBinding nm (DefCore (Def v _)) = nm `cmpTHName2Var` v namedBinding _ _ = False --- | Find all the possible targets of \"consider\".+-- | Find the names of all the variables that could be targets of \"consider\". considerTargets :: TranslateH Core [String] considerTargets = allT $ collectT (promoteBindT nonRec <+ promoteDefT def) where@@ -79,6 +81,7 @@ constUnq v () = unqualifiedVarName v +-- | Language constructs that can be zoomed to. data Considerable = Binding | Definition | CaseAlt | Variable | Literal | Application | Lambda | LetIn | CaseOf | Casty | Ticky | TypeVar | Coerce recognizedConsiderables :: String@@ -104,7 +107,11 @@ considerConstruct :: String -> TranslateH Core Path considerConstruct str = case string2considerable str of Nothing -> fail $ "Unrecognized construct \"" ++ str ++ "\". " ++ recognizedConsiderables ++ ". Or did you mean \"consider '" ++ str ++ "\"?"- Just c -> oneNonEmptyPathToT (underConsideration c)+ Just c -> considerConstructT c++-- | Find the 'Path' to the first matching construct.+considerConstructT :: Considerable -> TranslateH Core Path+considerConstructT = oneNonEmptyPathToT . underConsideration string2considerable :: String -> Maybe Considerable string2considerable = flip lookup considerables
src/Language/HERMIT/Primitive/New.hs view
@@ -14,11 +14,13 @@ import Language.HERMIT.Kure import Language.HERMIT.External import Language.HERMIT.GHC+import Language.HERMIT.ParserCore import Language.HERMIT.Primitive.Common import Language.HERMIT.Primitive.GHC import Language.HERMIT.Primitive.Local import Language.HERMIT.Primitive.Inline+import Language.HERMIT.Primitive.Unfold -- import Language.HERMIT.Primitive.Debug import qualified Language.Haskell.TH as TH@@ -28,29 +30,29 @@ externals = map ((.+ Experiment) . (.+ TODO)) [ external "test" (testQuery :: RewriteH Core -> TranslateH Core String) [ "determines if a rewrite could be successfully applied" ]- , external "cleanup-unfold" (promoteExprR cleanupUnfold :: RewriteH Core)- [ "clean up immeduate nested fully-applied lambdas, from the bottom up"]- , external "unfold" (promoteExprR . unfold :: TH.Name -> RewriteH Core)- [ "inline a definition, and apply the arguments; tranditional unfold"] , external "push" (promoteExprR . push :: TH.Name -> RewriteH Core) [ "push a function <f> into argument." , "Unsafe if f is not strict." ] .+ PreCondition- -- TODO: does not work with rules with no arguments- , external "unfold-rule" ((\ nm -> promoteExprR (rules nm >>> cleanupUnfold)) :: String -> RewriteH Core)- [ "apply a named GHC rule" ] , external "var" (promoteExprT . isVar :: TH.Name -> TranslateH Core ()) [ "var '<v> returns successfully for variable v, and fails otherwise.", "Useful in combination with \"when\", as in: when (var v) r" ] .+ Predicate , external "simplify" (simplifyR :: RewriteH Core)- [ "innermost (unfold '. <+ beta-reduce-plus <+ safe-let-subst <+ case-reduce <+ dead-let-elimination)" ]+ [ "innermost (unfold 'id <+ unfold '$ <+ unfold '. <+ beta-reduce-plus <+ safe-let-subst <+ case-reduce <+ dead-let-elimination)" ] .+ Bash , external "let-tuple" (promoteExprR . letTupleR :: TH.Name -> RewriteH Core) [ "let x = e1 in (let y = e2 in e) ==> let t = (e1,e2) in (let x = fst t in (let y = snd t in e))" ]- , external "any-call" (withUnfold :: RewriteH Core -> RewriteH Core)+ , external "any-call" (anyCallR :: RewriteH Core -> RewriteH Core) [ "any-call (.. unfold command ..) applies an unfold commands to all applications" , "preference is given to applications with more arguments" ] .+ Deep , external "static-arg" (promoteDefR staticArg :: RewriteH Core) [ "perform the static argument transformation on a recursive function" ]+ , external "unsafe-replace" (promoteExprR . unsafeReplace :: CoreString -> RewriteH Core)+ [ "replace the currently focused expression with a new expression" ] .+ Unsafe+ , external "unsafe-replace" (promoteExprR . unsafeReplaceStash :: String -> RewriteH Core)+ [ "replace the currently focused expression with an expression from the stash"+ , "DOES NOT ensure expressions have the same type, or that free variables in the replacement expression are in scope" ] .+ Unsafe+ , external "inline-all" (inlineAll :: [TH.Name] -> RewriteH Core)+ [ "inline all named functions in a bottom-up manner" ] ] ------------------------------------------------------------------------------------------------------@@ -63,8 +65,13 @@ simplifyR :: RewriteH Core simplifyR = setFailMsg "Simplify failed: nothing to simplify." $- innermostR (promoteExprR (unfold (TH.mkName ".") <+ betaReducePlus <+ safeLetSubstR <+ caseReduce <+ letElim))-+ innermostR (promoteExprR (unfoldNameR (TH.mkName "$")+ <+ unfoldNameR (TH.mkName ".")+ <+ unfoldNameR (TH.mkName "id")+ <+ betaReducePlus+ <+ safeLetSubstR+ <+ caseReduce+ <+ letElim)) collectLets :: CoreExpr -> ([(Var, CoreExpr)],CoreExpr) collectLets (Let (NonRec x e1) e2) = let (bs,expr) = collectLets e2 in ((x,e1):bs, expr)@@ -82,16 +89,12 @@ -- check if tupling the bindings would cause unbound variables let- rhsTypes = map exprType rhss frees = map coreExprFreeVars (drop 1 rhss) used = concat $ zipWith intersect (map (`take` vs) [1..]) frees if null used- then do tupleConId <- findIdT $ TH.mkName $ "(" ++ replicate (numBnds - 1) ',' ++ ")"- case isDataConId_maybe tupleConId of- Nothing -> fail "cannot find tuple data constructor."- Just dc -> let rhs = mkCoreApps (Var tupleConId) $ map Type rhsTypes ++ rhss- in constT $ do wild <- newIdH (show nm) (exprType rhs)- return $ Case rhs wild (exprType body) [(DataAlt dc, vs, body)]+ then let rhs = mkCoreTup rhss+ in constT $ do wild <- newIdH (show nm) (exprType rhs)+ return $ mkSmallTupleCase vs body wild rhs else fail $ "the following bound variables are used in subsequent bindings: " ++ showVars used @@ -104,11 +107,10 @@ Def f rhs <- idR let (bnds, body) = collectBinders rhs guardMsg (notNull bnds) "rhs is not a function"- c <- contextT- constT $ do+ contextonlyT $ \ c -> do let bodyContext = foldl (flip addLambdaBinding) c bnds - callPats <- apply (callsT (var2THName f) (collectArgsT >>> arr snd)) bodyContext (ExprCore body)+ callPats <- apply (callsT (var2THName f) (callT >>> arr snd)) bodyContext (ExprCore body) let argExprs = transpose callPats numCalls = length callPats -- ensure argument is present in every call (partial applications boo)@@ -125,7 +127,7 @@ let replaceCall :: RewriteH CoreExpr replaceCall = do- (_,exprs) <- collectArgsT+ (_,exprs) <- callT return $ mkApps (Var wkr) [ e | (p,e) <- zip [0..] exprs, (p::Int) `elem` ps ] ExprCore body' <- apply (callsR (var2THName f) replaceCall) bodyContext (ExprCore body)@@ -133,28 +135,6 @@ return $ Def f $ mkCoreLams bnds $ Let (Rec [(wkr, mkCoreLams dbnds body')]) $ mkApps (Var wkr) (varsToCoreExprs dbnds) --- | Like GHC's collectArgs, but fails if not an application-collectArgsT :: TranslateH CoreExpr (CoreExpr, [CoreExpr])-collectArgsT = do- App {} <- idR- arr collectArgs---- | Succeeds if we are looking at an application of given function-callG :: TH.Name -> TranslateH CoreExpr ()-callG nm = prefixFailMsg "callG failed: " $ do- (Var i,_) <- collectArgsT- guardMsg (cmpTHName2Var nm i) $ "not a call to " ++ show nm- return ()---- | Apply a rewrite to all applications of a given function in a top-down manner, pruning on success.-callsR :: TH.Name -> RewriteH CoreExpr -> RewriteH Core-callsR nm rr = prunetdR (promoteExprR $ callG nm >> rr)---- | Apply a translate to all applications of a given function in a top-down manner,--- pruning on success, collecting the results.-callsT :: TH.Name -> TranslateH CoreExpr b -> TranslateH Core [b]-callsT nm t = collectPruneT (promoteExprT $ callG nm >> t)- ------------------------------------------------------------------------------------------------------ testQuery :: RewriteH Core -> TranslateH Core String@@ -165,30 +145,9 @@ ------------------------------------------------------------------------------------------------------ --- | cleanupUnfold cleans a unfold operation--- (for example, an inline or rule application)--- It is used at the level of the top-redex.-cleanupUnfold :: RewriteH CoreExpr-cleanupUnfold = betaReducePlus >>> safeLetSubstPlusR--unfold :: TH.Name -> RewriteH CoreExpr-unfold nm = translate $ \ env e0 -> do- let n = appCount e0- let sub :: RewriteH Core- sub = pathR (replicate n 0) (promoteR $ inlineName nm)-- sub2 :: RewriteH CoreExpr- sub2 = extractR sub-- e1 <- apply sub2 env e0-- -- only cleanup if 1 or more arguments- if n > 0 then apply cleanupUnfold env e1- else return e1- -- match in a top-down manner,-withUnfold :: RewriteH Core -> RewriteH Core-withUnfold rr = prefixFailMsg "any-call failed: " $+anyCallR :: RewriteH Core -> RewriteH Core+anyCallR rr = prefixFailMsg "any-call failed: " $ readerT $ \ e -> case e of ExprCore (App {}) -> childR 1 rec >+> (rr <+ childR 0 rec) ExprCore (Var {}) -> rr@@ -196,7 +155,7 @@ where rec :: RewriteH Core- rec = withUnfold rr+ rec = anyCallR rr ------------------------------------------------------------------------------------------------------ @@ -215,5 +174,29 @@ Let {} -> letFloatArg _ -> fail "argument is not a Case or Let." _ -> fail "no function to match."++------------------------------------------------------------------------------------------------------++parseCoreExprT :: CoreString -> TranslateH a CoreExpr+parseCoreExprT = contextonlyT . parseCore++unsafeReplace :: CoreString -> RewriteH CoreExpr+unsafeReplace core =+ translate $ \ c e -> do+ e' <- parseCore core c+ guardMsg (eqType (exprType e) (exprType e')) "expression types differ."+ return e'++unsafeReplaceStash :: String -> RewriteH CoreExpr+unsafeReplaceStash label = prefixFailMsg "unsafe-replace failed: " $+ contextfreeT $ \ e -> do+ Def _ rhs <- lookupDef label+ guardMsg (eqType (exprType e) (exprType rhs)) "expression types differ."+ return rhs++------------------------------------------------------------------------------------------------------++inlineAll :: [TH.Name] -> RewriteH Core+inlineAll = innermostR . foldr (\nm rr -> promoteExprR (inlineName nm) <+ rr) (fail "inline-all: nothing to do") ------------------------------------------------------------------------------------------------------
src/Language/HERMIT/Primitive/Unfold.hs view
@@ -1,101 +1,151 @@-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts, TupleSections #-} module Language.HERMIT.Primitive.Unfold ( externals- , stashDef- , stashApply- , getUnfolding+ , cleanupUnfoldR+ , rememberR+ , showStashT+ , unfoldR+ , unfoldPredR+ , unfoldNameR+ , unfoldAnyR+ , unfoldSaturatedR+ , unfoldStashR+ , specializeR ) where import GhcPlugins hiding (empty)-import Control.Monad import Control.Applicative+import Control.Arrow+import Control.Monad -import Language.HERMIT.Primitive.GHC hiding (externals)+import qualified Data.Map as Map++import qualified Language.Haskell.TH as TH++import Language.HERMIT.PrettyPrinter.Common (DocH, PrettyH, TranslateDocH(..))+ import Language.HERMIT.Primitive.Common+import Language.HERMIT.Primitive.GHC hiding (externals)+import Language.HERMIT.Primitive.Inline hiding (externals) import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.Monad import Language.HERMIT.External-import Language.HERMIT.Context import Language.HERMIT.GHC import Prelude hiding (exp) +import qualified Text.PrettyPrint.MarkedHughesPJ as PP+ ------------------------------------------------------------------------ externals :: [External] externals =- [ external "remember" stashDef- ["Remember the current binding, allowing it to be folded/unfolded in the future."]- , external "unfold" (promoteExprR . stashApply)- ["Unfold a remembered definition."]- ]+ [ external "cleanup-unfold" (promoteExprR cleanupUnfoldR :: RewriteH Core)+ [ "Clean up immediately nested fully-applied lambdas, from the bottom up" ] .+ Deep+ , external "remember" rememberR+ [ "Remember the current binding, allowing it to be folded/unfolded in the future." ] .+ Context+ , external "unfold" (promoteExprR . unfoldStashR)+ [ "Unfold a remembered definition." ] .+ Deep .+ Context+ , external "unfold" (promoteExprR unfoldR :: RewriteH Core)+ [ "In application f x y z, unfold f." ] .+ Deep .+ Context+ , external "unfold" (promoteExprR . unfoldNameR :: TH.Name -> RewriteH Core)+ [ "Inline a definition, and apply the arguments; traditional unfold" ] .+ Deep .+ Context+ , external "unfold-saturated" (promoteExprR unfoldSaturatedR :: RewriteH Core)+ [ "Unfold a definition only if the function is fulled applied." ] .+ Deep .+ Context+ , external "specialize" (promoteExprR specializeR :: RewriteH Core)+ [ "Specialize an application to its type and coercion arguments." ] .+ Deep .+ Context+ , external "unfold-rule" ((\ nm -> promoteExprR (rule nm >>> cleanupUnfoldR)) :: String -> RewriteH Core)+ [ "Apply a named GHC rule" ] .+ Deep .+ Context -- TODO: does not work with rules with no arguments+ , external "show-remembered" (TranslateDocH showStashT :: TranslateDocH Core)+ [ "Display all remembered definitions." ]+ ] ------------------------------------------------------------------------ +-- | cleanupUnfoldR cleans a unfold operation+-- (for example, an inline or rule application)+-- It is used at the level of the top-redex.+-- Invariant: will not introduce let bindings+cleanupUnfoldR :: RewriteH CoreExpr+cleanupUnfoldR = do+ (f, args) <- callT <+ (idR >>> arr (,[]))+ let (vs, body) = collectBinders f+ lenargs = length args+ lenvs = length vs+ comp = compare lenargs lenvs+ body' = case comp of+ LT -> mkCoreLams (drop lenargs vs) body+ _ -> body+ bnds = zipWith NonRec vs args+ body'' <- contextonlyT $ \ c -> do+ apply (andR $ replicate (length bnds) letSubstR) c $ mkCoreLets bnds body'+ return $ case comp of+ GT -> mkCoreApps body'' $ drop lenvs args+ _ -> body''++-- | A more powerful 'inline'. Matches two cases:+-- Var ==> inlines+-- App ==> inlines the head of the function call for the app tree+unfoldR :: RewriteH CoreExpr+unfoldR = go >>> cleanupUnfoldR+ where go :: RewriteH CoreExpr+ go = inline <+ appAllR go idR++unfoldPredR :: (Id -> [CoreExpr] -> Bool) -> RewriteH CoreExpr+unfoldPredR p = callPredT p >>= \ _ -> unfoldR++unfoldNameR :: TH.Name -> RewriteH CoreExpr+unfoldNameR nm = callNameT nm >>= \ _ -> unfoldR++unfoldAnyR :: [TH.Name] -> RewriteH CoreExpr+unfoldAnyR = orR . map unfoldNameR++unfoldSaturatedR :: RewriteH CoreExpr+unfoldSaturatedR = callSaturatedT >>= \ _ -> unfoldR++specializeR :: RewriteH CoreExpr+specializeR = unfoldPredR (const (all isTyCoArg))+ -- NOTE: Using a Rewrite because of the way the Kernel is set up.--- This is a temperary hack until we work out the best way to structure the Kernel.+-- This is a temporary hack until we work out the best way to structure the Kernel. -- | Stash a binding with a name for later use. -- Allows us to look at past definitions.-stashDef :: String -> RewriteH Core-stashDef label = sideEffectR $ \ _ core ->+rememberR :: Label -> RewriteH Core+rememberR label = sideEffectR $ \ _ core -> case core of DefCore def -> saveDef label def BindCore (NonRec i e) -> saveDef label (Def i e)- _ -> fail "stashDef: not a binding"+ _ -> fail "remember: not a binding" -- | Stash a binding with a name for later use. -- Allows us to look at past definitions.--- stashDef :: String -> TranslateH Core ()--- stashDef label = contextfreeT $ \ core ->+-- rememberR :: String -> TranslateH Core ()+-- rememberR label = contextfreeT $ \ core -> -- case core of -- DefCore def -> saveDef label def -- BindCore (NonRec i e) -> saveDef label (Def i e)--- _ -> fail "stashDef: not a binding"+-- _ -> fail "remember: not a binding" -- | Apply a stashed definition (like inline, but looks in stash instead of context).-stashApply :: String -> RewriteH CoreExpr-stashApply label = setFailMsg "Inlining stashed definition failed: " $+unfoldStashR :: String -> RewriteH CoreExpr+unfoldStashR label = setFailMsg "Inlining stashed definition failed: " $ withPatFailMsg (wrongExprForm "Var v") $- do (c, Var v) <- exposeT- constT $ do Def i rhs <- lookupDef label- if idName i == idName v -- TODO: Is there a reason we're not just using equality on Id?- then ifM (all (inScope c) <$> apply freeVarsT c rhs)- (return rhs)- (fail "some free variables in stashed definition are no longer in scope.")- else fail $ "stashed definition applies to " ++ var2String i ++ " not " ++ var2String v--getUnfolding :: Monad m- => Bool -- ^ Get the scrutinee instead of the patten match (for case binders).- -> Bool -- ^ Only succeed if this variable is a case binder.- -> Id -> HermitC -> m (CoreExpr, Int)-getUnfolding scrutinee caseBinderOnly i c =- case lookupHermitBinding i c of- Nothing -> case unfoldingInfo (idInfo i) of- CoreUnfolding { uf_tmpl = uft } -> if caseBinderOnly then fail "not a case binder" else return (uft, 0)- _ -> fail $ "cannot find unfolding in Env or IdInfo."- Just (LAM {}) -> fail $ "variable is lambda-bound."- Just (BIND depth _ e') -> if caseBinderOnly then fail "not a case binder." else return (e', depth)- Just (CASE depth s coreAlt) -> return $ if scrutinee- then (s, depth)- else let tys = tyConAppArgs (idType i)- in either (,depth) (,depth+1) (alt2Exp s tys coreAlt)+ do (c, Var v) <- exposeT+ constT $ do Def i rhs <- lookupDef label+ if idName i == idName v -- TODO: Is there a reason we're not just using equality on Id?+ then ifM (all (inScope c) <$> apply freeVarsT c rhs)+ (return rhs)+ (fail "some free variables in stashed definition are no longer in scope.")+ else fail $ "stashed definition applies to " ++ var2String i ++ " not " ++ var2String v --- | Convert lhs of case alternative to a constructor application expression,--- or a default expression in the case of the DEFAULT alternative.--- Accepts a list of types to apply to the constructor before the value args.------ > data T a b = C a b Int------ Pseudocode:------ > alt2Exp (...) [a,b] (C, [x,y,z]) ==> C a b (x::a) (y::b) (z::Int)------ The 'Either' denotes whether we picked the default (scrutinee) or built an expression.--- This matters for the depth check.-alt2Exp :: CoreExpr -> [Type] -> (AltCon,[Id]) -> Either CoreExpr CoreExpr-alt2Exp d _ (DEFAULT , _ ) = Left d-alt2Exp _ _ (LitAlt l , _ ) = Right $ Lit l-alt2Exp _ tys (DataAlt dc, as) = Right $ mkCoreConApps dc (map Type tys ++ map Var as)+showStashT :: Injection CoreDef a => PrettyH a -> TranslateH a DocH+showStashT pp = do+ stash <- constT getStash+ docs <- contextonlyT $ \ c ->+ mapM (\ (l,d) -> do dfn <- apply (extractT pp) c d+ return $ PP.text ("[ " ++ l ++ " ]") PP.$+$ dfn PP.$+$ PP.space)+ (Map.toList stash)+ return $ PP.vcat docs
src/Language/HERMIT/Shell/Command.hs view
@@ -3,6 +3,8 @@ module Language.HERMIT.Shell.Command ( -- * The HERMIT Command-line Shell commandLine+ , interactive+ , unicodeConsole ) where import qualified GhcPlugins as GHC@@ -27,14 +29,16 @@ import Language.HERMIT.Monad import Language.HERMIT.Kure import Language.HERMIT.Dictionary-import Language.HERMIT.Expr import Language.HERMIT.External import Language.HERMIT.Interp+import Language.HERMIT.Kernel (queryK) import Language.HERMIT.Kernel.Scoped-import Language.HERMIT.PrettyPrinter+import Language.HERMIT.Parser+import Language.HERMIT.PrettyPrinter.Common -import Language.HERMIT.Primitive.Navigation+import Language.HERMIT.Primitive.GHC import Language.HERMIT.Primitive.Inline+import Language.HERMIT.Primitive.Navigation import System.Console.ANSI import System.IO@@ -79,12 +83,13 @@ deriving Typeable data QueryFun :: * where- QueryT :: TranslateH Core String -> QueryFun+ QueryString :: TranslateH Core String -> QueryFun+ QueryDocH :: (PrettyH Core -> TranslateH Core DocH) -> QueryFun -- These two be can generalized into -- (CommandLineState -> IO String)- Display :: QueryFun- Message :: String -> QueryFun- Inquiry ::(CommandLineState -> SessionState -> IO String) -> QueryFun+ Display :: QueryFun+ Message :: String -> QueryFun+ Inquiry :: (CommandLineState -> SessionState -> IO String) -> QueryFun deriving Typeable instance Extern QueryFun where@@ -98,6 +103,7 @@ | Dump String String String Int | LoadFile String -- load a file on top of the current node | SaveFile String+ | Delete SAST deriving Typeable instance Extern MetaCommand where@@ -129,9 +135,11 @@ interpShellCommand = [ interp $ \ (ShellCommandBox cmd) -> cmd , interp $ \ (RewriteCoreBox rr) -> AstEffect (Apply rr)+ , interp $ \ (BiRewriteCoreBox br) -> AstEffect (Apply $ forewardT br) , interp $ \ (TranslateCorePathBox tt) -> AstEffect (Pathfinder tt) , interp $ \ (StringBox str) -> QueryFun (Message str)- , interp $ \ (TranslateCoreStringBox tt) -> QueryFun (QueryT tt)+ , interp $ \ (TranslateCoreStringBox tt) -> QueryFun (QueryString tt)+ , interp $ \ (TranslateCoreDocHBox tt) -> QueryFun (QueryDocH $ unTranslateDocH tt) , interp $ \ (TranslateCoreCheckBox tt) -> AstEffect (CorrectnessCritera tt) , interp $ \ (effect :: AstEffect) -> AstEffect effect , interp $ \ (effect :: ShellEffect) -> ShellEffect effect@@ -153,6 +161,10 @@ [ "stops HERMIT; resumes compile" ] , external "abort" Abort -- UNIX Exit [ "hard UNIX-style exit; does not return to GHC; does not save" ]+ , external "gc" (Delete . SAST)+ [ "garbage-collect a given AST; does not remove from command log" ]+ , external "gc" (SessionStateEffect gc)+ [ "garbage-collect all ASTs except for the initial and current AST" ] , external "display" Display [ "redisplays current state" ] , external "left" (Direction L)@@ -181,6 +193,18 @@ [ "goto a specific step in the derivation" ] .+ VersionControl , external "goto" (SessionStateEffect . navigation . GotoTag) [ "goto a named step in the derivation" ]+ , external "set-fail-hard" (\ bStr -> SessionStateEffect $ \ _ st ->+ case reads bStr of+ [(b,"")] -> return $ st { cl_failhard = b }+ _ -> return st )+ [ "set-fail-hard <True|False>; False by default"+ , "any rewrite failure causes compilation to abort" ]+ , external "set-auto-corelint" (\ bStr -> SessionStateEffect $ \ _ st ->+ case reads bStr of+ [(b,"")] -> return $ st { cl_corelint = b }+ _ -> return st )+ [ "set-auto-corelint <True|False>; False by default"+ , "run core lint type-checker after every rewrite, reverting on failure" ] , external "setpp" (\ pp -> SessionStateEffect $ \ _ st -> case M.lookup pp pp_dictionary of Nothing -> do@@ -197,13 +221,16 @@ [ "dump <filename> <pretty-printer> <renderer> <width>"] , external "set-width" (\ n -> SessionStateEffect $ \ _ st -> return $ st { cl_width = n }) ["set the width of the screen"]- , external "set-pp-expr-type"- (\ str -> SessionStateEffect $ \ _ st -> case reads str :: [(ShowOption,String)] of- [(opt,"")] -> return $ st { cl_pretty_opts =- (cl_pretty_opts st) { po_exprTypes = opt }- }- _ -> return st)+ , external "set-pp-type" (\ str -> SessionStateEffect $ \ _ st ->+ case reads str :: [(ShowOption,String)] of+ [(opt,"")] -> return $ st { cl_pretty_opts = updateTypeShowOption opt (cl_pretty_opts st) }+ _ -> return st) ["set how to show expression-level types (Show|Abstact|Omit)"]+ , external "set-pp-coercion" (\ str -> SessionStateEffect $ \ _ st ->+ case reads str :: [(ShowOption,String)] of+ [(opt,"")] -> return $ st { cl_pretty_opts = updateCoShowOption opt (cl_pretty_opts st) }+ _ -> return st)+ ["set how to show coercions (Show|Abstact|Omit)"] , external "{" BeginScope ["push current lens onto a stack"] -- tag as internal , external "}" EndScope@@ -223,6 +250,15 @@ Nothing -> return st -- TODO: should fail with message Just r -> return $ st { cl_render = r } +gc :: CommandLineState -> SessionState -> IO SessionState+gc clst st = do+ let k = cl_kernel clst+ cursor = cl_cursor st+ initSAST = cl_initSAST clst+ asts <- listS k+ mapM_ (deleteS k) [ sast | sast <- asts, sast `notElem` [cursor, initSAST] ]+ return st+ ---------------------------------------------------------------------------------- catch :: IO a -> (String -> IO a) -> IO a@@ -255,12 +291,16 @@ iokm2clm :: MonadIO m => String -> IO (KureM a) -> CLM m a iokm2clm msg = iokm2clm' msg return +iokm2clm'' :: MonadIO m => IO (KureM a) -> CLM m a+iokm2clm'' = iokm2clm ""+ data CommandLineState = CommandLineState { cl_graph :: [(SAST,ExprH,SAST)] , cl_tags :: [(String,SAST)]- -- these two should be in a reader+ -- these three should be in a reader , cl_dict :: Dictionary , cl_kernel :: ScopedKernel+ , cl_initSAST :: SAST -- and the session state (perhaps in a seperate state?) , cl_session :: SessionState }@@ -272,14 +312,16 @@ -- Session-local issues; things that are never saved. data SessionState = SessionState- { cl_cursor :: SAST -- ^ the current AST- , cl_pretty :: String -- ^ which pretty printer to use- , cl_pretty_opts :: PrettyOptions -- ^ The options for the pretty printer- , cl_render :: Handle -> PrettyOptions -> DocH -> IO () -- ^ the way of outputing to the screen- , cl_width :: Int -- ^ how wide is the screen?- , cl_nav :: Bool -- ^ keyboard input the the nav panel- , cl_loading :: Bool -- ^ if loading a file- , cl_tick :: TVar (M.Map String Int) -- ^ The list of ticked messages+ { cl_cursor :: SAST -- ^ the current AST+ , cl_pretty :: String -- ^ which pretty printer to use+ , cl_pretty_opts :: PrettyOptions -- ^ The options for the pretty printer+ , cl_render :: Handle -> PrettyOptions -> DocH -> IO () -- ^ the way of outputing to the screen+ , cl_width :: Int -- ^ how wide is the screen?+ , cl_nav :: Bool -- ^ keyboard input the the nav panel+ , cl_loading :: Bool -- ^ if loading a file+ , cl_tick :: TVar (M.Map String Int) -- ^ The list of ticked messages+ , cl_corelint :: Bool -- ^ if true, run core lint on module after each rewrite+ , cl_failhard :: Bool -- ^ if true, abort on *any* failure } -------------------------------------------------------------------------------@@ -325,14 +367,20 @@ cl <- runKureM return fail mcls -- TO DO: probably shouldn't use fail here. return $ (map simpleCompletion . nub . filter (so_far `isPrefixOf`)) cl +setLoading :: MonadIO m => Bool -> CLM m ()+setLoading b = modify $ \st -> st { cl_session = (cl_session st) { cl_loading = b } }+ -- | The first argument is a list of files to load. commandLine :: [String] -> Behavior -> GHC.ModGuts -> GHC.CoreM GHC.ModGuts-commandLine filesToLoad behavior modGuts = do- let dict = dictionary $ all_externals shell_externals+commandLine filesToLoad behavior = scopedKernel (interactive filesToLoad behavior [])++interactive :: [FilePath] -> Behavior -> [External] -> ScopedKernel -> SAST -> IO ()+interactive filesToLoad behavior exts skernel sast = do+ let dict = dictionary $ all_externals $ shell_externals ++ exts let ws_complete = " ()" let startup = do- modify $ \st -> st { cl_session = (cl_session st) { cl_loading = True } }+ setLoading True sequence_ [ performMetaCommand $ case fileName of "abort" -> Abort "resume" -> Resume@@ -340,22 +388,20 @@ | fileName <- reverse filesToLoad , not (null fileName) ] `ourCatch` \ msg -> liftIO . putStrLn $ "Booting Failure: " ++ msg- modify $ \st -> st { cl_session = (cl_session st) { cl_loading = False } }+ setLoading False var <- GHC.liftIO $ atomically $ newTVar M.empty - flip scopedKernel modGuts $ \ skernel sast -> do-- let sessionState = SessionState sast "clean" def unicodeConsole 80 False False var- shellState = CommandLineState [] [] dict skernel sessionState+ let sessionState = SessionState sast "clean" def unicodeConsole 80 False False var False False+ shellState = CommandLineState [] [] dict skernel sast sessionState - completionMVar <- newMVar shellState+ completionMVar <- newMVar shellState - _ <- runInputTBehavior behavior+ _ <- runInputTBehavior behavior (setComplete (completeWordWithPrev Nothing ws_complete (shellComplete completionMVar)) defaultSettings) (evalStateT (runErrorT (startup >> showFocus >> loop completionMVar)) shellState) - return ()+ return () loop :: (MonadIO m, m ~ InputT IO) => MVar CommandLineState -> CLM m () loop completionMVar = loop'@@ -383,22 +429,19 @@ ourCatch :: MonadIO m => CLM IO () -> (String -> CLM m ()) -> CLM m () ourCatch m failure = do- st <- get- (res,st') <- liftIO $ runStateT (runErrorT m) st- put st'- case res of- Left msg -> failure msg- Right () -> return ()----evalStmts :: MonadIO m => [StmtH ExprH] -> CLM m ()-evalStmts = mapM_ evalExpr . scopes- where scopes :: [StmtH ExprH] -> [ExprH]- scopes [] = []- scopes (ExprH e:ss) = e : scopes ss- scopes (ScopeH s:ss) = (CmdName "{" : scopes s) ++ [CmdName "}"] ++ scopes ss+ st <- get+ (res,st') <- liftIO $ runStateT (runErrorT m) st+ put st'+ case res of+ Left msg -> if cl_failhard (cl_session st')+ then do+ performQuery Display+ liftIO $ putStrLn msg >> abortS (cl_kernel st')+ else failure msg+ Right () -> return () +evalStmts :: MonadIO m => [ExprH] -> CLM m ()+evalStmts = mapM_ evalExpr evalExpr :: MonadIO m => ExprH -> CLM m () evalExpr expr = do@@ -420,10 +463,21 @@ performAstEffect :: MonadIO m => AstEffect -> ExprH -> CLM m () performAstEffect (Apply rr) expr = do st <- get- iokm2clm' "Rewrite failed: "- (\ ast' -> put (newSAST expr ast' st) >> showFocus)- (applyS (cl_kernel st) (cl_cursor $ cl_session st) rr (cl_kernel_env $ cl_session st)) + let sk = cl_kernel st+ kEnv = cl_kernel_env $ cl_session st++ sast' <- iokm2clm "Rewrite failed: " $ applyS sk (cl_cursor $ cl_session st) rr kEnv++ let commit = put (newSAST expr sast' st) >> showFocus++ if cl_corelint (cl_session st)+ then do ast' <- iokm2clm'' $ toASTS sk sast'+ liftIO (queryK (kernelS sk) ast' lintModuleT kEnv)+ >>= runKureM (\ warns -> putStrToConsole warns >> commit)+ (\ errs -> liftIO (deleteS sk sast') >> fail errs)+ else commit+ performAstEffect (Pathfinder t) expr = do st <- get -- An extension to the Path@@ -442,13 +496,13 @@ performAstEffect BeginScope expr = do st <- get- ast <- liftIO $ beginScopeS (cl_kernel st) (cl_cursor (cl_session st))+ ast <- iokm2clm'' $ beginScopeS (cl_kernel st) (cl_cursor (cl_session st)) put $ newSAST expr ast st showFocus performAstEffect EndScope expr = do st <- get- ast <- liftIO $ endScopeS (cl_kernel st) (cl_cursor (cl_session st))+ ast <- iokm2clm'' $ endScopeS (cl_kernel st) (cl_cursor (cl_session st)) put $ newSAST expr ast st showFocus @@ -477,12 +531,19 @@ ------------------------------------------------------------------------------- performQuery :: MonadIO m => QueryFun -> CLM m ()-performQuery (QueryT q) = do+performQuery (QueryString q) = do st <- get iokm2clm' "Query failed: " putStrToConsole (queryS (cl_kernel st) (cl_cursor $ cl_session st) q (cl_kernel_env $ cl_session st)) +performQuery (QueryDocH q) = do+ st <- get+ let ss = cl_session st+ iokm2clm' "Query failed: "+ (liftIO . cl_render ss stdout (cl_pretty_opts ss))+ (queryS (cl_kernel st) (cl_cursor ss) (q $ pretty ss) (cl_kernel_env ss))+ performQuery (Inquiry f) = do st <- get str <- liftIO $ f st (cl_session st)@@ -490,14 +551,20 @@ -- These two need to use Inquiry performQuery (Message msg) = liftIO (putStrLn msg)-performQuery Display = showFocus+-- Explicit calls to display should work no matter what the loading state is.+performQuery Display = do+ load_st <- gets (cl_loading . cl_session)+ setLoading False+ showFocus+ setLoading load_st ------------------------------------------------------------------------------- performMetaCommand :: MonadIO m => MetaCommand -> CLM m () performMetaCommand Abort = gets cl_kernel >>= (liftIO . abortS) performMetaCommand Resume = do st <- get- liftIO $ resumeS (cl_kernel st) (cl_cursor $ cl_session st)+ iokm2clm'' $ resumeS (cl_kernel st) (cl_cursor $ cl_session st)+performMetaCommand (Delete sast) = gets cl_kernel >>= iokm2clm'' . flip deleteS sast performMetaCommand (Dump fileName _pp renderer width) = do st <- get case (M.lookup (cl_pretty (cl_session st)) pp_dictionary,lookup renderer finalRenders) of@@ -511,26 +578,18 @@ putStrToConsole $ "[loading " ++ fileName ++ "]" res <- liftIO $ try (readFile fileName) case res of- Right str -> case parseStmtsH (normalize str) of+ Right str -> case parseStmtsH str of Left msg -> throwError ("Parse failure: " ++ msg) Right stmts -> do load_st <- gets (cl_loading . cl_session)- modify $ \st -> st { cl_session = (cl_session st) { cl_loading = True } }+ setLoading True evalStmts stmts `catchError` (\ err -> do- modify $ \ st -> st { cl_session = (cl_session st) { cl_loading = load_st } }+ setLoading load_st throwError err)- modify $ \st -> st { cl_session = (cl_session st) { cl_loading = load_st } }+ setLoading load_st putStrToConsole $ "[done, loaded " ++ show (numStmtsH stmts) ++ " commands]" -- TODO: This is better than saying "N", but not very robust. showFocus Left (err :: IOException) -> throwError ("IO error: " ++ show err)- where- normalize = unlines- . map (++ ";") -- HACK!- . map rmComment- . lines- rmComment [] = []- rmComment xs | "--" `isPrefixOf` xs = [] -- we need a real parser and lexer here!- rmComment (x:xs) = x : rmComment xs performMetaCommand (SaveFile fileName) = do st <- get@@ -576,13 +635,14 @@ rDoHighlight _ (Color col:_) = UnicodeTerminal $ \ h _ -> do hSetSGR h [ Reset ] hSetSGR h $ case col of- KeywordColor -> [ SetConsoleIntensity BoldIntensity- , SetColor Foreground Dull Blue- ]- SyntaxColor -> [ SetColor Foreground Dull Red ]- VarColor -> [] -- as is- TypeColor -> [ SetColor Foreground Dull Green ]- LitColor -> [ SetColor Foreground Dull Cyan ]+ KeywordColor -> [ SetConsoleIntensity BoldIntensity+ , SetColor Foreground Dull Blue+ ]+ SyntaxColor -> [ SetColor Foreground Dull Red ]+ IdColor -> [] -- as is+ CoercionColor -> [ SetColor Foreground Dull Yellow ]+ TypeColor -> [ SetColor Foreground Dull Green ]+ LitColor -> [ SetColor Foreground Dull Cyan ] rDoHighlight o (_:rest) = rDoHighlight o rest rEnd = UnicodeTerminal $ \ h _ -> hPutStrLn h ""
+ src/Language/HERMIT/Syntax.hs view
@@ -0,0 +1,29 @@+module Language.HERMIT.Syntax+ (+ -- * Syntax Utilities+ isIdFirstChar,+ isIdChar,+ isInfixId+ )+where++import Data.Char (isAlphaNum)++---------------------------------------------------------------------++-- | Chars that are valid in identifiers anywhere.+isIdFirstChar :: Char -> Bool+isIdFirstChar c = isAlphaNum c || c `elem` "$_:."+{-# INLINE isIdFirstChar #-}++-- | Chars that are valid in identifiers, but not as the first character.+isIdChar :: Char -> Bool+isIdChar c = isIdFirstChar c || c `elem` "-'"+{-# INLINE isIdChar #-}++-- | Chars that are valid in infix operators.+isInfixId :: Char -> Bool+isInfixId c = c `elem` "!£$%^&*-+=@#<>?/.:|" -- I removed _ ' \\ as I don't think they're valid infix-operator symbols.+{-# INLINE isInfixId #-}++---------------------------------------------------------------------