packages feed

hermit 0.3.1.0 → 0.3.2.0

raw patch · 32 files changed

+1983/−373 lines, 32 files

Files

+ dist/build/HERMIT/Parser.hs view
@@ -0,0 +1,752 @@+{-# OPTIONS_GHC -w #-}+{-# OPTIONS -fglasgow-exts -cpp #-}+module HERMIT.Parser+    ( Script+    , parseScript+    , unparseScript+    , unparseExprH+    , ExprH(..)+    ) where++import Data.Char (isSpace)+import Data.List (intercalate)++import Control.Monad ((>=>))++import HERMIT.Syntax (isScriptInfixIdChar, isScriptIdFirstChar, isScriptIdChar)+import qualified Data.Array as Happy_Data_Array+import qualified GHC.Exts as Happy_GHC_Exts++-- parser produced by Happy Version 1.19.0++newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11 = HappyAbsSyn HappyAny+#if __GLASGOW_HASKELL__ >= 607+type HappyAny = Happy_GHC_Exts.Any+#else+type HappyAny = forall a . a+#endif+happyIn4 :: t4 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn4 #-}+happyOut4 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t4+happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut4 #-}+happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn5 #-}+happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t5+happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut5 #-}+happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn6 #-}+happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t6+happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut6 #-}+happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn7 #-}+happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t7+happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut7 #-}+happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn8 #-}+happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t8+happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut8 #-}+happyIn9 :: t9 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn9 #-}+happyOut9 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t9+happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut9 #-}+happyIn10 :: t10 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn10 #-}+happyOut10 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t10+happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut10 #-}+happyIn11 :: t11 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn11 #-}+happyOut11 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t11+happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut11 #-}+happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11)+happyInTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> (Token)+happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOutTok #-}+++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\x0e\x00\x1e\x00\x0e\x00\x06\x00\x00\x00\x00\x00\xfd\xff\x01\x00\x00\x00\x1a\x00\x0e\x00\x1a\x00\x0e\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x09\x00\x00\x00\x00\x00\x02\x00\x00\x00\x1a\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\x45\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x4d\x00\x39\x00\x48\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x2d\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00"#++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\xfa\xff\x00\x00\xfa\xff\x00\x00\xfc\xff\xfb\xff\xf9\xff\xf4\xff\xf2\xff\x00\x00\xfa\xff\xe8\xff\xfa\xff\x00\x00\xed\xff\xee\xff\xea\xff\xef\xff\xf1\xff\xf0\xff\xf6\xff\xe7\xff\x00\x00\xe9\xff\xfd\xff\x00\x00\xf3\xff\x00\x00\xfa\xff\xfa\xff\xfe\xff\xf7\xff\xf8\xff\xf5\xff\xeb\xff\xec\xff\x00\x00\xe6\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x04\x00\x01\x00\x05\x00\x02\x00\x08\x00\x05\x00\x03\x00\x04\x00\x05\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x01\x00\x07\x00\x03\x00\x04\x00\x05\x00\x0e\x00\x06\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x01\x00\x03\x00\x04\x00\x05\x00\x05\x00\x07\x00\x03\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x03\x00\x04\x00\x05\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\x1d\x00\x0a\x00\x1a\x00\x23\x00\x1e\x00\x0c\x00\x21\x00\x07\x00\x08\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x1c\x00\x0a\x00\x24\x00\x03\x00\x0b\x00\x0c\x00\xff\xff\x25\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0a\x00\x15\x00\x07\x00\x08\x00\x0c\x00\x25\x00\x03\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x1f\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x20\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x14\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x18\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x1e\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x15\x00\x07\x00\x08\x00\x16\x00\x17\x00\x19\x00\x07\x00\x08\x00\x00\x00\x12\x00\x13\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyReduceArr = Happy_Data_Array.array (1, 25) [+	(1 , happyReduce_1),+	(2 , happyReduce_2),+	(3 , happyReduce_3),+	(4 , happyReduce_4),+	(5 , happyReduce_5),+	(6 , happyReduce_6),+	(7 , happyReduce_7),+	(8 , happyReduce_8),+	(9 , happyReduce_9),+	(10 , happyReduce_10),+	(11 , happyReduce_11),+	(12 , happyReduce_12),+	(13 , happyReduce_13),+	(14 , happyReduce_14),+	(15 , happyReduce_15),+	(16 , happyReduce_16),+	(17 , happyReduce_17),+	(18 , happyReduce_18),+	(19 , happyReduce_19),+	(20 , happyReduce_20),+	(21 , happyReduce_21),+	(22 , happyReduce_22),+	(23 , happyReduce_23),+	(24 , happyReduce_24),+	(25 , happyReduce_25)+	]++happy_n_terms = 15 :: Int+happy_n_nonterms = 8 :: Int++happyReduce_1 = happySpecReduce_2  0# happyReduction_1+happyReduction_1 happy_x_2+	happy_x_1+	 =  case happyOut4 happy_x_2 of { happy_var_2 -> +	happyIn4+		 (CmdName "{" : happy_var_2+	)}++happyReduce_2 = happySpecReduce_2  0# happyReduction_2+happyReduction_2 happy_x_2+	happy_x_1+	 =  case happyOut4 happy_x_2 of { happy_var_2 -> +	happyIn4+		 (CmdName "}" : happy_var_2+	)}++happyReduce_3 = happySpecReduce_1  0# happyReduction_3+happyReduction_3 happy_x_1+	 =  case happyOut5 happy_x_1 of { happy_var_1 -> +	happyIn4+		 (happy_var_1+	)}++happyReduce_4 = happySpecReduce_1  1# happyReduction_4+happyReduction_4 happy_x_1+	 =  case happyOut6 happy_x_1 of { happy_var_1 -> +	happyIn5+		 (happy_var_1+	)}++happyReduce_5 = happySpecReduce_0  1# happyReduction_5+happyReduction_5  =  happyIn5+		 ([]+	)++happyReduce_6 = happySpecReduce_1  2# happyReduction_6+happyReduction_6 happy_x_1+	 =  case happyOut7 happy_x_1 of { happy_var_1 -> +	happyIn6+		 ([happy_var_1]+	)}++happyReduce_7 = happySpecReduce_3  2# happyReduction_7+happyReduction_7 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut7 happy_x_1 of { happy_var_1 -> +	case happyOut4 happy_x_3 of { happy_var_3 -> +	happyIn6+		 ([happy_var_1, CmdName "}"] ++ happy_var_3+	)}}++happyReduce_8 = happySpecReduce_3  2# happyReduction_8+happyReduction_8 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut7 happy_x_1 of { happy_var_1 -> +	case happyOut4 happy_x_3 of { happy_var_3 -> +	happyIn6+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_9 = happySpecReduce_2  2# happyReduction_9+happyReduction_9 happy_x_2+	happy_x_1+	 =  case happyOut4 happy_x_2 of { happy_var_2 -> +	happyIn6+		 (happy_var_2+	)}++happyReduce_10 = happySpecReduce_3  3# happyReduction_10+happyReduction_10 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut8 happy_x_1 of { happy_var_1 -> +	case happyOutTok happy_x_2 of { (InfixOp happy_var_2) -> +	case happyOut7 happy_x_3 of { happy_var_3 -> +	happyIn7+		 (AppH (AppH (CmdName happy_var_2) happy_var_1) happy_var_3+	)}}}++happyReduce_11 = happySpecReduce_1  3# happyReduction_11+happyReduction_11 happy_x_1+	 =  case happyOut8 happy_x_1 of { happy_var_1 -> +	happyIn7+		 (happy_var_1+	)}++happyReduce_12 = happySpecReduce_2  4# happyReduction_12+happyReduction_12 happy_x_2+	happy_x_1+	 =  case happyOut8 happy_x_1 of { happy_var_1 -> +	case happyOut9 happy_x_2 of { happy_var_2 -> +	happyIn8+		 (AppH happy_var_1 happy_var_2+	)}}++happyReduce_13 = happySpecReduce_1  4# happyReduction_13+happyReduction_13 happy_x_1+	 =  case happyOut9 happy_x_1 of { happy_var_1 -> +	happyIn8+		 (happy_var_1+	)}++happyReduce_14 = happySpecReduce_2  5# happyReduction_14+happyReduction_14 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_2 of { (Ident happy_var_2) -> +	happyIn9+		 (SrcName happy_var_2+	)}++happyReduce_15 = happySpecReduce_2  5# happyReduction_15+happyReduction_15 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_2 of { (InfixOp happy_var_2) -> +	happyIn9+		 (SrcName happy_var_2+	)}++happyReduce_16 = happySpecReduce_2  5# happyReduction_16+happyReduction_16 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_2 of { (Quote happy_var_2) -> +	happyIn9+		 (SrcName happy_var_2+	)}++happyReduce_17 = happySpecReduce_1  5# happyReduction_17+happyReduction_17 happy_x_1+	 =  case happyOutTok happy_x_1 of { (Quote happy_var_1) -> +	happyIn9+		 (CmdName happy_var_1+	)}++happyReduce_18 = happySpecReduce_1  5# happyReduction_18+happyReduction_18 happy_x_1+	 =  case happyOutTok happy_x_1 of { (CoreString happy_var_1) -> +	happyIn9+		 (CoreH happy_var_1+	)}++happyReduce_19 = happySpecReduce_3  5# happyReduction_19+happyReduction_19 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut10 happy_x_2 of { happy_var_2 -> +	happyIn9+		 (ListH happy_var_2+	)}++happyReduce_20 = happySpecReduce_3  5# happyReduction_20+happyReduction_20 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut7 happy_x_2 of { happy_var_2 -> +	happyIn9+		 (happy_var_2+	)}++happyReduce_21 = happySpecReduce_1  5# happyReduction_21+happyReduction_21 happy_x_1+	 =  case happyOutTok happy_x_1 of { (Ident happy_var_1) -> +	happyIn9+		 (CmdName happy_var_1+	)}++happyReduce_22 = happySpecReduce_1  6# happyReduction_22+happyReduction_22 happy_x_1+	 =  case happyOut11 happy_x_1 of { happy_var_1 -> +	happyIn10+		 (happy_var_1+	)}++happyReduce_23 = happySpecReduce_0  6# happyReduction_23+happyReduction_23  =  happyIn10+		 ([]+	)++happyReduce_24 = happySpecReduce_1  7# happyReduction_24+happyReduction_24 happy_x_1+	 =  case happyOut7 happy_x_1 of { happy_var_1 -> +	happyIn11+		 ([happy_var_1]+	)}++happyReduce_25 = happySpecReduce_3  7# happyReduction_25+happyReduction_25 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut7 happy_x_1 of { happy_var_1 -> +	case happyOut11 happy_x_3 of { happy_var_3 -> +	happyIn11+		 (happy_var_1 : happy_var_3+	)}}++happyNewToken action sts stk [] =+	happyDoAction 14# notHappyAtAll action sts stk []++happyNewToken action sts stk (tk:tks) =+	let cont i = happyDoAction i tk action sts stk tks in+	case tk of {+	ParenLeft -> cont 1#;+	ParenRight -> cont 2#;+	ScopeStart -> cont 3#;+	ScopeEnd -> cont 4#;+	ListStart -> cont 5#;+	ListDelim -> cont 6#;+	ListEnd -> cont 7#;+	StmtEnd -> cont 8#;+	Tick -> cont 9#;+	CoreString happy_dollar_dollar -> cont 10#;+	Quote happy_dollar_dollar -> cont 11#;+	Ident happy_dollar_dollar -> cont 12#;+	InfixOp happy_dollar_dollar -> cont 13#;+	_ -> happyError' (tk:tks)+	}++happyError_ 14# tk tks = happyError' tks+happyError_ _ tk tks = happyError' (tk:tks)++happyThen :: () => Either String a -> (a -> Either String b) -> Either String b+happyThen = (>>=)+happyReturn :: () => a -> Either String a+happyReturn = (return)+happyThen1 m k tks = (>>=) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> Either String a+happyReturn1 = \a tks -> (return) a+happyError' :: () => [(Token)] -> Either String a+happyError' = parseError++parser tks = happySomeParser where+  happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))++happySeq = happyDontSeq+++parseError :: [Token] -> Either String a+parseError ts = Left $ "Parse error: " ++ show ts++-- | A simple expression language AST, for things parsed from 'String' or JSON structures.+data ExprH+    = SrcName String                -- ^ Variable names (refers to source code).+    | CmdName String                -- ^ Commands (to be looked up in 'HERMIT.Dictionary').+    | AppH ExprH ExprH              -- ^ Application.+    | CoreH String                  -- ^ Core Fragment+    | ListH [ExprH]                 -- ^ List of expressions+    deriving (Eq, Show)++data Token+    = ParenLeft+    | ParenRight+    | ScopeStart+    | ScopeEnd+    | ListStart+    | ListDelim+    | ListEnd+    | StmtEnd+    | Tick+    | CoreString String+    | Quote String+    | Ident String+    | InfixOp String+    deriving (Eq, Show)++lexError :: String -> Either String a+lexError msg = Left ("Lexer error: " ++ msg)++lexer :: String -> Either String [Token]+lexer []           = Right []+lexer ('\n':cs)    = fmap (StmtEnd:)    $ lexer cs+lexer (';' :cs)    = fmap (StmtEnd:)    $ lexer cs+lexer ('(' :cs)    = fmap (ParenLeft:)  $ lexer cs+lexer (')' :cs)    = fmap (ParenRight:) $ lexer cs+lexer ('{' :cs)    = fmap (ScopeStart:) $ lexer cs+lexer ('}' :cs)    = fmap (ScopeEnd:)   $ lexer cs+lexer ('\'':cs)    = fmap (Tick:)       $ lexer cs+lexer ('\"':cs)    = do (str,cs') <- lexString cs+                        fmap (Quote str:) $ lexer cs'+lexer ('[':'|':cs) = do (str,cs') <- lexCore cs+                        fmap (CoreString str:) $ lexer cs'+lexer ('-':'-':cs) = let (_,s') = span (/= '\n') cs in lexer s'+lexer ('[' :cs)    = fmap (ListStart:)  $ lexer cs+lexer (',' :cs)    = fmap (ListDelim:)  $ lexer cs+lexer (']' :cs)    = fmap (ListEnd:)    $ lexer cs+lexer s@(c:cs)     | isSpace             c = lexer cs+                   | isScriptIdFirstChar c = let (i,s') = span isScriptIdChar s+                                              in fmap (Ident i:) $ lexer s'+                   | isScriptInfixIdChar c = let (op,s') = span isScriptInfixIdChar s+                                              in fmap (InfixOp op:) $ lexer s'+lexer s            = lexError $ "no match on " ++ s++lexString :: String -> Either String (String,String)+lexString ('\"':cs)      = Right ([],cs)+lexString ('\\':'\"':cs) = do (c',r) <- lexString cs+                              return ('"':c',r)+lexString (c:cs)         = do (c',r) <- lexString cs+                              return (c:c',r)+lexString []             = lexError "no matching quote"++lexCore :: String -> Either String (String,String)+lexCore ('|':']':rest) = Right ([],rest)+lexCore (c:cs)         = do (c',r) <- lexCore cs+                            return (c:c',r)+lexCore []             = lexError "no closing |]"++---------------------------------------------++-- | Use ghci Parser.hs to run this test function.+test = do+    ln <- getLine+    case ln of+        "quit" -> return ()+        _      -> do print $ lexer ln+                     print $ parseScript ln+                     test++type Script = [ExprH]++parseScript :: String -> Either String Script+parseScript = lexer >=> parser++---------------------------------------------++unparseScript :: Script -> String+unparseScript = intercalate " ; " . map unparseExprH++unparseExprH :: ExprH -> String+unparseExprH (SrcName nm)+    | nm /= "" && (all isScriptInfixIdChar nm || isScriptIdFirstChar (head nm) && all isScriptIdChar (tail nm)) = "'" ++ nm+    | otherwise = "'\"" ++ concatMap escape nm ++ "\""+        where escape '\"' = "\\\""+              escape c    = [c]+unparseExprH (CmdName nm)+    | nm == "{"             = "{ "+    | nm == "}"             = " }"+    | all isScriptIdChar nm = nm+    | otherwise             = show nm     -- with quotes+unparseExprH (AppH (AppH (CmdName nm) e1) e2)+    | all isScriptInfixIdChar nm+    = unparseAtom e1 ++ " " ++ nm ++ " " ++ unparseAtom e2+unparseExprH (AppH e1 e2) = unparseExprH e1 ++ " " ++ unparseAtom e2+unparseExprH (CoreH s)    = "[|" ++ s ++ "|]"+unparseExprH (ListH es)   = "[" ++ intercalate "," (map unparseExprH es) ++ "]"++unparseAtom :: ExprH -> String+unparseAtom e@(AppH {}) = "(" ++ unparseExprH e ++ ")"+unparseAtom e           = unparseExprH e++---------------------------------------------+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp ++{-# LINE 13 "templates/GenericTemplate.hs" #-}++++++#if __GLASGOW_HASKELL__ > 706+#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool)+#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool)+#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool)+#else+#define LT(n,m) (n Happy_GHC_Exts.<# m)+#define GTE(n,m) (n Happy_GHC_Exts.>=# m)+#define EQ(n,m) (n Happy_GHC_Exts.==# m)+#endif+{-# LINE 45 "templates/GenericTemplate.hs" #-}+++data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList++++++{-# LINE 66 "templates/GenericTemplate.hs" #-}++{-# LINE 76 "templates/GenericTemplate.hs" #-}++{-# LINE 85 "templates/GenericTemplate.hs" #-}++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is 0#, it means we've just accepted a partial+-- parse (a %partial parser).  We must ignore the saved token on the top of+-- the stack in this case.+happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =+	happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = +	(happyTcHack j (happyTcHack st)) (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++++happyDoAction i tk st+	= {- nothing -}+++	  case action of+		0#		  -> {- nothing -}+				     happyFail i tk st+		-1# 	  -> {- nothing -}+				     happyAccept i tk st+		n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}++				     (happyReduceArr Happy_Data_Array.! rule) i tk st+				     where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))+		n		  -> {- nothing -}+++				     happyShift new_state i tk st+                                     where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))+   where off    = indexShortOffAddr happyActOffsets st+         off_i  = (off Happy_GHC_Exts.+# i)+	 check  = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#))+                  then EQ(indexShortOffAddr happyCheck off_i, i)+		  else False+         action+          | check     = indexShortOffAddr happyTable off_i+          | otherwise = indexShortOffAddr happyDefActions st+++indexShortOffAddr (HappyA# arr) off =+	Happy_GHC_Exts.narrow16Int# i+  where+        i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)+        high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))+        low  = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))+        off' = off Happy_GHC_Exts.*# 2#++++++data HappyAddr = HappyA# Happy_GHC_Exts.Addr#+++++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++{-# LINE 169 "templates/GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =+     let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+--     trace "shifting the error token" $+     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)++happyShift new_state i tk st sts stk =+     happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_0 nt fn j tk st@((action)) sts stk+     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')+     = let r = fn v1 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')+     = let r = fn v1 v2 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+     = let r = fn v1 v2 v3 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happyReduce k nt fn j tk st sts stk+     = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of+	 sts1@((HappyCons (st1@(action)) (_))) ->+        	let r = fn stk in  -- it doesn't hurt to always seq here...+       		happyDoSeq r (happyGoto nt j tk st1 sts1 r)++happyMonadReduce k nt fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+      case happyDrop k (HappyCons (st) (sts)) of+        sts1@((HappyCons (st1@(action)) (_))) ->+          let drop_stk = happyDropStk k stk in+          happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))++happyMonad2Reduce k nt fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+      case happyDrop k (HappyCons (st) (sts)) of+        sts1@((HappyCons (st1@(action)) (_))) ->+         let drop_stk = happyDropStk k stk++             off = indexShortOffAddr happyGotoOffsets st1+             off_i = (off Happy_GHC_Exts.+# nt)+             new_state = indexShortOffAddr happyTable off_i++++          in+          happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))++happyDrop 0# l = l+happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t++happyDropStk 0# l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction+++happyGoto nt j tk st = +   {- nothing -}+   happyDoAction j tk new_state+   where off = indexShortOffAddr happyGotoOffsets st+         off_i = (off Happy_GHC_Exts.+# nt)+         new_state = indexShortOffAddr happyTable off_i+++++-----------------------------------------------------------------------------+-- Error recovery (0# is the error token)++-- parse error if we are in recovery and we fail again+happyFail 0# tk old_st _ stk@(x `HappyStk` _) =+     let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+--	trace "failing" $ +        happyError_ i tk++{-  We don't need state discarding for our restricted implementation of+    "error".  In fact, it can cause some bogus parses, so I've disabled it+    for now --SDM++-- discard a state+happyFail  0# tk old_st (HappyCons ((action)) (sts)) +						(saved_tok `HappyStk` _ `HappyStk` stk) =+--	trace ("discarding state, depth " ++ show (length stk))  $+	happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+--                       save the old token and carry on.+happyFail  i tk (action) sts stk =+--      trace "entering error recovery" $+	happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll :: a+notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions+++happyTcHack :: Happy_GHC_Exts.Int# -> a -> a+happyTcHack x y = y+{-# INLINE happyTcHack #-}+++-----------------------------------------------------------------------------+-- Seq-ing.  If the --strict flag is given, then Happy emits +--	happySeq = happyDoSeq+-- otherwise it emits+-- 	happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq   a b = a `seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template.  GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.+++{-# NOINLINE happyDoAction #-}+{-# NOINLINE happyTable #-}+{-# NOINLINE happyCheck #-}+{-# NOINLINE happyActOffsets #-}+{-# NOINLINE happyGotoOffsets #-}+{-# NOINLINE happyDefActions #-}++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
+ dist/build/HERMIT/ParserCore.hs view
@@ -0,0 +1,624 @@+{-# OPTIONS_GHC -w #-}+{-# OPTIONS -fglasgow-exts -cpp #-}+{-# LANGUAGE CPP #-}+ module HERMIT.ParserCore (parseCore, parseCoreExprT, parse2beforeBiR, parse3beforeBiR) where++import Control.Arrow+import Control.Monad.Reader+import Data.Char (isSpace, isDigit)++import HERMIT.Context+import HERMIT.External+import HERMIT.GHC+import HERMIT.Kure+import HERMIT.Monad+import HERMIT.Syntax (isCoreInfixIdChar, isCoreIdFirstChar, isCoreIdChar)++import HERMIT.Dictionary.Common++import Language.KURE.MonadCatch (prefixFailMsg)++import Language.Haskell.TH as TH+import qualified Data.Array as Happy_Data_Array+import qualified GHC.Exts as Happy_GHC_Exts++-- parser produced by Happy Version 1.19.0++newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 = HappyAbsSyn HappyAny+#if __GLASGOW_HASKELL__ >= 607+type HappyAny = Happy_GHC_Exts.Any+#else+type HappyAny = forall a . a+#endif+happyIn4 :: t4 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn4 #-}+happyOut4 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t4+happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut4 #-}+happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn5 #-}+happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t5+happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut5 #-}+happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn6 #-}+happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t6+happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut6 #-}+happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn7 #-}+happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t7+happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut7 #-}+happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn8 #-}+happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t8+happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut8 #-}+happyIn9 :: t9 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn9 #-}+happyOut9 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t9+happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut9 #-}+happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8 t9)+happyInTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> (Token)+happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOutTok #-}+++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\xf8\xff\xf8\xff\xf8\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\xf0\xff\xf6\xff\x00\x00\x00\x00\x00\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\x0b\x00\x18\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\xfc\xff\xf8\xff\xf7\xff\xf9\xff\x00\x00\xf4\xff\xf6\xff\xf5\xff\x00\x00\x00\x00\xfa\xff\xfd\xff\xfb\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x0c\x00\x0d\x00\x0d\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x1c\x00\x22\x00\x1e\x00\x1c\x00\x20\x00\x1e\x00\xff\xff\x20\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x02\x00\x03\x00\x04\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\x08\x00\x0e\x00\x10\x00\x08\x00\x0c\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0b\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x09\x00\xff\xff\x0a\x00\x09\x00\x0b\x00\x0a\x00\x00\x00\x0b\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0e\x00\x04\x00\x05\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyReduceArr = Happy_Data_Array.array (1, 11) [+	(1 , happyReduce_1),+	(2 , happyReduce_2),+	(3 , happyReduce_3),+	(4 , happyReduce_4),+	(5 , happyReduce_5),+	(6 , happyReduce_6),+	(7 , happyReduce_7),+	(8 , happyReduce_8),+	(9 , happyReduce_9),+	(10 , happyReduce_10),+	(11 , happyReduce_11)+	]++happy_n_terms = 35 :: Int+happy_n_nonterms = 6 :: Int++happyReduce_1 = happySpecReduce_1  0# happyReduction_1+happyReduction_1 happy_x_1+	 =  case happyOut5 happy_x_1 of { happy_var_1 -> +	happyIn4+		 (happy_var_1+	)}++happyReduce_2 = happySpecReduce_2  1# happyReduction_2+happyReduction_2 happy_x_2+	happy_x_1+	 =  case happyOut5 happy_x_1 of { happy_var_1 -> +	case happyOut6 happy_x_2 of { happy_var_2 -> +	happyIn5+		 (App happy_var_1 happy_var_2+	)}}++happyReduce_3 = happySpecReduce_1  1# happyReduction_3+happyReduction_3 happy_x_1+	 =  case happyOut6 happy_x_1 of { happy_var_1 -> +	happyIn5+		 (happy_var_1+	)}++happyReduce_4 = happySpecReduce_3  2# happyReduction_4+happyReduction_4 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut4 happy_x_2 of { happy_var_2 -> +	happyIn6+		 (happy_var_2+	)}++happyReduce_5 = happyMonadReduce 2# 2# happyReduction_5+happyReduction_5 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen (( lookupName "()" Var)+	) (\r -> happyReturn (happyIn6 r))++happyReduce_6 = happySpecReduce_1  2# happyReduction_6+happyReduction_6 happy_x_1+	 =  case happyOut9 happy_x_1 of { happy_var_1 -> +	happyIn6+		 (happy_var_1+	)}++happyReduce_7 = happySpecReduce_1  2# happyReduction_7+happyReduction_7 happy_x_1+	 =  case happyOut7 happy_x_1 of { happy_var_1 -> +	happyIn6+		 (happy_var_1+	)}++happyReduce_8 = happySpecReduce_1  2# happyReduction_8+happyReduction_8 happy_x_1+	 =  case happyOut8 happy_x_1 of { happy_var_1 -> +	happyIn6+		 (happy_var_1+	)}++happyReduce_9 = happyMonadReduce 1# 3# happyReduction_9+happyReduction_9 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen (case happyOutTok happy_x_1 of { (Tinteger happy_var_1) -> +	( mkIntExpr' happy_var_1)}+	) (\r -> happyReturn (happyIn7 r))++happyReduce_10 = happyMonadReduce 1# 4# happyReduction_10+happyReduction_10 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen (case happyOutTok happy_x_1 of { (Tstring happy_var_1) -> +	( lift $ mkStringExpr happy_var_1)}+	) (\r -> happyReturn (happyIn8 r))++happyReduce_11 = happyMonadReduce 1# 5# happyReduction_11+happyReduction_11 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen (case happyOutTok happy_x_1 of { (Tname happy_var_1) -> +	( lookupName happy_var_1 varToCoreExpr)}+	) (\r -> happyReturn (happyIn9 r))++happyNewToken action sts stk [] =+	happyDoAction 34# notHappyAtAll action sts stk []++happyNewToken action sts stk (tk:tks) =+	let cont i = happyDoAction i tk action sts stk tks in+	case tk of {+	Tforall -> cont 1#;+	Trec -> cont 2#;+	Tlet -> cont 3#;+	Tin -> cont 4#;+	Tcase -> cont 5#;+	Tof -> cont 6#;+	Tcast -> cont 7#;+	Tnote -> cont 8#;+	Texternal -> cont 9#;+	Tlocal -> cont 10#;+	Twild -> cont 11#;+	Toparen -> cont 12#;+	Tcparen -> cont 13#;+	Tobrace -> cont 14#;+	Tcbrace -> cont 15#;+	Thash -> cont 16#;+	Teq -> cont 17#;+	Tcolon -> cont 18#;+	Tcoloncolon -> cont 19#;+	Tcoloneqcolon -> cont 20#;+	Tstar -> cont 21#;+	Tarrow -> cont 22#;+	Tlambda -> cont 23#;+	Tat -> cont 24#;+	Tdot -> cont 25#;+	Tquestion -> cont 26#;+	Tsemicolon -> cont 27#;+	Tname happy_dollar_dollar -> cont 28#;+	Tcname happy_dollar_dollar -> cont 29#;+	Tinteger happy_dollar_dollar -> cont 30#;+	Trational happy_dollar_dollar -> cont 31#;+	Tstring happy_dollar_dollar -> cont 32#;+	Tchar happy_dollar_dollar -> cont 33#;+	_ -> happyError' (tk:tks)+	}++happyError_ 34# tk tks = happyError' tks+happyError_ _ tk tks = happyError' (tk:tks)++happyThen :: () => CoreParseM a -> (a -> CoreParseM b) -> CoreParseM b+happyThen = (>>=)+happyReturn :: () => a -> CoreParseM a+happyReturn = (return)+happyThen1 m k tks = (>>=) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> CoreParseM a+happyReturn1 = \a tks -> (return) a+happyError' :: () => [(Token)] -> CoreParseM a+happyError' = parseError++parser tks = happySomeParser where+  happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))++happySeq = happyDontSeq+++mkIntExpr' :: Integer -> CoreParseM CoreExpr+#if __GLASGOW_HASKELL__ > 706+mkIntExpr' i = do+    dflags <- lift getDynFlags+    return $ mkIntExpr dflags i+#else+mkIntExpr' i = return $ mkIntExpr i+#endif++lookupName :: String -> (Id -> CoreExpr) -> CoreParseM CoreExpr+lookupName nm k = do+    c <- ask+    v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId (TH.mkName nm) c+    return (k v)++type CoreParseM a = ReaderT HermitC HermitM a++parseError :: Monad m => [Token] -> m a+parseError ts = fail $ "core parse error: " ++ show ts++data Token+    = Tforall+    | Trec+    | Tlet+    | Tin+    | Tcase+    | Tof+    | Tcast+    | Tnote+    | Texternal+    | Tlocal+    | Twild --+    | Toparen --+    | Tcparen --+    | Tobrace+    | Tcbrace+    | Thash+    | Teq+    | Tcolon --+    | Tcoloncolon --+    | Tcoloneqcolon+    | Tstar+    | Tarrow+    | Tlambda --+    | Tat+    | Tdot+    | Tquestion+    | Tsemicolon+    | Tname String+    | Tcname String+    | Tinteger Integer+    | Trational Float+    | Tstring String+    | Tchar Char+    deriving (Eq, Show)++lexer :: String -> Either String [Token]+lexer []           = Right []+lexer ('_' :cs)    = fmap (Twild:)       $ lexer cs+lexer ('(' :cs)    = fmap (Toparen:)     $ lexer cs+lexer (')' :cs)    = fmap (Tcparen:)     $ lexer cs+lexer (':':':':cs) = fmap (Tcoloncolon:) $ lexer cs+-- lexer (':' :cs)    = fmap (Tcolon:)      $ lexer cs+lexer ('\\':cs)    = fmap (Tlambda:)     $ lexer cs+lexer ('-':'>':cs) = fmap (Tarrow:)      $ lexer cs+lexer ('\"':cs)    = let (str,rest) = span (/='\"') cs+                     in case rest of+                           ('\"':cs') -> fmap (Tstring str:) $ lexer cs'+                           _          -> Left "lexer: no matching quote"+lexer s@(c:cs) | isSpace           c = lexer cs+               | isDigit           c = let (i,s') = span isDigit s+                                         in fmap (Tinteger (read i):) $ lexer s'+               | isCoreIdFirstChar c = let (i,s') = span isCoreIdChar s+                                         in fmap (Tname i:) $ lexer s'+               | isCoreInfixIdChar c = let (op,s') = span isCoreInfixIdChar s+                                         in fmap (Tname op:) $ lexer s'+lexer s            = Left $ "lexer: no match on " ++ s++---------------------------------------------++parseCore :: CoreString -> HermitC -> HermitM CoreExpr+parseCore (CoreString s) c =+    case lexer s of+        Left msg -> fail msg+        Right tokens -> runReaderT (parser tokens) c++---------------------------------------------++-- These three should probably go somewhere else.++-- | Parse a 'CoreString' to a 'CoreExpr', using the current context.+parseCoreExprT :: CoreString -> TranslateH a CoreExpr+parseCoreExprT = contextonlyT . parseCore++parse2beforeBiR :: (CoreExpr -> CoreExpr -> BiRewriteH a) -> CoreString -> CoreString -> BiRewriteH a+parse2beforeBiR f s1 s2 = beforeBiR (parseCoreExprT s1 &&& parseCoreExprT s2) (uncurry f)++parse3beforeBiR :: (CoreExpr -> CoreExpr -> CoreExpr -> BiRewriteH a) -> CoreString -> CoreString -> CoreString -> BiRewriteH a+parse3beforeBiR f s1 s2 s3 = beforeBiR ((parseCoreExprT s1 &&& parseCoreExprT s2) &&& parseCoreExprT s3) ((uncurry.uncurry) f)++---------------------------------------------+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp ++{-# LINE 13 "templates/GenericTemplate.hs" #-}++++++#if __GLASGOW_HASKELL__ > 706+#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool)+#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool)+#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool)+#else+#define LT(n,m) (n Happy_GHC_Exts.<# m)+#define GTE(n,m) (n Happy_GHC_Exts.>=# m)+#define EQ(n,m) (n Happy_GHC_Exts.==# m)+#endif+{-# LINE 45 "templates/GenericTemplate.hs" #-}+++data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList++++++{-# LINE 66 "templates/GenericTemplate.hs" #-}++{-# LINE 76 "templates/GenericTemplate.hs" #-}++{-# LINE 85 "templates/GenericTemplate.hs" #-}++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is 0#, it means we've just accepted a partial+-- parse (a %partial parser).  We must ignore the saved token on the top of+-- the stack in this case.+happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =+	happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = +	(happyTcHack j (happyTcHack st)) (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++++happyDoAction i tk st+	= {- nothing -}+++	  case action of+		0#		  -> {- nothing -}+				     happyFail i tk st+		-1# 	  -> {- nothing -}+				     happyAccept i tk st+		n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}++				     (happyReduceArr Happy_Data_Array.! rule) i tk st+				     where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))+		n		  -> {- nothing -}+++				     happyShift new_state i tk st+                                     where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))+   where off    = indexShortOffAddr happyActOffsets st+         off_i  = (off Happy_GHC_Exts.+# i)+	 check  = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#))+                  then EQ(indexShortOffAddr happyCheck off_i, i)+		  else False+         action+          | check     = indexShortOffAddr happyTable off_i+          | otherwise = indexShortOffAddr happyDefActions st+++indexShortOffAddr (HappyA# arr) off =+	Happy_GHC_Exts.narrow16Int# i+  where+        i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)+        high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))+        low  = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))+        off' = off Happy_GHC_Exts.*# 2#++++++data HappyAddr = HappyA# Happy_GHC_Exts.Addr#+++++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++{-# LINE 169 "templates/GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =+     let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+--     trace "shifting the error token" $+     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)++happyShift new_state i tk st sts stk =+     happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_0 nt fn j tk st@((action)) sts stk+     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')+     = let r = fn v1 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')+     = let r = fn v1 v2 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+     = let r = fn v1 v2 v3 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happyReduce k nt fn j tk st sts stk+     = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of+	 sts1@((HappyCons (st1@(action)) (_))) ->+        	let r = fn stk in  -- it doesn't hurt to always seq here...+       		happyDoSeq r (happyGoto nt j tk st1 sts1 r)++happyMonadReduce k nt fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+      case happyDrop k (HappyCons (st) (sts)) of+        sts1@((HappyCons (st1@(action)) (_))) ->+          let drop_stk = happyDropStk k stk in+          happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))++happyMonad2Reduce k nt fn 0# tk st sts stk+     = happyFail 0# tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+      case happyDrop k (HappyCons (st) (sts)) of+        sts1@((HappyCons (st1@(action)) (_))) ->+         let drop_stk = happyDropStk k stk++             off = indexShortOffAddr happyGotoOffsets st1+             off_i = (off Happy_GHC_Exts.+# nt)+             new_state = indexShortOffAddr happyTable off_i++++          in+          happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))++happyDrop 0# l = l+happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t++happyDropStk 0# l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction+++happyGoto nt j tk st = +   {- nothing -}+   happyDoAction j tk new_state+   where off = indexShortOffAddr happyGotoOffsets st+         off_i = (off Happy_GHC_Exts.+# nt)+         new_state = indexShortOffAddr happyTable off_i+++++-----------------------------------------------------------------------------+-- Error recovery (0# is the error token)++-- parse error if we are in recovery and we fail again+happyFail 0# tk old_st _ stk@(x `HappyStk` _) =+     let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+--	trace "failing" $ +        happyError_ i tk++{-  We don't need state discarding for our restricted implementation of+    "error".  In fact, it can cause some bogus parses, so I've disabled it+    for now --SDM++-- discard a state+happyFail  0# tk old_st (HappyCons ((action)) (sts)) +						(saved_tok `HappyStk` _ `HappyStk` stk) =+--	trace ("discarding state, depth " ++ show (length stk))  $+	happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+--                       save the old token and carry on.+happyFail  i tk (action) sts stk =+--      trace "entering error recovery" $+	happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll :: a+notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions+++happyTcHack :: Happy_GHC_Exts.Int# -> a -> a+happyTcHack x y = y+{-# INLINE happyTcHack #-}+++-----------------------------------------------------------------------------+-- Seq-ing.  If the --strict flag is given, then Happy emits +--	happySeq = happyDoSeq+-- otherwise it emits+-- 	happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq   a b = a `seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template.  GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.+++{-# NOINLINE happyDoAction #-}+{-# NOINLINE happyTable #-}+{-# NOINLINE happyCheck #-}+{-# NOINLINE happyActOffsets #-}+{-# NOINLINE happyGotoOffsets #-}+{-# NOINLINE happyDefActions #-}++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
driver/Main.hs view
@@ -25,7 +25,8 @@         ,"          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."+        ,"A * may be used for the module name. * matches any module."+        ,"If a module name is not supplied, * is assumed."         ,""         ,"HERMIT_ARGS"         ,"  -opt=MODULE : where MODULE is the module containing a HERMIT optimization plugin"@@ -49,7 +50,7 @@ main1 [] = usage main1 args@[file_nm,script_nm] = do     e <- doesFileExist script_nm-    if e then main4 file_nm [] [("Main", [script_nm])] [] else main2 args+    if e then main4 file_nm [] [("*", [script_nm])] [] else main2 args main1 other = main2 other  main2 (file_nm:rest) = case span (/= "--") rest of@@ -65,7 +66,7 @@           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", [])] ghc_args+main4 file_nm hermit_args []          ghc_args = main4 file_nm hermit_args [("*", [])] ghc_args main4 file_nm hermit_args module_args ghc_args = do         putStrLn $ "[starting " ++ hermit_version ++ " on " ++ file_nm ++ "]"         let (pluginName, hermit_args') = getPlugin hermit_args
hermit.cabal view
@@ -1,5 +1,5 @@ Name:                hermit-Version:             0.3.1.0+Version:             0.3.2.0 Synopsis:            Haskell Equational Reasoning Model-to-Implementation Tunnel Description:   HERMIT uses Haskell to express semi-formal models,@@ -30,12 +30,12 @@   .   @    $ hermit Reverse.hs Reverse.hss resume-   [starting HERMIT v0.3.1.0 on Reverse.hs]+   [starting HERMIT v0.3.2.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.3.1.0 ... linking ... done.+   Loading package hermit-0.3.2.0 ... linking ... done.    [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )    Linking Reverse ...    $ ./Reverse@@ -46,12 +46,12 @@   .   @    $ hermit Reverse.hs-   [starting HERMIT v0.3.1.0 on Reverse.hs]+   [starting HERMIT v0.3.2.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.3.1.0 ... linking ... done.+   Loading package hermit-0.3.2.0 ... linking ... done.    [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )    ===================== Welcome to HERMIT =====================    HERMIT is a toolkit for the interactive transformation of GHC
src/HERMIT.hs view
@@ -1,7 +1,11 @@ module HERMIT (plugin) where +import Data.Maybe (fromMaybe)+ import HERMIT.GHC import HERMIT.Optimize+import HERMIT.Plugin (getPhaseFlag)  plugin :: Plugin-plugin = optimize $ \ options -> phase 0 $ interactive [] options+plugin = optimize $ \ options -> let (pn,opts) = fromMaybe (0,options) (getPhaseFlag options)+                                 in phase pn $ interactive [] opts
src/HERMIT/Context.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, InstanceSigs #-}  module HERMIT.Context        ( -- * HERMIT Contexts@@ -12,7 +12,11 @@        , HermitBindingSite(..)        , BindingDepth        , HermitBinding+       , hbDepth+       , hbSite+       , hbPath        , hermitBindingSiteExpr+       , hermitBindingSummary        , hermitBindingExpr          -- ** Adding bindings to contexts        , AddBindings(..)@@ -62,13 +66,17 @@ --   Bound expressions cannot be inlined without checking for shadowing issues (using the depth information). data HermitBindingSite = LAM                               -- ^ A lambda-bound variable.                        | NONREC CoreExpr                   -- ^ A non-recursive binding of an expression.-                       | REC CoreExpr                      -- ^ A (potentially) recursive binding of an expression.-                       | SELFREC                           -- ^ A (potentially) recursive binding of a superexpression of the current node.+                       | REC CoreExpr                      -- ^ A recursive binding that does not depend on the current expression (i.e. we're not in the binding group of that binding).+                       | SELFREC                           -- ^ A recursive binding of a superexpression of the current node (i.e. we're in the RHS of that binding).+                       | MUTUALREC CoreExpr                -- ^ A recursive binding that is mutually recursive with the binding under consideration (i.e. we're in another definition in the same recursive binding group.).                        | CASEALT                           -- ^ A variable bound in a case alternative.                        | CASEWILD CoreExpr (AltCon,[Var])  -- ^ A case wildcard binder.  We store both the scrutinised expression, and the case alternative 'AltCon' and variables.                        | FORALL                            -- ^ A universally quantified type variable. -type HermitBinding = (BindingDepth, HermitBindingSite)+data HermitBinding = HB { hbDepth :: BindingDepth +                        , hbSite :: HermitBindingSite +                        , hbPath :: AbsolutePathH+                        }  -- | Retrieve the expression in a 'HermitBindingSite', if there is one. hermitBindingSiteExpr :: HermitBindingSite -> KureM CoreExpr@@ -76,14 +84,26 @@                             LAM          -> fail "variable is lambda-bound, not bound to an expression."                             NONREC e     -> return e                             REC e        -> return e+                            MUTUALREC e  -> return e                             SELFREC      -> fail "identifier recursively refers to the expression under consideration."                             CASEALT      -> fail "variable is bound in a case alternative, not bound to an expression."                             CASEWILD e _ -> return e                             FORALL       -> fail "variable is a universally quantified type variable." +hermitBindingSummary :: HermitBinding -> String+hermitBindingSummary b = show (hbDepth b) ++ "$" ++ case hbSite b of+                            LAM          -> "LAM"+                            NONREC {}    -> "NONREC"+                            REC {}       -> "REC"+                            MUTUALREC {} -> "MUTUALREC"+                            SELFREC {}   -> "SELFREC"+                            CASEALT      -> "CASEALT"+                            CASEWILD {}  -> "CASEWILD"+                            FORALL       -> "FORALL"+ -- | Retrieve the expression in a 'HermitBinding', if there is one. hermitBindingExpr :: HermitBinding -> KureM CoreExpr-hermitBindingExpr = hermitBindingSiteExpr . snd+hermitBindingExpr = hermitBindingSiteExpr . hbSite  ------------------------------------------------------------------------ @@ -93,16 +113,19 @@   --   (Parallel bindings occur in recursive let bindings and case alternatives.)   --   This can also be used for solitary bindings (e.g. lambdas).   --   Bindings are added in parallel sets to help with shadowing issues.-  addHermitBindings :: [(Var,HermitBindingSite)] -> c -> c+  addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> c -> c  -- | The bindings are just discarded. instance AddBindings (SnocPath crumb) where-  addHermitBindings :: [(Var,HermitBindingSite)] -> SnocPath crumb -> SnocPath crumb+  addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> SnocPath crumb -> SnocPath crumb   addHermitBindings _ = id +instance ReadPath c Crumb => ReadPath (ExtendContext c e) Crumb where+  absPath = absPath . baseContext+ -- | The bindings are added to the base context and the extra context. instance (AddBindings c, AddBindings e) => AddBindings (ExtendContext c e) where-  addHermitBindings :: [(Var,HermitBindingSite)] -> ExtendContext c e -> ExtendContext c e+  addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> ExtendContext c e -> ExtendContext c e   addHermitBindings bnds c = c                               { baseContext  = addHermitBindings bnds (baseContext c)                               , extraContext = addHermitBindings bnds (extraContext c)@@ -110,43 +133,39 @@  ------------------------------------------- --- | Add a single binding to the context.-addHermitBinding  :: AddBindings c => Var -> HermitBindingSite -> c -> c-addHermitBinding v bd = addHermitBindings [(v,bd)]- -- | Add all bindings in a binding group to a context.-addBindingGroup :: AddBindings c => CoreBind -> c -> c-addBindingGroup (NonRec v e) = addHermitBinding  v (NONREC e)-addBindingGroup (Rec ies)    = addHermitBindings [ (i, REC e) | (i,e) <- ies ]+addBindingGroup :: (AddBindings c, ReadPath c Crumb) => CoreBind -> c -> c+addBindingGroup (NonRec v e) c = addHermitBindings [(v,NONREC e,absPath c @@ Let_Bind)] c+addBindingGroup (Rec ies)    c = addHermitBindings [ (i, REC e, absPath c @@ Let_Bind) | (i,e) <- ies ] c  -- | Add the binding for a recursive definition currently under examination. --   Note that because the expression may later be modified, the context only records the identifier, not the expression.-addDefBinding :: AddBindings c => Id -> c -> c-addDefBinding i = addHermitBinding i SELFREC+addDefBinding :: (AddBindings c, ReadPath c Crumb) => Id -> c -> c+addDefBinding i c = addHermitBindings [(i,SELFREC,absPath c @@ Def_Id)] c  -- | Add a list of recursive bindings to the context, except the nth binding in the list. --   The idea is to exclude the definition being descended into.-addDefBindingsExcept :: AddBindings c => Int -> [(Id,CoreExpr)] -> c -> c-addDefBindingsExcept n ies = addHermitBindings [ (i, REC e) | (m,(i,e)) <- zip [0..] ies, m /= n ]+addDefBindingsExcept :: (AddBindings c, ReadPath c Crumb) => Int -> [(Id,CoreExpr)] -> c -> c+addDefBindingsExcept n ies c = addHermitBindings [ (i, MUTUALREC e, absPath c @@ Rec_Def m) | (m,(i,e)) <- zip [0..] ies, m /= n ] c  -- | Add a wildcard binding for a specific case alternative.-addCaseWildBinding :: AddBindings c => (Id,CoreExpr,CoreAlt) -> c -> c-addCaseWildBinding (i,e,(con,vs,_)) = addHermitBinding i (CASEWILD e (con,vs))+addCaseWildBinding :: (AddBindings c, ReadPath c Crumb) => (Id,CoreExpr,CoreAlt) -> c -> c+addCaseWildBinding (i,e,(con,vs,_)) c = addHermitBindings [(i,CASEWILD e (con,vs),absPath c @@ Case_Binder)] c  -- | Add a lambda bound variable to a context. --   All that is known is the variable, which may shadow something. --   If so, we don't worry about that here, it is instead checked during inlining.-addLambdaBinding :: AddBindings c => Var -> c -> c-addLambdaBinding v = addHermitBinding v LAM+addLambdaBinding :: (AddBindings c, ReadPath c Crumb) => Var -> c -> c+addLambdaBinding v c = addHermitBindings [(v,LAM,absPath c @@ Lam_Var)] c  -- | Add the variables bound by a 'DataCon' in a case. --   They are all bound at the same depth.-addAltBindings :: AddBindings c => [Var] -> c -> c-addAltBindings vs = addHermitBindings [ (v, CASEALT) | v <- vs ]+addAltBindings :: (AddBindings c, ReadPath c Crumb) => [Var] -> c -> c+addAltBindings vs c = addHermitBindings [ (v, CASEALT, absPath c @@ Alt_Var i) | (v,i) <- zip vs [1..] ] c  -- | Add a universally quantified type variable to a context.-addForallBinding :: AddBindings c => TyVar -> c -> c-addForallBinding v = addHermitBinding v FORALL+addForallBinding :: (AddBindings c, ReadPath c Crumb) => TyVar -> c -> c+addForallBinding v c = addHermitBindings [(v,FORALL,absPath c @@ ForAllTy_Var)] c  ------------------------------------------------------------------------ @@ -178,11 +197,11 @@  -- | Lookup the depth of a variable's binding in a context. lookupHermitBindingDepth :: (ReadBindings c, Monad m) => Var -> c -> m BindingDepth-lookupHermitBindingDepth v = liftM fst . lookupHermitBinding v+lookupHermitBindingDepth v = liftM hbDepth . lookupHermitBinding v  -- | Lookup the binding for a variable in a context, ensuring it was bound at the specified depth. lookupHermitBindingSite :: (ReadBindings c, Monad m) => Var -> BindingDepth -> c -> m HermitBindingSite-lookupHermitBindingSite v depth c = do (d,bnd) <- lookupHermitBinding v c+lookupHermitBindingSite v depth c = do HB d bnd _ <- lookupHermitBinding v c                                        guardMsg (d == depth) "lookupHermitBinding succeeded, but depth does not match.  The variable has probably been shadowed."                                        return bnd @@ -252,9 +271,9 @@ ------------------------------------------------------------------------  instance AddBindings HermitC where-  addHermitBindings :: [(Var,HermitBindingSite)] -> HermitC -> HermitC+  addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> HermitC -> HermitC   addHermitBindings vbs c = let nextDepth = succ (hermitC_depth c)-                                vhbs      = [ (v, (nextDepth,b)) | (v,b) <- vbs ]+                                vhbs      = [ (v, HB nextDepth b p) | (v,b,p) <- vbs ]                              in c { hermitC_bindings = fromList vhbs `union` hermitC_bindings c                                   , hermitC_depth    = nextDepth                                   }
src/HERMIT/Core.hs view
@@ -46,6 +46,8 @@           , freeVarsDef           , freeVarsExpr           , freeVarsAlt+          , freeVarsVar+          , localFreeVarsAlt           , freeVarsType           , freeVarsCoercion           , localFreeVarsExpr@@ -301,18 +303,26 @@  -- | Find all free identifiers in a binding group, which excludes any variables bound in the group. freeVarsBind :: CoreBind -> VarSet-freeVarsBind (NonRec v e) = freeVarsExpr e `unionVarSet` varTypeTyVars v+freeVarsBind (NonRec v e) = freeVarsExpr e `unionVarSet` freeVarsVar v freeVarsBind (Rec defs)   = let (bs,es) = unzip defs                              in delVarSetList (unionVarSets $ map freeVarsExpr es) bs-                                `unionVarSet`  unionVarSets (map varTypeTyVars bs)+                                `unionVarSet`  unionVarSets (map freeVarsVar bs) --- | Find all free variables is a recursive definition, which excludes the bound variable.+-- | Find all free variables on a binder. Equivalent to idFreeVars, but safe to call on type bindings.+freeVarsVar :: Var -> VarSet+freeVarsVar v = varTypeTyVars v `unionVarSet` bndrRuleAndUnfoldingVars v++-- | Find all free variables in a recursive definition, which excludes the bound variable. freeVarsDef :: CoreDef -> VarSet-freeVarsDef (Def v e) = delVarSet (freeVarsExpr e) v `unionVarSet` varTypeTyVars v+freeVarsDef (Def v e) = delVarSet (freeVarsExpr e) v `unionVarSet` freeVarsVar v  -- | Find all free variables in a case alternative, which excludes any variables bound in the alternative. freeVarsAlt :: CoreAlt -> VarSet-freeVarsAlt (_,bs,e) = delVarSetList (freeVarsExpr e `unionVarSet` unionVarSets (map varTypeTyVars bs)) bs+freeVarsAlt (_,bs,e) = delVarSetList (freeVarsExpr e `unionVarSet` unionVarSets (map freeVarsVar bs)) bs++-- | Find all free local variables in a case alternative, which excludes any variables bound in the alternative.+localFreeVarsAlt :: CoreAlt -> VarSet+localFreeVarsAlt (_,bs,e) = delVarSetList (localFreeVarsExpr e `unionVarSet` unionVarSets (map freeVarsVar bs)) bs  -- | Find all free variables in a program. freeVarsProg :: CoreProg -> VarSet
src/HERMIT/Dictionary/AlphaConversion.hs view
@@ -135,7 +135,7 @@  -- | Rename local variables with manifestly unique names (x, x0, x1, ...). --   Does not rename top-level definitions.-unshadowR :: forall c. (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core+unshadowR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core unshadowR = setFailMsg "No shadows to eliminate." $            anytdR (promoteExprR unshadowExpr <+ promoteAltR unshadowAlt) @@ -156,7 +156,7 @@  -- | Replace all occurrences of a specified variable. --   Arguments are the variable to replace and the replacement variable, respectively.-replaceVarR :: (ExtendPath c Crumb, AddBindings c, Injection a Core, MonadCatch m) => Var -> Var -> Rewrite c m a+replaceVarR :: (Injection a Core, MonadCatch m) => Var -> Var -> Rewrite c m a replaceVarR v v' = extractR $ tryR $ substR v $ varToCoreExpr v'  -- | Given a variable to replace, and a replacement, produce a 'Var' @->@ 'Var' function that@@ -174,7 +174,7 @@ -----------------------------------------------------------------------  -- | Alpha rename a lambda binder.  Optionally takes a suggested new name.-alphaLamR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr+alphaLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr alphaLamR mn = setFailMsg (wrongFormForAlpha "Lam v e") $               do (v, nameModifier) <- lamT idR (freshNameGenT mn) (,)                  v' <- constT (cloneVarH nameModifier v)@@ -183,7 +183,7 @@ -----------------------------------------------------------------------  -- | Alpha rename a case binder.  Optionally takes a suggested new name.-alphaCaseBinderR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr+alphaCaseBinderR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr alphaCaseBinderR mn = setFailMsg (wrongFormForAlpha "Case e v ty alts") $                      do Case _ v _ _ <- idR                         nameModifier <- freshNameGenT mn@@ -193,53 +193,55 @@ -----------------------------------------------------------------------  -- | Rename the specified variable in a case alternative.  Optionally takes a suggested new name.-alphaAltVarR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Var -> Rewrite c HermitM CoreAlt-alphaAltVarR mn v =-  do nameModifier <- altT idR (\ _ -> idR) (freshNameGenT mn) (\ _ _ nameGen -> nameGen)-     v' <- constT (cloneVarH nameModifier v)-     altAnyR (fail "") (\ _ -> arr (replaceVar v v')) (replaceVarR v v')+alphaAltVarR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Var -> Rewrite c HermitM CoreAlt+alphaAltVarR mn v = do+    nameModifier <- liftM (freshNameGenAvoiding mn) $ liftM2 unionVarSet boundVarsT (arr freeVarsAlt)+    v' <- constT (cloneVarH nameModifier v)+    -- Must replace the binder first, then substitution will work.+    altAllR idR (\_ -> arr (replaceVar v v')) idR >>> substAltR v (varToCoreExpr v')  -- | Rename the specified variables in a case alternative, using the suggested names where provided.-alphaAltVarsWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Var)] -> Rewrite c HermitM CoreAlt-alphaAltVarsWithR = andR . map (uncurry alphaAltVarR)+-- Suggested names *must* be provided in left-to-right order matching the order of the alt binders.+alphaAltVarsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Var)] -> Rewrite c HermitM CoreAlt+alphaAltVarsWithR = andR . map (uncurry alphaAltVarR) . reverse -- note: right-to-left so type subst aren't undone  -- | Rename the variables bound in a case alternative with the given list of suggested names.-alphaAltWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreAlt+alphaAltWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreAlt alphaAltWithR ns =   do vs <- arr altVars      alphaAltVarsWithR $ zip (map Just ns) vs  -- | Rename the specified variables in a case alternative.-alphaAltVarsR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreAlt+alphaAltVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreAlt alphaAltVarsR vs =   do bs <- arr altVars      alphaAltVarsWithR (zip (repeat Nothing) (bs `intersect` vs))  -- | Rename all identifiers bound in a case alternative.-alphaAltR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreAlt+alphaAltR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreAlt alphaAltR = arr altVars >>= alphaAltVarsR  -----------------------------------------------------------------------  -- | Rename all identifiers bound in a case expression.-alphaCaseR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+alphaCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr alphaCaseR = alphaCaseBinderR Nothing >+> caseAllR idR idR idR (const alphaAltR)  -----------------------------------------------------------------------  -- | Alpha rename a non-recursive let binder.  Optionally takes a suggested new name.-alphaLetNonRecR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr+alphaLetNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr alphaLetNonRecR mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $                     do (v, nameModifier) <- letNonRecT idR mempty (freshNameGenT mn) (\ v () nameMod -> (v, nameMod))                        v' <- constT (cloneVarH nameModifier v)                        letNonRecAnyR (return v') idR (replaceVarR v v')  -- | Alpha rename a non-recursive let binder if the variable appears in the argument list.  Optionally takes a suggested new name.-alphaLetNonRecVarsR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> [Var] -> Rewrite c HermitM CoreExpr+alphaLetNonRecVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> [Var] -> Rewrite c HermitM CoreExpr alphaLetNonRecVarsR mn vs = whenM ((`elem` vs) <$> letNonRecVarT) (alphaLetNonRecR mn)  -- | Rename the specified identifier bound in a recursive let.  Optionally takes a suggested new name.-alphaLetRecIdR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Id -> Rewrite c HermitM CoreExpr+alphaLetRecIdR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Id -> Rewrite c HermitM CoreExpr alphaLetRecIdR mn v = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $                      do usedVars <- unionVarSet <$> boundVarsT                                                 <*> letRecT (\ _ -> defT idR (arr freeVarsExpr) (flip extendVarSet)) (arr freeVarsExpr) (\ bndfvs vs -> unionVarSets (vs:bndfvs))@@ -247,29 +249,29 @@                         letRecDefAnyR (\ _ -> (arr (replaceVar v v'), replaceVarR v v')) (replaceVarR v v')  -- | Rename the specified identifiers in a recursive let, using the suggested names where provided.-alphaLetRecIdsWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Id)] -> Rewrite c HermitM CoreExpr+alphaLetRecIdsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Id)] -> Rewrite c HermitM CoreExpr alphaLetRecIdsWithR = andR . map (uncurry alphaLetRecIdR)  -- | Rename the identifiers bound in a Let with the given list of suggested names.-alphaLetWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreExpr+alphaLetWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreExpr alphaLetWithR ns = alphaLetNonRecR (listToMaybe ns)                   <+ (letRecIdsT >>= (alphaLetRecIdsWithR . zip (map Just ns)))  -- | Rename the specified variables bound in a let.-alphaLetVarsR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreExpr+alphaLetVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreExpr alphaLetVarsR vs = alphaLetNonRecVarsR Nothing vs                    <+ (do bs <- letT (arr bindVars) successT const                           alphaLetRecIdsWithR (zip (repeat Nothing) (bs `intersect` vs))                       )  -- | Rename all identifiers bound in a Let.-alphaLetR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+alphaLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr alphaLetR = letVarsT >>= alphaLetVarsR  -----------------------------------------------------------------------  -- | Alpha rename a non-recursive top-level binder.  Optionally takes a suggested new name.-alphaProgConsNonRecR :: (ExtendPath c Crumb, AddBindings c) => TH.Name -> Rewrite c HermitM CoreProg+alphaProgConsNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => TH.Name -> Rewrite c HermitM CoreProg alphaProgConsNonRecR n = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $                     do ProgCons (NonRec v _) _ <- idR                        v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v)@@ -280,17 +282,17 @@ -- alphaConsNonRecIds mn vs = whenM ((`elem` vs) <$> consNonRecIdT) (alphaConsNonRec mn)  -- | Rename the specified identifier bound in a recursive top-level binder.  Optionally takes a suggested new name.-alphaProgConsRecIdR :: (ExtendPath c Crumb, AddBindings c) => TH.Name -> Id -> Rewrite c HermitM CoreProg+alphaProgConsRecIdR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => TH.Name -> Id -> Rewrite c HermitM CoreProg alphaProgConsRecIdR n v =  setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $                       do v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v)                          consRecDefAnyR (\ _ -> (arr (replaceVar v v'), replaceVarR v v')) (replaceVarR v v')  -- | Rename the specified identifiers in a recursive top-level binding at the head of a program, using the suggested names where provided.-alphaProgConsRecIdsWithR :: (ExtendPath c Crumb, AddBindings c) => [(TH.Name,Id)] -> Rewrite c HermitM CoreProg+alphaProgConsRecIdsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => [(TH.Name,Id)] -> Rewrite c HermitM CoreProg alphaProgConsRecIdsWithR = andR . map (uncurry alphaProgConsRecIdR)  -- | Rename the identifiers bound in the top-level binding at the head of the program with the given list of suggested names.-alphaProgConsWithR :: (ExtendPath c Crumb, AddBindings c) => [TH.Name] -> Rewrite c HermitM CoreProg+alphaProgConsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => [TH.Name] -> Rewrite c HermitM CoreProg alphaProgConsWithR []     = fail "At least one new name must be provided." alphaProgConsWithR (n:ns) = alphaProgConsNonRecR n <+ (progConsRecIdsT >>= (alphaProgConsRecIdsWithR . zip (n:ns))) @@ -311,7 +313,7 @@ -----------------------------------------------------------------------  -- | Alpha rename any bindings at this node.  Note: does not rename case alternatives unless invoked on the alternative.-alphaR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core+alphaR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core alphaR = setFailMsg "Cannot alpha-rename here." $            promoteExprR (alphaLamR Nothing <+ alphaCaseBinderR Nothing <+ alphaLetR)         <+ promoteAltR alphaAltR
src/HERMIT/Dictionary/Common.hs view
@@ -113,26 +113,26 @@     return res  -- | Apply a rewrite to all applications of a given function in a top-down manner, pruning on success.-callsR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Rewrite c m CoreExpr -> Rewrite c m Core+callsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Rewrite c m CoreExpr -> Rewrite c m Core callsR nm rr = prunetdR (promoteExprR $ callNameG nm >> rr)  -- | Apply a translate to all applications of a given function in a top-down manner, --   pruning on success, collecting the results.-callsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Translate c m CoreExpr b -> Translate c m Core [b]+callsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Translate c m CoreExpr b -> Translate c m Core [b] callsT nm t = collectPruneT (promoteExprT $ callNameG nm >> t)  ------------------------------------------------------------------------------  -- | List the identifiers bound by the top-level binding group at the head of the program.-progConsIdsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreProg [Id]+progConsIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreProg [Id] progConsIdsT = progConsT (arr bindVars) mempty (\ vs () -> vs)  -- | List the identifiers bound by a recursive top-level binding group at the head of the program.-progConsRecIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg [Id]+progConsRecIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg [Id] progConsRecIdsT = progConsT recIdsT mempty (\ vs () -> vs)  -- | Return the identifier bound by a non-recursive top-level binding at the head of the program.-progConsNonRecIdT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg Id+progConsNonRecIdT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg Id progConsNonRecIdT = progConsT nonRecVarT mempty (\ v () -> v)  -- | Return the variable bound by a non-recursive let expression.@@ -140,35 +140,35 @@ nonRecVarT = nonRecT idR mempty (\ v () -> v)  -- | List all identifiers bound in a recursive binding group.-recIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind [Id]+recIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind [Id] recIdsT = recT (\ _ -> arr defId) id  -- | Return the variable bound by a lambda expression.-lamVarT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var+lamVarT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var lamVarT = lamT idR mempty (\ v () -> v)  -- | List the variables bound by a let expression.-letVarsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreExpr [Var]+letVarsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreExpr [Var] letVarsT = letT (arr bindVars) mempty (\ vs () -> vs)  -- | List the identifiers bound by a recursive let expression.-letRecIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Id]+letRecIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Id] letRecIdsT = letT recIdsT mempty (\ vs () -> vs)  -- | Return the variable bound by a non-recursive let expression.-letNonRecVarT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var+letNonRecVarT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var letNonRecVarT = letT nonRecVarT mempty (\ v () -> v)  -- | List all variables bound by a case expression (in the alternatives and the wildcard binder).-caseVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Var]+caseVarsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Var] caseVarsT = caseT mempty idR mempty (\ _ -> arr altVars) (\ () v () vss -> v : nub (concat vss))  -- | Return the case wildcard binder.-caseWildIdT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Id+caseWildIdT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Id caseWildIdT = caseT mempty idR mempty (\ _ -> idR) (\ () i () _ -> i)  -- | List the variables bound by all alternatives in a case expression.-caseAltVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [[Var]]+caseAltVarsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [[Var]] caseAltVarsT = caseT mempty mempty mempty (\ _ -> arr altVars) (\ () () () vss -> vss)  ------------------------------------------------------------------------------
src/HERMIT/Dictionary/Composite.hs view
@@ -53,11 +53,11 @@  -- | Unfold the current expression if it is one of the basic combinators: ('$'), ('.'), 'id', 'flip', 'const', 'fst' or 'snd'. --   This is intended to be used as a component of simplification traversals such as 'simplifyR' or 'bashR'.-unfoldBasicCombinatorR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+unfoldBasicCombinatorR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr unfoldBasicCombinatorR = setFailMsg "unfold-basic-combinator failed." $      unfoldNamesR (map TH.mkName basicCombinators) -simplifyR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core+simplifyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core simplifyR = setFailMsg "Simplify failed: nothing to simplify." $     innermostR (   promoteBindR recToNonrecR                 <+ promoteExprR ( unfoldBasicCombinatorR@@ -69,10 +69,10 @@  ------------------------------------------------------------------------------------------------------ -bashR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core+bashR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core bashR = bashUsingR (map fst bashComponents) -bashExtendedWithR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core+bashExtendedWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core bashExtendedWithR rs = bashUsingR (rs ++ map fst bashComponents)  bashDebugR :: RewriteH Core@@ -90,7 +90,7 @@ --     bashCoreR :: Rewrite c m Core --     bashCoreR = repeatR (innermostR (catchesT rs) >>> occurAnalyseR) -bashUsingR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => [Rewrite c m Core] -> Rewrite c m Core+bashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => [Rewrite c m Core] -> Rewrite c m Core bashUsingR rs =     setFailMsg "bash failed: nothing to do." $     repeatR (occurAnalyseR >>> onetdR (catchesT rs)) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR@@ -115,7 +115,7 @@                                                                                        )  -- TODO: Think about a good order for bash.-bashComponents :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => [(Rewrite c HermitM Core, String)]+bashComponents :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [(Rewrite c HermitM Core, String)] bashComponents =   [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr")    -- ??     (promoteExprR betaReduceR, "beta-reduce")                        -- O(1)
src/HERMIT/Dictionary/Fold.hs view
@@ -132,7 +132,9 @@ foldMatch vs as (Var i) e | i `elem` vs = return [(i,e)]                           | otherwise   = case e of                                             Var i' | maybe False (==i) (lookup i' as) -> return [(i,e)]-                                                   | i == i' -> return []+                                                             -- TODO: type comparison here is a total hack,+                                                             --       see notes in hermit-syb+                                                   | i == i' && eqType (idType i) (idType i') -> return []                                             _                -> Nothing foldMatch _  _ (Lit l) (Lit l') | l == l' = return [] foldMatch vs as (App e a) (App e' a') = do
src/HERMIT/Dictionary/Function.hs view
@@ -34,15 +34,15 @@ ------------------------------------------------------------------------------------------------------  -- | Traditional Static Argument Transformation-staticArgR :: (ExtendPath c Crumb, AddBindings c) => Rewrite c HermitM CoreDef+staticArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Rewrite c HermitM CoreDef staticArgR = staticArgPredR (return . map fst)  -- | Static Argument Transformation that only considers type arguments to be static.-staticArgTypesR :: (ExtendPath c Crumb, AddBindings c) => Rewrite c HermitM CoreDef+staticArgTypesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Rewrite c HermitM CoreDef staticArgTypesR = staticArgPredR (return . map fst . filter (isTyVar . snd))  -- | Static Argument Transformations which requires that arguments in the given position are static.-staticArgPosR :: (ExtendPath c Crumb, AddBindings c) => [Int] -> Rewrite c HermitM CoreDef+staticArgPosR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => [Int] -> Rewrite c HermitM CoreDef staticArgPosR is' = staticArgPredR $ \ss' -> let is = nub is'                                                  ss = map fst ss'                                             in if is == (is `intersect` ss)@@ -50,7 +50,7 @@                                                else fail $ "args " ++ commas (filter (`notElem` ss) is) ++ " are not static."  -- | Generalized Static Argument Transformation, which allows static arguments to be filtered.-staticArgPredR :: (ExtendPath c Crumb, AddBindings c)+staticArgPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c)                => ([(Int, Var)] -> HermitM [Int]) -- ^ given list of static args and positions, decided which to transform                -> Rewrite c HermitM CoreDef staticArgPredR decide = prefixFailMsg "static-arg failed: " $ do
src/HERMIT/Dictionary/GHC.hs view
@@ -6,7 +6,8 @@        , anyCallR          -- ** Substitution        , substR-       , substExprR+       , substAltR+       , substCoreExpr          -- ** Utilities        , inScope        , rule@@ -30,6 +31,7 @@ import qualified CoreLint import IOEnv hiding (liftIO) import qualified SpecConstr+import qualified Specialise  import Control.Arrow import Control.Monad@@ -45,6 +47,7 @@ import HERMIT.GHC  import HERMIT.Dictionary.Debug hiding (externals)+import HERMIT.Dictionary.Kure (unitT)  import qualified Language.Haskell.TH as TH @@ -77,6 +80,8 @@                 [ "Runs GHC's Core Lint, which typechecks the current module."] .+ Deep .+ Debug .+ Query          , external "spec-constr" (promoteModGutsR specConstrR :: RewriteH Core)                 [ "Run GHC's SpecConstr pass, which performs call pattern specialization."] .+ Deep+         , external "specialise" (promoteModGutsR specialise :: RewriteH Core)+                [ "Run GHC's specialisation pass, which performs type and dictionary specialization."] .+ Deep          , external "any-call" (anyCallR :: RewriteH Core -> RewriteH Core)                 [ "any-call (.. unfold command ..) applies an unfold command to all applications."                 , "Preference is given to applications with more arguments." ] .+ Deep@@ -85,19 +90,19 @@ ------------------------------------------------------------------------  -- | Substitute all occurrences of a variable with an expression, in either a program or an expression.-substR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Var -> CoreExpr -> Rewrite c m Core-substR v e = setFailMsg "Can only perform substitution on expressions or programs." $-             promoteExprR (substExprR v e) <+ promoteProgR (substTopBindR v e) <+ promoteAltR (substAltR v e)+substR :: MonadCatch m => Var -> CoreExpr -> Rewrite c m Core+substR v e = setFailMsg "Can only perform substitution on expressions, case alternatives or programs." $+             promoteExprR (arr $ substCoreExpr v e) <+ promoteProgR (substTopBindR v e) <+ promoteAltR (substAltR v e)  -- | Substitute all occurrences of a variable with an expression, in an expression.-substExprR :: Monad m => Var -> CoreExpr -> Rewrite c m CoreExpr-substExprR v e =  contextfreeT $ \ expr -> do+substCoreExpr :: Var -> CoreExpr -> (CoreExpr -> CoreExpr)+substCoreExpr v e expr =     -- The InScopeSet needs to include any free variables appearing in the     -- expression to be substituted.  Constructing a NonRec Let expression     -- to pass on to exprFeeVars takes care of this, but ...     -- TODO Is there a better way to do this ???     let emptySub = mkEmptySubst (mkInScopeSet (localFreeVarsExpr (Let (NonRec v e) expr)))-    return $ substExpr (text "substR") (extendSubst emptySub v e) expr+     in substExpr (text "substCoreExpr") (extendSubst emptySub v e) expr  -- | Substitute all occurrences of a variable with an expression, in a program. substTopBindR :: Monad m => Var -> CoreExpr -> Rewrite c m CoreProg@@ -107,17 +112,12 @@     return $ bindsToProg $ snd (mapAccumL substBind (extendSubst emptySub v e) (progToBinds p))  -- | Substitute all occurrences of a variable with an expression, in a case alternative.-substAltR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Var -> CoreExpr -> Rewrite c m CoreAlt-substAltR v e = do (_, vs, _) <- idR-                   if v `elem` vs-                    then fail "variable is shadowed by a case-alternative constructor argument."-                    else altAllR idR (\ _ -> idR) (substExprR v e)---- Neil: Commented this out as it's not (currently) used.---  Perform let-substitution the specified number of times.--- letSubstNR :: Int -> Rewrite c m Core--- letSubstNR 0 = idR--- letSubstNR n = childR 1 (letSubstNR (n - 1)) >>> promoteExprR letSubstR+substAltR :: Monad m => Var -> CoreExpr -> Rewrite c m CoreAlt+substAltR v e = do+    (inS, (c, vs, rhs)) <- arr (flip delVarSet v . unionVarSet (localFreeVarsExpr e) . localFreeVarsAlt) &&& idR+    let subst = extendSubst (mkEmptySubst (mkInScopeSet inS)) v e+        (subst', vs') = substBndrs subst vs+    return (c, vs', substExpr (text "alt-rhs") subst' rhs)  ------------------------------------------------------------------------ @@ -291,14 +291,34 @@                  $ CoreLint.lintUnfolding noSrcLoc (varSetElems $ boundVars c) e #endif +-- | Run GHC's specConstr pass, and apply any rules generated. specConstrR :: RewriteH ModGuts-specConstrR = do+specConstrR = prefixFailMsg "spec-constr failed: " $ do     rs  <- extractT specRules     e'  <- contextfreeT $ liftCoreM . SpecConstr.specConstrProgram     rs' <- return e' >>> extractT specRules     let specRs = deleteFirstsBy ((==) `on` ru_name) rs' rs+    guardMsg (notNull specRs) "no rules created."     return e' >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewriteH specRs))) +-- | Run GHC's specialisation pass, and apply any rules generated.+specialise :: RewriteH ModGuts+specialise = prefixFailMsg "specialisation failed: " $ do+    gRules <- arr mg_rules+    lRules <- extractT specRules++    dflags <- dynFlagsT+    guts <- contextfreeT $ liftCoreM . Specialise.specProgram dflags++    lRules' <- return guts >>> extractT specRules -- spec rules on bindings in this module+    let gRules' = mg_rules guts            -- plus spec rules on imported bindings+        gSpecRs = deleteFirstsBy ((==) `on` ru_name) gRules' gRules+        lSpecRs = deleteFirstsBy ((==) `on` ru_name) lRules' lRules+        specRs = gSpecRs ++ lSpecRs+    guardMsg (notNull specRs) "no rules created."+    liftIO $ putStrLn $ unlines $ map (unpackFS . ru_name) specRs+    return guts >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewriteH specRs)))+ -- | Get all the specialization rules on a binding. --   These are created by SpecConstr and other GHC passes. idSpecRules :: TranslateH Id [CoreRule]@@ -306,8 +326,8 @@  -- | Promote 'idSpecRules' to CoreBind. bindSpecRules :: TranslateH CoreBind [CoreRule]-bindSpecRules =    recT (\_ -> defT idSpecRules (return ()) const) concat-                <+ nonRecT idSpecRules (return ()) const+bindSpecRules =    recT (\_ -> defT idSpecRules unitT const) concat+                <+ nonRecT idSpecRules unitT const  -- | Find all specialization rules in a Core fragment. specRules :: TranslateH Core [CoreRule]@@ -342,7 +362,7 @@ dezombifyR = varR (acceptR isDeadBinder >>^ zapVarOccInfo)  -- | Apply 'occurAnalyseExprR' to all sub-expressions.-occurAnalyseR :: (AddBindings c, ExtendPath c Crumb, MonadCatch m) => Rewrite c m Core+occurAnalyseR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core occurAnalyseR = let r  = promoteExprR (arr occurAnalyseExpr)                     go = r <+ anyR go                  in tryR go -- always succeed@@ -352,14 +372,14 @@ occurAnalyseExprChangedR = changedByR exprSyntaxEq (arr occurAnalyseExpr)  -- | Occurrence analyse all sub-expressions, failing if the result is syntactically equal to the initial expression.-occurAnalyseChangedR :: (AddBindings c, ExtendPath c Crumb, MonadCatch m) => Rewrite c m Core+occurAnalyseChangedR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core occurAnalyseChangedR = changedByR coreSyntaxEq occurAnalyseR  -- | Run GHC's occurrence analyser, and also eliminate any zombies.-occurAnalyseAndDezombifyR :: (AddBindings c, ExtendPath c Crumb, MonadCatch m) => Rewrite c m Core+occurAnalyseAndDezombifyR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core occurAnalyseAndDezombifyR = allbuR (tryR $ promoteExprR dezombifyR) >>> occurAnalyseR -occurrenceAnalysisR :: (AddBindings c, ExtendPath c Crumb, MonadCatch m) => Rewrite c m Core+occurrenceAnalysisR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core occurrenceAnalysisR = occurAnalyseAndDezombifyR  {- Does not work (no export)
src/HERMIT/Dictionary/Inline.hs view
@@ -60,30 +60,30 @@ data InlineConfig           = CaseBinderOnly CaseBinderInlineOption | AllBinders deriving (Eq, Show)  -- | If the current variable matches the given name, then inline it.-inlineNameR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => TH.Name -> Rewrite c HermitM CoreExpr+inlineNameR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => TH.Name -> Rewrite c HermitM CoreExpr inlineNameR nm = configurableInlineR AllBinders (arr $ cmpTHName2Var nm)  -- | If the current variable matches any of the given names, then inline it.-inlineNamesR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => [TH.Name] -> Rewrite c HermitM CoreExpr+inlineNamesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [TH.Name] -> Rewrite c HermitM CoreExpr inlineNamesR []  = fail "inline-names failed: no names given." inlineNamesR nms = configurableInlineR AllBinders (arr $ \ v -> any (flip cmpTHName2Var v) nms)  -- | Inline the current variable.-inlineR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+inlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr inlineR = configurableInlineR AllBinders (return True)  -- | Inline the current identifier if it is a case binder, using the scrutinee rather than the case-alternative pattern.-inlineCaseScrutineeR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+inlineCaseScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr inlineCaseScrutineeR = configurableInlineR (CaseBinderOnly Scrutinee) (return True)  -- | Inline the current identifier if is a case binder, using the case-alternative pattern rather than the scrutinee.-inlineCaseAlternativeR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+inlineCaseAlternativeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr inlineCaseAlternativeR = configurableInlineR (CaseBinderOnly Alternative) (return True)  -- | The implementation of inline, an important transformation. -- This *only* works if the current expression has the form @Var v@ (it does not traverse the expression). -- It can trivially be prompted to more general cases using traversal strategies.-configurableInlineR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c)+configurableInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c)                     => InlineConfig                     -> (Translate c HermitM Id Bool) -- ^ Only inline identifiers that satisfy this predicate.                     -> Rewrite c HermitM CoreExpr@@ -99,22 +99,23 @@ -- NOTE: When inlining, we have to take care to avoid variable capture. --       Our approach is to track the binding depth of the inlined identifier. --       After inlining, we then resolve all names in the inlined expression, and require that they were all bound prior to (i.e. lower numbered depth) the binding we inlined.---       The precise depth check varies between binding types as follows (where d is the depth of the inlined binder):+--       The precise depth check varies between binding sites as follows (where d is the depth of the inlined binder): -----         Binder                Safe to Inline+--         Binding Site          Safe to Inline --         global-id             (<= 0)---         letnonrec             (< d)---         letrec                (<= d)---         case-wild-scrutinee   (< d)---         case-wild-alt         (<= d+1)---         self-rec-def          NA---         lam                   NA---         case-alt              NA+--         NONREC                (< d)+--         REC                   (<= d)+--         MUTUALREC             (<= d+1)+--         CASEWILD-scrutinee    (< d)+--         CASEWILD-alt          (<= d+1)+--         SELFREC-def           NA+--         LAM                   NA+--         CASEALT               NA   -- | Ensure all the free variables in an expression were bound above a given depth. -- Assumes minimum depth is 0.-ensureDepthT :: forall c m. (ExtendPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m) => (BindingDepth -> Bool) -> Translate c m CoreExpr Bool+ensureDepthT :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m) => (BindingDepth -> Bool) -> Translate c m CoreExpr Bool ensureDepthT uncaptured =   do frees <- arr localFreeVarsExpr      let collectDepthsT :: Translate c m Core [BindingDepth]@@ -137,7 +138,8 @@                       DFunUnfolding _arity dc args    -> (,uncaptured) <$> dFunExpr dc args (idType i) #endif                       _                               -> fail $ "cannot find unfolding in Env or IdInfo."-      Just (depth,b) -> case b of+      Just b -> let depth = hbDepth b+                in case hbSite b of                           CASEWILD s alt -> let tys             = tyConAppArgs (idType i)                                                 altExprDepthM   = (, (<= depth+1)) <$> alt2Exp tys alt                                                 scrutExprDepthM = return (s, (< depth))@@ -152,6 +154,9 @@                           REC e          -> do requireAllBinders config                                                return (e, (<= depth)) +                          MUTUALREC e    -> do requireAllBinders config+                                               return (e, (<= depth+1))+                           _              -> fail "variable is not bound to an expression."   where     requireAllBinders :: Monad m => InlineConfig -> m ()@@ -174,7 +179,7 @@ alt2Exp tys (DataAlt dc, vs) = return $ mkCoreConApps dc (map Type tys ++ map (varToCoreExpr . zapVarOccInfo) vs)  -- | Get list of possible inline targets. Used by shell for completion.-inlineTargetsT :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Translate c HermitM Core [String]+inlineTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Translate c HermitM Core [String] inlineTargetsT = collectT $ promoteT $ whenM (testM inlineR) (varT $ arr var2String)  -- | Build a CoreExpr for a DFunUnfolding
src/HERMIT/Dictionary/Kure.hs view
@@ -3,6 +3,7 @@ module HERMIT.Dictionary.Kure        ( -- * KURE Strategies          externals+       , unitT        ) where @@ -21,6 +22,8 @@ externals = map (.+ KURE)    [ external "id"         (idR :: RewriteH Core)        [ "Perform an identity rewrite."] .+ Shallow+   , external "unit"       (unitT :: TranslateH Core ())+       [ "An always succeeding translation to ()." ]    , external "fail"       (fail :: String -> RewriteH Core)        [ "A failing rewrite."]    , external "<+"         ((<+) :: RewriteH Core -> RewriteH Core -> RewriteH Core)@@ -113,3 +116,7 @@ {-# INLINE testQuery #-}  ------------------------------------------------------------------------------------++unitT :: Monad m => Translate c m a ()+unitT = return ()+{-# INLINE unitT #-}
src/HERMIT/Dictionary/Local.hs view
@@ -35,6 +35,7 @@ import HERMIT.Utilities  import HERMIT.Dictionary.Common+import HERMIT.Dictionary.GHC (substCoreExpr) import HERMIT.Dictionary.Local.Bind hiding (externals) import qualified HERMIT.Dictionary.Local.Bind as Bind import HERMIT.Dictionary.Local.Case hiding (externals)@@ -175,7 +176,7 @@                                Nothing -> fail "type of expression is not a function or a forall."  -- | Perform multiple eta-expansions.-multiEtaExpandR :: (ExtendPath c Crumb, AddBindings c) => [String] -> Rewrite c HermitM CoreExpr+multiEtaExpandR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => [String] -> Rewrite c HermitM CoreExpr multiEtaExpandR []       = idR multiEtaExpandR (nm:nms) = etaExpandR nm >>> lamAllR idR (multiEtaExpandR nms) @@ -200,11 +201,12 @@  -- | Abstract over a variable using a lambda. --   e  ==>  (\ x. e) x-abstractR :: (ReadBindings c, MonadCatch m) => TH.Name -> Rewrite c m CoreExpr+abstractR :: (ReadBindings c) => TH.Name -> Rewrite c HermitM CoreExpr abstractR nm = prefixFailMsg "abstraction failed: " $-   do e <- idR-      v <- findBoundVarT nm-      return (App (Lam v e) (varToCoreExpr v))+   do v  <- findBoundVarT nm+      v' <- constT (cloneVarH id v) -- currently uses the same visible name (via "id").  We could do something else here, e.g. add a prime suffix.+      e  <- arr (substCoreExpr v (varToCoreExpr v'))+      return $ App (Lam v' e) (varToCoreExpr v)  ------------------------------------------------------------------------------------------------------ @@ -215,7 +217,7 @@  -- | Push a function through a Case or Let expression. --   Unsafe if the function is not strict.-pushR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c, HasGlobalRdrEnv c)+pushR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasGlobalRdrEnv c)       => Maybe (Rewrite c HermitM CoreExpr) -- ^ a proof that the function (after being applied to its type arguments) is strict       -> (Id -> Bool)                       -- ^ a predicate to identify the function       -> Rewrite c HermitM CoreExpr
src/HERMIT/Dictionary/Local/Case.hs view
@@ -9,9 +9,9 @@     , caseFloatCastR     , caseFloatLetR     , caseFloatR-    , caseUnfloatR-    , caseUnfloatAppR-    , caseUnfloatArgsR+    , caseFloatInR+    , caseFloatInAppR+    , caseFloatInArgsR     , caseReduceR     , caseReduceDataconR     , caseReduceLiteralR@@ -76,12 +76,12 @@         [ "let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e" ] .+ Commute .+ Shallow     , external "case-float" (promoteExprR caseFloatR :: RewriteH Core)         [ "case-float = case-float-app <+ case-float-case <+ case-float-let <+ case-float-cast" ]    .+ Commute .+ Shallow-    , external "case-unfloat" (promoteExprR caseUnfloatR :: RewriteH Core)-        [ "Unfloat a Case whatever the context." ]                             .+ Commute .+ Shallow .+ PreCondition-    , external "case-unfloat-args" (promoteExprR caseUnfloatArgsR :: 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-float-in" (promoteExprR caseFloatInR :: RewriteH Core)+        [ "Float in a Case whatever the context." ]                             .+ Commute .+ Shallow .+ PreCondition+    , external "case-float-in-args" (promoteExprR caseFloatInArgsR :: RewriteH Core)+        [ "Float in a Case whose alternatives are parallel applications of the same function." ] .+ Commute .+ Shallow .+ PreCondition+    -- , external "case-float-in-app" (promoteExprR caseFloatInApp :: RewriteH Core)+    --     [ "Float in a Case whose alternatives are applications of different functions with the same arguments." ] .+ Commute .+ Shallow .+ PreCondition     , external "case-reduce" (promoteExprR caseReduceR :: RewriteH Core)         [ "Case of Known Constructor"         , "case-reduce-datacon <+ case-reduce-literal" ]                     .+ Shallow .+ Eval@@ -142,7 +142,7 @@ ------------------------------------------------------------------------------  -- | (case s of alt1 -> e1; alt2 -> e2) v ==> case s of alt1 -> e1 v; alt2 -> e2 v-caseFloatAppR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseFloatAppR = prefixFailMsg "Case floating from App function failed: " $   do     captures    <- appT (map mkVarSet <$> caseAltVarsT) (arr freeVarsExpr) (flip (map . intersectVarSet))@@ -162,7 +162,7 @@  -- | @f (case s of alt1 -> e1; alt2 -> e2)@ ==> @case s of alt1 -> f e1; alt2 -> f e2@ --   Only safe if @f@ is strict.-caseFloatArgR :: (ExtendPath c Crumb, AddBindings c, BoundVars c, HasGlobalRdrEnv c)+caseFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, HasGlobalRdrEnv c)               => Maybe (CoreExpr, Maybe (Rewrite c HermitM CoreExpr)) -- ^ Maybe the function to float past, and maybe a proof of its strictness.               -> Rewrite c HermitM CoreExpr caseFloatArgR mfstrict = prefixFailMsg "Case floating from App argument failed: " $@@ -191,7 +191,7 @@ --   case s1 of --     alt11 -> case e11 of alt21 -> e21; alt22 -> e22 --     alt12 -> case e12 of alt21 -> e21; alt22 -> e22-caseFloatCaseR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseFloatCaseR = prefixFailMsg "Case floating from Case failed: " $   do     captures <- caseT (map mkVarSet <$> caseAltVarsT) idR mempty (const $ arr freeVarsAlt) (\ vss w () fvs -> map (intersectVarSet (delVarSet (unionVarSets fvs) w)) vss)@@ -206,7 +206,7 @@           (\ (Case s1 b1 _ alts1) b2 ty alts2 -> Case s1 b1 ty $ mapAlts (\s -> Case s b2 ty alts2) alts1)  -- | let v = case s of alt1 -> e1 in e ==> case s of alt1 -> let v = e1 in e-caseFloatLetR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseFloatLetR = prefixFailMsg "Case floating from Let failed: " $   do vs <- letNonRecT idR caseAltVarsT mempty (\ letVar caseVars () -> letVar `elem` concat caseVars)      let bdsAction = if not vs then idR else nonRecAllR idR alphaCaseR@@ -223,23 +223,23 @@  -- | caseFloatR = caseFloatAppR <+ caseFloatCaseR <+ caseFloatLetR <+ caseFloatCastR --   Note: does NOT include caseFloatArg-caseFloatR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseFloatR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseFloatR = setFailMsg "Unsuitable expression for Case floating." $     caseFloatAppR <+ caseFloatCaseR <+ caseFloatLetR <+ caseFloatCastR  ------------------------------------------------------------------------------ --- | Unfloat a Case whatever the context.-caseUnfloatR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr-caseUnfloatR = setFailMsg "Case unfloating failed." $-    caseUnfloatAppR <+ caseUnfloatArgsR+-- | Float in a Case whatever the context.+caseFloatInR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr+caseFloatInR = setFailMsg "Case floating in failed." $+    caseFloatInAppR <+ caseFloatInArgsR  -- | Unimplemented!-caseUnfloatAppR :: Monad m => Rewrite c m CoreExpr-caseUnfloatAppR = fail "caseUnfloatApp: TODO"+caseFloatInAppR :: Monad m => Rewrite c m CoreExpr+caseFloatInAppR = fail "caseFloatInApp: TODO" -caseUnfloatArgsR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr-caseUnfloatArgsR = prefixFailMsg "Case unfloating into arguments failed: " $+caseFloatInArgsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr+caseFloatInArgsR = prefixFailMsg "Case floating into arguments failed: " $                    withPatFailMsg (wrongExprForm "Case s v t alts") $     do Case s wild _ty alts <- idR        (vss, fs, argss) <- caseT mempty mempty mempty (\ _ -> altT mempty (\ _ -> idR) callT $ \ () vs (fn, args) -> (vs, fn, args))@@ -260,12 +260,12 @@ ------------------------------------------------------------------------------  -- | Inline the case scrutinee (if it is an identifier), and then perform case reduction.-caseReduceIdR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseReduceIdR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseReduceIdR = caseAllR inlineR idR idR (const idR) >>> caseReduceR  -- | Case of Known Constructor. --   Eliminate a case if the scrutinee is a data constructor or a literal.-caseReduceR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseReduceR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseReduceR = setFailMsg "Unsuitable expression for Case reduction." $               caseReduceDataconR <+ caseReduceLiteralR @@ -290,7 +290,7 @@  -- | Case of Known Constructor. --   Eliminate a case if the scrutinee is a data constructor.-caseReduceDataconR :: forall c. (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseReduceDataconR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseReduceDataconR = prefixFailMsg "Case reduction failed: " $                      withPatFailMsg (wrongExprForm "Case e v t alts")                      go@@ -358,12 +358,12 @@ -- for each occurance of the named variable. -- -- > caseSplitInline nm = caseSplit nm >>> anybuR (inlineName nm)-caseSplitInlineR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => TH.Name -> Rewrite c HermitM Core+caseSplitInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => TH.Name -> Rewrite c HermitM Core caseSplitInlineR nm = promoteR (caseSplitR nm) >>> anybuR (promoteExprR $ inlineNameR nm)  ------------------------------------------------------------------------------ -caseInlineBinderR :: forall c. (ExtendPath c Crumb, AddBindings c, ReadBindings c) => CaseBinderInlineOption -> Rewrite c HermitM CoreExpr+caseInlineBinderR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => CaseBinderInlineOption -> Rewrite c HermitM CoreExpr caseInlineBinderR opt =   do w <- caseWildIdT      caseAllR idR idR idR $ \ _ -> setFailMsg "no inlinable occurrences." $@@ -371,12 +371,12 @@                                       extractR $ anybuR (promoteExprR (configurableInlineR (CaseBinderOnly opt) (varIsOccurrenceOfT w depth)) :: Rewrite c HermitM Core)  -- | Inline the case wildcard binder as the case scrutinee everywhere in the case alternatives.-caseInlineScrutineeR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseInlineScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseInlineScrutineeR = prefixFailMsg "case-inline-scrutinee failed: " $                        caseInlineBinderR Scrutinee  -- | Inline the case wildcard binder as the case-alternative pattern everywhere in the case alternatives.-caseInlineAlternativeR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseInlineAlternativeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseInlineAlternativeR = prefixFailMsg "case-inline-alternative failed: " $                          caseInlineBinderR Alternative @@ -396,30 +396,30 @@                     return $ Case e w ty [(DEFAULT,[],head rhss)]  -- | In the case alternatives, fold any occurrences of the case alt patterns to the wildcard binder.-caseFoldWildR :: forall c.  (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseFoldWildR :: forall c.  (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseFoldWildR = prefixFailMsg "case-fold-wild failed: " $                 do w <- caseWildIdT                    caseAllR idR idR idR $ \ _ -> do depth <- varBindingDepthT w                                                     extractR $ anybuR (promoteExprR (foldVarR w (Just depth)) :: Rewrite c HermitM Core)  -- | A cleverer version of 'mergeCaseAlts' that first attempts to abstract out any occurrences of the alternative pattern using the wildcard binder.-caseMergeAltsWithWildR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseMergeAltsWithWildR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseMergeAltsWithWildR = prefixFailMsg "merge-case-alts-with-wild failed: " $                          withPatFailMsg (wrongExprForm "Case e w ty alts") $                          tryR caseFoldWildR >>> caseMergeAltsR  -- | Eliminate a case, inlining any occurrences of the case binder as the scrutinee.-caseElimInlineScrutineeR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseElimInlineScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseElimInlineScrutineeR = alphaCaseBinderR Nothing >>> tryR caseInlineScrutineeR >>> caseElimR  -- | Eliminate a case, merging the case alternatives into a single default alternative and inlining the case binder as the scrutinee (if possible).-caseElimMergeAltsR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseElimMergeAltsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseElimMergeAltsR = tryR caseFoldWildR >>> tryR caseMergeAltsR >>> caseElimInlineScrutineeR  ------------------------------------------------------------------------------  -- | Eliminate a case that corresponds to a pointless 'seq'.-caseElimSeqR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseElimSeqR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseElimSeqR = prefixFailMsg "case-elim-seq failed: " $                withPatFailMsg "not a seq case." $   do Case s w _ [(DEFAULT,[],rhs)] <- idR
src/HERMIT/Dictionary/Local/Let.hs view
@@ -11,9 +11,12 @@        , letElimR        , letNonRecElimR        , letRecElimR+       , progBindElimR+       , progBindNonRecElimR+       , progBindRecElimR          -- ** Let Introduction        , letIntroR-         -- ** Let Floating+         -- ** Let Floating Out        , letFloatAppR        , letFloatArgR        , letFloatLetR@@ -22,11 +25,11 @@        , letFloatCastR        , letFloatExprR        , letFloatTopR-         -- ** Let Unfloating-       , letUnfloatR-       , letUnfloatAppR-       , letUnfloatCaseR-       , letUnfloatLamR+         -- ** Let Floating In+       , letFloatInR+       , letFloatInAppR+       , letFloatInCaseR+       , letFloatInLamR          -- ** Miscallaneous        , reorderNonRecLetsR        , letTupleR@@ -102,14 +105,14 @@         [ "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" ]-    , external "let-unfloat" (promoteExprR letUnfloatR :: RewriteH Core)-        [ "Unfloat a let if possible." ]                                        .+ Commute .+ Shallow-    , external "let-unfloat-app" ((promoteExprR letUnfloatAppR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core)+    , external "let-float-in" (promoteExprR letFloatInR :: RewriteH Core)+        [ "Float-in a let if possible." ]                                        .+ Commute .+ Shallow+    , external "let-float-in-app" ((promoteExprR letFloatInAppR >+> anybuR (promoteExprR letElimR)) :: 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 letUnfloatCaseR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core)+    , external "let-float-in-case" ((promoteExprR letFloatInCaseR >+> anybuR (promoteExprR letElimR)) :: 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 "let-unfloat-lam" ((promoteExprR letUnfloatLamR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core)+    , external "let-float-in-lam" ((promoteExprR letFloatInLamR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core)         [ "let v = ev in \\ x -> e ==> \\ x -> let v = ev in e"         , "if v does not shadow x" ]                                            .+ Commute .+ Shallow     , external "reorder-lets" (promoteExprR . reorderNonRecLetsR :: [TH.Name] -> RewriteH Core)@@ -118,16 +121,26 @@     , external "let-tuple" (promoteExprR . letTupleR . show :: TH.Name -> RewriteH Core)         [ "Combine nested non-recursive lets into case of a tuple."         , "E.g. let {v1 = e1 ; v2 = e2 ; v3 = e3} in body ==> case (e1,e2,e3) of {(v1,v2,v3) -> body}" ] .+ Commute+    , external "prog-bind-elim" (promoteProgR progBindElimR :: RewriteH Core)+        [ "Remove unused top-level binding(s)."+        , "prog-bind-nonrec-elim <+ prog-bind-rec-elim" ]                       .+ Eval .+ Shallow+    , external "prog-bind-nonrec-elim" (promoteProgR progBindNonRecElimR :: RewriteH Core)+        [ "Remove unused top-level binding(s)."+        , "v = e : prog ==> prog, if v is not free in prog and not exported." ] .+ Eval .+ Shallow+    , external "prog-bind-rec-elim" (promoteProgR progBindRecElimR :: RewriteH Core)+        [ "Remove unused top-level binding(s)."+        , "v+ = e+ : prog ==> v* = e* : prog, where v* is a subset of v+ consisting"+        , "of vs that are free in prog or e+, or exported." ]                   .+ Eval .+ Shallow     ]  -------------------------------------------------------------------------------------------  -- | (let x = e1 in e2) ==> (e2[e1/x]), (x must not be free in e1)-letSubstR :: (AddBindings c, ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoreExpr+letSubstR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m CoreExpr letSubstR = letAllR (tryR recToNonrecR) idR >>> letNonRecSubstR  -- | As 'letNonRecSubstSafeR', but attempting to convert a singleton recursive binding to a non-recursive binding first.-letSubstSafeR :: (AddBindings c, ExtendPath c Crumb, ReadBindings c, MonadCatch m) => Rewrite c m CoreExpr+letSubstSafeR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, ReadBindings c, MonadCatch m) => Rewrite c m CoreExpr letSubstSafeR = letAllR (tryR recToNonrecR) idR >>> letNonRecSubstSafeR  -- | @Let (NonRec v e) body@ ==> @body[e/v]@@@ -135,11 +148,11 @@ letNonRecSubstR = prefixFailMsg "Let substitution failed: " $                   withPatFailMsg (wrongExprForm "Let (NonRec v rhs) body") $     do Let (NonRec v rhs) body <- idR-       return body >>> substExprR v rhs+       return (substCoreExpr v rhs body)  -- | Currently we always substitute types and coercions, and use a heuristic to decide whether to substitute expressions. --   This may need revisiting.-letNonRecSubstSafeR :: forall c m. (AddBindings c, ExtendPath c Crumb, ReadBindings c, MonadCatch m) => Rewrite c m CoreExpr+letNonRecSubstSafeR :: forall c m. (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, ReadBindings c, MonadCatch m) => Rewrite c m CoreExpr letNonRecSubstSafeR =     do Let (NonRec v _) _ <- idR        when (isId v) $ guardMsgM (safeSubstT v) "safety criteria not met."@@ -225,16 +238,41 @@           else if bs `subVarSet` liveBinders                  then fail "no dead binders to eliminate."                  else return $ Let (Rec $ filter ((`elemVarSet` liveBinders) . fst) bnds) body-  where-    chaseDependencies :: VarSet -> [(Var,VarSet)] -> VarSet-    chaseDependencies usedIds bsAndFrees = case partition ((`elemVarSet` usedIds) . fst) bsAndFrees of-                                              ([],_)        -> usedIds-                                              (used,unused) -> chaseDependencies (unionVarSets (usedIds : map snd used)) unused +progBindElimR :: MonadCatch m => Rewrite c m CoreProg+progBindElimR = progBindNonRecElimR <+ progBindRecElimR++progBindNonRecElimR :: MonadCatch m => Rewrite c m CoreProg+progBindNonRecElimR = withPatFailMsg (wrongExprForm "ProgCons (NonRec v e1) e2") $ do+    ProgCons (NonRec v _) p <- idR+    guardMsg (v `notElemVarSet` freeVarsProg p) "variable appears in program body."+    guardMsg (not (isExportedId v)) "variable is exported."+    return p++-- | Remove all unused bindings at the top level.+progBindRecElimR :: MonadCatch m => Rewrite c m CoreProg+progBindRecElimR = withPatFailMsg (wrongExprForm "ProgCons (Rec v e1) e2") $+    do ProgCons (Rec bnds) p <- idR+       let pFrees      = freeVarsProg p+           bsAndFrees  = map (second freeIdsExpr) bnds+           usedIds     = chaseDependencies pFrees bsAndFrees+           bs          = mkVarSet (map fst bsAndFrees)+           liveBinders = (bs `intersectVarSet` usedIds) `unionVarSet` (filterVarSet isExportedId bs)+       if isEmptyVarSet liveBinders+          then return p+          else if bs `subVarSet` liveBinders+                 then fail "no dead binders to eliminate."+                 else return $ ProgCons (Rec $ filter ((`elemVarSet` liveBinders) . fst) bnds) p++chaseDependencies :: VarSet -> [(Var,VarSet)] -> VarSet+chaseDependencies usedIds bsAndFrees = case partition ((`elemVarSet` usedIds) . fst) bsAndFrees of+                                          ([],_)        -> usedIds+                                          (used,unused) -> chaseDependencies (unionVarSets (usedIds : map snd used)) unused+ -------------------------------------------------------------------------------------------  -- | @let v = ev in e@ ==> @case ev of v -> e@-letToCaseR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+letToCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr letToCaseR = prefixFailMsg "Converting Let to Case failed: " $             withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $   do Let (NonRec v ev) _ <- idR@@ -246,7 +284,7 @@ -------------------------------------------------------------------------------------------  -- | @(let v = ev in e) x@ ==> @let v = ev in e x@-letFloatAppR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+letFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr letFloatAppR = prefixFailMsg "Let floating from App function failed: " $                withPatFailMsg (wrongExprForm "App (Let bnds body) e") $   do App (Let bnds body) e <- idR@@ -256,7 +294,7 @@         else appAllR (alphaLetVarsR $ varSetElems vs) idR >>> letFloatAppR  -- | @f (let v = ev in e)@ ==> @let v = ev in f e@-letFloatArgR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+letFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr letFloatArgR = prefixFailMsg "Let floating from App argument failed: " $                withPatFailMsg (wrongExprForm "App f (Let bnds body)") $   do App f (Let bnds body) <- idR@@ -266,7 +304,7 @@         else appAllR idR (alphaLetVarsR $ varSetElems vs) >>> letFloatArgR  -- | @let v = (let bds in e1) in e2@ ==> @let bds in let v = e1 in e2@-letFloatLetR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+letFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr letFloatLetR = prefixFailMsg "Let floating from Let failed: " $                withPatFailMsg (wrongExprForm "Let (NonRec v (Let bds e1)) e2") $   do Let (NonRec v (Let bds e1)) e2 <- idR@@ -278,7 +316,7 @@ -- | @(\ v -> let binds in e2)@  ==>  @let binds in (\ v1 -> e2)@ --   Fails if @v@ occurs in the RHS of @binds@. --   If @v@ is shadowed in binds, then @v@ will be alpha-renamed.-letFloatLamR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+letFloatLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr letFloatLamR = prefixFailMsg "Let floating from Lam failed: " $                withPatFailMsg (wrongExprForm "Lam v1 (Let bds body)") $   do Lam v (Let binds body) <- idR@@ -291,7 +329,7 @@  -- | @case (let bnds in e) of wild alts@ ==> @let bnds in (case e of wild alts)@ --   Fails if any variables bound in @bnds@ occurs in @alts@.-letFloatCaseR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+letFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr letFloatCaseR = prefixFailMsg "Let floating from Case failed: " $                 withPatFailMsg (wrongExprForm "Case (Let bnds e) w ty alts") $   do Case (Let bnds e) w ty alts <- idR@@ -308,12 +346,12 @@      return $ Let bnds (Cast e co)  -- | Float a 'Let' through an expression, whatever the context.-letFloatExprR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr+letFloatExprR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr letFloatExprR = setFailMsg "Unsuitable expression for Let floating." $                letFloatArgR <+ letFloatAppR <+ letFloatLetR <+ letFloatLamR <+ letFloatCaseR <+ letFloatCastR  -- | @'ProgCons' ('NonRec' v ('Let' bds e)) p@ ==> @'ProgCons' bds ('ProgCons' ('NonRec' v e) p)@-letFloatTopR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreProg+letFloatTopR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreProg letFloatTopR = prefixFailMsg "Let floating to top level failed: " $                withPatFailMsg (wrongExprForm "NonRec v (Let bds e) `ProgCons` p") $                do ProgCons (NonRec v (Let bds e)) p <- idR@@ -326,34 +364,35 @@  ------------------------------------------------------------------------------------------- --- | Unfloat a 'Let' if possible.-letUnfloatR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr-letUnfloatR = letUnfloatCaseR <+ letUnfloatAppR <+ letUnfloatLamR+-- | Float in a 'Let' if possible.+letFloatInR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) => Rewrite c HermitM CoreExpr+letFloatInR = letFloatInCaseR <+ letFloatInAppR <+ letFloatInLamR  -- | @let v = ev in case s of p -> e@ ==> @case (let v = ev in s) of p -> let v = ev in e@, --   if @v@ does not shadow a pattern binder in @p@-letUnfloatCaseR :: MonadCatch m => Rewrite c m CoreExpr-letUnfloatCaseR = prefixFailMsg "Let unfloating from case failed: " $+letFloatInCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) => Rewrite c HermitM CoreExpr+letFloatInCaseR = prefixFailMsg "Let floating in to case failed: " $                   withPatFailMsg (wrongExprForm "Let bnds (Case s w ty alts)") $   do Let bnds (Case s w ty alts) <- idR      let bs = bindVars bnds          captured = bs `intersect` (w : concatMap altVars alts)      guardMsg (null captured) "let bindings would capture case pattern bindings."-     let unbound = mkVarSet bs `intersectVarSet` tyVarsOfType ty+     let unbound = mkVarSet bs `intersectVarSet` (tyVarsOfType ty `unionVarSet` freeVarsVar w)      guardMsg (isEmptyVarSet unbound) "type variables in case signature would become unbound."-     return $ Case (Let bnds s) w ty $ mapAlts (Let bnds) alts+     return (Case (Let bnds s) w ty alts) >>> caseAllR idR idR idR (\_ -> altAllR idR (\_ -> idR) (arr (Let bnds) >>> alphaLetR))  -- | @let v = ev in f a@ ==> @(let v = ev in f) (let v = ev in a)@-letUnfloatAppR :: MonadCatch m => Rewrite c m CoreExpr-letUnfloatAppR = prefixFailMsg "Let unfloating from app failed: " $+letFloatInAppR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) => Rewrite c HermitM CoreExpr+letFloatInAppR = prefixFailMsg "Let floating in to app failed: " $                 withPatFailMsg (wrongExprForm "Let bnds (App e1 e2)") $   do Let bnds (App e1 e2) <- idR-     return $ App (Let bnds e1) (Let bnds e2)+     lhs <- return (Let bnds e1) >>> alphaLetR+     return $ App lhs (Let bnds e2)  -- | @let v = ev in \ x -> e@ ==> @\x -> let v = ev in e@ --   if @v@ does not shadow @x@-letUnfloatLamR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr-letUnfloatLamR = prefixFailMsg "Let unfloating from lambda failed: " $+letFloatInLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr+letFloatInLamR = prefixFailMsg "Let floating in to lambda failed: " $                 withPatFailMsg (wrongExprForm "Let bnds (Lam v e)") $   do Let bnds (Lam v e) <- idR      safe <- letT (arr bindVars) lamVarT $ flip notElem
src/HERMIT/Dictionary/Navigation.hs view
@@ -167,19 +167,19 @@ -----------------------------------------------------------------------  -- | Find all possible targets of 'occurrenceOfT'.-occurrenceOfTargetsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet+occurrenceOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet occurrenceOfTargetsT = allT $ crushbuT (arr varOccurrence >>> projectT >>^ unitVarSet)  -- | Find all possible targets of 'bindingOfT'.-bindingOfTargetsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet+bindingOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet bindingOfTargetsT = allT $ crushbuT (arr binders)  -- | Find all possible targets of 'bindingGroupOfT'.-bindingGroupOfTargetsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet+bindingGroupOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet bindingGroupOfTargetsT = allT $ crushbuT (promoteBindT $ arr (mkVarSet . bindVars))  -- | Find all possible targets of 'rhsOfT'.-rhsOfTargetsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet+rhsOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet rhsOfTargetsT = crushbuT (promoteBindT (arr binderBind) <+ promoteDefT (arr binderDef))  -----------------------------------------------------------------------
src/HERMIT/Dictionary/Query.hs view
@@ -12,6 +12,7 @@ import Control.Arrow  import Data.List (intercalate)+import qualified Data.Map as Map  import HERMIT.Context import HERMIT.Core@@ -52,7 +53,11 @@               con      =   "Constructor: " ++ coreTCConstructor coreTC               pa       =   "Path:     " ++ showCrumbs (snocPathToPath $ absPath c)               children =   "Children: " ++ showCrumbs crumbs-              bds      =   "Local bindings in scope: " ++ showVarSet (boundVars c)+              bds      =   "Local bindings in scope: " ++ concat+                                [ "\n  " ++ var2String k ++  " : " ++ hermitBindingSummary hbs+                                | (k,hbs) <- Map.toList (hermitBindings c)+                                ]+--               showVarSet (boundVars c)               freevars = [ "Free local identifiers:  " ++ showVarSet (filterVarSet isLocalId fvs)                          , "Free global identifiers: " ++ showVarSet (filterVarSet isGlobalId fvs)                          , "Free type variables:     " ++ showVarSet (filterVarSet isTyVar fvs)@@ -63,6 +68,8 @@                                                         in [(if isKind tyK then "Kind:        " else "Type:        ") ++ showPpr dynFlags tyK] ++                                                            case e of                                                              Var i -> [ ""+                                                                      , "OccName:                  " ++ getOccString i+                                                                      , "Unique:                   " ++ show (getUnique i)                                                                       , "Identifier arity:         " ++ show (arityOf c i)                                                                       , "Identifier binding depth: " ++ runKureM show id (lookupHermitBindingDepth i c) ]                                                              _     -> []@@ -159,7 +166,7 @@      guardMsg (core1 `coreAlphaEq` core2) "core fragments are not alpha-equivalent."  -- | Compare the definitions of two identifiers for alpha-equality.-compareBoundIdsT :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Id -> Id -> Translate c HermitM x ()+compareBoundIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Id -> Id -> Translate c HermitM x () compareBoundIdsT i1 i2 =   do e1 <-                       fst ^<< getUnfoldingT AllBinders <<< return i1      e2 <- replaceVarR i2 i1 <<< fst ^<< getUnfoldingT AllBinders <<< return i2@@ -167,7 +174,7 @@      guardMsg (e1 `exprAlphaEq` e2) "bindings are not alpha-equivalent."  -- | Compare the definitions of the two named identifiers for alpha-equality.-compareBoundIds :: (ExtendPath c Crumb, AddBindings c, ReadBindings c, HasGlobalRdrEnv c) => TH.Name -> TH.Name -> Translate c HermitM x ()+compareBoundIds :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasGlobalRdrEnv c) => TH.Name -> TH.Name -> Translate c HermitM x () compareBoundIds nm1 nm2 = do i1 <- findIdT nm1                              i2 <- findIdT nm2                              compareBoundIdsT i1 i2
src/HERMIT/Dictionary/Undefined.hs view
@@ -128,7 +128,7 @@ ------------------------------------------------------------------------------------------------------  -- | undefinedExprR = undefinedAppR <+ undefinedLamR <+ undefinedLetR <+ undefinedCastR <+ undefinedTickR <+ undefinedCaseR-undefinedExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+undefinedExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr undefinedExprR = setFailMsg "undefined-expr failed."                    (undefinedAppR <+ undefinedLamR <+ undefinedLetR <+ undefinedCastR <+ undefinedTickR <+ undefinedCaseR) @@ -141,13 +141,13 @@                    replaceWithUndefinedR  -- | @(\ v -> undefined ty1)@ ==> @undefined ty2@  (where v is not a 'TyVar')-undefinedLamR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+undefinedLamR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr undefinedLamR = prefixFailMsg "undefined-lam failed: " $                 do lamT successT isUndefinedValT (<>)                    replaceWithUndefinedR  -- | let bds in (undefined ty) ==> undefined ty-undefinedLetR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+undefinedLetR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr undefinedLetR = prefixFailMsg "undefined-let failed: " $                 do letT successT isUndefinedValT (<>)                    replaceWithUndefinedR@@ -165,17 +165,17 @@                    replaceWithUndefinedR  -- | undefinedCaseR = undefinedCaseScrutineeR <+ undefinedCaseAltsR-undefinedCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseR = setFailMsg "undefined-case failed" (undefinedCaseScrutineeR <+ undefinedCaseAltsR)  -- | case (undefined ty) of alts ==> undefined ty-undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseScrutineeR = prefixFailMsg "undefined-case failed: " $                  do caseT isUndefinedValT successT successT (const successT) (\ _ _ _ _ -> ())                     replaceWithUndefinedR  -- | case e of {pat_1 -> undefined ty ; pat_2 -> undefined ty ; ... ; pat_n -> undefined ty} ==> undefined ty-undefinedCaseAltsR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseAltsR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseAltsR = prefixFailMsg "undefined-case-alts failed: " $                      do caseAltT successT successT successT (const (successT,const successT,isUndefinedValT)) (\ _ _ _ _ -> ())                         replaceWithUndefinedR
src/HERMIT/Dictionary/Unfold.hs view
@@ -16,6 +16,7 @@ import Control.Arrow import Control.Monad +import Data.List (intercalate) import qualified Data.Map as Map  import qualified Language.Haskell.TH as TH@@ -89,26 +90,26 @@ -- | A more powerful 'inline'. Matches two cases: --      Var ==> inlines --      App ==> inlines the head of the function call for the app tree-unfoldR :: forall c. (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+unfoldR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr unfoldR = prefixFailMsg "unfold failed: " (go >>> cleanupUnfoldR)     where go :: Rewrite c HermitM CoreExpr           go = inlineR <+ appAllR go idR -unfoldPredR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => (Id -> [CoreExpr] -> Bool) -> Rewrite c HermitM CoreExpr+unfoldPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => (Id -> [CoreExpr] -> Bool) -> Rewrite c HermitM CoreExpr unfoldPredR p = callPredT p >> unfoldR -unfoldNameR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => TH.Name -> Rewrite c HermitM CoreExpr+unfoldNameR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => TH.Name -> Rewrite c HermitM CoreExpr unfoldNameR nm = prefixFailMsg ("unfold '" ++ show nm ++ " failed: ") (callNameT nm >> unfoldR) -unfoldNamesR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => [TH.Name] -> Rewrite c HermitM CoreExpr+unfoldNamesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [TH.Name] -> Rewrite c HermitM CoreExpr unfoldNamesR []  = fail "unfold-names failed: no names given." unfoldNamesR nms = setFailMsg "unfold-names failed." $                    orR (map unfoldNameR nms) -unfoldSaturatedR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+unfoldSaturatedR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr unfoldSaturatedR = callSaturatedT >> unfoldR -specializeR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+specializeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr specializeR = unfoldPredR (const $ all isTyCoArg)  -- NOTE: Using a Rewrite because of the way the Kernel is set up.@@ -133,14 +134,16 @@  -- | Apply a stashed definition (like inline, but looks in stash instead of context). unfoldStashR :: ReadBindings c => String -> Rewrite c HermitM CoreExpr-unfoldStashR label = setFailMsg "Inlining stashed definition failed: " $+unfoldStashR label = prefixFailMsg "Inlining stashed definition failed: " $                      withPatFailMsg (wrongExprForm "Var v") $     do (c, Var v) <- exposeT        constT $ do Def i rhs <- lookupDef label+                   dflags <- getDynFlags                    if idName i == idName v -- TODO: Is there a reason we're not just using equality on Id?-                   then if all (inScope c) $ varSetElems $ freeVarsExpr rhs-                          then return rhs-                          else fail "some free variables in stashed definition are no longer in scope."+                   then let fvars = varSetElems $ localFreeVarsExpr rhs+                        in if all (inScope c) fvars+                           then return rhs+                           else fail $ "free variables " ++ intercalate "," (map (showPpr dflags) (filter (not . inScope c) fvars)) ++ " in stashed definition are no longer in scope."                    else fail $ "stashed definition applies to " ++ var2String i ++ " not " ++ var2String v  showStashT :: Injection CoreDef a => PrettyC -> PrettyH a -> Translate c HermitM a DocH
src/HERMIT/External.hs view
@@ -9,6 +9,8 @@        , externName        , externDyn        , externHelp+       , externTypeString+       , externTypeArgResString        , Dictionary        , toDictionary        , toHelp@@ -52,6 +54,7 @@ import Data.Map hiding (map) import Data.Dynamic import Data.List+import Data.Typeable.Internal (TypeRep(..), funTc)  import qualified Language.Haskell.TH as TH @@ -250,18 +253,39 @@ toHelp = fromListWith (++) . map toH   where          toH :: External -> (ExternalName,ExternalHelp)-         toH e = (externName e, spaceout (externName e ++ " :: " ++ fixup (show (dynTypeRep (externDyn e))))+         toH e = (externName e, spaceout (externName e ++ " :: " ++ externTypeString e)                                          (show (externTags e)) : externHelp e)           spaceout xs ys = xs ++ replicate (width - (length xs + length ys)) ' ' ++ ys           width = 78 -         fixup :: String -> String-         fixup xs | "Box" `isPrefixOf` xs = fixup (drop 3 xs)-         fixup (x:xs)                     = x : fixup xs-         fixup []                         = []+-- | Get a string representation of the (monomorphic) type of an 'External'+externTypeString :: External -> String+externTypeString = deBoxify . show . dynTypeRep . externDyn +-- | Remove the word 'Box' from a string.+deBoxify :: String -> String+deBoxify xs | "Box" `isPrefixOf` xs = deBoxify (drop 3 xs)+deBoxify (x:xs)                     = x : deBoxify xs+deBoxify []                         = []++externTypeArgResString :: External -> ([String], String)+externTypeArgResString e = (map (deBoxify . show) aTys, deBoxify (show rTy))+    where (aTys, rTy) = splitExternFunType e++splitExternFunType :: External -> ([TypeRep], TypeRep)+splitExternFunType = splitFunTyArgs . dynTypeRep . externDyn++splitFunTyArgs :: TypeRep -> ([TypeRep], TypeRep)+splitFunTyArgs tr = case splitFunTyMaybe tr of+                        Nothing -> ([], tr)+                        Just (a, r) -> let (as, r') = splitFunTyArgs r+                                         in (a:as, r')++splitFunTyMaybe :: TypeRep -> Maybe (TypeRep, TypeRep)+splitFunTyMaybe (TypeRep _ tc [a,r]) | tc == funTc = Just (a,r)+splitFunTyMaybe _ = Nothing  -----------------------------------------------------------------
src/HERMIT/GHC.hs view
@@ -26,6 +26,7 @@     , occurAnalyseExpr     , isKind     , isLiftedTypeKindCon+    , exprType -- TODO: remove once we can use GHC's exprType again #if __GLASGOW_HASKELL__ > 706     , coAxiomName     , CoAxiom.BranchIndex@@ -36,28 +37,40 @@     , varSetToStrings     , showVarSet     , Pair(..)+    , bndrRuleAndUnfoldingVars #if __GLASGOW_HASKELL__ <= 706     , Control.Monad.IO.Class.liftIO #endif     ) where  #if __GLASGOW_HASKELL__ <= 706+-- GHC 7.6 import qualified Control.Monad.IO.Class import qualified MonadUtils (MonadIO,liftIO)-import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, liftIO)+import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, exprType, liftIO) #else+#if __GLASGOW_HASKELL__ < 708+-- TODO: remove this case once 7.8 comes out, only here because+-- my HEAD installs are pre-8522 patch, and I don't want to rebuild+-- on four different machines just yet.+-- GHC 7.7.XXX+import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, exprType) -- we hide these so that they don't get inadvertently used.  See Core.hs+#else+-- GHC 7.8 import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars) -- we hide these so that they don't get inadvertently used.  See Core.hs #endif+#endif  -- hacky direct GHC imports import Convert (thRdrNameGuesses)-import TysPrim (alphaTyVars)-import TypeRep (Type(..),TyLit(..))-import Panic (GhcException(ProgramError), throwGhcException) import CoreArity import Kind (isKind,isLiftedTypeKindCon) import OccurAnal (occurAnalyseExpr) import Pair (Pair(..))+import Panic (GhcException(ProgramError), throwGhcException)+import PprCore (pprCoreExpr)+import TypeRep (Type(..),TyLit(..))+import TysPrim (alphaTy, alphaTyVars)  #if __GLASGOW_HASKELL__ <= 706 import Data.Maybe (isJust)@@ -70,6 +83,32 @@  -------------------------------------------------------------------------- +#if __GLASGOW_HASKELL < 708+-- Note: once 7.8 comes out, change condition above to "<= 706"+exprType :: CoreExpr -> Type+-- ^ Recover the type of a well-typed Core expression. Fails when+-- applied to the actual 'CoreSyn.Type' expression as it cannot+-- really be said to have a type+exprType (Var var)           = idType var+exprType (Lit lit)           = literalType lit+exprType (Coercion co)       = coercionType co+exprType (Let bind body)+  | NonRec tv rhs <- bind+  , Type ty <- rhs           = substTyWith [tv] [ty] (exprType body)+  | otherwise                = exprType body+exprType (Case _ _ ty _)     = ty+exprType (Cast _ co)         = pSnd (coercionKind co)+exprType (Tick _ e)          = exprType e+exprType (Lam binder expr)   = mkPiType binder (exprType expr)+exprType e@(App _ _)+  = case collectArgs e of+        (fun, args) -> applyTypeToArgs e (exprType fun) args++exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy+#endif++--------------------------------------------------------------------------+ -- | Convert a 'VarSet' to a list of user-readable strings. varSetToStrings :: VarSet -> [String] varSetToStrings = map var2String . varSetElems@@ -225,3 +264,10 @@ #endif  --------------------------------------------------------------------------++-- This function is copied from GHC, which defines but doesn't expose it.+-- A 'let' can bind a type variable, and idRuleVars assumes+-- it's seeing an Id. This function tests first.+bndrRuleAndUnfoldingVars :: Var -> VarSet+bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet+                           | otherwise = idRuleAndUnfoldingVars v
src/HERMIT/Kure.hs view
@@ -110,6 +110,7 @@ type PathH          = Path Crumb  -- I find it annoying that Applicative is not a superclass of Monad.+-- This causes a warning now, and will need to be CPP'd for 7.10 (<$>) :: Monad m => (a -> b) -> m a -> m b (<$>) = liftM {-# INLINE (<$>) #-}@@ -121,7 +122,7 @@ ---------------------------------------------------------------------  -- | Walking over modules, programs, binding groups, definitions, expressions and case alternatives.-instance (ExtendPath c Crumb, AddBindings c) => Walker c Core where+instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Walker c Core where    allR :: forall m. MonadCatch m => Rewrite c m Core -> Rewrite c m Core   allR r = prefixFailMsg "allR failed: " $@@ -174,7 +175,7 @@ ---------------------------------------------------------------------  -- | Walking over types (only).-instance (ExtendPath c Crumb, AddBindings c) => Walker c Type where+instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Walker c Type where    allR :: MonadCatch m => Rewrite c m Type -> Rewrite c m Type   allR r = prefixFailMsg "allR failed: " $@@ -188,7 +189,7 @@ ---------------------------------------------------------------------  -- | Walking over coercions (only).-instance (ExtendPath c Crumb, AddBindings c) => Walker c Coercion where+instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Walker c Coercion where    allR :: MonadCatch m => Rewrite c m Coercion -> Rewrite c m Coercion   allR r = prefixFailMsg "allR failed: " $@@ -211,7 +212,7 @@ ---------------------------------------------------------------------  -- | Walking over types and coercions.-instance (ExtendPath c Crumb, AddBindings c) => Walker c TyCo where+instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Walker c TyCo where    allR :: forall m. MonadCatch m => Rewrite c m TyCo -> Rewrite c m TyCo   allR r = prefixFailMsg "allR failed: " $@@ -245,7 +246,7 @@ ---------------------------------------------------------------------  -- | Walking over modules, programs, binding groups, definitions, expressions and case alternatives.-instance (ExtendPath c Crumb, AddBindings c) => Walker c CoreTC where+instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Walker c CoreTC where    allR :: forall m. MonadCatch m => Rewrite c m CoreTC -> Rewrite c m CoreTC   allR r = prefixFailMsg "allR failed: " $@@ -318,24 +319,24 @@ {-# INLINE progNilT #-}  -- | Translate a program of the form: ('CoreBind' @:@ 'CoreProg')-progConsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind a1 -> Translate c m CoreProg a2 -> (a1 -> a2 -> b) -> Translate c m CoreProg b+progConsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind a1 -> Translate c m CoreProg a2 -> (a1 -> a2 -> b) -> Translate c m CoreProg b progConsT t1 t2 f = translate $ \ c -> \case                                           ProgCons bd p -> f <$> apply t1 (c @@ ProgCons_Head) bd <*> apply t2 (addBindingGroup bd c @@ ProgCons_Tail) p                                           _             -> fail "not a non-empty program." {-# INLINE progConsT #-}  -- | Rewrite all children of a program of the form: ('CoreBind' @:@ 'CoreProg')-progConsAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg+progConsAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg progConsAllR r1 r2 = progConsT r1 r2 ProgCons {-# INLINE progConsAllR #-}  -- | Rewrite any children of a program of the form: ('CoreBind' @:@ 'CoreProg')-progConsAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg+progConsAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg progConsAnyR r1 r2 = unwrapAnyR $ progConsAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE progConsAnyR #-}  -- | Rewrite one child of a program of the form: ('CoreBind' @:@ 'CoreProg')-progConsOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg+progConsOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg progConsOneR r1 r2 = unwrapOneR $  progConsAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE progConsOneR #-} @@ -365,7 +366,7 @@   -- | Translate a binding group of the form: @Rec@ ['CoreDef']-recT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a) -> ([a] -> b) -> Translate c m CoreBind b+recT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a) -> ([a] -> b) -> Translate c m CoreBind b recT t f = translate $ \ c -> \case          Rec bds -> -- The group is recursive, so we add all other bindings in the group to the context (excluding the one under consideration).                     f <$> sequence [ apply (t n) (addDefBindingsExcept n bds c @@ Rec_Def n) (Def i e) -- here we convert from (Id,CoreExpr) to CoreDef@@ -375,63 +376,63 @@ {-# INLINE recT #-}  -- | Rewrite all children of a binding group of the form: @Rec@ ['CoreDef']-recAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind+recAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind recAllR rs = recT rs defsToRecBind {-# INLINE recAllR #-}  -- | Rewrite any children of a binding group of the form: @Rec@ ['CoreDef']-recAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind+recAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind recAnyR rs = unwrapAnyR $ recAllR (wrapAnyR . rs) {-# INLINE recAnyR #-}  -- | Rewrite one child of a binding group of the form: @Rec@ ['CoreDef']-recOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind+recOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind recOneR rs = unwrapOneR $ recAllR (wrapOneR . rs) {-# INLINE recOneR #-}  ---------------------------------------------------------------------  -- | Translate a recursive definition of the form: @Def@ 'Id' 'CoreExpr'-defT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Id a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreDef b+defT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Id a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreDef b defT t1 t2 f = translate $ \ c (Def i e) -> f <$> apply t1 (c @@ Def_Id) i <*> apply t2 (addDefBinding i c @@ Def_RHS) e {-# INLINE defT #-}  -- | Rewrite all children of a recursive definition of the form: @Def@ 'Id' 'CoreExpr'-defAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef+defAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef defAllR r1 r2 = defT r1 r2 Def {-# INLINE defAllR #-}  -- | Rewrite any children of a recursive definition of the form: @Def@ 'Id' 'CoreExpr'-defAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef+defAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef defAnyR r1 r2 = unwrapAnyR (defAllR (wrapAnyR r1) (wrapAnyR r2)) {-# INLINE defAnyR #-}  -- | Rewrite one child of a recursive definition of the form: @Def@ 'Id' 'CoreExpr'-defOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef+defOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef defOneR r1 r2 = unwrapOneR (defAllR (wrapOneR r1) (wrapOneR r2)) {-# INLINE defOneR #-}  ---------------------------------------------------------------------  -- | Translate a case alternative of the form: ('AltCon', ['Var'], 'CoreExpr')-altT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m AltCon a1 -> (Int -> Translate c m Var a2) -> Translate c m CoreExpr a3 -> (a1 -> [a2] -> a3 -> b) -> Translate c m CoreAlt b+altT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m AltCon a1 -> (Int -> Translate c m Var a2) -> Translate c m CoreExpr a3 -> (a1 -> [a2] -> a3 -> b) -> Translate c m CoreAlt b altT t1 ts t2 f = translate $ \ c (con,vs,e) -> f <$> apply t1 (c @@ Alt_Con) con                                                   <*> sequence [ apply (ts n) (c @@ Alt_Var n) v | (v,n) <- zip vs [1..] ]                                                   <*> apply t2 (addAltBindings vs c @@ Alt_RHS) e {-# INLINE altT #-}  -- | Rewrite all children of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr')-altAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt+altAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt altAllR r1 rs r2 = altT r1 rs r2 (,,) {-# INLINE altAllR #-}  -- | Rewrite any children of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr')-altAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt+altAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt altAnyR r1 rs r2 = unwrapAnyR (altAllR (wrapAnyR r1) (wrapAnyR . rs) (wrapAnyR r2)) {-# INLINE altAnyR #-}  -- | Rewrite one child of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr')-altOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt+altOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt altOneR r1 rs r2 = unwrapOneR (altAllR (wrapOneR r1) (wrapOneR . rs) (wrapOneR r2)) {-# INLINE altOneR #-} @@ -487,30 +488,30 @@   -- | Translate an expression of the form: @Lam@ 'Var' 'CoreExpr'-lamT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b+lamT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b lamT t1 t2 f = translate $ \ c -> \case                                      Lam v e -> f <$> apply t1 (c @@ Lam_Var) v <*> apply t2 (addLambdaBinding v c @@ Lam_Body) e                                      _       -> fail "not a lambda." {-# INLINE lamT #-}  -- | Rewrite all children of an expression of the form: @Lam@ 'Var' 'CoreExpr'-lamAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+lamAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr lamAllR r1 r2 = lamT r1 r2 Lam {-# INLINE lamAllR #-}  -- | Rewrite any children of an expression of the form: @Lam@ 'Var' 'CoreExpr'-lamAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+lamAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr lamAnyR r1 r2 = unwrapAnyR $ lamAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE lamAnyR #-}  -- | Rewrite one child of an expression of the form: @Lam@ 'Var' 'CoreExpr'-lamOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+lamOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr lamOneR r1 r2 = unwrapOneR $ lamAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE lamOneR #-}   -- | Translate an expression of the form: @Let@ 'CoreBind' 'CoreExpr'-letT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b+letT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b letT t1 t2 f = translate $ \ c -> \case         Let bds e -> -- Note we use the *original* context for the binding group.                      -- If the bindings are recursive, they will be added to the context by recT.@@ -519,23 +520,23 @@ {-# INLINE letT #-}  -- | Rewrite all children of an expression of the form: @Let@ 'CoreBind' 'CoreExpr'-letAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letAllR r1 r2 = letT r1 r2 Let {-# INLINE letAllR #-}  -- | Rewrite any children of an expression of the form: @Let@ 'CoreBind' 'CoreExpr'-letAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letAnyR r1 r2 = unwrapAnyR $ letAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE letAnyR #-}  -- | Rewrite one child of an expression of the form: @Let@ 'CoreBind' 'CoreExpr'-letOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letOneR r1 r2 = unwrapOneR $ letAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE letOneR #-}   -- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']-caseT :: (ExtendPath c Crumb, AddBindings c, Monad m)+caseT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m)       => Translate c m CoreExpr e       -> Translate c m Id w       -> Translate c m Type ty@@ -553,7 +554,7 @@ {-# INLINE caseT #-}  -- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']-caseAllR :: (ExtendPath c Crumb, AddBindings c, Monad m)+caseAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m)          => Rewrite c m CoreExpr          -> Rewrite c m Id          -> Rewrite c m Type@@ -563,7 +564,7 @@ {-# INLINE caseAllR #-}  -- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']-caseAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m)+caseAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m)          => Rewrite c m CoreExpr          -> Rewrite c m Id          -> Rewrite c m Type@@ -573,7 +574,7 @@ {-# INLINE caseAnyR #-}  -- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']-caseOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m)+caseOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m)          => Rewrite c m CoreExpr          -> Rewrite c m Id          -> Rewrite c m Type@@ -659,19 +660,19 @@ -- Some composite congruence combinators to export.  -- | Translate a definition of the form @NonRec 'Var' 'CoreExpr'@ or @Def 'Id' 'CoreExpr'@-defOrNonRecT :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m g b+defOrNonRecT :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m g b defOrNonRecT t1 t2 f = promoteBindT (nonRecT t1 t2 f)                     <+ promoteDefT  (defT    t1 t2 f) {-# INLINE defOrNonRecT #-}  -- | Rewrite all children of a definition of the form @NonRec 'Var' 'CoreExpr'@ or @Def 'Id' 'CoreExpr'@-defOrNonRecAllR :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m g+defOrNonRecAllR :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m g defOrNonRecAllR r1 r2 = promoteBindR (nonRecAllR r1 r2)                      <+ promoteDefR  (defAllR    r1 r2) {-# INLINE defOrNonRecAllR #-}  -- | Rewrite any children of a definition of the form @NonRec 'Var' 'CoreExpr'@ or @Def 'Id' 'CoreExpr'@-defOrNonRecAnyR :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m g+defOrNonRecAnyR :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m g defOrNonRecAnyR r1 r2 = unwrapAnyR $ defOrNonRecAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE defOrNonRecAnyR #-} @@ -682,154 +683,154 @@   -- | Translate a binding group of the form: @Rec@ [('Id', 'CoreExpr')]-recDefT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> ([(a1,a2)] -> b) -> Translate c m CoreBind b+recDefT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> ([(a1,a2)] -> b) -> Translate c m CoreBind b recDefT ts = recT (\ n -> uncurry defT (ts n) (,)) {-# INLINE recDefT #-}  -- | Rewrite all children of a binding group of the form: @Rec@ [('Id', 'CoreExpr')]-recDefAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind+recDefAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind recDefAllR rs = recAllR (\ n -> uncurry defAllR (rs n)) {-# INLINE recDefAllR #-}  -- | Rewrite any children of a binding group of the form: @Rec@ [('Id', 'CoreExpr')]-recDefAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind+recDefAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind recDefAnyR rs = recAnyR (\ n -> uncurry defAnyR (rs n)) {-# INLINE recDefAnyR #-}  -- | Rewrite one child of a binding group of the form: @Rec@ [('Id', 'CoreExpr')]-recDefOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind+recDefOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind recDefOneR rs = recOneR (\ n -> uncurry defOneR (rs n)) {-# INLINE recDefOneR #-}   -- | Translate a program of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'-consNonRecT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> Translate c m CoreProg a3 -> (a1 -> a2 -> a3 -> b) -> Translate c m CoreProg b+consNonRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> Translate c m CoreProg a3 -> (a1 -> a2 -> a3 -> b) -> Translate c m CoreProg b consNonRecT t1 t2 t3 f = progConsT (nonRecT t1 t2 (,)) t3 (uncurry f) {-# INLINE consNonRecT #-}  -- | Rewrite all children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'-consNonRecAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consNonRecAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg consNonRecAllR r1 r2 r3 = progConsAllR (nonRecAllR r1 r2) r3 {-# INLINE consNonRecAllR #-}  -- | Rewrite any children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'-consNonRecAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consNonRecAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg consNonRecAnyR r1 r2 r3 = progConsAllR (nonRecAnyR r1 r2) r3 {-# INLINE consNonRecAnyR #-}  -- | Rewrite one child of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'-consNonRecOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consNonRecOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg consNonRecOneR r1 r2 r3 = progConsAllR (nonRecOneR r1 r2) r3 {-# INLINE consNonRecOneR #-}   -- | Translate an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'-consRecT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a1) -> Translate c m CoreProg a2 -> ([a1] -> a2 -> b) -> Translate c m CoreProg b+consRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a1) -> Translate c m CoreProg a2 -> ([a1] -> a2 -> b) -> Translate c m CoreProg b consRecT ts t = progConsT (recT ts id) t {-# INLINE consRecT #-}  -- | Rewrite all children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'-consRecAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consRecAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg consRecAllR rs r = progConsAllR (recAllR rs) r {-# INLINE consRecAllR #-}  -- | Rewrite any children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'-consRecAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consRecAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg consRecAnyR rs r = progConsAnyR (recAnyR rs) r {-# INLINE consRecAnyR #-}  -- | Rewrite one child of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'-consRecOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consRecOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg consRecOneR rs r = progConsOneR (recOneR rs) r {-# INLINE consRecOneR #-}   -- | Translate an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'-consRecDefT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> Translate c m CoreProg a3 -> ([(a1,a2)] -> a3 -> b) -> Translate c m CoreProg b+consRecDefT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> Translate c m CoreProg a3 -> ([(a1,a2)] -> a3 -> b) -> Translate c m CoreProg b consRecDefT ts t = consRecT (\ n -> uncurry defT (ts n) (,)) t {-# INLINE consRecDefT #-}  -- | Rewrite all children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'-consRecDefAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consRecDefAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg consRecDefAllR rs r = consRecAllR (\ n -> uncurry defAllR (rs n)) r {-# INLINE consRecDefAllR #-}  -- | Rewrite any children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'-consRecDefAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consRecDefAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg consRecDefAnyR rs r = consRecAnyR (\ n -> uncurry defAnyR (rs n)) r {-# INLINE consRecDefAnyR #-}  -- | Rewrite one child of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'-consRecDefOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg+consRecDefOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg consRecDefOneR rs r = consRecOneR (\ n -> uncurry defOneR (rs n)) r {-# INLINE consRecDefOneR #-}   -- | Translate an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'-letNonRecT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> Translate c m CoreExpr a3 -> (a1 -> a2 -> a3 -> b) -> Translate c m CoreExpr b+letNonRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> Translate c m CoreExpr a3 -> (a1 -> a2 -> a3 -> b) -> Translate c m CoreExpr b letNonRecT t1 t2 t3 f = letT (nonRecT t1 t2 (,)) t3 (uncurry f) {-# INLINE letNonRecT #-}  -- | Rewrite all children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'-letNonRecAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letNonRecAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letNonRecAllR r1 r2 r3 = letAllR (nonRecAllR r1 r2) r3 {-# INLINE letNonRecAllR #-}  -- | Rewrite any children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'-letNonRecAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letNonRecAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letNonRecAnyR r1 r2 r3 = letAnyR (nonRecAnyR r1 r2) r3 {-# INLINE letNonRecAnyR #-}  -- | Rewrite one child of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'-letNonRecOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letNonRecOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letNonRecOneR r1 r2 r3 = letOneR (nonRecOneR r1 r2) r3 {-# INLINE letNonRecOneR #-}   -- | Translate an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'-letRecT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a1) -> Translate c m CoreExpr a2 -> ([a1] -> a2 -> b) -> Translate c m CoreExpr b+letRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a1) -> Translate c m CoreExpr a2 -> ([a1] -> a2 -> b) -> Translate c m CoreExpr b letRecT ts t = letT (recT ts id) t {-# INLINE letRecT #-}  -- | Rewrite all children of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'-letRecAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letRecAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letRecAllR rs r = letAllR (recAllR rs) r {-# INLINE letRecAllR #-}  -- | Rewrite any children of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'-letRecAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letRecAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letRecAnyR rs r = letAnyR (recAnyR rs) r {-# INLINE letRecAnyR #-}  -- | Rewrite one child of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'-letRecOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letRecOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letRecOneR rs r = letOneR (recOneR rs) r {-# INLINE letRecOneR #-}   -- | Translate an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'-letRecDefT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> Translate c m CoreExpr a3 -> ([(a1,a2)] -> a3 -> b) -> Translate c m CoreExpr b+letRecDefT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> Translate c m CoreExpr a3 -> ([(a1,a2)] -> a3 -> b) -> Translate c m CoreExpr b letRecDefT ts t = letRecT (\ n -> uncurry defT (ts n) (,)) t {-# INLINE letRecDefT #-}  -- | Rewrite all children of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'-letRecDefAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letRecDefAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letRecDefAllR rs r = letRecAllR (\ n -> uncurry defAllR (rs n)) r {-# INLINE letRecDefAllR #-}  -- | Rewrite any children of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'-letRecDefAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letRecDefAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letRecDefAnyR rs r = letRecAnyR (\ n -> uncurry defAnyR (rs n)) r {-# INLINE letRecDefAnyR #-}  -- | Rewrite one child of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'-letRecDefOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr+letRecDefOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letRecDefOneR rs r = letRecOneR (\ n -> uncurry defOneR (rs n)) r {-# INLINE letRecDefOneR #-}   -- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]-caseAltT :: (ExtendPath c Crumb, AddBindings c, Monad m)+caseAltT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m)          => Translate c m CoreExpr sc          -> Translate c m Id w          -> Translate c m Type ty@@ -839,7 +840,7 @@ {-# INLINE caseAltT #-}  -- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]-caseAltAllR :: (ExtendPath c Crumb, AddBindings c, Monad m)+caseAltAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m)             => Rewrite c m CoreExpr             -> Rewrite c m Id             -> Rewrite c m Type@@ -849,7 +850,7 @@ {-# INLINE caseAltAllR #-}  -- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]-caseAltAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m)+caseAltAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m)             => Rewrite c m CoreExpr             -> Rewrite c m Id             -> Rewrite c m Type@@ -859,7 +860,7 @@ {-# INLINE caseAltAnyR #-}  -- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]-caseAltOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m)+caseAltOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m)             => Rewrite c m CoreExpr             -> Rewrite c m Id             -> Rewrite c m Type@@ -946,24 +947,24 @@   -- | Translate a type of the form: @ForAllTy@ 'Var' 'Type'-forAllTyT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Type b+forAllTyT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Type b forAllTyT t1 t2 f = translate $ \ c -> \case                                           ForAllTy v ty -> f <$> apply t1 (c @@ ForAllTy_Var) v <*> apply t2 (addForallBinding v c @@ ForAllTy_Body) ty                                           _             -> fail "not a forall type." {-# INLINE forAllTyT #-}  -- | Rewrite all children of a type of the form: @ForAllTy@ 'Var' 'Type'-forAllTyAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type+forAllTyAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type forAllTyAllR r1 r2 = forAllTyT r1 r2 ForAllTy {-# INLINE forAllTyAllR #-}  -- | Rewrite any children of a type of the form: @ForAllTy@ 'Var' 'Type'-forAllTyAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type+forAllTyAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type forAllTyAnyR r1 r2 = unwrapAnyR $ forAllTyAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE forAllTyAnyR #-}  -- | Rewrite one child of a type of the form: @ForAllTy@ 'Var' 'Type'-forAllTyOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type+forAllTyOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type forAllTyOneR r1 r2 = unwrapOneR $ forAllTyAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE forAllTyOneR #-} @@ -1075,24 +1076,24 @@   -- | Translate a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion'-forAllCoT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m TyVar a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b+forAllCoT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m TyVar a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b forAllCoT t1 t2 f = translate $ \ c -> \case                                           ForAllCo v co -> f <$> apply t1 (c @@ ForAllCo_TyVar) v <*> apply t2 (addForallBinding v c @@ ForAllCo_Body) co                                           _             -> fail "not a forall coercion." {-# INLINE forAllCoT #-}  -- | Rewrite all children of a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion'-forAllCoAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion+forAllCoAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion forAllCoAllR r1 r2 = forAllCoT r1 r2 ForAllCo {-# INLINE forAllCoAllR #-}  -- | Rewrite any children of a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion'-forAllCoAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion+forAllCoAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion forAllCoAnyR r1 r2 = unwrapAnyR $ forAllCoAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE forAllCoAnyR #-}  -- | Rewrite one child of a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion'-forAllCoOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion+forAllCoOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion forAllCoOneR r1 r2 = unwrapOneR $ forAllCoAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE forAllCoOneR #-}
src/HERMIT/Optimize.hs view
@@ -15,6 +15,7 @@     , phase     , after     , before+    , until     , allPhases     , firstPhase     , lastPhase@@ -26,6 +27,7 @@     , omToIO     ) where +import Control.Applicative import Control.Arrow import Control.Concurrent.STM import Control.Monad.Error hiding (guard)@@ -51,6 +53,8 @@ import HERMIT.Shell.Command import HERMIT.Shell.Types +import Prelude hiding (until)+ import System.Console.Haskeline (defaultBehavior)  data OInst :: * -> * where@@ -61,7 +65,7 @@     Query    :: (Injection ModGuts g, Walker HermitC g) => TranslateH g a                  -> OInst a  newtype OM a = OM (ProgramT OInst (ReaderT PhaseInfo (CLM IO)) a)-    deriving (Monad, MonadIO)+    deriving (Functor, Applicative, Monad, MonadIO)  optimize :: ([CommandLineOption] -> OM ()) -> Plugin optimize f = hermitPlugin $ \ phaseInfo -> runOM phaseInfo . f@@ -79,6 +83,7 @@                        , cl_running_script = False                        , cl_tick          = tick                        , cl_corelint      = False+                       , cl_diffonly      = False                        , cl_failhard      = False                        , cl_window        = mempty                        , cl_dict          = error "cl_dict" -- TODO@@ -198,6 +203,9 @@ before cp = guard (\phaseInfo -> case phasesLeft phaseInfo of                             (x:_) | cp == x -> True                             _               -> False)++until :: CorePass -> OM () -> OM ()+until cp = guard ((cp `elem`) . phasesLeft)  allPhases :: OM () -> OM () allPhases = guard (const True)
src/HERMIT/Plugin.hs view
@@ -6,6 +6,7 @@     , getCorePass     , ghcPasses     , PhaseInfo(..)+    , getPhaseFlag     )  where  import Data.List@@ -26,7 +27,7 @@              -- This is a bit of a hack; otherwise we lose what we've not seen             liftIO $ hSetBuffering stdout NoBuffering-            +             let todos' = flattenTodos todos                 passes = map getCorePass todos'                 allPasses = foldr (\ (n,p,seen,notyet) r -> mkPass n seen notyet : p : r)@@ -47,7 +48,14 @@  -- | Filter options to those pertaining to this module, stripping module prefix. filterOpts :: [CommandLineOption] -> ModGuts -> [CommandLineOption]-filterOpts opts guts = [ drop len nm | nm <- opts, modName `isPrefixOf` nm ]+filterOpts opts guts = [ opt | nm <- opts+                             , let mopt = if modName `isPrefixOf` nm+                                          then Just (drop len nm)+                                          else if "*:" `isPrefixOf` nm+                                               then Just (drop 2 nm)+                                               else Nothing+                             , Just opt <- [mopt]+                             ]     where modName = moduleNameString $ moduleName $ mg_module guts           len = length modName + 1 -- for the colon @@ -133,3 +141,10 @@               , phasesLeft :: [CorePass]               }     deriving (Read, Show, Eq)++-- | If HERMIT user specifies the -pN flag, get the N+-- TODO: as written will discard other flags that start with -p+getPhaseFlag :: [CommandLineOption] -> Maybe (Int, [CommandLineOption])+getPhaseFlag opts = case partition ("-p" `isPrefixOf`) opts of+                        ([],_) -> Nothing+                        (ps,r) -> Just (read (drop 2 (last ps)), r)
src/HERMIT/PrettyPrinter/Clean.hs view
@@ -215,6 +215,15 @@ ppVar :: PrettyH Var ppVar = readerT $ \ v -> varName ^>> ppName (varColor v) +-- For var occurences (in CoreExpr)+ppVarOcc :: PrettyH Var+ppVarOcc = do+    (c,i) <- exposeT+    let colFn = if isDeadBinder i || (isLocalId i && (i `notElemVarSet` boundVars c))+                then const WarningColor+                else varColor+    markBindingSite i c <$> (readerT $ \ v -> varName ^>> ppName (colFn v))+ varColor :: Var -> SyntaxForColor varColor var | isTyVar var = TypeColor              | isCoVar var = CoercionColor@@ -331,14 +340,7 @@            <+ letT ppCoreBind ppCoreExprR (retLet p)            <+ appT ppCoreExprR ppCoreExprR (retApp p App_Fun App_Arg)            <+ caseT ppCoreExpr ppVar (ppTypeModeR >>> parenExpr) (const ppCoreAlt) (\ s w ty alts -> RetExpr ((keyword p "case" <+> s <+> keyword p "of" <+> w <+> ty) $$ nest 2 (vcat alts)))--           <+ varT (do (c,i) <- exposeT-                       RetAtom <$> if isDeadBinder i ||-                                      (isLocalId i && (i `notElemVarSet` boundVars c))-                                    then varName ^>> ppName WarningColor-                                    else ppVar-                   )-+           <+ varT (RetAtom <$> ppVarOcc)            <+ litT (RetAtom <$> ppSDoc)            <+ typeT ppTypeModeR            <+ coercionT ppCoercionModeR@@ -366,7 +368,7 @@   where     ppKindOrTypePR :: AbsolutePathH -> Translate PrettyC HermitM KindOrType RetExpr     ppKindOrTypePR p =-           tyVarT (RetAtom <$> ppVar)+           tyVarT (RetAtom <$> ppVarOcc)         <+ litTyT (RetAtom <$> ppLitTy)         <+ appTyT ppKindOrTypeR ppKindOrTypeR (retApp p AppTy_Fun AppTy_Arg)         <+ funTyT ppKindOrTypeR ppKindOrTypeR (retArrowType p FunTy_Dom FunTy_CoDom)@@ -405,7 +407,7 @@   where     ppCoercionPR :: AbsolutePathH -> Translate PrettyC HermitM Coercion RetExpr     ppCoercionPR p =-                   coVarCoT (RetAtom <$> ppVar)+                   coVarCoT (RetAtom <$> ppVarOcc)                 <+ symCoT (ppCoercionR >>> parenExpr >>^ \ co -> RetExpr (coKeyword p "sym" <+> co))                 <+ forAllCoT ppBinderMode ppCoercionR (retForAll p ForAllCo_Body)                 <+ transCoT (ppCoercionR >>> parenExprExceptApp) (ppCoercionR >>> parenExprExceptApp) (\ co1 co2 -> RetExpr (co1 <+> coChar p ';' <+> co2))
src/HERMIT/PrettyPrinter/Common.hs view
@@ -10,6 +10,7 @@     , coercionColor     , idColor     , keywordColor+    , markBindingSite     , markColor     , typeColor     , ShowOption(..)@@ -86,8 +87,9 @@     deriving Show  -- These are the attributes-data Attr = PathAttr AbsolutePathH-          | Color SyntaxForColor+data Attr = BndrAttr AbsolutePathH -- path to binding of a variable+          | Color SyntaxForColor   +          | PathAttr AbsolutePathH -- path to this spot           | SpecialFont     deriving (Eq, Show) @@ -129,11 +131,16 @@ -- TODO: change monads to something more restricted?  -- | Context for PrettyH translations.-data PrettyC = PrettyC { prettyC_path    :: AbsolutePath Crumb-                       , prettyC_vars    :: VarSet+data PrettyC = PrettyC { prettyC_path    :: AbsolutePathH+                       , prettyC_vars    :: M.Map Var AbsolutePathH                        , prettyC_options :: PrettyOptions                        } +markBindingSite :: Var -> PrettyC -> DocH -> DocH+markBindingSite i c d = case M.lookup i (prettyC_vars c) of+                            Nothing -> d+                            Just p -> attr (BndrAttr p) d+ ------------------------------------------------------------------------  instance ReadPath PrettyC Crumb where@@ -147,23 +154,13 @@   {-# INLINE (@@) #-}  instance AddBindings PrettyC where-  addHermitBindings :: [(Var,HermitBindingSite)] -> PrettyC -> PrettyC-  addHermitBindings vbs c = c { prettyC_vars = foldr (flip extendVarSet) (prettyC_vars c) (map fst vbs) }-                            -- let vhbs = [ (v, (0,b)) | (v,b) <- vbs ] -- TODO: do we care about depth?-                            --  in c { prettyC_bindings = M.fromList vhbs `M.union` prettyC_bindings c }+  addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> PrettyC -> PrettyC+  addHermitBindings vbs c = c { prettyC_vars = M.union (prettyC_vars c) (M.fromList [ (i,p) | (i,_,p) <- vbs ]) }   {-# INLINE addHermitBindings #-} --- instance ReadBindings PrettyC where---   hermitDepth :: PrettyC -> BindingDepth---   hermitDepth = prettyC_depth----   hermitBindings :: PrettyC -> M.Map Var HermitBinding---   hermitBindings = prettyC_bindings---   {-# INLINE hermitBindings #-}- instance BoundVars PrettyC where   boundVars :: PrettyC -> VarSet-  boundVars = prettyC_vars+  boundVars = mkVarSet . M.keys . prettyC_vars  ------------------------------------------------------------------------ @@ -172,13 +169,13 @@  liftPrettyC :: (ReadBindings c, ReadPath c Crumb) => PrettyOptions -> c -> PrettyC liftPrettyC opts c = PrettyC { prettyC_path    = absPath c-                             , prettyC_vars    = boundVars c+                             , prettyC_vars    = M.fromList [ (i,hbPath b) | (i,b) <- M.toList (hermitBindings c) ]                              , prettyC_options = opts}  initPrettyC :: PrettyOptions -> PrettyC initPrettyC opts = PrettyC                       { prettyC_path    = mempty-                      , prettyC_vars    = emptyVarSet+                      , prettyC_vars    = M.empty                       , prettyC_options = opts                       }
src/HERMIT/Shell/Command.hs view
@@ -36,7 +36,7 @@ import HERMIT.External import qualified HERMIT.GHC as GHC import HERMIT.Interp-import HERMIT.Kernel (queryK)+import HERMIT.Kernel (queryK, AST) import HERMIT.Kernel.Scoped hiding (abortS, resumeS) import HERMIT.Kure import HERMIT.Monad@@ -94,7 +94,7 @@     focusPath <- getFocusPath     let skernel = cl_kernel st         ppOpts = (cl_pretty_opts st) { po_focus = Just focusPath }-    -- No not show focus while loading+    -- Do not show focus while loading     ifM (gets cl_running_script)         (return ())         (iokm2clm' "Rendering error: "@@ -209,6 +209,7 @@                             , cl_dict        = dict                             , cl_pretty_opts = (cl_pretty_opts initState) { po_width = w }                             , cl_height      = h+                            , cl_initSAST    = cl_cursor initState                             }     put clState @@ -276,6 +277,14 @@              fail              (interpExprH dict interpShellCommand expr) +ppWholeProgram :: MonadIO m => AST -> CLM m DocH+ppWholeProgram ast = do+    st <- get+    liftIO (queryK (kernelS $ cl_kernel st)+            ast+            (extractT $ pathT [ModGuts_Prog] $ liftPrettyH (cl_pretty_opts st) $ cl_pretty st)+            (cl_kernel_env st)) >>= runKureM return fail+ -------------------------------------------------------------------------------  -- TODO: This can be refactored. We always showWindow. Also, Perhaps return a modifier, not ()@@ -288,10 +297,16 @@      let sk = cl_kernel st         kEnv = cl_kernel_env st+        sast = cl_cursor st+        ppOpts = cl_pretty_opts st -    sast' <- prefixFailMsg "Rewrite failed: " $ applyS sk rr kEnv (cl_cursor st)+    sast' <- prefixFailMsg "Rewrite failed: " $ applyS sk rr kEnv sast -    let commit = put (newSAST expr sast' st) >> showWindow+    let commit = put (newSAST expr sast' st) >> showResult+        showResult = if cl_diffonly st then showDiff else showWindow+        showDiff = do doc1 <- queryS sk (liftPrettyH ppOpts (cl_pretty st)) kEnv sast+                      doc2 <- queryS sk (liftPrettyH ppOpts (cl_pretty st)) kEnv sast'+                      diffDocH ppOpts doc1 doc2 >>= cl_putStr      if cl_corelint st         then do ast' <- toASTS sk sast'@@ -388,11 +403,7 @@      ast1 <- toASTS (cl_kernel st) s1     ast2 <- toASTS (cl_kernel st) s2-    let getDoc ast = liftIO (queryK (kernelS $ cl_kernel st)-                                    ast-                                    (extractT $ pathT [ModGuts_Prog] $ liftPrettyH (cl_pretty_opts st) $ cl_pretty st)-                                    (cl_kernel_env st)) >>= runKureM return fail-        getCmds sast | sast == s1 = []+    let getCmds sast | sast == s1 = []                      | otherwise = case [ (f,c) | (f,c,to) <- vs_graph (cl_version st), to == sast ] of                                     [(sast',cmd)] -> unparseExprH cmd : getCmds sast'                                     _ -> ["error: history broken!"] -- should be impossible@@ -401,8 +412,8 @@     cl_putStrLn "========="     cl_putStrLn $ unlines $ reverse $ getCmds s2 -    doc1 <- getDoc ast1-    doc2 <- getDoc ast2+    doc1 <- ppWholeProgram ast1+    doc2 <- ppWholeProgram ast2      r <- diffDocH (cl_pretty_opts st) doc1 doc2
src/HERMIT/Shell/Externals.hs view
@@ -89,6 +89,12 @@        [ "tag <label> names the current AST with a label" ]                     .+ VersionControl    , external "diff"            (\ s1 s2 -> Diff (SAST s1) (SAST s2))        [ "show diff of two ASTs" ]                                              .+ VersionControl+   , external "set-pp-diffonly" (\ bStr -> CLSModify $ \ st ->+        case reads bStr of+            [(b,"")] -> return $ st { cl_diffonly = b }+            _        -> return st )+       [ "set-pp-diffonly <True|False>; False by default"+       , "print diffs rather than full code after a rewrite" ]    , external "set-fail-hard" (\ bStr -> CLSModify $ \ st ->         case reads bStr of             [(b,"")] -> return $ st { cl_failhard = b }@@ -114,7 +120,7 @@    , external "set-pp-renderer"    showRenderers        [ "set the output renderer mode"]    , external "dump"    Dump-       [ "dump <filename> <pretty-printer> <renderer> <width>"]+       [ "dump <filename> <renderer> <width>"]    , external "set-pp-width" (\ w -> CLSModify $ \ st ->         return $ st { cl_pretty_opts = updateWidthOption w (cl_pretty_opts st) })        ["set the width of the screen"]@@ -213,11 +219,12 @@ -------------------------------------------------------------------------------  showDerivationTree :: CommandLineState -> IO String-showDerivationTree st = return $ unlines $ showRefactorTrail graph tags 0 me+showDerivationTree st = return $ unlines $ showRefactorTrail graph tags start me   where           graph = [ (a,[unparseExprH b],c) | (SAST a,b,SAST c) <- vs_graph (cl_version st) ]           tags  = [ (n,nm) | (nm,SAST n) <- vs_tags (cl_version st) ]           SAST me = cl_cursor st+          SAST start = cl_initSAST st  showRefactorTrail :: (Eq a, Show a) => [(a,[String],a)] -> [(a,String)] -> a -> a -> [String] showRefactorTrail db tags a me =
src/HERMIT/Shell/Types.hs view
@@ -2,6 +2,7 @@  module HERMIT.Shell.Types where +import Control.Applicative import Control.Concurrent.STM import Control.Monad.State import Control.Monad.Error@@ -120,7 +121,7 @@     strMsg = CLError  newtype CLM m a = CLM { unCLM :: ErrorT CLException (StateT CommandLineState m) a }-    deriving (MonadIO, MonadError CLException, MonadState CommandLineState)+    deriving (Functor, Applicative, MonadIO, MonadError CLException, MonadState CommandLineState)  -- | Our own custom instance of Monad for CLM m so we don't have to depend on -- newtype deriving to do the right thing for fail.@@ -187,6 +188,7 @@     , cl_running_script :: Bool                                     -- ^ if running a script     , 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_diffonly       :: Bool                                     -- ^ if true, show diffs rather than pp full code     , cl_failhard       :: Bool                                     -- ^ if true, abort on *any* failure     , cl_window         :: PathH                                    -- ^ path to beginning of window, always a prefix of focus path in kernel     -- these four should be in a reader