diff --git a/dist/build/HERMIT/Parser.hs b/dist/build/HERMIT/Parser.hs --- a/dist/build/HERMIT/Parser.hs +++ b/dist/build/HERMIT/Parser.hs @@ -6,6 +6,7 @@ , unparseScript , unparseExprH , ExprH(..) + , parseExprH ) where import Data.Char (isSpace) @@ -19,85 +20,84 @@ -- parser produced by Happy Version 1.19.3 -newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11 = HappyAbsSyn HappyAny +newtype HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 type HappyAny = Happy_GHC_Exts.Any #else type HappyAny = forall a . a #endif -happyIn4 :: t4 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t4 -happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut4 #-} -happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn5 :: t5 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t5 +happyOut5 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t5 happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut5 #-} -happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn6 :: t6 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t6 +happyOut6 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t6 happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut6 #-} -happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn7 :: t7 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t7 +happyOut7 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t7 happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut7 #-} -happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn8 :: t8 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t8 +happyOut8 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t8 happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut8 #-} -happyIn9 :: t9 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn9 :: t9 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t9 +happyOut9 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t9 happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut9 #-} -happyIn10 :: t10 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn10 :: t10 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t10 +happyOut10 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t10 happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut10 #-} -happyIn11 :: t11 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn11 :: t11 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t11 +happyOut11 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t11 happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut11 #-} -happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn12 :: t12 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) +happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> t12 +happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyInTok :: (Token) -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) happyInTok x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> (Token) +happyOutTok :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12) -> (Token) happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOutTok #-} happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x0e\x00\x1e\x00\x0e\x00\x06\x00\x00\x00\x00\x00\xfd\xff\x01\x00\x00\x00\x1a\x00\x0e\x00\x1a\x00\x0e\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x09\x00\x00\x00\x00\x00\x02\x00\x00\x00\x1a\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00"# +happyActOffsets = HappyA# "\x0e\x00\x1a\x00\x1e\x00\x0e\x00\x06\x00\x01\x00\x00\x00\x1a\x00\x1a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\xfd\xff\x0e\x00\x0e\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x09\x00\x00\x00\x02\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00"# happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x45\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x4d\x00\x39\x00\x48\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x2d\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00"# +happyGotoOffsets = HappyA# "\x45\x00\x50\x00\x00\x00\x3f\x00\x00\x00\xfe\xff\x00\x00\x4d\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x33\x00\x00\x00\x00\x00\x2d\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00"# happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xfa\xff\x00\x00\xfa\xff\x00\x00\xfc\xff\xfb\xff\xf9\xff\xf4\xff\xf2\xff\x00\x00\xfa\xff\xe8\xff\xfa\xff\x00\x00\xed\xff\xee\xff\xea\xff\xef\xff\xf1\xff\xf0\xff\xf6\xff\xe7\xff\x00\x00\xe9\xff\xfd\xff\x00\x00\xf3\xff\x00\x00\xfa\xff\xfa\xff\xfe\xff\xf7\xff\xf8\xff\xf5\xff\xeb\xff\xec\xff\x00\x00\xe6\xff"# +happyDefActions = HappyA# "\xf9\xff\x00\x00\x00\x00\xf9\xff\x00\x00\xf3\xff\xf1\xff\x00\x00\xe7\xff\x00\x00\xec\xff\xed\xff\xe9\xff\x00\x00\xfb\xff\xfa\xff\xf8\xff\xf9\xff\xf9\xff\xf5\xff\xfc\xff\xf9\xff\xf9\xff\xee\xff\xf0\xff\xef\xff\xe6\xff\x00\x00\xe8\xff\x00\x00\xf2\xff\x00\x00\xfd\xff\xf4\xff\xea\xff\xeb\xff\x00\x00\xf6\xff\xf7\xff\xe5\xff"# happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x04\x00\x01\x00\x05\x00\x02\x00\x08\x00\x05\x00\x03\x00\x04\x00\x05\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x01\x00\x07\x00\x03\x00\x04\x00\x05\x00\x0e\x00\x06\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x01\x00\x03\x00\x04\x00\x05\x00\x05\x00\x07\x00\x03\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x03\x00\x04\x00\x05\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +happyCheck = HappyA# "\xff\xff\x04\x00\x01\x00\x05\x00\x02\x00\x08\x00\x05\x00\x03\x00\x04\x00\x05\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x01\x00\x07\x00\x03\x00\x04\x00\x05\x00\x0e\x00\x06\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x01\x00\x03\x00\x04\x00\x05\x00\x05\x00\x07\x00\x03\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x1d\x00\x0a\x00\x1a\x00\x23\x00\x1e\x00\x0c\x00\x21\x00\x07\x00\x08\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x1c\x00\x0a\x00\x24\x00\x03\x00\x0b\x00\x0c\x00\xff\xff\x25\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0a\x00\x15\x00\x07\x00\x08\x00\x0c\x00\x25\x00\x03\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x1f\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x20\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x14\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x18\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x1e\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x15\x00\x07\x00\x08\x00\x16\x00\x17\x00\x19\x00\x07\x00\x08\x00\x00\x00\x12\x00\x13\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyTable = HappyA# "\x00\x00\x16\x00\x08\x00\x1e\x00\x23\x00\x17\x00\x09\x00\x21\x00\x05\x00\x06\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x08\x00\x24\x00\x04\x00\x12\x00\x09\x00\xff\xff\x25\x00\x13\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x08\x00\x1a\x00\x05\x00\x06\x00\x09\x00\x27\x00\x04\x00\x00\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x25\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x26\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x13\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x14\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x20\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x1a\x00\x05\x00\x06\x00\x1b\x00\x1c\x00\x1d\x00\x05\x00\x06\x00\x04\x00\x05\x00\x06\x00\x18\x00\x19\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# -happyReduceArr = Happy_Data_Array.array (1, 25) [ - (1 , happyReduce_1), +happyReduceArr = Happy_Data_Array.array (2, 26) [ (2 , happyReduce_2), (3 , happyReduce_3), (4 , happyReduce_4), @@ -121,205 +121,206 @@ (22 , happyReduce_22), (23 , happyReduce_23), (24 , happyReduce_24), - (25 , happyReduce_25) + (25 , happyReduce_25), + (26 , happyReduce_26) ] happy_n_terms = 15 :: Int happy_n_nonterms = 8 :: Int -happyReduce_1 = happySpecReduce_2 0# happyReduction_1 -happyReduction_1 happy_x_2 +happyReduce_2 = happySpecReduce_2 0# happyReduction_2 +happyReduction_2 happy_x_2 happy_x_1 - = case happyOut4 happy_x_2 of { happy_var_2 -> - happyIn4 + = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn5 (CmdName "{" : happy_var_2 )} -happyReduce_2 = happySpecReduce_2 0# happyReduction_2 -happyReduction_2 happy_x_2 +happyReduce_3 = happySpecReduce_2 0# happyReduction_3 +happyReduction_3 happy_x_2 happy_x_1 - = case happyOut4 happy_x_2 of { happy_var_2 -> - happyIn4 + = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn5 (CmdName "}" : happy_var_2 )} -happyReduce_3 = happySpecReduce_1 0# happyReduction_3 -happyReduction_3 happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn4 - (happy_var_1 - )} - -happyReduce_4 = happySpecReduce_1 1# happyReduction_4 +happyReduce_4 = happySpecReduce_1 0# happyReduction_4 happyReduction_4 happy_x_1 = case happyOut6 happy_x_1 of { happy_var_1 -> happyIn5 (happy_var_1 )} -happyReduce_5 = happySpecReduce_0 1# happyReduction_5 -happyReduction_5 = happyIn5 +happyReduce_5 = happySpecReduce_1 1# happyReduction_5 +happyReduction_5 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_6 = happySpecReduce_0 1# happyReduction_6 +happyReduction_6 = happyIn6 ([] ) -happyReduce_6 = happySpecReduce_1 2# happyReduction_6 -happyReduction_6 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn6 +happyReduce_7 = happySpecReduce_1 2# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn7 ([happy_var_1] )} -happyReduce_7 = happySpecReduce_3 2# happyReduction_7 -happyReduction_7 happy_x_3 +happyReduce_8 = happySpecReduce_3 2# happyReduction_8 +happyReduction_8 happy_x_3 happy_x_2 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut4 happy_x_3 of { happy_var_3 -> - happyIn6 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn7 ([happy_var_1, CmdName "}"] ++ happy_var_3 )}} -happyReduce_8 = happySpecReduce_3 2# happyReduction_8 -happyReduction_8 happy_x_3 +happyReduce_9 = happySpecReduce_3 2# happyReduction_9 +happyReduction_9 happy_x_3 happy_x_2 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut4 happy_x_3 of { happy_var_3 -> - happyIn6 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn7 (happy_var_1 : happy_var_3 )}} -happyReduce_9 = happySpecReduce_2 2# happyReduction_9 -happyReduction_9 happy_x_2 +happyReduce_10 = happySpecReduce_2 2# happyReduction_10 +happyReduction_10 happy_x_2 happy_x_1 - = case happyOut4 happy_x_2 of { happy_var_2 -> - happyIn6 + = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn7 (happy_var_2 )} -happyReduce_10 = happySpecReduce_3 3# happyReduction_10 -happyReduction_10 happy_x_3 +happyReduce_11 = happySpecReduce_3 3# happyReduction_11 +happyReduction_11 happy_x_3 happy_x_2 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> + = case happyOut9 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { (InfixOp happy_var_2) -> - case happyOut7 happy_x_3 of { happy_var_3 -> - happyIn7 + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn8 (AppH (AppH (CmdName happy_var_2) happy_var_1) happy_var_3 )}}} -happyReduce_11 = happySpecReduce_1 3# happyReduction_11 -happyReduction_11 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn7 +happyReduce_12 = happySpecReduce_1 3# happyReduction_12 +happyReduction_12 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn8 (happy_var_1 )} -happyReduce_12 = happySpecReduce_2 4# happyReduction_12 -happyReduction_12 happy_x_2 +happyReduce_13 = happySpecReduce_2 4# happyReduction_13 +happyReduction_13 happy_x_2 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - happyIn8 + = case happyOut9 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn9 (AppH happy_var_1 happy_var_2 )}} -happyReduce_13 = happySpecReduce_1 4# happyReduction_13 -happyReduction_13 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn8 +happyReduce_14 = happySpecReduce_1 4# happyReduction_14 +happyReduction_14 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn9 (happy_var_1 )} -happyReduce_14 = happySpecReduce_2 5# happyReduction_14 -happyReduction_14 happy_x_2 +happyReduce_15 = happySpecReduce_2 5# happyReduction_15 +happyReduction_15 happy_x_2 happy_x_1 = case happyOutTok happy_x_2 of { (Ident happy_var_2) -> - happyIn9 + happyIn10 (SrcName happy_var_2 )} -happyReduce_15 = happySpecReduce_2 5# happyReduction_15 -happyReduction_15 happy_x_2 +happyReduce_16 = happySpecReduce_2 5# happyReduction_16 +happyReduction_16 happy_x_2 happy_x_1 = case happyOutTok happy_x_2 of { (InfixOp happy_var_2) -> - happyIn9 + happyIn10 (SrcName happy_var_2 )} -happyReduce_16 = happySpecReduce_2 5# happyReduction_16 -happyReduction_16 happy_x_2 +happyReduce_17 = happySpecReduce_2 5# happyReduction_17 +happyReduction_17 happy_x_2 happy_x_1 = case happyOutTok happy_x_2 of { (Quote happy_var_2) -> - happyIn9 + happyIn10 (SrcName happy_var_2 )} -happyReduce_17 = happySpecReduce_1 5# happyReduction_17 -happyReduction_17 happy_x_1 +happyReduce_18 = happySpecReduce_1 5# happyReduction_18 +happyReduction_18 happy_x_1 = case happyOutTok happy_x_1 of { (Quote happy_var_1) -> - happyIn9 + happyIn10 (CmdName happy_var_1 )} -happyReduce_18 = happySpecReduce_1 5# happyReduction_18 -happyReduction_18 happy_x_1 +happyReduce_19 = happySpecReduce_1 5# happyReduction_19 +happyReduction_19 happy_x_1 = case happyOutTok happy_x_1 of { (CoreString happy_var_1) -> - happyIn9 + happyIn10 (CoreH happy_var_1 )} -happyReduce_19 = happySpecReduce_3 5# happyReduction_19 -happyReduction_19 happy_x_3 +happyReduce_20 = happySpecReduce_3 5# happyReduction_20 +happyReduction_20 happy_x_3 happy_x_2 happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn9 + = case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn10 (ListH happy_var_2 )} -happyReduce_20 = happySpecReduce_3 5# happyReduction_20 -happyReduction_20 happy_x_3 +happyReduce_21 = happySpecReduce_3 5# happyReduction_21 +happyReduction_21 happy_x_3 happy_x_2 happy_x_1 - = case happyOut7 happy_x_2 of { happy_var_2 -> - happyIn9 + = case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn10 (happy_var_2 )} -happyReduce_21 = happySpecReduce_1 5# happyReduction_21 -happyReduction_21 happy_x_1 +happyReduce_22 = happySpecReduce_1 5# happyReduction_22 +happyReduction_22 happy_x_1 = case happyOutTok happy_x_1 of { (Ident happy_var_1) -> - happyIn9 + happyIn10 (CmdName happy_var_1 )} -happyReduce_22 = happySpecReduce_1 6# happyReduction_22 -happyReduction_22 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10 +happyReduce_23 = happySpecReduce_1 6# happyReduction_23 +happyReduction_23 happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + happyIn11 (happy_var_1 )} -happyReduce_23 = happySpecReduce_0 6# happyReduction_23 -happyReduction_23 = happyIn10 +happyReduce_24 = happySpecReduce_0 6# happyReduction_24 +happyReduction_24 = happyIn11 ([] ) -happyReduce_24 = happySpecReduce_1 7# happyReduction_24 -happyReduction_24 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn11 +happyReduce_25 = happySpecReduce_1 7# happyReduction_25 +happyReduction_25 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn12 ([happy_var_1] )} -happyReduce_25 = happySpecReduce_3 7# happyReduction_25 -happyReduction_25 happy_x_3 +happyReduce_26 = happySpecReduce_3 7# happyReduction_26 +happyReduction_26 happy_x_3 happy_x_2 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut11 happy_x_3 of { happy_var_3 -> - happyIn11 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut12 happy_x_3 of { happy_var_3 -> + happyIn12 (happy_var_1 : happy_var_3 )}} @@ -359,8 +360,11 @@ happyError' = parseError parser tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) +exprParser tks = happySomeParser where + happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut8 x)) + happySeq = happyDontSeq @@ -448,6 +452,9 @@ parseScript :: String -> Either String Script parseScript = lexer >=> parser + +parseExprH :: String -> Either String ExprH +parseExprH = lexer >=> exprParser --------------------------------------------- diff --git a/dist/build/HERMIT/ParserCore.hs b/dist/build/HERMIT/ParserCore.hs --- a/dist/build/HERMIT/ParserCore.hs +++ b/dist/build/HERMIT/ParserCore.hs @@ -4,6 +4,8 @@ module HERMIT.ParserCore ( parseCore , parseCoreExprT + , parse2BeforeT + , parse3BeforeT , parse2beforeBiR , parse3beforeBiR , parse4beforeBiR @@ -256,21 +258,17 @@ mkIntExpr' :: Integer -> CoreParseM CoreExpr -#if __GLASGOW_HASKELL__ > 706 mkIntExpr' i = do dflags <- lift getDynFlags return $ mkIntExpr dflags i -#else -mkIntExpr' i = return $ mkIntExpr i -#endif lookupName :: String -> CoreParseM CoreExpr lookupName nm = do - c <- ask - v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId nm c + vset <- ask + v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId (parseName nm) vset return $ varToCoreExpr v -type CoreParseM a = ReaderT HermitC HermitM a +type CoreParseM a = ReaderT VarSet HermitM a parseError :: Monad m => [Token] -> m a parseError ts = fail $ "core parse error: " ++ show ts @@ -337,19 +335,30 @@ --------------------------------------------- -parseCore :: CoreString -> HermitC -> HermitM CoreExpr +parseCore :: BoundVars c => CoreString -> c -> HermitM CoreExpr parseCore (CoreString s) c = case lexer s of Left msg -> fail msg - Right tokens -> runReaderT (parser tokens) c + Right tokens -> runReaderT (parser tokens) (boundVars c) --------------------------------------------- -- These should probably go somewhere else. -- | Parse a 'CoreString' to a 'CoreExpr', using the current context. -parseCoreExprT :: CoreString -> TransformH a CoreExpr -parseCoreExprT = contextonlyT . parseCore +parseCoreExprT :: (BoundVars c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, HasStash m, LiftCoreM m) + => CoreString -> Transform c m a CoreExpr +parseCoreExprT cs = contextonlyT $ embedHermitM . parseCore cs + +parse2BeforeT :: (BoundVars c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, HasStash m, LiftCoreM m) + => (CoreExpr -> CoreExpr -> Translate c m a b) + -> CoreString -> CoreString -> Translate c m a b +parse2BeforeT f s1 s2 = parseCoreExprT s1 &&& parseCoreExprT s2 >>= uncurry f + +parse3BeforeT :: (BoundVars c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, HasStash m, LiftCoreM m) + => (CoreExpr -> CoreExpr -> CoreExpr -> Translate c m a b) + -> CoreString -> CoreString -> CoreString -> Translate c m a b +parse3BeforeT f s1 s2 s3 = (parseCoreExprT s1 &&& parseCoreExprT s2) &&& parseCoreExprT s3 >>= (uncurry . uncurry $ f) parse2beforeBiR :: (CoreExpr -> CoreExpr -> BiRewriteH a) -> CoreString -> CoreString -> BiRewriteH a diff --git a/dist/build/HERMIT/ParserType.hs b/dist/build/HERMIT/ParserType.hs --- a/dist/build/HERMIT/ParserType.hs +++ b/dist/build/HERMIT/ParserType.hs @@ -2,15 +2,11 @@ {-# OPTIONS -fglasgow-exts -cpp #-} {-# LANGUAGE CPP #-} module HERMIT.ParserType -#if __GLASGOW_HASKELL__ <= 706 - () where -#else ( parseType , parseTypeT , parseTypeWithHoles , parseTypeWithHolesT ) where -#endif import Control.Arrow import Control.Monad.State @@ -238,14 +234,10 @@ happySeq = happyDontSeq -#if __GLASGOW_HASKELL__ <= 706 -findType = error "findType cannot be called in < GHC 7.8" -#endif - lookupName :: String -> TypeParseM Type lookupName nm = do c <- getContext - et <- lift $ attemptM $ findType nm c + et <- lift $ attemptM $ findType (parseName nm) c either (const (addTyVar nm)) return et catchFrees :: Type -> TypeParseM ([TyVar], Type) @@ -268,7 +260,7 @@ addTyVar :: String -> TypeParseM Type addTyVar tvStr = do used <- gets tpUsed - case [ tv | tv <- used, getOccString tv == tvStr ] of + case [ tv | tv <- used, unqualifiedName tv == tvStr ] of [] -> do tv <- lift $ newTyVarH tvStr liftedTypeKind modify $ \ st -> st { tpUsed = tv : tpUsed st } return $ mkTyVarTy tv diff --git a/examples/concatVanishes/Flatten.hs b/examples/concatVanishes/Flatten.hs --- a/examples/concatVanishes/Flatten.hs +++ b/examples/concatVanishes/Flatten.hs @@ -3,10 +3,6 @@ import HList -#if __GLASGOW_HASKELL__ < 708 -import Data.Function (fix) -#endif - data Tree a = Node (Tree a) (Tree a) | Leaf a flatten :: Tree a -> [a] diff --git a/examples/concatVanishes/QSort.hs b/examples/concatVanishes/QSort.hs --- a/examples/concatVanishes/QSort.hs +++ b/examples/concatVanishes/QSort.hs @@ -4,10 +4,6 @@ import HList import Data.List -#if __GLASGOW_HASKELL__ < 708 -import Data.Function (fix) -#endif - data Tree a = Node (Tree a) (Tree a) | Leaf a qsort :: Ord a => [a] -> [a] diff --git a/examples/concatVanishes/Rev.hs b/examples/concatVanishes/Rev.hs --- a/examples/concatVanishes/Rev.hs +++ b/examples/concatVanishes/Rev.hs @@ -3,10 +3,6 @@ import HList -#if __GLASGOW_HASKELL__ < 708 -import Data.Function (fix) -#endif - rev :: [a] -> [a] rev [] = [] rev (y:ys) = rev ys ++ [y] diff --git a/examples/evaluation/Eval.hs b/examples/evaluation/Eval.hs --- a/examples/evaluation/Eval.hs +++ b/examples/evaluation/Eval.hs @@ -3,10 +3,6 @@ import Prelude hiding (abs) -#if __GLASGOW_HASKELL__ < 708 -import Data.Function (fix) -#endif - data Expr = Val Int | Add Expr Expr | Throw | Catch Expr Expr type Mint = Maybe Int diff --git a/examples/factorial/Fac.hs b/examples/factorial/Fac.hs --- a/examples/factorial/Fac.hs +++ b/examples/factorial/Fac.hs @@ -6,10 +6,6 @@ import Prelude hiding ((*),(-)) import GHC.Exts -#if __GLASGOW_HASKELL__ < 708 -import Data.Function (fix) -#endif - ------------------------------------ fac :: Int -> Int diff --git a/examples/fib-stream/Fib.hs b/examples/fib-stream/Fib.hs --- a/examples/fib-stream/Fib.hs +++ b/examples/fib-stream/Fib.hs @@ -5,10 +5,6 @@ import Nat import Stream -#if __GLASGOW_HASKELL__ < 708 -import Data.Function (fix) -#endif - fib :: Nat -> Nat fib Zero = Zero fib (Succ Zero) = Succ Zero diff --git a/examples/fib-tuple/Fib.hs b/examples/fib-tuple/Fib.hs --- a/examples/fib-tuple/Fib.hs +++ b/examples/fib-tuple/Fib.hs @@ -1,11 +1,6 @@ {-# LANGUAGE CPP #-} module Main where -#if __GLASGOW_HASKELL__ < 708 --- so we can fix-intro -import Data.Function (fix) -#endif - import Prelude hiding ((+)) data Nat = Z | S Nat diff --git a/examples/flatten/Flatten.hs b/examples/flatten/Flatten.hs --- a/examples/flatten/Flatten.hs +++ b/examples/flatten/Flatten.hs @@ -3,10 +3,6 @@ import HList -#if __GLASGOW_HASKELL__ < 708 -import Data.Function (fix) -#endif - data Tree a = Node (Tree a) (Tree a) | Leaf a flatten :: Tree a -> [a] diff --git a/examples/hanoi/Hanoi.hs b/examples/hanoi/Hanoi.hs --- a/examples/hanoi/Hanoi.hs +++ b/examples/hanoi/Hanoi.hs @@ -5,10 +5,6 @@ import Control.Monad (forM_) -#if __GLASGOW_HASKELL__ < 708 -import Data.Function (fix) -#endif - data Nat = Z | S Nat toInt :: Nat -> Int diff --git a/examples/last/Last.hs b/examples/last/Last.hs --- a/examples/last/Last.hs +++ b/examples/last/Last.hs @@ -1,10 +1,6 @@ {-# LANGUAGE CPP #-} module Main where -#if __GLASGOW_HASKELL__ < 708 -import Data.Function (fix) -#endif - import Prelude hiding (last) ------------------------------------------------- diff --git a/examples/qsort/QSort.hs b/examples/qsort/QSort.hs --- a/examples/qsort/QSort.hs +++ b/examples/qsort/QSort.hs @@ -3,10 +3,6 @@ import HList -#if __GLASGOW_HASKELL__ < 708 -import Data.Function (fix) -#endif - import Data.List data Tree a = Node (Tree a) (Tree a) | Leaf a diff --git a/examples/reverse/Reverse.hs b/examples/reverse/Reverse.hs --- a/examples/reverse/Reverse.hs +++ b/examples/reverse/Reverse.hs @@ -4,10 +4,6 @@ import HList -- import Seq -#if __GLASGOW_HASKELL__ < 708 -import Data.Function (fix) -#endif - rev :: [a] -> [a] rev [] = [] rev (x:xs) = rev xs ++ [x] diff --git a/hermit.cabal b/hermit.cabal --- a/hermit.cabal +++ b/hermit.cabal @@ -1,5 +1,5 @@ Name: hermit -Version: 0.5.0.0 +Version: 0.6.0.0 Synopsis: Haskell Equational Reasoning Model-to-Implementation Tunnel Description: HERMIT uses Haskell to express semi-formal models, @@ -28,12 +28,12 @@ . @ $ hermit Reverse.hs Reverse.hss resume - [starting HERMIT v0.5.0.0 on Reverse.hs] + [starting HERMIT v0.6.0.0 on Reverse.hs] % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:Main:Reverse.hss -fplugin-opt=HERMIT:Main:resume [1 of 2] Compiling HList ( HList.hs, HList.o ) Loading package ghc-prim ... linking ... done. ... - Loading package hermit-0.5.0.0 ... linking ... done. + Loading package hermit-0.6.0.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) Linking Reverse ... $ ./Reverse @@ -44,12 +44,12 @@ . @ $ hermit Reverse.hs - [starting HERMIT v0.5.0.0 on Reverse.hs] + [starting HERMIT v0.6.0.0 on Reverse.hs] % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:*: [1 of 2] Compiling HList ( HList.hs, HList.o ) Loading package ghc-prim ... linking ... done. ... - Loading package hermit-0.5.0.0 ... linking ... done. + Loading package hermit-0.6.0.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) ===================== Welcome to HERMIT ===================== HERMIT is a toolkit for the interactive transformation of GHC @@ -143,9 +143,9 @@ containers >= 0.5.0.0, data-default >= 0.5.0, directory >= 1.2.0.0, - ghc >= 7.6, + ghc >= 7.8, haskeline >= 0.7.0.3, - kure >= 2.16.0, + kure >= 2.16.4, marked-pretty >= 0.1, mtl >= 2.1.2, operational >= 0.2.2.1, @@ -154,13 +154,13 @@ temporary >= 1.2.0.3, transformers - if !os(windows) + if os(windows) + build-depends: Win32 + else build-depends: terminfo >= 0.3.2.5 - if impl(ghc >= 7.8) - build-tools: happy >= 1.19.3, alex >= 3.1.3 - else - build-tools: happy, alex + build-tools: alex >= 3.1.3, + happy >= 1.19.3 default-language: Haskell2010 @@ -226,6 +226,7 @@ HERMIT.PrettyPrinter.GHC HERMIT.Shell.Command + HERMIT.Shell.Completion HERMIT.Shell.Dictionary HERMIT.Shell.Interpreter HERMIT.Shell.Externals @@ -241,6 +242,11 @@ HERMIT.Syntax Paths_hermit + + if os(windows) + Other-modules: + HERMIT.Win32.Console + HERMIT.Win32.IO Hs-Source-Dirs: src diff --git a/src/HERMIT.hs b/src/HERMIT.hs --- a/src/HERMIT.hs +++ b/src/HERMIT.hs @@ -3,9 +3,9 @@ import Data.Maybe (fromMaybe) import HERMIT.GHC -import HERMIT.Plugin.Builder (getPhaseFlag) +import HERMIT.Plugin.Builder (getPassFlag) import HERMIT.Plugin plugin :: Plugin -plugin = hermitPlugin $ \ options -> let (pn,opts) = fromMaybe (0,options) (getPhaseFlag options) - in phase pn $ interactive [] opts +plugin = hermitPlugin $ \ options -> let (pn,opts) = fromMaybe (0,options) (getPassFlag options) + in pass pn $ interactive [] opts diff --git a/src/HERMIT/Context.hs b/src/HERMIT/Context.hs --- a/src/HERMIT/Context.hs +++ b/src/HERMIT/Context.hs @@ -178,9 +178,9 @@ boundVars :: VarSet -> VarSet boundVars = id --- | List all variables bound in the context that match the given name. -findBoundVars :: BoundVars c => String -> c -> VarSet -findBoundVars nm = filterVarSet (cmpString2Var nm) . boundVars +-- | List all variables bound in the context that match the given predicate. +findBoundVars :: BoundVars c => (Var -> Bool) -> c -> VarSet +findBoundVars p = filterVarSet p . boundVars -- | A class of contexts from which HERMIT bindings can be retrieved. class BoundVars c => ReadBindings c where diff --git a/src/HERMIT/Core.hs b/src/HERMIT/Core.hs --- a/src/HERMIT/Core.hs +++ b/src/HERMIT/Core.hs @@ -58,11 +58,11 @@ , isCoArg , exprKindOrType , exprTypeM - , endoFunType + , endoFunTypeM , splitTyConAppM , splitFunTypeM - , endoFunExprType - , funExprArgResTypes + , endoFunExprTypeM + , funExprArgResTypesM , funExprsWithInverseTypes , appCount , mapAlts @@ -184,24 +184,15 @@ -- | Syntactic Equality of 'Coercion's. coercionSyntaxEq :: Coercion -> Coercion -> Bool -#if __GLASGOW_HASKELL__ > 706 coercionSyntaxEq (Refl role1 ty1) (Refl role2 ty2) = role1 == role2 && typeSyntaxEq ty1 ty2 coercionSyntaxEq (TyConAppCo role1 tc1 cos1) (TyConAppCo role2 tc2 cos2) = role1 == role2 && tc1 == tc2 && all2 coercionSyntaxEq cos1 cos2 -#else -coercionSyntaxEq (Refl ty1) (Refl ty2) = typeSyntaxEq ty1 ty2 -coercionSyntaxEq (TyConAppCo tc1 cos1) (TyConAppCo tc2 cos2) = tc1 == tc2 && all2 coercionSyntaxEq cos1 cos2 -#endif coercionSyntaxEq (AppCo co11 co12) (AppCo co21 co22) = coercionSyntaxEq co11 co21 && coercionSyntaxEq co12 co22 coercionSyntaxEq (ForAllCo v1 co1) (ForAllCo v2 co2) = v1 == v2 && coercionSyntaxEq co1 co2 coercionSyntaxEq (CoVarCo v1) (CoVarCo v2) = v1 == v2 -#if __GLASGOW_HASKELL__ > 706 coercionSyntaxEq (AxiomInstCo con1 ind1 cos1) (AxiomInstCo con2 ind2 cos2) = con1 == con2 && ind1 == ind2 && all2 coercionSyntaxEq cos1 cos2 coercionSyntaxEq (LRCo lr1 co1) (LRCo lr2 co2) = lr1 == lr2 && coercionSyntaxEq co1 co2 coercionSyntaxEq (UnivCo role1 ty11 ty12) (UnivCo role2 ty21 ty22) = role1 == role2 && typeSyntaxEq ty11 ty21 && typeSyntaxEq ty12 ty22 -#else -coercionSyntaxEq (AxiomInstCo con1 cos1) (AxiomInstCo con2 cos2) = con1 == con2 && all2 coercionSyntaxEq cos1 cos2 -coercionSyntaxEq (UnsafeCo ty11 ty12) (UnsafeCo ty21 ty22) = typeSyntaxEq ty11 ty21 && typeSyntaxEq ty12 ty22 -#endif +coercionSyntaxEq (SubCo co1) (SubCo co2) = coercionSyntaxEq co1 co2 coercionSyntaxEq (SymCo co1) (SymCo co2) = coercionSyntaxEq co1 co2 coercionSyntaxEq (TransCo co11 co12) (TransCo co21 co22) = coercionSyntaxEq co11 co21 && coercionSyntaxEq co12 co22 coercionSyntaxEq (NthCo n1 co1) (NthCo n2 co2) = n1 == n2 && coercionSyntaxEq co1 co2 @@ -308,8 +299,7 @@ freeVarsBind :: CoreBind -> VarSet freeVarsBind (NonRec v e) = freeVarsExpr e `unionVarSet` freeVarsVar v freeVarsBind (Rec defs) = let (bs,es) = unzip defs - in delVarSetList (unionVarSets $ map freeVarsExpr es) bs - `unionVarSet` unionVarSets (map freeVarsVar bs) + in delVarSetList (unionVarSets (map freeVarsVar bs ++ map freeVarsExpr es)) bs -- | Find all free variables on a binder. Equivalent to idFreeVars, but safe to call on type bindings. freeVarsVar :: Var -> VarSet @@ -380,30 +370,33 @@ splitTyConAppM :: Monad m => Type -> m (TyCon, [Type]) splitTyConAppM = maybeM "splitTyConApp failed." . splitTyConApp_maybe --- | Return the domain and codomain types of a function type, if it is a function type. -splitFunTypeM :: Monad m => Type -> m (Type,Type) -splitFunTypeM = maybeM "not a function type." . splitFunTy_maybe +-- | Get the quantified variables, domain, and codomain of a function type. +splitFunTypeM :: MonadCatch m => Type -> m ([TyVar], Type, Type) +splitFunTypeM ty = prefixFailMsg "Split function type failed: " $ do + let (tvs, fTy) = splitForAllTys ty + (argTy, resTy) <- maybeM "not a function type." $ splitFunTy_maybe fTy + return (tvs, argTy, resTy) -- | Return the domain/codomain type of an endofunction type. -endoFunType :: Monad m => Type -> m Type -endoFunType ty = - do (ty1,ty2) <- splitFunTypeM ty +endoFunTypeM :: MonadCatch m => Type -> m ([TyVar], Type) +endoFunTypeM ty = + do (tvs,ty1,ty2) <- splitFunTypeM ty guardMsg (eqType ty1 ty2) ("argument and result types differ.") - return ty1 + return (tvs, ty1) -- | Return the domain/codomain type of an endofunction expression. -endoFunExprType :: Monad m => CoreExpr -> m Type -endoFunExprType = exprTypeM >=> endoFunType +endoFunExprTypeM :: MonadCatch m => CoreExpr -> m ([TyVar], Type) +endoFunExprTypeM = exprTypeM >=> endoFunTypeM -- | Return the domain and codomain types of a function expression. -funExprArgResTypes :: Monad m => CoreExpr -> m (Type,Type) -funExprArgResTypes = exprTypeM >=> splitFunTypeM +funExprArgResTypesM :: MonadCatch m => CoreExpr -> m ([TyVar],Type,Type) +funExprArgResTypesM = exprTypeM >=> splitFunTypeM -- | Check two expressions have types @a -> b@ and @b -> a@, returning @(a,b)@. funExprsWithInverseTypes :: MonadCatch m => CoreExpr -> CoreExpr -> m (Type,Type) funExprsWithInverseTypes f g = - do (fdom,fcod) <- funExprArgResTypes f - (gdom,gcod) <- funExprArgResTypes g + do (_,fdom,fcod) <- funExprArgResTypesM f -- TODO: don't throw away TyVars + (_,gdom,gcod) <- funExprArgResTypesM g setFailMsg "functions do not have inverse types." $ do guardM (eqType fdom gcod) guardM (eqType gdom fcod) diff --git a/src/HERMIT/Dictionary.hs b/src/HERMIT/Dictionary.hs --- a/src/HERMIT/Dictionary.hs +++ b/src/HERMIT/Dictionary.hs @@ -20,6 +20,7 @@ , module HERMIT.Dictionary.Undefined , module HERMIT.Dictionary.Unfold , module HERMIT.Dictionary.Unsafe + , module HERMIT.Dictionary.WorkerWrapper.Common -- TODO: rename , module HERMIT.Dictionary.WorkerWrapper.Fix , module HERMIT.Dictionary.WorkerWrapper.FixResult ) where @@ -64,6 +65,8 @@ import qualified HERMIT.Dictionary.Unfold as Unfold import HERMIT.Dictionary.Unsafe hiding (externals) import qualified HERMIT.Dictionary.Unsafe as Unsafe +import HERMIT.Dictionary.WorkerWrapper.Common hiding (externals) +import qualified HERMIT.Dictionary.WorkerWrapper.Common as WorkerWrapperCommon import HERMIT.Dictionary.WorkerWrapper.Fix hiding (externals) import qualified HERMIT.Dictionary.WorkerWrapper.Fix as WorkerWrapperFix import HERMIT.Dictionary.WorkerWrapper.FixResult hiding (externals) @@ -92,6 +95,7 @@ ++ Undefined.externals ++ Unfold.externals ++ Unsafe.externals + ++ WorkerWrapperCommon.externals ++ WorkerWrapperFix.externals ++ WorkerWrapperFixResult.externals diff --git a/src/HERMIT/Dictionary/AlphaConversion.hs b/src/HERMIT/Dictionary/AlphaConversion.hs --- a/src/HERMIT/Dictionary/AlphaConversion.hs +++ b/src/HERMIT/Dictionary/AlphaConversion.hs @@ -1,50 +1,47 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} module HERMIT.Dictionary.AlphaConversion - ( -- * Alpha-Renaming and Shadowing - externals - -- ** Alpha-Renaming - , alphaR - , alphaLamR - , alphaCaseBinderR - , alphaAltWithR - , alphaAltVarsR - , alphaAltR - , alphaCaseR - , alphaLetWithR - , alphaLetVarsR - , alphaLetR - , alphaProgConsWithR - , alphaProgConsIdsR - , alphaProgConsR - , alphaProgR - -- ** Shadow Detection and Unshadowing - , unshadowR - , unshadowExprR - , unshadowAltR - , unshadowProgR - , visibleVarsT - , cloneVarAvoidingT --- , freshNameGenAvoidingT - , freshNameGenAvoiding - , detectShadowsM - , replaceVarR - ) -where + ( -- * Alpha-Renaming and Shadowing + externals + -- ** Alpha-Renaming + , alphaR + , alphaLamR + , alphaCaseBinderR + , alphaAltWithR + , alphaAltVarsR + , alphaAltR + , alphaCaseR + , alphaLetWithR + , alphaLetVarsR + , alphaLetR + , alphaProgConsWithR + , alphaProgConsIdsR + , alphaProgConsR + , alphaProgR + -- ** Shadow Detection and Unshadowing + , unshadowR + , unshadowExprR + , unshadowAltR + , unshadowProgR + , visibleVarsT + , cloneVarAvoidingT + , freshNameGenAvoiding + , detectShadowsM + , replaceVarR + ) where -import Control.Applicative import Control.Arrow -import Control.Monad (liftM2) +import Control.Monad (liftM, liftM2) import Data.Char (isDigit) import Data.Function (on) -import Data.List (intersect) -import Data.Maybe (fromMaybe, listToMaybe) +import Data.List (intersect, delete, elemIndex) +import Data.Maybe (listToMaybe) import HERMIT.Core import HERMIT.Context -import HERMIT.Monad import HERMIT.Kure import HERMIT.External import HERMIT.GHC +import HERMIT.Name import HERMIT.Utilities(dupsBy) import HERMIT.Dictionary.GHC hiding (externals) @@ -106,7 +103,7 @@ -- | If a name is provided, use that as the name of the new variable. -- Otherwise modify the variable name making sure to /not/ clash with the given variables or any visible variables. -cloneVarAvoidingT :: BoundVars c => Var -> Maybe String -> [Var] -> Transform c HermitM CoreTC Var +cloneVarAvoidingT :: (BoundVars c, MonadUnique m) => Var -> Maybe String -> [Var] -> Transform c m CoreTC Var cloneVarAvoidingT v mn vs = do vvs <- visibleVarsT let nameModifier = freshNameGenAvoiding mn (extendVarSetList vvs vs) @@ -125,7 +122,7 @@ , nm `notElem` names ] where - names = map uqName (varSetElems curr) + names = varSetToStrings curr nums = reverse $ takeWhile isDigit (reverse old) baseLeng = length $ drop (length nums) old base = take baseLeng old @@ -136,8 +133,8 @@ -- | Discard variables from the first set that do not shadow a variable in the second set. shadowedBy :: VarSet -> VarSet -> VarSet -shadowedBy vs fvs = let fvUqNames = map uqName (varSetElems fvs) - in filterVarSet (\ v -> uqName v `elem` fvUqNames) vs +shadowedBy vs fvs = let fvNames = varSetToStrings fvs + in filterVarSet (\ v -> unqualifiedName v `elem` fvNames) vs -- | Shadows are any duplicates in the list, or any occurrences of the list elements in the set. detectShadowsM :: Monad m => [Var] -> VarSet -> m VarSet @@ -147,72 +144,86 @@ -- | Rename local variables with manifestly unique names (x, x0, x1, ...). -- Does not rename top-level definitions. -unshadowR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb) - => Rewrite c HermitM Core +unshadowR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c + , ReadPath c Crumb, MonadCatch m, MonadUnique m ) + => Rewrite c m Core unshadowR = setFailMsg "No shadows to eliminate." $ anytdR (promoteExprR unshadowExprR <+ promoteAltR unshadowAltR <+ promoteProgR unshadowProgR) -unshadowExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) - => Rewrite c HermitM CoreExpr +unshadowExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr unshadowExprR = do - bs <- letVarsT <+ (return <$> (caseBinderIdT <+ lamVarT)) - fvs <- unionVarSet <$> boundVarsT <*> arr freeVarsExpr + bs <- letVarsT <+ (liftM return (caseBinderIdT <+ lamVarT)) + fvs <- liftM2 unionVarSet boundVarsT (arr freeVarsExpr) ss <- detectShadowsM bs fvs alphaLamR Nothing <+ alphaLetVarsR (varSetElems ss) <+ alphaCaseBinderR Nothing -unshadowAltR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) - => Rewrite c HermitM CoreAlt +unshadowAltR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m) + => Rewrite c m CoreAlt unshadowAltR = do bs <- arr altVars - fvs <- unionVarSet <$> boundVarsT <*> arr freeVarsAlt + fvs <- liftM2 unionVarSet boundVarsT (arr freeVarsAlt) ss <- detectShadowsM bs fvs alphaAltVarsR (varSetElems ss) -unshadowProgR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) - => Rewrite c HermitM CoreProg +unshadowProgR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m) + => Rewrite c m CoreProg unshadowProgR = do bs <- progConsIdsT - fvs <- unionVarSet <$> boundVarsT <*> arr freeVarsProg + fvs <- liftM2 unionVarSet boundVarsT (arr freeVarsProg) ss <- detectShadowsM bs fvs alphaProgConsIdsR (varSetElems ss) dupVars :: [Var] -> [Var] -dupVars = dupsBy ((==) `on` uqName) +dupVars = dupsBy ((==) `on` unqualifiedName) ----------------------------------------------------------------------- --- Maybe this should be defined elsewhere. +-- Maybe this should be defined in Dictionary.GHC. -- | Replace all occurrences of a specified variable. -- Arguments are the variable to replace and the replacement variable, respectively. replaceVarR :: (Injection a Core, MonadCatch m) => Var -> Var -> Rewrite c m a replaceVarR v v' = extractR $ tryR $ substR v $ varToCoreExpr v' --- | Given a variable to replace, and a replacement, produce a 'Var' @->@ 'Var' function that --- acts as an identity for all 'Var's except the one to replace, for which it returns the replacment. --- Don't export this, it'll likely just cause confusion. -replaceVar :: Var -> Var -> (Var -> Var) -replaceVar v v' = replaceVars [(v,v')] +-- TODO: Experimental +replaceRecBindVarR :: Monad m => Id -> Id -> Rewrite c m CoreBind +replaceRecBindVarR v v' = + do Rec ies <- idR + let (is,es) = unzip ies + case elemIndex v is of + Nothing -> fail "Specified identifier does not occur in the current recursive binding group." + Just n -> let is0 = delete v is + (is1,is2) = splitAt n is0 + is' = is1 ++ v' : is2 + es' = map (substCoreExpr v (Var v')) es + -- TODO. Do we need to initialize the emptySubst with bindFreeVars? + sub = extendSubst emptySubst v (Var v') + in return $ snd $ substBind sub (Rec (zip is' es')) --- | Given a lists of variables to replace, and their replacements, produce a 'Var' @->@ 'Var' function that --- acts as in identity for all 'Var's except the ones to replace, for which it returns the replacment. --- Don't export this, it'll likely just cause confusion. -replaceVars :: [(Var,Var)] -> (Var -> Var) -replaceVars kvs v = fromMaybe v (lookup v kvs) + -- let is0 = delete v is + -- emptySub = mkEmptySubst $ mkInScopeSet $ unionVarSets (map (localFreeVarsExpr . Var) is0) + -- sub = extendSubst emptySub v (Var v') + -- (is1,is2) = splitAt n (snd $ substRecBndrs sub is0) + -- is' = is1 ++ v' : is2 + -- es' = map (substCoreExpr v (Var v')) es + -- in return $ Rec (zip is' es') ----------------------------------------------------------------------- -- | Alpha rename a lambda binder. Optionally takes a suggested new name. -alphaLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Rewrite c HermitM CoreExpr +alphaLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Maybe String -> Rewrite c m CoreExpr alphaLamR mn = setFailMsg (wrongFormForAlpha "Lam v e") $ do v <- lamVarT v' <- extractT (cloneVarAvoidingT v mn [v]) - lamAnyR (arr $ replaceVar v v') (replaceVarR v v') + lamAnyR (return v') (replaceVarR v v') ----------------------------------------------------------------------- -- | Alpha rename a case binder. Optionally takes a suggested new name. -alphaCaseBinderR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Rewrite c HermitM CoreExpr +alphaCaseBinderR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Maybe String -> Rewrite c m CoreExpr alphaCaseBinderR mn = setFailMsg (wrongFormForAlpha "Case e i ty alts") $ do i <- caseBinderIdT i' <- extractT (cloneVarAvoidingT i mn [i]) @@ -221,7 +232,8 @@ ----------------------------------------------------------------------- -- | Rename the specified variable in a case alternative. Optionally takes a suggested new name. -alphaAltVarR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Var -> Rewrite c HermitM CoreAlt +alphaAltVarR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Maybe String -> Var -> Rewrite c m CoreAlt alphaAltVarR mn v = do (con, vs, rhs) <- idR v' <- extractT (cloneVarAvoidingT v mn vs) @@ -238,129 +250,150 @@ -- | Rename the specified variables in a case alternative, using the suggested names where provided. -- Suggested names *must* be provided in left-to-right order matching the order of the alt binders. -alphaAltVarsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe String,Var)] -> Rewrite c HermitM CoreAlt +alphaAltVarsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => [(Maybe String,Var)] -> Rewrite c m CoreAlt alphaAltVarsWithR = andR . map (uncurry alphaAltVarR) . reverse -- note: right-to-left so type subst aren't undone -- | Rename the variables bound in a case alternative with the given list of suggested names. -alphaAltWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [String] -> Rewrite c HermitM CoreAlt +alphaAltWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => [String] -> Rewrite c m CoreAlt alphaAltWithR ns = do vs <- arr altVars alphaAltVarsWithR $ zip (map Just ns) vs -- | Rename the specified variables in a case alternative. -alphaAltVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreAlt +alphaAltVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => [Var] -> Rewrite c m CoreAlt alphaAltVarsR vs = do bs <- arr altVars alphaAltVarsWithR (zip (repeat Nothing) (bs `intersect` vs)) -- | Rename all identifiers bound in a case alternative. -alphaAltR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreAlt +alphaAltR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreAlt alphaAltR = arr altVars >>= alphaAltVarsR ----------------------------------------------------------------------- -- | Rename all identifiers bound in a case expression. -alphaCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +alphaCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr alphaCaseR = alphaCaseBinderR Nothing >+> caseAllR idR idR idR (const alphaAltR) ----------------------------------------------------------------------- -- | Alpha rename a non-recursive let binder. Optionally takes a suggested new name. -alphaLetNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Rewrite c HermitM CoreExpr +alphaLetNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Maybe String -> Rewrite c m CoreExpr alphaLetNonRecR mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $ do v <- letNonRecVarT v' <- extractT (cloneVarAvoidingT v mn [v]) letNonRecAnyR (return v') idR (replaceVarR v v') -- | Alpha rename a non-recursive let binder if the variable appears in the argument list. Optionally takes a suggested new name. -alphaLetNonRecVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> [Var] -> Rewrite c HermitM CoreExpr -alphaLetNonRecVarsR mn vs = whenM ((`elem` vs) <$> letNonRecVarT) (alphaLetNonRecR mn) +alphaLetNonRecVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Maybe String -> [Var] -> Rewrite c m CoreExpr +alphaLetNonRecVarsR mn vs = whenM (liftM (`elem` vs) letNonRecVarT) (alphaLetNonRecR mn) -- TODO: Maybe it would be more efficient to rename all the Ids at once, rather than one by one? -- | Rename the specified identifiers in a recursive let, using the suggested names where provided. -alphaLetRecIdsWithR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe String,Id)] -> Rewrite c HermitM CoreExpr +alphaLetRecIdsWithR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , BoundVars c, MonadCatch m, MonadUnique m ) + => [(Maybe String,Id)] -> Rewrite c m CoreExpr alphaLetRecIdsWithR = andR . map (uncurry alphaLetRecIdR) where -- | Rename the specified identifier bound in a recursive let. Optionally takes a suggested new name. - alphaLetRecIdR :: Maybe String -> Id -> Rewrite c HermitM CoreExpr + alphaLetRecIdR :: Maybe String -> Id -> Rewrite c m CoreExpr alphaLetRecIdR mn i = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $ do is <- letRecIdsT i' <- extractT (cloneVarAvoidingT i mn is) - letRecDefAnyR (\ _ -> (arr (replaceVar i i'), replaceVarR i i')) (replaceVarR i i') + letAnyR (replaceRecBindVarR i i') (replaceVarR i i') -- | Rename the identifiers bound in a Let with the given list of suggested names. -alphaLetWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [String] -> Rewrite c HermitM CoreExpr +alphaLetWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => [String] -> Rewrite c m CoreExpr alphaLetWithR ns = alphaLetNonRecR (listToMaybe ns) <+ (letRecIdsT >>= (alphaLetRecIdsWithR . zip (map Just ns))) -- | Rename the specified variables bound in a let. -alphaLetVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreExpr +alphaLetVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => [Var] -> Rewrite c m CoreExpr alphaLetVarsR vs = alphaLetNonRecVarsR Nothing vs <+ (do bs <- letT (arr bindVars) successT const alphaLetRecIdsWithR (zip (repeat Nothing) (bs `intersect` vs)) ) -- | Rename all identifiers bound in a Let. -alphaLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +alphaLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr alphaLetR = letVarsT >>= alphaLetVarsR ----------------------------------------------------------------------- -- | Alpha rename a non-recursive top-level binder. Optionally takes a suggested new name. -alphaProgConsNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Rewrite c HermitM CoreProg +alphaProgConsNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Maybe String -> Rewrite c m CoreProg alphaProgConsNonRecR mn = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $ do i <- progConsNonRecIdT - guardMsg (not $ isExportedId i) ("Identifier " ++ var2String i ++ " is exported, and thus cannot be alpha-renamed.") + guardMsg (not $ isExportedId i) ("Identifier " ++ unqualifiedName i ++ " is exported, and thus cannot be alpha-renamed.") i' <- extractT (cloneVarAvoidingT i mn [i]) consNonRecAnyR (return i') idR (replaceVarR i i') -- | Alpha rename a non-recursive top-level binder if the identifier appears in the argument list. Optionally takes a suggested new name. -alphaProgConsNonRecIdsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> [Id] -> Rewrite c HermitM CoreProg -alphaProgConsNonRecIdsR mn is = whenM ((`elem` is) <$> progConsNonRecIdT) (alphaProgConsNonRecR mn) +alphaProgConsNonRecIdsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Maybe String -> [Id] -> Rewrite c m CoreProg +alphaProgConsNonRecIdsR mn is = whenM (liftM (`elem` is) progConsNonRecIdT) (alphaProgConsNonRecR mn) -- TODO: Maybe it would be more efficient to rename all the Ids at once, rather than one by one? -- | Rename the specified identifiers in a recursive top-level binding at the head of a program, using the suggested names where provided. -alphaProgConsRecIdsWithR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe String,Id)] -> Rewrite c HermitM CoreProg +alphaProgConsRecIdsWithR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , BoundVars c, MonadCatch m, MonadUnique m ) + => [(Maybe String,Id)] -> Rewrite c m CoreProg alphaProgConsRecIdsWithR = andR . map (uncurry alphaProgConsRecIdR) . filter (not . isExportedId . snd) where -- | Rename the specified identifier bound in a recursive top-level binder. Optionally takes a suggested new name. - alphaProgConsRecIdR :: Maybe String -> Id -> Rewrite c HermitM CoreProg + alphaProgConsRecIdR :: Maybe String -> Id -> Rewrite c m CoreProg alphaProgConsRecIdR mn i = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $ do is <- progConsRecIdsT i' <- extractT (cloneVarAvoidingT i mn is) - consRecDefAnyR (\ _ -> (arr (replaceVar i i'), replaceVarR i i')) (replaceVarR i i') + progConsAnyR (replaceRecBindVarR i i') (replaceVarR i i') -- | Rename the identifiers bound in the top-level binding at the head of the program with the given list of suggested names. -alphaProgConsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [String] -> Rewrite c HermitM CoreProg +alphaProgConsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => [String] -> Rewrite c m CoreProg alphaProgConsWithR ns = alphaProgConsNonRecR (listToMaybe ns) <+ (progConsRecIdsT >>= (alphaProgConsRecIdsWithR . zip (map Just ns))) -- | Rename the specified variables bound in the top-level binding at the head of the program. -alphaProgConsIdsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Id] -> Rewrite c HermitM CoreProg +alphaProgConsIdsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => [Id] -> Rewrite c m CoreProg alphaProgConsIdsR vs = alphaProgConsNonRecIdsR Nothing vs <+ (do bs <- progConsT (arr bindVars) successT const alphaProgConsRecIdsWithR (zip (repeat Nothing) (bs `intersect` vs)) ) -- | Rename all identifiers bound in the top-level binding at the head of the program. -alphaProgConsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreProg +alphaProgConsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreProg alphaProgConsR = progConsIdsT >>= alphaProgConsIdsR ----------------------------------------------------------------------- -- | Rename all identifiers bound at the top-level. -alphaProgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreProg +alphaProgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreProg alphaProgR = alphaProgConsR >+> progConsAllR idR alphaProgR ----------------------------------------------------------------------- -- | Alpha rename any bindings at this node. Note: does not rename case alternatives unless invoked on the alternative. -alphaR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core +alphaR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m Core alphaR = setFailMsg "Cannot alpha-rename here." $ promoteExprR (alphaLamR Nothing <+ alphaCaseBinderR Nothing <+ alphaLetR) <+ promoteAltR alphaAltR diff --git a/src/HERMIT/Dictionary/Common.hs b/src/HERMIT/Dictionary/Common.hs --- a/src/HERMIT/Dictionary/Common.hs +++ b/src/HERMIT/Dictionary/Common.hs @@ -13,8 +13,6 @@ , callNameG , callDataConT , callDataConNameT - , callsR - , callsT -- ** Collecting variable bindings , progConsIdsT , progConsRecIdsT @@ -32,11 +30,9 @@ , boundVarsT , findBoundVarT , findIdT -#if __GLASGOW_HASKELL__ > 706 , findVarT , findTyConT , findTypeT -#endif , varBindingDepthT , varIsOccurrenceOfT , exprIsOccurrenceOfT @@ -63,9 +59,9 @@ ------------------------------------------------------------------------------ --- | Apply a transformation to a value in the current context. +-- | apply a transformation to a value in the current context. applyInContextT :: Transform c m a b -> a -> Transform c m x b -applyInContextT t a = contextonlyT $ \ c -> apply t c a +applyInContextT t a = contextonlyT $ \ c -> applyT t c a -- Note: this is the same as: return a >>> t @@ -78,6 +74,7 @@ App {} -> return (collectArgs e) _ -> fail "not an application or variable occurence." +-- | Succeeds if we are looking at an application matching the given predicate. callPredT :: Monad m => (Id -> [CoreExpr] -> Bool) -> Transform c m CoreExpr (CoreExpr, [CoreExpr]) callPredT p = do call@(Var i, args) <- callT @@ -86,9 +83,11 @@ -- | Succeeds if we are looking at an application of given function -- returning zero or more arguments to which it is applied. -callNameT :: MonadCatch m => String -> Transform c m CoreExpr (CoreExpr, [CoreExpr]) -callNameT nm = setFailMsg ("callNameT failed: not a call to '" ++ nm ++ ".") $ - callPredT (const . cmpString2Var nm) +-- +-- Note: comparison is performed with cmpHN2Var. +callNameT :: MonadCatch m => HermitName -> Transform c m CoreExpr (CoreExpr, [CoreExpr]) +callNameT nm = prefixFailMsg ("callNameT failed: not a call to '" ++ show nm ++ ".") + $ callPredT (const . cmpHN2Var nm) -- | Succeeds if we are looking at a fully saturated function call. callSaturatedT :: Monad m => Transform c m CoreExpr (CoreExpr, [CoreExpr]) @@ -97,20 +96,15 @@ -- idArity is conservatively set to zero by default. -- | Succeeds if we are looking at an application of given function -callNameG :: MonadCatch m => String -> Transform c m CoreExpr () -callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >>= \_ -> constT (return ()) +callNameG :: MonadCatch m => HermitName -> Transform c m CoreExpr () +callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >> return () -- | Succeeds if we are looking at an application of a data constructor. callDataConT :: MonadCatch m => Transform c m CoreExpr (DataCon, [Type], [CoreExpr]) callDataConT = prefixFailMsg "callDataConT failed:" $ -#if __GLASGOW_HASKELL__ > 706 do mb <- contextfreeT $ \ e -> let in_scope = mkInScopeSet (mkVarEnv [ (v,v) | v <- varSetElems (localFreeVarsExpr e) ]) in return $ exprIsConApp_maybe (in_scope, idUnfolding) e maybe (fail "not a datacon application.") return mb -#else - contextfreeT (return . exprIsConApp_maybe idUnfolding) - >>= maybe (fail "not a datacon application.") return -#endif -- | Succeeds if we are looking at an application of a named data constructor. callDataConNameT :: MonadCatch m => String -> Transform c m CoreExpr (DataCon, [Type], [CoreExpr]) @@ -119,16 +113,6 @@ guardMsg (cmpString2Name nm (dataConName dc)) "wrong datacon." return res --- TODO: Both callsR and callsT should be eliminated, now that we have callNameT --- | Apply a rewrite to all applications of a given function in a top-down manner, pruning on success. -callsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => String -> Rewrite c m CoreExpr -> Rewrite c m Core -callsR nm rr = prunetdR (promoteExprR $ callNameG nm >> rr) - --- | Apply a translate to all applications of a given function in a top-down manner, --- pruning on success, collecting the results. -callsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => String -> Transform c m CoreExpr b -> Transform c m Core [b] -callsT nm t = collectPruneT (promoteExprT $ callNameG nm >> t) - ------------------------------------------------------------------------------ -- | List the identifiers bound by the top-level binding group at the head of the program. @@ -200,35 +184,39 @@ boundVarsT = contextonlyT (return . boundVars) -- | Find the unique variable bound in the context that matches the given name, failing if it is not unique. -findBoundVarT :: (BoundVars c, MonadCatch m) => String -> Transform c m a Var -findBoundVarT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ - do c <- contextT - case varSetElems (findBoundVars nm c) of - [] -> fail "no matching variables in scope." - [v] -> return v - _ : _ : _ -> fail "multiple matching variables in scope." +findBoundVarT :: (BoundVars c, MonadCatch m) => (Var -> Bool) -> Transform c m a Var +findBoundVarT p = do + c <- contextT + case varSetElems (findBoundVars p c) of + [] -> fail "no matching variables in scope." + [v] -> return v + _ : _ : _ -> fail "multiple matching variables in scope." -------------------------------------------------------------------------------------------------- -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment. -findIdT :: (BoundVars c, HasModGuts m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> Transform c m a Id -findIdT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ contextonlyT (findId nm) +findIdT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) + => HermitName -> Transform c m a Id +findIdT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findId nm) -#if __GLASGOW_HASKELL__ > 706 -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment. -findVarT :: (BoundVars c, HasModGuts m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> Transform c m a Var -findVarT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ contextonlyT (findVar nm) +findVarT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) + => HermitName -> Transform c m a Var +findVarT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findVar nm) -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment. -findTyConT :: (BoundVars c, HasModGuts m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> Transform c m a TyCon -findTyConT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ contextonlyT (findTyCon nm) +findTyConT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) + => HermitName -> Transform c m a TyCon +findTyConT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findTyCon nm) -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment. -findTypeT :: (BoundVars c, HasModGuts m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> Transform c m a Type -findTypeT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ contextonlyT (findType nm) -#endif +findTypeT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) + => HermitName -> Transform c m a Type +findTypeT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findType nm) -- TODO: "inScope" was defined elsewhere, but I've moved it here. Should it be combined with the above functions? +-- Used in Dictionary.Inline to check if variables an in scope. +-- Used in Dictionary.Fold -- | Determine whether a variable is in scope. inScope :: ReadBindings c => c -> Var -> Bool @@ -241,7 +229,7 @@ -- | Modify transformation to apply to current expression as if it were the body of a lambda binding the given variables. withVarsInScope :: (AddBindings c, ReadPath c Crumb) => [Var] -> Transform c m a b -> Transform c m a b -withVarsInScope vs t = transform $ apply t . flip (foldl (flip addLambdaBinding)) vs -- careful to add left-to-right +withVarsInScope vs t = transform $ applyT t . flip (foldl (flip addLambdaBinding)) vs -- careful to add left-to-right ------------------------------------------------------------------------------ diff --git a/src/HERMIT/Dictionary/Composite.hs b/src/HERMIT/Dictionary/Composite.hs --- a/src/HERMIT/Dictionary/Composite.hs +++ b/src/HERMIT/Dictionary/Composite.hs @@ -8,17 +8,22 @@ , bashR , bashExtendedWithR , bashDebugR - ) -where + , smashR + , smashUsingR + , smashExtendedWithR + ) where import Control.Arrow +import Data.String (fromString) + import HERMIT.Context import HERMIT.Core +import HERMIT.External import HERMIT.GHC -import HERMIT.Monad import HERMIT.Kure -import HERMIT.External +import HERMIT.Monad +import HERMIT.Name import HERMIT.Dictionary.Debug hiding (externals) import HERMIT.Dictionary.GHC hiding (externals) @@ -31,7 +36,8 @@ externals :: [External] externals = [ external "unfold-basic-combinator" (promoteExprR unfoldBasicCombinatorR :: RewriteH Core) - [ "Unfold the current expression if it is one of the basic combinators: ($), (.), id, flip, const, fst or snd." ] + [ "Unfold the current expression if it is one of the basic combinators:" + , "($), (.), id, flip, const, fst, snd, curry, and uncurry." ] , external "simplify" (simplifyR :: RewriteH Core) [ "innermost (unfold-basic-combinator <+ beta-reduce-plus <+ safe-let-subst <+ case-reduce <+ let-elim)" ] , external "bash" (bashR :: RewriteH Core) @@ -52,16 +58,20 @@ ------------------------------------------------------------------------------------------------------ -basicCombinators :: [String] -basicCombinators = ["$",".","id","flip","const","fst","snd","curry","uncurry"] +basicCombinators :: [HermitName] +basicCombinators = map fromString ["$",".","id","flip","const","fst","snd","curry","uncurry"] --- | Unfold the current expression if it is one of the basic combinators: ('$'), ('.'), 'id', 'flip', 'const', 'fst' or 'snd'. +-- | Unfold the current expression if it is one of the basic combinators: +-- ('$'), ('.'), 'id', 'flip', 'const', 'fst', 'snd', 'curry', and 'uncurry'. -- This is intended to be used as a component of simplification traversals such as 'simplifyR' or 'bashR'. -unfoldBasicCombinatorR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr -unfoldBasicCombinatorR = setFailMsg "unfold-basic-combinator failed." $ - unfoldNamesR basicCombinators +unfoldBasicCombinatorR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , MonadCatch m ) + => Rewrite c m CoreExpr +unfoldBasicCombinatorR = setFailMsg "unfold-basic-combinator failed." $ unfoldNamesR basicCombinators -simplifyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM Core +simplifyR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , MonadCatch m, MonadUnique m ) + => Rewrite c m Core simplifyR = setFailMsg "Simplify failed: nothing to simplify." $ innermostR ( promoteBindR recToNonrecR <+ promoteExprR ( unfoldBasicCombinatorR @@ -73,80 +83,68 @@ ------------------------------------------------------------------------------------------------------ -bashR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM Core +-- | Bash is intended as a general-purpose cleanup/simplification command. +-- It performs rewrites such as let floating, case floating, and case elimination, when safe. +-- It also performs dead binding elimination and case reduction, and unfolds a number of +-- basic combinators. See 'bashComponents' for a list of rewrites performed. +-- Bash also performs occurrence analysis and de-zombification on the result, to update +-- IdInfo attributes relied-upon by GHC. +bashR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , MonadCatch m, MonadUnique m ) + => Rewrite c m Core bashR = bashExtendedWithR [] -bashExtendedWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core +-- | An extensible bash. Given rewrites are performed before normal bash rewrites. +bashExtendedWithR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , MonadCatch m, MonadUnique m ) + => [Rewrite c m Core] -> Rewrite c m Core bashExtendedWithR rs = bashUsingR (rs ++ map fst bashComponents) - -smashR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM Core -smashR = smashExtendedWithR [] - -smashExtendedWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core -smashExtendedWithR rs = smashUsingR (rs ++ map fst smashComponents1) (map fst smashComponents2) - - --- | Like bashR, but outputs name of each successful sub-rewrite, providing a log. +-- | Like 'bashR', but outputs name of each successful sub-rewrite, providing a log. -- Also performs core lint on the result of a successful sub-rewrite. -- If core lint fails, shows core fragment before and after the sub-rewrite which introduced the problem. -- Note: core fragment which fails linting is still returned! Otherwise would behave differently than bashR. -- Useful for debugging the bash command itself. -bashDebugR :: RewriteH Core -bashDebugR = bashUsingR [ idR >>= \e -> r >>> traceR nm >>> (catchM (promoteT lintExprT >> idR) - (\s -> do _ <- return e >>> observeR "[before]" - observeR ("[" ++ nm ++ "]\n" ++ s))) +bashDebugR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , HasDebugChan m, HasDynFlags m, MonadCatch m, MonadUnique m ) + => Rewrite c m Core +bashDebugR = bashUsingR [ bracketR nm r >>> catchM (promoteT lintExprT >> idR) traceR | (r,nm) <- bashComponents ] --- bashUsingR :: forall c m. (ExtendPath c Crumb, AddBindings c, MonadCatch m) => [Rewrite c m Core] -> Rewrite c m Core --- bashUsingR rs = --- setFailMsg "bash failed: nothing to do." $ --- readerT $ \ core1 -> occurAnalyseR >>> readerT (\ core2 -> if core1 `coreSyntaxEq` core2 --- then bashCoreR -- equal, no progress yet --- else tryR bashCoreR -- unequal, progress has already been made --- ) --- -- the changedByR combinator doesn't quite do what we need here --- where --- bashCoreR :: Rewrite c m Core --- bashCoreR = repeatR (innermostR (catchesT rs) >>> occurAnalyseR) - -bashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => [Rewrite c m Core] -> Rewrite c m Core -bashUsingR rs = - setFailMsg "bash failed: nothing to do." $ +-- | Perform the 'bash' algorithm with a given list of rewrites. +bashUsingR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb, MonadCatch m) + => [Rewrite c m Core] -> Rewrite c m Core +bashUsingR rs = setFailMsg "bash failed: nothing to do." $ repeatR (occurAnalyseR >>> onetdR (catchesT rs)) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR -smashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => [Rewrite c m Core] -> [Rewrite c m Core] -> Rewrite c m Core -smashUsingR rs1 rs2 = - setFailMsg "smash failed: nothing to do." $ - repeatR (occurAnalyseR >>> (onetdR (catchesT rs1) <+ onetdR (catchesT rs2))) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR - - - -- occurAnalyseChangedR >+> (innermostR (catchesT rs) >>> occurAnalyseR) - {- Occurrence Analysis updates meta-data, as well as performing some basic simplifications. occurAnalyseR always succeeds, whereas occurAnalyseChangedR fails is the result is syntactically equivalent. The awkwardness is because: - we want bash to fail if nothing changes - - we want bash to succeed if the result is not syntactically-equivalent (ideally, if any changes are made at all, but that's not the case yet) + - we want bash to succeed if the result is not syntactically-equivalent + (ideally, if any changes are made at all, but that's not the case yet) - we want bash to update the meta-data - after running bash there should be nothing left to do (i.e. an immediately subsequent bash should always fail) -Also, it's still possible for some meta-data to be out-of-date after bash, despite the case analysis. For example, if the focal point is a case-alt rhs, this won't update the identifer info of variables bound in the alternative. +Also, it's still possible for some meta-data to be out-of-date after bash, despite the case analysis. +For example, if the focal point is a case-alt rhs, this won't update the identifer info of variables +bound in the alternative. -} bashHelp :: [String] -bashHelp = "Iteratively apply the following rewrites until nothing changes:" : map snd (bashComponents - :: [(RewriteH Core,String)] -- to resolve ambiguity +bashHelp = "Iteratively apply the following rewrites until nothing changes:" + : map snd (bashComponents :: [(RewriteH Core,String)] -- to resolve ambiguity ) - -- TODO: Think about a good order for bash. -bashComponents :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [(Rewrite c HermitM Core, String)] +bashComponents :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , MonadCatch m, MonadUnique m ) + => [(Rewrite c m Core, String)] bashComponents = [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr") -- ?? (promoteExprR betaReduceR, "beta-reduce") -- O(1) , (promoteExprR (caseReduceR True), "case-reduce") -- O(n) - , (promoteExprR (caseReduceIdR True), "case-reduce-id") -- O(n) + , (promoteExprR (caseReduceUnfoldR True), "case-reduce-unfold") -- O(n) , (promoteExprR caseElimSeqR, "case-elim-seq") , (promoteExprR unfoldBasicCombinatorR, "unfold-basic-combinator") -- O(n) , (promoteExprR inlineCaseAlternativeR, "inline-case-alternative") -- O(n) @@ -171,6 +169,28 @@ ] +------------------------------------------------------------------------------------------------------ + +-- | Smash is a more powerful but less efficient version of bash. +-- Unlike bash, smash is not concerned with whether it duplicates work, +-- and is intended for use during proving tasks. +smashR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , MonadCatch m, MonadUnique m ) + => Rewrite c m Core +smashR = smashExtendedWithR [] + +smashExtendedWithR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , MonadCatch m, MonadUnique m ) + => [Rewrite c m Core] -> Rewrite c m Core +smashExtendedWithR rs = smashUsingR (rs ++ map fst smashComponents1) (map fst smashComponents2) + + +smashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => [Rewrite c m Core] -> [Rewrite c m Core] -> Rewrite c m Core +smashUsingR rs1 rs2 = + setFailMsg "smash failed: nothing to do." $ + repeatR (occurAnalyseR >>> (onetdR (catchesT rs1) <+ onetdR (catchesT rs2))) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR + + smashHelp :: [String] smashHelp = "A more powerful but less efficient version of \"bash\", intended for use while proving lemmas. Iteratively apply the following rewrites until nothing changes:" : map snd (smashComponents1 ++ smashComponents2 :: [(RewriteH Core,String)] -- to resolve ambiguity @@ -178,12 +198,14 @@ -- | As bash, but with "let-nonrec-subst" instead of "let-nonrec-subst-safe". -smashComponents1 :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [(Rewrite c HermitM Core, String)] +smashComponents1 :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , MonadCatch m, MonadUnique m ) + => [(Rewrite c m Core, String)] smashComponents1 = [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr") -- ?? (promoteExprR betaReduceR, "beta-reduce") -- O(1) , (promoteExprR (caseReduceR True), "case-reduce") -- O(n) - , (promoteExprR (caseReduceIdR True), "case-reduce-id") -- O(n) + , (promoteExprR (caseReduceUnfoldR True), "case-reduce-unfold") -- O(n) , (promoteExprR caseElimSeqR, "case-elim-seq") , (promoteExprR unfoldBasicCombinatorR, "unfold-basic-combinator") -- O(n) , (promoteExprR inlineCaseAlternativeR, "inline-case-alternative") -- O(n) @@ -207,14 +229,9 @@ -- , (promoteExprR dezombifyR, "dezombify") -- O(1) -- performed at the end ] -smashComponents2 :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [(Rewrite c HermitM Core, String)] +smashComponents2 :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c + , MonadCatch m, MonadUnique m ) + => [(Rewrite c m Core, String)] smashComponents2 = - [ - (promoteExprR caseElimMergeAltsR, "case-elim-merge-alts") -- do this last, lest it prevent other simplifications - ] - - --- (beta-reduce <+ case-reduce <+ case-reduce-id <+ case-elim-seq <+ unfold-basic-combinator <+ inline-case-alternative <+ eta-reduce <+ let-subst <+ case-float-app <+ case-float-case <+ case-float-let <+ case-float-cast <+ let-float-app <+ let-float-arg <+ let-float-lam <+ let-float-let <+ let-float-case <+ let-float-cast <+ let-float-top <+ cast-elim-refl <+ cast-elim-sym - ------------------------------------------------------------------------------------------------------- - + [ (promoteExprR caseElimMergeAltsR, "case-elim-merge-alts") -- do this last, lest it prevent other simplifications + ] diff --git a/src/HERMIT/Dictionary/Debug.hs b/src/HERMIT/Dictionary/Debug.hs --- a/src/HERMIT/Dictionary/Debug.hs +++ b/src/HERMIT/Dictionary/Debug.hs @@ -1,48 +1,51 @@ {-# LANGUAGE FlexibleContexts #-} module HERMIT.Dictionary.Debug - ( -- * Debugging Dictionarys - externals - , bracketR - , observeR - , observeFailureR - , traceR - ) -where + ( -- * Debugging Rewrites + externals + , bracketR + , observeR + , observeFailureR + , traceR + ) where import Control.Arrow -import HERMIT.Kure +import HERMIT.Context +import HERMIT.Core import HERMIT.External +import HERMIT.Kure import HERMIT.Monad -- | Exposed debugging 'External's. externals :: [External] externals = map (.+ Debug) - [ external "trace" (traceR :: String -> RewriteH Core) - [ "give a side-effect message as output when processing this command" ] - , external "observe" (observeR :: String -> RewriteH Core) - [ "give a side-effect message as output, and observe the value being processed" ] - , external "observe-failure" (observeFailureR :: String -> RewriteH Core -> RewriteH Core) - [ "give a side-effect message if the rewrite fails, including the failing input" ] - , external "bracket" (bracketR :: String -> RewriteH Core -> RewriteH Core) - [ "if given rewrite succeeds, see its input and output" ] - ] + [ external "trace" (traceR :: String -> RewriteH Core) + [ "give a side-effect message as output when processing this command" ] + , external "observe" (observeR :: String -> RewriteH Core) + [ "give a side-effect message as output, and observe the value being processed" ] + , external "observe-failure" (observeFailureR :: String -> RewriteH Core -> RewriteH Core) + [ "give a side-effect message if the rewrite fails, including the failing input" ] + , external "bracket" (bracketR :: String -> RewriteH Core -> RewriteH Core) + [ "if given rewrite succeeds, see its input and output" ] + ] -- | If the 'Rewrite' fails, print out the 'Core', with a message. -observeFailureR :: Injection a CoreTC => String -> RewriteH a -> RewriteH a +observeFailureR :: (Injection a CoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, MonadCatch m) + => String -> Rewrite c m a -> Rewrite c m a observeFailureR str m = m <+ observeR str -- | Print out the 'Core', with a message. -observeR :: Injection a CoreTC => String -> RewriteH a -observeR msg = extractR $ sideEffectR $ \ cxt core -> - sendDebugMessage $ DebugCore msg cxt core +observeR :: (Injection a CoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, Monad m) + => String -> Rewrite c m a +observeR msg = extractR $ sideEffectR $ \ cxt -> sendDebugMessage . DebugCore msg cxt -- | Just say something, every time the rewrite is done. -traceR :: String -> RewriteH a +traceR :: (HasDebugChan m, Monad m) => String -> Rewrite c m a traceR msg = sideEffectR $ \ _ _ -> sendDebugMessage $ DebugTick msg -- | Show before and after a rewrite. -bracketR :: Injection a CoreTC => String -> RewriteH a -> RewriteH a +bracketR :: (Injection a CoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, MonadCatch m) + => String -> Rewrite c m a -> Rewrite c m a bracketR msg rr = do -- Be careful to only run the rr once, in case it has side effects. (e,r) <- idR &&& attemptM rr diff --git a/src/HERMIT/Dictionary/FixPoint.hs b/src/HERMIT/Dictionary/FixPoint.hs --- a/src/HERMIT/Dictionary/FixPoint.hs +++ b/src/HERMIT/Dictionary/FixPoint.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} module HERMIT.Dictionary.FixPoint - ( -- * Operations on the Fixed Point Operator (fix) - -- | Note that many of these operations require 'Data.Function.fix' to be explicitly imported, if it is not used in the source file. - HERMIT.Dictionary.FixPoint.externals - -- ** Rewrites and BiRewrites on Fixed Points - , fixIntroR - , fixComputationRuleBR - , fixRollingRuleBR - , fixFusionRuleBR - -- ** Utilities - , mkFixT - , isFixExprT - ) -where + ( -- * Operations on the Fixed Point Operator (fix) + HERMIT.Dictionary.FixPoint.externals + -- ** Rewrites and BiRewrites on Fixed Points + , fixIntroR + , fixIntroNonRecR + , fixIntroRecR + , fixComputationRuleBR + , fixRollingRuleBR + , fixFusionRuleBR + -- ** Utilities + , isFixExprT + ) where import Control.Applicative import Control.Arrow +import Control.Monad import Control.Monad.IO.Class -import Data.Monoid (mempty) +import Data.String (fromString) import HERMIT.Context import HERMIT.Core @@ -27,60 +27,100 @@ import HERMIT.Kure import HERMIT.External import HERMIT.GHC +import HERMIT.Name import HERMIT.ParserCore import HERMIT.Utilities import HERMIT.Dictionary.Common -import HERMIT.Dictionary.GHC +import HERMIT.Dictionary.Function +import HERMIT.Dictionary.Kure import HERMIT.Dictionary.Reasoning import HERMIT.Dictionary.Undefined +import HERMIT.Dictionary.Unfold -------------------------------------------------------------------------------------------------- -- | Externals for manipulating fixed points. externals :: [External] externals = - [ external "fix-intro" (promoteDefR fixIntroR :: RewriteH Core) - [ "rewrite a recursive binding into a non-recursive binding using fix" - ] .+ Introduce .+ Context - , external "fix-computation-rule" (promoteExprBiR fixComputationRuleBR :: BiRewriteH Core) - [ "Fixed-Point Computation Rule", - "fix t f <==> f (fix t f)" - ] .+ Context - , external "fix-rolling-rule" (promoteExprBiR fixRollingRuleBR :: BiRewriteH Core) - [ "Rolling Rule", - "fix tyA (\\ a -> f (g a)) <==> f (fix tyB (\\ b -> g (f b))" - ] .+ Context - , external "fix-fusion-rule" ((\ f g h lhsR rhsR strictf -> promoteExprBiR (fixFusionRule (Just (lhsR,rhsR)) (Just strictf) f g h)) :: CoreString -> CoreString -> CoreString -> RewriteH Core -> RewriteH Core -> RewriteH Core -> BiRewriteH Core) - [ "Fixed-point Fusion Rule" - , "Given f :: A -> B, g :: A -> A, h :: B -> B, and" - , "proofs that, for some x, (f (g a) ==> x) and (h (f a) ==> x) and that f is strict, then" - , "f (fix g) <==> fix h" - ] .+ Context - , external "fix-fusion-rule-unsafe" ((\ f g h lhsR rhsR -> promoteExprBiR (fixFusionRule (Just (lhsR,rhsR)) Nothing f g h)) :: CoreString -> CoreString -> CoreString -> RewriteH Core -> RewriteH Core -> BiRewriteH Core) - [ "(Unsafe) Fixed-point Fusion Rule" - , "Given f :: A -> B, g :: A -> A, h :: B -> B, and" - , "a proof that, for some x, (f (g a) ==> x) and (h (f a) ==> x), then" - , "f (fix g) <==> fix h" - , "Note that the precondition that f is strict is required to hold." - ] .+ Context .+ PreCondition - , external "fix-fusion-rule-unsafe" ((\ f g h -> promoteExprBiR (fixFusionRule Nothing Nothing f g h)) :: CoreString -> CoreString -> CoreString -> BiRewriteH Core) - [ "(Very Unsafe) Fixed-point Fusion Rule" - , "Given f :: A -> B, g :: A -> A, h :: B -> B, then" - , "f (fix g) <==> fix h" - , "Note that the preconditions that f (g a) == h (f a) and that f is strict are required to hold." - ] .+ Context .+ PreCondition - ] + [ external "fix-intro" (fixIntroR :: RewriteH Core) + [ "rewrite a function binding into a non-recursive binding using fix" ] .+ Introduce .+ Context + , external "fix-computation-rule" (promoteExprBiR fixComputationRuleBR :: BiRewriteH Core) + [ "Fixed-Point Computation Rule", + "fix t f <==> f (fix t f)" + ] .+ Context + , external "fix-rolling-rule" (promoteExprBiR fixRollingRuleBR :: BiRewriteH Core) + [ "Rolling Rule", + "fix tyA (\\ a -> f (g a)) <==> f (fix tyB (\\ b -> g (f b))" + ] .+ Context + , external "fix-fusion-rule" ((\ f g h r1 r2 strictf -> promoteExprBiR + (fixFusionRule (Just (r1,r2)) (Just strictf) f g h)) + :: CoreString -> CoreString -> CoreString + -> RewriteH Core -> RewriteH Core + -> RewriteH Core -> BiRewriteH Core) + [ "Fixed-point Fusion Rule" + , "Given f :: A -> B, g :: A -> A, h :: B -> B, and" + , "proofs that, for some x, (f (g a) ==> x) and (h (f a) ==> x) and that f is strict, then" + , "f (fix g) <==> fix h" + ] .+ Context + , external "fix-fusion-rule-unsafe" ((\ f g h r1 r2 -> promoteExprBiR (fixFusionRule (Just (r1,r2)) Nothing f g h)) + :: CoreString -> CoreString -> CoreString + -> RewriteH Core -> RewriteH Core -> BiRewriteH Core) + [ "(Unsafe) Fixed-point Fusion Rule" + , "Given f :: A -> B, g :: A -> A, h :: B -> B, and" + , "a proof that, for some x, (f (g a) ==> x) and (h (f a) ==> x), then" + , "f (fix g) <==> fix h" + , "Note that the precondition that f is strict is required to hold." + ] .+ Context .+ PreCondition + , external "fix-fusion-rule-unsafe" ((\ f g h -> promoteExprBiR (fixFusionRule Nothing Nothing f g h)) + :: CoreString -> CoreString -> CoreString -> BiRewriteH Core) + [ "(Very Unsafe) Fixed-point Fusion Rule" + , "Given f :: A -> B, g :: A -> A, h :: B -> B, then" + , "f (fix g) <==> fix h" + , "Note that the preconditions that f (g a) == h (f a) and that f is strict are required to hold." + ] .+ Context .+ PreCondition + ] -------------------------------------------------------------------------------------------------- +fixIntroR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) + => Rewrite c m Core +fixIntroR = promoteR fixIntroRecR <+ promoteR fixIntroNonRecR + +fixIntroNonRecR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) + => Rewrite c m CoreBind +fixIntroNonRecR = prefixFailMsg "fix introduction failed: " $ do + NonRec f rhs <- idR + rhs' <- polyFixT f <<< return rhs + return $ NonRec f rhs' + -- | @f = e@ ==\> @f = fix (\\ f -> e)@ -fixIntroR :: RewriteH CoreDef -fixIntroR = prefixFailMsg "fix introduction failed: " $ - do Def f _ <- idR - f' <- constT $ cloneVarH id f - Def f <$> (mkFixT =<< (defT mempty (extractR $ substR f $ varToCoreExpr f') (\ () e' -> Lam f' e'))) +fixIntroRecR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) + => Rewrite c m CoreDef +fixIntroRecR = prefixFailMsg "fix introduction failed: " $ do + Def f rhs <- idR + rhs' <- polyFixT f <<< return rhs + return $ Def f rhs' +-- | Helper for fixIntroNonRecR and fixIntroRecR. Argument is function name. +-- Meant to be applied to RHS of function. +polyFixT :: forall c m. + ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) + => Id -> Rewrite c m CoreExpr +polyFixT f = do + (tvs, body) <- arr collectTyBinders + f' <- constT $ newIdH (unqualifiedName f) (exprType body) + body' <- contextonlyT $ \ c -> do + let constLam = mkCoreLams tvs $ varToCoreExpr f' + c' = addBindingGroup (NonRec f constLam) -- we want to unfold f such as to throw away TyArgs + $ addBindingGroup (NonRec f' body) c -- add f' to context so its in-scope after unfolding + applyT (tryR (extractR (anyCallR (promoteR (unfoldPredR (const . (==f))) :: Rewrite c m Core)))) c' body + liftM (mkCoreLams tvs) $ buildFixT $ Lam f' body' + -------------------------------------------------------------------------------------------------- -- | @fix ty f@ \<==\> @f (fix ty f)@ @@ -129,7 +169,7 @@ rollingRuleResult :: Type -> CoreExpr -> CoreExpr -> TransformH z CoreExpr rollingRuleResult ty f g = do x <- constT (newIdH "x" ty) - mkFixT (Lam x (App f (App g (Var x)))) + buildFixT (Lam x (App f (App g (Var x)))) wrongFixBody :: String wrongFixBody = "body of fix does not have the form: Lam v (App f (App g (Var v)))" @@ -141,12 +181,12 @@ -- h :: B -> B -- | If @f@ is strict, then (@f (g a)@ == @h (f a)@) ==\> (@f (fix g)@ == @fix h@) -fixFusionRuleBR :: Maybe (CoreExprEqualityProof HermitC HermitM) -> Maybe (RewriteH CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr -> BiRewriteH CoreExpr +fixFusionRuleBR :: Maybe (EqualityProof HermitC HermitM) -> Maybe (RewriteH CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr -> BiRewriteH CoreExpr fixFusionRuleBR meq mfstrict f g h = beforeBiR (prefixFailMsg "fixed-point fusion failed: " $ - do (tyA,tyB) <- funExprArgResTypes f - tyA' <- endoFunExprType g - tyB' <- endoFunExprType h + do (_,tyA,tyB) <- funExprArgResTypesM f -- TODO: don't throw away TyVars + (_,tyA') <- endoFunExprTypeM g + (_,tyB') <- endoFunExprTypeM h guardMsg (typeAlphaEq tyA tyA' && typeAlphaEq tyB tyB') "given functions do not have compatible types." whenJust (verifyStrictT f) mfstrict whenJust (\ eq -> @@ -167,13 +207,13 @@ guardMsg (exprAlphaEq f f') "first argument function does not match." (_,g') <- isFixExprT <<< return fixg guardMsg (exprAlphaEq g g') "second argument function does not match." - mkFixT h + buildFixT h fixFusionR :: RewriteH CoreExpr fixFusionR = prefixFailMsg "(reversed) fixed-point fusion failed: " $ do (_,h') <- isFixExprT guardMsg (exprAlphaEq h h') "third argument function does not match." - App f <$> mkFixT g + App f <$> buildFixT g -- | If @f@ is strict, then (@f (g a)@ == @h (f a)@) ==> (@f (fix g)@ == @fix h@) fixFusionRule :: Maybe (RewriteH Core, RewriteH Core) -> Maybe (RewriteH Core) -> CoreString -> CoreString -> CoreString -> BiRewriteH CoreExpr @@ -184,24 +224,14 @@ -- | Check that the expression has the form "fix t (f :: t -> t)", returning "t" and "f". isFixExprT :: TransformH CoreExpr (Type,CoreExpr) isFixExprT = withPatFailMsg (wrongExprForm "fix t f") $ -- fix :: forall a. (a -> a) -> a - do App (App (Var fixId) (Type ty)) f <- idR - fixId' <- findFixId - guardMsg (fixId == fixId') (var2String fixId ++ " does not match " ++ fixLocation) + do (Var fixId, [Type ty, f]) <- callT + fixId' <- findIdT fixLocation + guardMsg (fixId == fixId') (unqualifiedName fixId ++ " does not match " ++ show fixLocation) return (ty,f) -------------------------------------------------------------------------------------------------- --- | f ==> fix f -mkFixT :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => CoreExpr -> Transform c m z CoreExpr -mkFixT f = do t <- endoFunExprType f - fixId <- findFixId - return $ mkCoreApps (varToCoreExpr fixId) [Type t, f] - -fixLocation :: String -fixLocation = "Data.Function.fix" - --- TODO: will crash if 'fix' is not used (or explicitly imported) in the source file. -findFixId :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id -findFixId = findIdT fixLocation +fixLocation :: HermitName +fixLocation = fromString "Data.Function.fix" -------------------------------------------------------------------------------------------------- diff --git a/src/HERMIT/Dictionary/Fold.hs b/src/HERMIT/Dictionary/Fold.hs --- a/src/HERMIT/Dictionary/Fold.hs +++ b/src/HERMIT/Dictionary/Fold.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} module HERMIT.Dictionary.Fold ( -- * Fold/Unfold Transformation externals @@ -7,24 +8,24 @@ , stashFoldAnyR -- * Unlifted fold interface , fold - , unifyTypes + , unifyTypes -- TODO: remove in favor of GHC's unification , tyMatchesToCoreExpr - ) - -where + ) where import Control.Arrow import Control.Applicative import Control.Monad +import Control.Monad.IO.Class import qualified Data.Map as Map import HERMIT.Core import HERMIT.Context -import HERMIT.Monad -import HERMIT.Kure import HERMIT.External import HERMIT.GHC +import HERMIT.Kure +import HERMIT.Monad +import HERMIT.Name import HERMIT.Dictionary.Common (varBindingDepthT,inScope,findIdT) import HERMIT.Dictionary.Inline hiding (externals) @@ -35,7 +36,7 @@ externals :: [External] externals = - [ external "fold" (promoteExprR . foldR :: String -> RewriteH Core) + [ external "fold" (promoteExprR . foldR :: HermitName -> RewriteH Core) [ "fold a definition" , "" , "double :: Int -> Int" @@ -47,7 +48,7 @@ , "" , "Note: due to associativity, if you wanted to fold 5 + 6 + 6, " , "you first need to apply an associativity rewrite." ] .+ Context .+ Deep - , external "fold-remembered" (promoteExprR . stashFoldR :: Label -> RewriteH Core) + , external "fold-remembered" (promoteExprR . stashFoldR :: RememberedName -> RewriteH Core) [ "Fold a remembered definition." ] .+ Context .+ Deep , external "fold-any" (promoteExprR stashFoldAnyR :: RewriteH Core) [ "Attempt to fold any of the remembered definitions." ] .+ Context .+ Deep @@ -55,26 +56,25 @@ ------------------------------------------------------------------------ -stashFoldR :: ReadBindings c => Label -> Rewrite c HermitM CoreExpr +stashFoldR :: (ReadBindings c, HasStash m, MonadCatch m) => RememberedName -> Rewrite c m CoreExpr stashFoldR label = prefixFailMsg "Fold failed: " $ transform $ \ c e -> do Def i rhs <- lookupDef label - guardMsg (inScope c i) $ var2String i ++ " is not in scope.\n(A common cause of this error is trying to fold a recursive call while being in the body of a non-recursive definition. This can be resolved by calling \"nonrec-to-rec\" on the non-recursive binding group.)" + guardMsg (inScope c i) $ unqualifiedName i ++ " is not in scope.\n(A common cause of this error is trying to fold a recursive call while being in the body of a non-recursive definition. This can be resolved by calling \"nonrec-to-rec\" on the non-recursive binding group.)" maybe (fail "no match.") return (fold i rhs e) -stashFoldAnyR :: ReadBindings c => Rewrite c HermitM CoreExpr +stashFoldAnyR :: (ReadBindings c, HasStash m, MonadCatch m) => Rewrite c m CoreExpr stashFoldAnyR = setFailMsg "Fold failed: no definitions could be folded." $ - catchesM =<< map stashFoldR <$> (Map.keys <$> constT getStash) + catchesM =<< liftM (map stashFoldR) (liftM Map.keys (constT getStash)) -foldR :: ReadBindings c => String -> Rewrite c HermitM CoreExpr -foldR nm = prefixFailMsg "Fold failed: " $ do - v <- findIdT nm - foldVarR v Nothing +foldR :: (ReadBindings c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m) + => HermitName -> Rewrite c m CoreExpr +foldR nm = prefixFailMsg "Fold failed: " $ findIdT nm >>= foldVarR Nothing -foldVarR :: ReadBindings c => Var -> Maybe BindingDepth -> Rewrite c HermitM CoreExpr -foldVarR v md = do +foldVarR :: (ReadBindings c, MonadCatch m, MonadUnique m) => Maybe BindingDepth -> Var -> Rewrite c m CoreExpr +foldVarR md v = do case md of Nothing -> return () Just depth -> do depth' <- varBindingDepthT v @@ -148,7 +148,7 @@ foldMatch vs as (Var i) e | i `elem` vs = matchWithTypes vs as i e | otherwise = case e of Var i' | maybe False (==i) (lookup i' as) -> matchWithTypes vs as i e - | i == i' -> liftM tail $ matchWithTypes vs as i e + | i == i' -> liftM tail $ matchWithTypes vs as i e -- note we depend on (i,e) being at front here -- this is not strictly necessary, but is faster _ -> Nothing @@ -190,7 +190,7 @@ return (x ++ tyMatchesToCoreExpr t ++ concat y) foldMatch vs as (Cast e c) (Cast e' c') = do - guard (coreEqCoercion c c') + guard (coreEqCoercion c c') foldMatch vs as e e' foldMatch vs as (Type t1) (Type t2) = liftM tyMatchesToCoreExpr $ foldMatchType vs as t1 t2 @@ -221,6 +221,10 @@ -> Type -- ^ expression we are checking -> Maybe [(TyVar,Type)] -- ^ mapping of vars to types, or failure +-- look through type synonyms +foldMatchType vs as t1 t2 | Just t1' <- tcView t1 = foldMatchType vs as t1' t2 + | Just t2' <- tcView t2 = foldMatchType vs as t1 t2' + foldMatchType vs as (TyVarTy v) t | v `elem` vs = return [(v,t)] | otherwise = case t of TyVarTy v' | maybe False (==v) (lookup v' as) -> return [(v,t)] @@ -237,7 +241,7 @@ let f ty1 ty2 | isKind ty1 && eqKind ty1 ty2 = return [] | otherwise = foldMatchType vs as ty1 ty2 liftM concat $ zipWithM f kOrTys1 kOrTys2 - + foldMatchType vs as (FunTy ty1 ty2) (FunTy ty1' ty2') = do x <- foldMatchType vs as ty1 ty1' y <- foldMatchType vs as ty2 ty2' diff --git a/src/HERMIT/Dictionary/Function.hs b/src/HERMIT/Dictionary/Function.hs --- a/src/HERMIT/Dictionary/Function.hs +++ b/src/HERMIT/Dictionary/Function.hs @@ -1,25 +1,34 @@ -{-# LANGUAGE FlexibleContexts, RankNTypes #-} +{-# LANGUAGE CPP, FlexibleContexts, RankNTypes, ScopedTypeVariables #-} module HERMIT.Dictionary.Function ( externals + , appArgM + , buildApplicationM + , buildCompositionT + , buildFixT + , buildIdT , staticArgR , staticArgPosR , staticArgPredR , staticArgTypesR - ) -where + ) where import Control.Arrow +import Control.Monad.IO.Class import Data.List (nub, intercalate, intersect, partition, transpose) +import Data.Maybe (isNothing) +import Data.String (fromString) import HERMIT.Context import HERMIT.Core -import HERMIT.Monad -import HERMIT.Kure import HERMIT.External import HERMIT.GHC +import HERMIT.Kure +import HERMIT.Monad +import HERMIT.Name import HERMIT.Dictionary.Common +import HERMIT.Dictionary.GHC hiding (externals) externals :: [External] externals = @@ -34,15 +43,18 @@ ------------------------------------------------------------------------------------------------------ -- | Traditional Static Argument Transformation -staticArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c) => Rewrite c HermitM CoreDef +staticArgR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb, MonadCatch m, MonadUnique m) + => Rewrite c m CoreDef staticArgR = staticArgPredR (return . map fst) -- | Static Argument Transformation that only considers type arguments to be static. -staticArgTypesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c) => Rewrite c HermitM CoreDef +staticArgTypesR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb, MonadCatch m, MonadUnique m) + => Rewrite c m CoreDef staticArgTypesR = staticArgPredR (return . map fst . filter (isTyVar . snd)) -- | Static Argument Transformations which requires that arguments in the given position are static. -staticArgPosR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c) => [Int] -> Rewrite c HermitM CoreDef +staticArgPosR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb, MonadCatch m, MonadUnique m) + => [Int] -> Rewrite c m CoreDef staticArgPosR is' = staticArgPredR $ \ss' -> let is = nub is' ss = map fst ss' in if is == (is `intersect` ss) @@ -50,9 +62,10 @@ else fail $ "args " ++ commas (filter (`notElem` ss) is) ++ " are not static." -- | Generalized Static Argument Transformation, which allows static arguments to be filtered. -staticArgPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c) - => ([(Int, Var)] -> HermitM [Int]) -- ^ given list of static args and positions, decided which to transform - -> Rewrite c HermitM CoreDef +staticArgPredR :: forall c m. (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb + , MonadCatch m, MonadUnique m) + => ([(Int, Var)] -> m [Int]) -- ^ given list of static args and positions, decided which to transform + -> Rewrite c m CoreDef staticArgPredR decide = prefixFailMsg "static-arg failed: " $ do Def f rhs <- idR let (bnds, body) = collectBinders rhs @@ -60,9 +73,11 @@ contextonlyT $ \ c -> do let bodyContext = foldl (flip addLambdaBinding) c bnds - -- TODO: we convert an Id to string here, and callsT then uses cmpString2Var - -- refactor to avoid intermediate string! - callPats <- apply (callsT (var2String f) (callT >>> arr snd)) bodyContext (ExprCore body) + callPatsT :: Transform c m CoreExpr [[CoreExpr]] + callPatsT = extractT $ collectPruneT + (promoteExprT $ callPredT (const . (== f)) >>> arr snd :: Transform c m Core [CoreExpr]) + + callPats <- applyT callPatsT bodyContext body let argExprs = transpose callPats numCalls = length callPats allBinds = zip [0..] bnds @@ -92,17 +107,91 @@ $ "type variables in args " ++ commas (nub $ map fst unboundTys) ++ " would become unbound unless args " ++ commas (nub $ map snd unboundTys) ++ " are included in the transformation." - wkr <- newIdH (var2String f ++ "'") (exprType (mkCoreLams dbnds body)) + wkr <- newIdH (unqualifiedName f ++ "'") (exprType (mkCoreLams dbnds body)) let replaceCall :: Monad m => Rewrite c m CoreExpr replaceCall = do - (_,exprs) <- callT + (_,exprs) <- callPredT (const . (== f)) return $ mkApps (Var wkr) [ e | (p,e) <- zip [0..] exprs, (p::Int) `elem` ps ] - ExprCore body' <- apply (callsR (var2String f) replaceCall) bodyContext (ExprCore body) + body' <- applyT (extractR $ prunetdR (promoteExprR replaceCall :: Rewrite c m Core)) bodyContext body return $ Def f $ mkCoreLams bnds $ Let (Rec [(wkr, mkCoreLams dbnds body')]) $ mkApps (Var wkr) (varsToCoreExprs dbnds) +------------------------------------------------------------------------------ + +-- | Get the nth argument of an application. Arg 0 is the function being applied. +appArgM :: Monad m => Int -> CoreExpr -> m CoreExpr +appArgM n e | n < 0 = fail "appArgM: arg must be non-negative" + | otherwise = let (fn,args) = collectArgs e + l = fn : args + in if n > length args + then fail "appArgM: not enough arguments" + else return $ l !! n + +-- | Build composition of two functions. +buildCompositionT :: (BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) + => CoreExpr -> CoreExpr -> Transform c m x CoreExpr +buildCompositionT f g = do + composeId <- findIdT $ fromString "Data.Function.." + fDot <- buildApplicationM (varToCoreExpr composeId) f + buildApplicationM fDot g + +-- | Given expression for f and for x, build f x, figuring out the type arguments. +buildApplicationM :: (HasDynFlags m, MonadCatch m, MonadIO m) => CoreExpr -> CoreExpr -> m CoreExpr +buildApplicationM f x = do + (vsF, domF, _) <- splitFunTypeM (exprType f) + let (vsX, xTy) = splitForAllTys (exprType x) + allTvs = vsF ++ vsX + bindFn v = if v `elem` allTvs then BindMe else Skolem + + sub <- maybe (do d <- getDynFlags + liftIO $ putStrLn $ "f: " ++ showPpr d f + liftIO $ putStrLn $ "x: " ++ showPpr d x + liftIO $ putStrLn $ "vsF: " ++ showPpr d vsF + liftIO $ putStrLn $ "domF: " ++ showPpr d domF + liftIO $ putStrLn $ "vsX: " ++ showPpr d vsX + liftIO $ putStrLn $ "xTy: " ++ showPpr d xTy + fail "buildApplicationM - domain of f and type of x do not unify") + return + (tcUnifyTys bindFn [domF] [xTy]) + + f' <- substOrApply f [ (v, Type $ substTyVar sub v) | v <- vsF ] + x' <- substOrApply x [ (v, Type $ substTyVar sub v) | v <- vsX ] + let vs = [ v | v <- vsF ++ vsX, isNothing $ lookupTyVar sub v ] -- things we should stick back on as foralls + -- TODO: make sure vsX don't capture anything in f' + -- and vsF' doesn't capture anything in x' + return $ mkCoreLams vs $ mkCoreApp f' x' + +-- | Given expression for f, build fix f. +buildFixT :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m) + => CoreExpr -> Transform c m x CoreExpr +buildFixT f = do + (tvs, ty) <- endoFunExprTypeM f + fixId <- findIdT $ fromString "Data.Function.fix" + f' <- substOrApply f [ (v, varToCoreExpr v) | v <- tvs ] + return $ mkCoreLams tvs $ mkCoreApps (varToCoreExpr fixId) [Type ty, f'] + +-- | Build an expression that is the monomorphic id function for given type. +buildIdT :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m) + => Type -> Transform c m x CoreExpr +buildIdT ty = do + idId <- findIdT $ fromString "Data.Function.id" + return $ mkCoreApp (varToCoreExpr idId) (Type ty) + +------------------------------------------------------------------------------ + commas :: Show a => [a] -> String commas = intercalate "," . map show + +-- | Like mkCoreApps, but automatically beta-reduces when possible. +substOrApply :: Monad m => CoreExpr -> [(Var,CoreExpr)] -> m CoreExpr +substOrApply e [] = return e +substOrApply (Lam b e) ((v,ty):r) = if b == v + then substOrApply e r >>= return . substCoreExpr b ty + else fail $ "substOrApply: unexpected binder - " + ++ unqualifiedName b ++ " - " ++ unqualifiedName v +substOrApply e rest = return $ mkCoreApps e (map snd rest) + +------------------------------------------------------------------------------ diff --git a/src/HERMIT/Dictionary/GHC.hs b/src/HERMIT/Dictionary/GHC.hs --- a/src/HERMIT/Dictionary/GHC.hs +++ b/src/HERMIT/Dictionary/GHC.hs @@ -1,42 +1,47 @@ {-# LANGUAGE CPP, FlexibleContexts #-} module HERMIT.Dictionary.GHC - ( -- * GHC-based Transformations - -- | This module contains transformations that are reflections of GHC functions, or derived from GHC functions. - externals - -- ** Substitution - , substR - , substCoreAlt - , substCoreExpr - -- ** Utilities - -- , inScope - , dynFlagsT - , arityOf - -- ** Lifted GHC capabilities - -- A zombie is an identifer that has 'OccInfo' 'IAmDead', but still has occurrences. - , lintExprT - , lintModuleT - , occurAnalyseR - , occurAnalyseChangedR - , occurAnalyseExprChangedR - , occurAnalyseAndDezombifyR - , dezombifyR - ) -where + ( -- * GHC-based Transformations + -- | This module contains transformations that are reflections of GHC functions, or derived from GHC functions. + externals + -- ** Substitution + , substR + , substCoreAlt + , substCoreExpr + -- ** Utilities + -- , inScope + , dynFlagsT + , arityOf + -- ** Lifted GHC capabilities + -- A zombie is an identifer that has 'OccInfo' 'IAmDead', but still has occurrences. + , lintExprT + , lintModuleT + , occurAnalyseR + , occurAnalyseChangedR + , occurAnalyseExprChangedR + , occurAnalyseAndDezombifyR + , dezombifyR + , buildDictionary + , buildDictionaryT + , buildTypeable + ) where import qualified Bag import qualified CoreLint -import Control.Arrow - -import Data.List (mapAccumL) +import Control.Arrow +import Control.Monad.IO.Class -import HERMIT.Core -import HERMIT.Context -import HERMIT.Kure -import HERMIT.External -import HERMIT.GHC +import Data.Char (isSpace) +import Data.List (mapAccumL) -import HERMIT.Dictionary.Debug hiding (externals) +import HERMIT.Core +import HERMIT.Context +import HERMIT.Dictionary.Debug hiding (externals) +import HERMIT.External +import HERMIT.GHC +import HERMIT.Kure +import HERMIT.Monad +import HERMIT.Name ------------------------------------------------------------------------ @@ -125,11 +130,7 @@ lintModuleT = do dynFlags <- dynFlagsT bnds <- arr mg_binds -#if __GLASGOW_HASKELL__ > 706 let (warns, errs) = CoreLint.lintCoreBindings [] bnds -- [] are vars to treat as in scope, used by GHCi -#else - let (warns, errs) = CoreLint.lintCoreBindings bnds -#endif dumpSDocs endMsg = Bag.foldBag (\ d r -> d ++ ('\n':r)) (showSDoc dynFlags) endMsg if Bag.isEmptyBag errs then return $ dumpSDocs "Core Lint Passed" warns @@ -143,11 +144,7 @@ lintExprT = transform $ \ c e -> do dflags <- getDynFlags maybe (return "Core Lint Passed") (fail . showSDoc dflags) -#if __GLASGOW_HASKELL__ > 706 $ CoreLint.lintExpr (varSetElems $ boundVars c) e -#else - $ CoreLint.lintUnfolding noSrcLoc (varSetElems $ boundVars c) e -#endif ------------------------------------------- @@ -168,13 +165,23 @@ -- | Apply 'occurAnalyseExprR' to all sub-expressions. occurAnalyseR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core -occurAnalyseR = let r = promoteExprR (arr occurAnalyseExpr) +occurAnalyseR = let r = promoteExprR (arr occurAnalyseExpr_NoBinderSwap) -- See Note [No Binder Swap] go = r <+ anyR go in tryR go -- always succeed +{- + Note [No Binder Swap] + + The binder swap performed by occurrence analysis in GHC <= 7.8.3 is buggy + in that it can lead to unintended variable capture (Trac #9440). Concretely, + this will send bash into a loop, or cause core lint to fail. As this is an + un-expected change as far as HERMIT users are concerned anyway, we use the + version that doesn't perform the binder swap. +-} + -- | Occurrence analyse an expression, failing if the result is syntactically equal to the initial expression. occurAnalyseExprChangedR :: MonadCatch m => Rewrite c m CoreExpr -occurAnalyseExprChangedR = changedByR exprSyntaxEq (arr occurAnalyseExpr) +occurAnalyseExprChangedR = changedByR exprSyntaxEq (arr occurAnalyseExpr_NoBinderSwap) -- See Note [No Binder Swap] -- | Occurrence analyse all sub-expressions, failing if the result is syntactically equal to the initial expression. occurAnalyseChangedR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core @@ -198,3 +205,37 @@ -} ---------------------------------------------------------------------- + +-- TODO: this is mostly an example, move somewhere? +buildTypeable :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadIO m) => Type -> m (Id, [CoreBind]) +buildTypeable ty = do + evar <- runTcM $ do + cls <- tcLookupClass typeableClassName + let predTy = mkClassPred cls [typeKind ty, ty] -- recall that Typeable is now poly-kinded + newWantedEvVar predTy + buildDictionary evar + +-- | Build a dictionary for the given +buildDictionary :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadIO m) => Id -> m (Id, [CoreBind]) +buildDictionary evar = do + (i, bs) <- runTcM $ do + loc <- getCtLoc $ GivenOrigin UnkSkol + let predTy = varType evar + nonC = mkNonCanonical $ CtWanted { ctev_pred = predTy, ctev_evar = evar, ctev_loc = loc } + wCs = mkFlatWC [nonC] + (wCs', bnds) <- solveWantedsTcM wCs + reportAllUnsolved wCs' + return (evar, bnds) + bnds <- runDsM $ dsEvBinds bs + return (i,bnds) + +buildDictionaryT :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadUnique m) + => Transform c m Type CoreExpr +buildDictionaryT = prefixFailMsg "buildDictionaryT failed: " $ contextfreeT $ \ ty -> do + dflags <- getDynFlags + binder <- newIdH ("$d" ++ zEncodeString (filter (not . isSpace) (showPpr dflags ty))) ty + (i,bnds) <- buildDictionary binder + guardMsg (notNull bnds) "no dictionary bindings generated." + return $ case bnds of + [NonRec v e] | i == v -> e -- the common case that we would have gotten a single non-recursive let + _ -> mkCoreLets bnds (varToCoreExpr i) diff --git a/src/HERMIT/Dictionary/Induction.hs b/src/HERMIT/Dictionary/Induction.hs --- a/src/HERMIT/Dictionary/Induction.hs +++ b/src/HERMIT/Dictionary/Induction.hs @@ -17,6 +17,7 @@ import HERMIT.GHC import HERMIT.Kure import HERMIT.Monad +import HERMIT.Name -- import HERMIT.Utilities (soleElement) import HERMIT.Dictionary.Common @@ -30,7 +31,7 @@ ------------------------------------------------------------------------------ -inductionCaseSplit :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb) +inductionCaseSplit :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb) => [Var] -> Id -> CoreExpr -> CoreExpr -> Transform c HermitM x [(Maybe DataCon,[Var],CoreExpr,CoreExpr)] inductionCaseSplit vs i lhsE rhsE = do -- first construct an expression containing both the LHS and the RHS diff --git a/src/HERMIT/Dictionary/Inline.hs b/src/HERMIT/Dictionary/Inline.hs --- a/src/HERMIT/Dictionary/Inline.hs +++ b/src/HERMIT/Dictionary/Inline.hs @@ -1,40 +1,30 @@ {-# LANGUAGE CPP, TupleSections, FlexibleContexts, ScopedTypeVariables #-} module HERMIT.Dictionary.Inline - ( -- * Inlining - externals - , InlineConfig(..) - , CaseBinderInlineOption(..) - , getUnfoldingT - , ensureBoundT - , inlineR - , inlineNameR - , inlineNamesR - , inlineMatchingPredR - , inlineCaseScrutineeR - , inlineCaseAlternativeR - , configurableInlineR - , inlineTargetsT - ) - -where - -#if __GLASGOW_HASKELL__ > 706 -#else -import TcType (tcSplitDFunTy) -#endif + ( -- * Inlining + externals + , InlineConfig(..) + , CaseBinderInlineOption(..) + , getUnfoldingT + , ensureBoundT + , inlineR + , inlineNameR + , inlineNamesR + , inlineMatchingPredR + , inlineCaseScrutineeR + , inlineCaseAlternativeR + , configurableInlineR + , inlineTargetsT + ) where import Control.Arrow -import Control.Applicative import Control.Monad -import Data.List (intercalate) - import HERMIT.Context import HERMIT.Core import HERMIT.External import HERMIT.GHC import HERMIT.Kure -import HERMIT.Monad +import HERMIT.Name import HERMIT.Dictionary.Common @@ -43,17 +33,17 @@ -- | 'External's for inlining variables. externals :: [External] externals = - [ external "inline" (promoteExprR inlineR :: RewriteH Core) - [ "(Var v) ==> " ].+ Eval .+ Deep - , external "inline" (promoteExprR . inlineNameR :: String -> RewriteH Core) - [ "Given a specific v, (Var v) ==> " ] .+ Eval .+ Deep - , external "inline" (promoteExprR . inlineNamesR :: [String] -> RewriteH Core) - [ "If the current variable matches any of the given names, then inline it." ] .+ Eval .+ Deep - , external "inline-case-scrutinee" (promoteExprR inlineCaseScrutineeR :: RewriteH Core) - [ "if v is a case binder, replace (Var v) with the bound case scrutinee." ] .+ Eval .+ Deep - , external "inline-case-alternative" (promoteExprR inlineCaseAlternativeR :: RewriteH Core) - [ "if v is a case binder, replace (Var v) with the bound case-alternative pattern." ] .+ Eval .+ Deep .+ Unsafe - ] + [ external "inline" (promoteExprR inlineR :: RewriteH Core) + [ "(Var v) ==> " ].+ Eval .+ Deep + , external "inline" (promoteExprR . inlineMatchingPredR . mkOccPred :: OccurrenceName -> RewriteH Core) + [ "Given a specific v, (Var v) ==> " ] .+ Eval .+ Deep + , external "inline" (promoteExprR . inlineNamesR :: [String] -> RewriteH Core) + [ "If the current variable matches any of the given names, then inline it." ] .+ Eval .+ Deep + , external "inline-case-scrutinee" (promoteExprR inlineCaseScrutineeR :: RewriteH Core) + [ "if v is a case binder, replace (Var v) with the bound case scrutinee." ] .+ Eval .+ Deep + , external "inline-case-alternative" (promoteExprR inlineCaseAlternativeR :: RewriteH Core) + [ "if v is a case binder, replace (Var v) with the bound case-alternative pattern." ] .+ Eval .+ Deep .+ Unsafe + ] ------------------------------------------------------------------------ @@ -62,37 +52,50 @@ data InlineConfig = CaseBinderOnly CaseBinderInlineOption | AllBinders deriving (Eq, Show) -- | If the current variable matches the given name, then inline it. -inlineNameR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => String -> Rewrite c HermitM CoreExpr +inlineNameR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m ) + => String -> Rewrite c m CoreExpr inlineNameR nm = inlineMatchingPredR (cmpString2Var nm) -- | If the current variable matches any of the given names, then inline it. -inlineNamesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [String] -> Rewrite c HermitM CoreExpr +inlineNamesR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m ) + => [String] -> Rewrite c m CoreExpr inlineNamesR [] = fail "inline-names failed: no names given." inlineNamesR nms = inlineMatchingPredR (\ v -> any (flip cmpString2Var v) nms) -- | If the current variable satisifies the predicate, then inline it. -inlineMatchingPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => (Id -> Bool) -> Rewrite c HermitM CoreExpr +inlineMatchingPredR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m ) + => (Id -> Bool) -> Rewrite c m CoreExpr inlineMatchingPredR idPred = configurableInlineR AllBinders (arr $ idPred) -- | Inline the current variable. -inlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr +inlineR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, + ReadBindings c, ReadPath c Crumb, MonadCatch m ) + => Rewrite c m CoreExpr inlineR = configurableInlineR AllBinders (return True) -- | Inline the current identifier if it is a case binder, using the scrutinee rather than the case-alternative pattern. -inlineCaseScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr +inlineCaseScrutineeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m ) + => Rewrite c m CoreExpr inlineCaseScrutineeR = configurableInlineR (CaseBinderOnly Scrutinee) (return True) -- | Inline the current identifier if is a case binder, using the case-alternative pattern rather than the scrutinee. -inlineCaseAlternativeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr +inlineCaseAlternativeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m ) + => Rewrite c m CoreExpr inlineCaseAlternativeR = configurableInlineR (CaseBinderOnly Alternative) (return True) -- | The implementation of inline, an important transformation. -- This *only* works if the current expression has the form @Var v@ (it does not traverse the expression). -- It can trivially be prompted to more general cases using traversal strategies. -configurableInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) +configurableInlineR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c + , ReadPath c Crumb, MonadCatch m ) => InlineConfig - -> (Transform c HermitM Id Bool) -- ^ Only inline identifiers that satisfy this predicate. - -> Rewrite c HermitM CoreExpr + -> (Transform c m Id Bool) -- ^ Only inline identifiers that satisfy this predicate. + -> Rewrite c m CoreExpr configurableInlineR config p = prefixFailMsg "Inline failed: " $ do b <- varT p @@ -106,8 +109,8 @@ -- Fails, listing unbound variables if not. ensureBoundT :: (Monad m, ReadBindings c) => Transform c m CoreExpr () ensureBoundT = do - unbound <- transform $ \ c -> return . filter (not . inScope c) . varSetElems . localFreeVarsExpr - guardMsg (null unbound) $ "the following variables are unbound: " ++ intercalate ", " (map getOccString unbound) + unbound <- transform $ \ c -> return . filterVarSet (not . inScope c) . localFreeVarsExpr + guardMsg (isEmptyVarSet unbound) $ "the following variables are unbound: " ++ showVarSet unbound -- NOTE: When inlining, we have to take care to avoid variable capture. -- Our approach is to track the binding depth of the inlined identifier. @@ -136,29 +139,25 @@ all uncaptured `liftM` extractT collectDepthsT -- | Return the unfolding of an identifier, and a predicate over the binding depths of all variables within that unfolding to determine if they have been captured in their new location. -getUnfoldingT :: ReadBindings c +getUnfoldingT :: (ReadBindings c, MonadCatch m) => InlineConfig - -> Transform c HermitM Id (CoreExpr, BindingDepth -> Bool) + -> Transform c m Id (CoreExpr, BindingDepth -> Bool) getUnfoldingT config = transform $ \ c i -> case lookupHermitBinding i c of Nothing -> do requireAllBinders config let uncaptured = (<= 0) -- i.e. is global - -- this check is necessary because idInfo panics on TyVars, though it - -- should never be the case that a type variable is NOT in the context, - -- at least this will give a reasonable error message, instead of a GHC panic. - guardMsg (isId i) "type variable is not in Env (this should not happen)." + -- This check is necessary because idInfo panics on TyVars. Type variables should + -- ALWAYS be in the context (so we should never be in this branch), but at least this + -- will give a reasonable error message if something goes wrong, instead of a GHC panic. + guardMsg (isId i) "type variable is not in Env (this should not happen)." case unfoldingInfo (idInfo i) of CoreUnfolding { uf_tmpl = uft } -> return (uft, uncaptured) -#if __GLASGOW_HASKELL__ > 706 - dunf@(DFunUnfolding {}) -> (,uncaptured) <$> dFunExpr dunf -#else - DFunUnfolding _arity dc args -> (,uncaptured) <$> dFunExpr dc args (idType i) -#endif + dunf@(DFunUnfolding {}) -> liftM (,uncaptured) $ dFunExpr dunf _ -> fail $ "cannot find unfolding in Env or IdInfo." Just b -> let depth = hbDepth b in case hbSite b of CASEBINDER s alt -> let tys = tyConAppArgs (idType i) - altExprDepthM = (, (<= depth+1)) <$> alt2Exp tys alt + altExprDepthM = liftM (, (<= depth+1)) $ alt2Exp tys alt scrutExprDepthM = return (s, (< depth)) in case config of CaseBinderOnly Scrutinee -> scrutExprDepthM @@ -200,44 +199,14 @@ alt2Exp tys (DataAlt dc, vs) = return $ mkCoreConApps dc (map Type tys ++ map (varToCoreExpr . zapVarOccInfo) vs) -- | Get list of possible inline targets. Used by shell for completion. -inlineTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Transform c HermitM Core [String] -inlineTargetsT = collectT $ promoteT $ whenM (testM inlineR) (varT $ arr var2String) +inlineTargetsT :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m ) + => Transform c m Core [String] +inlineTargetsT = collectT $ promoteT $ whenM (testM inlineR) (varT $ arr unqualifiedName) -- | Build a CoreExpr for a DFunUnfolding -#if __GLASGOW_HASKELL__ > 706 -{- -data Unfolding - = ... - | DFunUnfolding { -- The Unfolding of a DFunId - -- See Note [DFun unfoldings] - -- df = /\a1..am. \d1..dn. MkD t1 .. tk - -- (op1 a1..am d1..dn) - -- (op2 a1..am d1..dn) - df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] - df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) - df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, - } -- in positional order --} -dFunExpr :: Unfolding -> HermitM CoreExpr --- TODO: is this correct? -dFunExpr dunf@(DFunUnfolding {}) = return $ mkCoreConApps (df_con dunf) (df_args dunf) +dFunExpr :: Monad m => Unfolding -> m CoreExpr +dFunExpr dunf@(DFunUnfolding {}) = return $ mkCoreLams (df_bndrs dunf) $ mkCoreConApps (df_con dunf) (df_args dunf) dFunExpr _ = fail "dFunExpr: not a DFunUnfolding" -#else -dFunExpr :: DataCon -> [DFunArg CoreExpr] -> Type -> HermitM CoreExpr -dFunExpr dc args ty = do - let (_, _, _, tcArgs) = tcSplitDFunTy ty - (forallTvs, ty') = splitForAllTys ty - (argTys, _resTy) = splitFunTys ty' - - ids <- mapM (uncurry newIdH) $ zip [ [ch] | ch <- cycle ['a'..'z'] ] argTys - vars <- mapM (cloneVarH id) forallTvs - - let allVars = varsToCoreExprs $ vars ++ ids - - mkArg (DFunLamArg i) = allVars !! i - mkArg (DFunPolyArg e) = mkCoreApps e allVars - - return $ mkCoreConApps dc $ map Type tcArgs ++ map mkArg args -#endif ------------------------------------------------------------------------ diff --git a/src/HERMIT/Dictionary/Kure.hs b/src/HERMIT/Dictionary/Kure.hs --- a/src/HERMIT/Dictionary/Kure.hs +++ b/src/HERMIT/Dictionary/Kure.hs @@ -1,11 +1,11 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} module HERMIT.Dictionary.Kure - ( -- * KURE Strategies - externals - , anyCallR - ) -where + ( -- * KURE Strategies + externals + , anyCallR + , betweenR + ) where import Control.Arrow import Control.Monad (liftM) @@ -98,6 +98,8 @@ [ "Promote a RewriteCore to a RewriteCoreTC" ] , external "extract" (extractR :: RewriteH CoreTC -> RewriteH Core) [ "Extract a RewriteCore from a RewriteCoreTC" ] + , external "between" (betweenR :: Int -> Int -> RewriteH CoreTC -> RewriteH CoreTC) + [ "between x y rr -> perform rr at least x times and at most y times." ] ] ------------------------------------------------------------------------------------ @@ -137,3 +139,14 @@ rec = anyCallR rr ------------------------------------------------------------------------------------ + +-- | betweenR x y rr -> perform rr at least x times and at most y times. +betweenR :: MonadCatch m => Int -> Int -> Rewrite c m a -> Rewrite c m a +betweenR l h rr | l < 0 = fail "betweenR: lower limit below zero" + | h < l = fail "betweenR: upper limit less than lower limit" + | otherwise = go 0 + where -- 'c' is number of times rr has run already + go c | c >= h = idR -- done + | c < l = rr >>> go (c+1) -- haven't hit lower bound yet + | otherwise = tryR (rr >>> go (c+1)) -- met lower bound + diff --git a/src/HERMIT/Dictionary/Local.hs b/src/HERMIT/Dictionary/Local.hs --- a/src/HERMIT/Dictionary/Local.hs +++ b/src/HERMIT/Dictionary/Local.hs @@ -1,37 +1,36 @@ {-# LANGUAGE FlexibleContexts #-} module HERMIT.Dictionary.Local - ( -- * Local Structural Manipulations - HERMIT.Dictionary.Local.externals - -- ** Binding Groups - , module HERMIT.Dictionary.Local.Bind - -- ** Case Expressions - , module HERMIT.Dictionary.Local.Case - -- ** Cast Expressions - , module HERMIT.Dictionary.Local.Cast - -- ** Let Expressions - , module HERMIT.Dictionary.Local.Let - -- ** Miscellaneous - , abstractR - , pushR - , betaReduceR - , betaReducePlusR - , betaExpandR - , etaReduceR - , etaExpandR - , multiEtaExpandR - , flattenModuleR - , flattenProgramR - , flattenProgramT - ) -where + ( -- * Local Structural Manipulations + HERMIT.Dictionary.Local.externals + -- ** Binding Groups + , module HERMIT.Dictionary.Local.Bind + -- ** Case Expressions + , module HERMIT.Dictionary.Local.Case + -- ** Cast Expressions + , module HERMIT.Dictionary.Local.Cast + -- ** Let Expressions + , module HERMIT.Dictionary.Local.Let + -- ** Miscellaneous + , abstractR + , pushR + , betaReduceR + , betaExpandR + , etaReduceR + , etaExpandR + , multiEtaExpandR + , flattenModuleR + , flattenProgramR + , flattenProgramT + ) where import HERMIT.Core import HERMIT.Context -import HERMIT.Kure -import HERMIT.Monad import HERMIT.External import HERMIT.GHC +import HERMIT.Kure +import HERMIT.Monad +import HERMIT.Name import HERMIT.Utilities import HERMIT.Dictionary.Common @@ -57,8 +56,6 @@ [ "((\\ v -> E1) E2) ==> let v = E2 in E1" , "This form of beta-reduction is safe if E2 is an arbitrary expression" , "(won't duplicate work)." ] .+ Eval .+ Shallow - , external "beta-reduce-plus" (promoteExprR betaReducePlusR :: RewriteH Core) - [ "Perform one or more beta-reductions."] .+ Eval .+ Shallow , external "beta-expand" (promoteExprR betaExpandR :: RewriteH Core) [ "(let v = e1 in e2) ==> (\\ v -> e2) e1" ] .+ Shallow , external "eta-reduce" (promoteExprR etaReduceR :: RewriteH Core) @@ -71,7 +68,7 @@ , external "flatten-program" (promoteProgR flattenProgramR :: RewriteH Core) [ "Flatten all the top-level binding groups in a program (list of binding groups) to a single" , "recursive binding group. This can be useful if you intend to apply GHC RULES." ] - , external "abstract" (promoteExprR . abstractR :: String -> RewriteH Core) + , external "abstract" (promoteExprR . abstractR . mkOccPred :: OccurrenceName -> RewriteH Core) [ "Abstract over a variable using a lambda." , "e ==> (\\ x -> e) x" ] .+ Shallow .+ Introduce .+ Context , external "push" ((\ nm strictf -> push (Just strictf) (cmpString2Var nm)) :: String -> RewriteH Core -> RewriteH Core) @@ -96,49 +93,6 @@ do App (Lam v e1) e2 <- idR return $ Let (NonRec v e2) e1 - -multiBetaReduceR :: MonadCatch m => (Int -> Bool) -> Rewrite c m CoreExpr -multiBetaReduceR p = prefixFailMsg "Multi-Beta-Reduce failed: " $ - do - e <- idR - let (f,xs) = collectArgs e - guardMsg (p (length xs)) "incorrect number of arguments." - - let (vs,e0) = collectBinders f - - guardMsg (length vs >= length xs) "insufficent lambdas." - - let (vs1,vs2) = splitAt (length xs) vs - - return - $ mkLets (zipWith NonRec vs1 xs) - $ mkLams vs2 e0 - --- TODO: inline this everywhere --- Neil: Are we sure we want to inline this? --- | Perform one or more beta-reductions. -betaReducePlusR :: MonadCatch m => Rewrite c m CoreExpr -betaReducePlusR = multiBetaReduceR (> 0) - -{- - - tagFailR "betaReducePlus failed." $ - appT liftLambda idR App >>> beta_reduce - where - -- lift lambda finds the (perhaps hidden) lambda, and brings it out - liftLambda = observeR "pre-liftLambda" >>> liftLambda' >>> observeR "post-liftLambda" - liftLambda' = - (do e@(Lam {}) <- idR - return e) - <+ (betaReducePlus - >>> observeR "liftLambda(UP)" - -- let v = e in ... - -- TODO: check scope here - >>> (do Let bds (Lam v e) <- idR - return (Lam v (Let bds e))) - ) --} - -- | (let v = e1 in e2) ==> (\\ v -> e2) e1 betaExpandR :: MonadCatch m => Rewrite c m CoreExpr betaExpandR = setFailMsg ("Beta-expansion failed: " ++ wrongExprForm "Let (NonRec v e1) e2") $ @@ -158,7 +112,7 @@ Nothing -> fail "the argument expression is not a type variable." Just v2 -> guardMsg (v1 == v2) "type variables are not equal." _ -> fail "the argument expression is not a variable." - guardMsg (v1 `notElemVarSet` freeVarsExpr f) $ var2String v1 ++ " is free in the function being applied." + guardMsg (v1 `notElemVarSet` freeVarsExpr f) $ unqualifiedName v1 ++ " is free in the function being applied." return f -- | e1 ==> (\\ v -> e1 v) @@ -199,12 +153,13 @@ -- | Abstract over a variable using a lambda. -- e ==> (\ x. e) x -abstractR :: (ReadBindings c) => String -> Rewrite c HermitM CoreExpr -abstractR nm = prefixFailMsg "abstraction failed: " $ - do v <- findBoundVarT nm - v' <- constT (cloneVarH id v) -- currently uses the same visible name (via "id"). We could do something else here, e.g. add a prime suffix. +abstractR :: (ReadBindings c, MonadCatch m, MonadUnique m) => (Var -> Bool) -> Rewrite c m CoreExpr +abstractR p = prefixFailMsg "abstraction failed: " $ + do v <- findBoundVarT p + v' <- constT (cloneVarH id v) -- currently uses the same visible name (via "id"). + -- We could do something else here, e.g. add a prime suffix. e <- arr (substCoreExpr v (varToCoreExpr v')) - return $ App (Lam v' e) (varToCoreExpr v) + return $ mkCoreApp (Lam v' e) (varToCoreExpr v) ------------------------------------------------------------------------------------------------------ diff --git a/src/HERMIT/Dictionary/Local/Bind.hs b/src/HERMIT/Dictionary/Local/Bind.hs --- a/src/HERMIT/Dictionary/Local/Bind.hs +++ b/src/HERMIT/Dictionary/Local/Bind.hs @@ -1,10 +1,9 @@ module HERMIT.Dictionary.Local.Bind - ( -- * Rewrites on Binding Groups - externals - , nonrecToRecR - , recToNonrecR - ) -where + ( -- * Rewrites on Binding Groups + externals + , nonrecToRecR + , recToNonrecR + ) where import HERMIT.Core import HERMIT.External @@ -41,7 +40,7 @@ recToNonrecR = prefixFailMsg "Converting singleton recursive binding to non-recursive binding failed: " $ withPatFailMsg (wrongExprForm "Rec [Def v e]") $ do Rec [(v,e)] <- idR - guardMsg (v `notElemVarSet` freeIdsExpr e) ("'" ++ uqName v ++ " is recursively defined.") + guardMsg (v `notElemVarSet` freeIdsExpr e) ("'" ++ unqualifiedName v ++ " is recursively defined.") return (NonRec v e) ------------------------------------------------------------------------------ diff --git a/src/HERMIT/Dictionary/Local/Case.hs b/src/HERMIT/Dictionary/Local/Case.hs --- a/src/HERMIT/Dictionary/Local/Case.hs +++ b/src/HERMIT/Dictionary/Local/Case.hs @@ -5,6 +5,7 @@ externals , caseFloatAppR , caseFloatArgR + , caseFloatArgLemmaR , caseFloatCaseR , caseFloatCastR , caseFloatLetR @@ -15,7 +16,7 @@ , caseReduceR , caseReduceDataconR , caseReduceLiteralR - , caseReduceIdR + -- , caseReduceIdR , caseReduceUnfoldR , caseSplitR , caseSplitInlineR @@ -28,29 +29,32 @@ , caseElimMergeAltsR , caseIntroSeqR , caseElimSeqR - ) -where + ) where -import Data.List -import Data.Monoid import Control.Arrow import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Data.List +import Data.Monoid + import HERMIT.Core import HERMIT.Context -import HERMIT.Monad -import HERMIT.Kure -import HERMIT.GHC import HERMIT.External -import HERMIT.Utilities +import HERMIT.GHC +import HERMIT.Kure +import HERMIT.Monad +import HERMIT.Name import HERMIT.ParserCore +import HERMIT.Utilities import HERMIT.Dictionary.Common import HERMIT.Dictionary.Inline hiding (externals) import HERMIT.Dictionary.AlphaConversion hiding (externals) import HERMIT.Dictionary.Fold (foldVarR) import HERMIT.Dictionary.GHC (substCoreExpr) -import HERMIT.Dictionary.Undefined (verifyStrictT) +import HERMIT.Dictionary.Undefined (verifyStrictT, buildStrictnessLemmaT) import HERMIT.Dictionary.Unfold (unfoldR) -- NOTE: these are hard to test in small examples, as GHC does them for us, so use with caution @@ -60,30 +64,33 @@ externals :: [External] externals = [ external "case-float-app" (promoteExprR caseFloatAppR :: RewriteH Core) - [ "(case ec of alt -> e) v ==> case ec of alt -> e v" ] .+ Commute .+ Shallow + [ "(case ec of alt -> e) v ==> case ec of alt -> e v" ] .+ Commute .+ Shallow , external "case-float-arg" ((\ strict -> promoteExprR (caseFloatArg Nothing (Just strict))) :: RewriteH Core -> RewriteH Core) [ "Given a proof that f is strict, then" - , "f (case s of alt -> e) ==> case s of alt -> f e" ] .+ Commute .+ Shallow + , "f (case s of alt -> e) ==> case s of alt -> f e" ] .+ Commute .+ Shallow , external "case-float-arg" ((\ f strict -> promoteExprR (caseFloatArg (Just f) (Just strict))) :: CoreString -> RewriteH Core -> RewriteH Core) [ "For a specified f, given a proof that f is strict, then" - , "f (case s of alt -> e) ==> case s of alt -> f e" ] .+ Commute .+ Shallow + , "f (case s of alt -> e) ==> case s of alt -> f e" ] .+ Commute .+ Shallow , external "case-float-arg-unsafe" ((\ f -> promoteExprR (caseFloatArg (Just f) Nothing)) :: CoreString -> RewriteH Core) [ "For a specified f," - , "f (case s of alt -> e) ==> case s of alt -> f e" ] .+ Commute .+ Shallow .+ PreCondition + , "f (case s of alt -> e) ==> case s of alt -> f e" ] .+ Commute .+ Shallow .+ PreCondition .+ Strictness , external "case-float-arg-unsafe" (promoteExprR (caseFloatArg Nothing Nothing) :: RewriteH Core) - [ "f (case s of alt -> e) ==> case s of alt -> f e" ] .+ Commute .+ Shallow .+ PreCondition + [ "f (case s of alt -> e) ==> case s of alt -> f e" ] .+ Commute .+ Shallow .+ PreCondition .+ Strictness + , external "case-float-arg-lemma" (promoteExprR . caseFloatArgLemmaR :: LemmaName -> RewriteH Core) + [ "f (case s of alt -> e) ==> case s of alt -> f e" + , "Generates a lemma with given name for strictness side condition on f." ] .+ Commute .+ Shallow .+ PreCondition .+ Strictness , external "case-float-case" (promoteExprR caseFloatCaseR :: RewriteH Core) [ "case (case ec of alt1 -> e1) of alta -> ea ==> case ec of alt1 -> case e1 of alta -> ea" ] .+ Commute .+ Eval , external "case-float-cast" (promoteExprR caseFloatCastR :: RewriteH Core) [ "cast (case s of p -> e) co ==> case s of p -> cast e co" ] .+ Shallow .+ Commute , external "case-float-let" (promoteExprR caseFloatLetR :: RewriteH Core) - [ "let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e" ] .+ Commute .+ Shallow + [ "let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e" ] .+ Commute .+ Shallow .+ Strictness , external "case-float" (promoteExprR caseFloatR :: RewriteH Core) - [ "case-float = case-float-app <+ case-float-case <+ case-float-let <+ case-float-cast" ] .+ Commute .+ Shallow + [ "case-float = case-float-app <+ case-float-case <+ case-float-let <+ case-float-cast" ] .+ Commute .+ Shallow .+ Strictness , external "case-float-in" (promoteExprR caseFloatInR :: RewriteH Core) [ "Float in a Case whatever the context." ] .+ Commute .+ Shallow .+ PreCondition , external "case-float-in-args" (promoteExprR caseFloatInArgsR :: RewriteH Core) - [ "Float in a Case whose alternatives are parallel applications of the same function." ] .+ Commute .+ Shallow .+ PreCondition + [ "Float in a Case whose alternatives are parallel applications of the same function." ] .+ Commute .+ Shallow .+ PreCondition .+ Strictness -- , external "case-float-in-app" (promoteExprR caseFloatInApp :: RewriteH Core) -- [ "Float in a Case whose alternatives are applications of different functions with the same arguments." ] .+ Commute .+ Shallow .+ PreCondition , external "case-reduce" (promoteExprR (caseReduceR True) :: RewriteH Core) @@ -95,21 +102,19 @@ , external "case-reduce-literal" (promoteExprR (caseReduceLiteralR True) :: RewriteH Core) [ "Case of Known Constructor" , "case L of L -> e ==> e" ] .+ Shallow .+ Eval - , external "case-reduce-id" (promoteExprR (caseReduceIdR True) :: RewriteH Core) - [ "Inline the case scrutinee (if it is an identifier) and then case-reduce." ] .+ Shallow .+ Eval .+ Context , external "case-reduce-unfold" (promoteExprR (caseReduceUnfoldR True) :: RewriteH Core) - [ "Unfold the case scrutinee (if it is a function application) and then case-reduce." ] .+ Shallow .+ Eval .+ Context + [ "Unfold the case scrutinee and then case-reduce." ] .+ Shallow .+ Eval .+ Context , external "case-split" (promoteExprR . caseSplitR . cmpString2Var :: String -> RewriteH Core) [ "case-split 'x" - , "e ==> case x of C1 vs -> e; C2 vs -> e, where x is free in e" ] .+ Shallow + , "e ==> case x of C1 vs -> e; C2 vs -> e, where x is free in e" ] .+ Shallow .+ Strictness , external "case-split-inline" (promoteExprR . caseSplitInlineR . cmpString2Var :: String -> RewriteH Core) [ "Like case-split, but additionally inlines the matched constructor " - , "applications for all occurances of the named variable." ] .+ Deep + , "applications for all occurances of the named variable." ] .+ Deep .+ Strictness , external "case-intro-seq" (promoteExprR . caseIntroSeqR . cmpString2Var :: String -> RewriteH Core) [ "Force evaluation of a variable by introducing a case." - , "case-seq 'v is is equivalent to adding @(seq v)@ in the source code." ] .+ Shallow .+ Introduce + , "case-intro-seq 'v is is equivalent to adding @(seq v)@ in the source code." ] .+ Shallow .+ Introduce .+ Strictness , external "case-elim-seq" (promoteExprR caseElimSeqR :: RewriteH Core) - [ "Eliminate a case that corresponds to a pointless seq." ] .+ Deep .+ Eval + [ "Eliminate a case that corresponds to a pointless seq." ] .+ Deep .+ Eval .+ Strictness , external "case-inline-alternative" (promoteExprR caseInlineAlternativeR :: RewriteH Core) [ "Inline the case binder as the case-alternative pattern everywhere in the case alternatives." ] .+ Deep , external "case-inline-scrutinee" (promoteExprR caseInlineScrutineeR :: RewriteH Core) @@ -122,7 +127,7 @@ [ "A cleverer version of 'mergeCaseAlts' that first attempts to" , "abstract out any occurrences of the alternative pattern using the case binder." ] .+ Deep , external "case-elim" (promoteExprR caseElimR :: RewriteH Core) - [ "case s of w; C vs -> e ==> e if w and vs are not free in e" ] .+ Shallow + [ "case s of w; C vs -> e ==> e if w and vs are not free in e" ] .+ Shallow .+ Strictness , external "case-elim-inline-scrutinee" (promoteExprR caseElimInlineScrutineeR :: RewriteH Core) [ "Eliminate a case, inlining any occurrences of the case binder as the scrutinee." ] .+ Deep , external "case-elim-merge-alts" (promoteExprR caseElimMergeAltsR :: RewriteH Core) @@ -135,7 +140,7 @@ ------------------------------------------------------------------------------ -- | case s of w; C vs -> e ==> e if w and vs are not free in e -caseElimR :: Rewrite c HermitM CoreExpr +caseElimR :: MonadCatch m => Rewrite c m CoreExpr caseElimR = prefixFailMsg "Case elimination failed: " $ withPatFailMsg (wrongExprForm "Case s bnd ty alts") $ do Case _ bnd _ alts <- idR @@ -148,10 +153,11 @@ ------------------------------------------------------------------------------ -- | (case s of alt1 -> e1; alt2 -> e2) v ==> case s of alt1 -> e1 v; alt2 -> e2 v -caseFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr caseFloatAppR = prefixFailMsg "Case floating from App function failed: " $ do - captures <- appT (map mkVarSet <$> caseAltVarsT) (arr freeVarsExpr) (flip (map . intersectVarSet)) + captures <- appT (liftM (map mkVarSet) caseAltVarsT) (arr freeVarsExpr) (flip (map . intersectVarSet)) bndrCapture <- appT caseBinderIdT (arr freeVarsExpr) elemVarSet appT ((if not bndrCapture then idR else alphaCaseBinderR Nothing) >>> caseAllR idR idR idR (\i -> if isEmptyVarSet (captures !! i) then idR else alphaAltR) @@ -169,9 +175,10 @@ -- | @f (case s of alt1 -> e1; alt2 -> e2)@ ==> @case s of alt1 -> f e1; alt2 -> f e2@ -- Only safe if @f@ is strict. -caseFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) - => Maybe CoreExpr -> Maybe (Rewrite c HermitM CoreExpr) -- ^ Maybe the function to float past, and maybe a proof of its strictness. - -> Rewrite c HermitM CoreExpr +caseFloatArgR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c + , HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) + => Maybe CoreExpr -> Maybe (Rewrite c m CoreExpr) -- ^ Maybe the function to float past, and maybe a proof of its strictness. + -> Rewrite c m CoreExpr caseFloatArgR mf mstrict = prefixFailMsg "Case floating from App argument failed: " $ withPatFailMsg "App f (Case s w ty alts)" $ do App f (Case s w _ alts) <- idR @@ -191,39 +198,41 @@ ) ) >>> caseFloatArgR Nothing Nothing --- caseFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, HasGlobalRdrEnv c) --- => Maybe (CoreExpr, Maybe (Rewrite c HermitM CoreExpr)) -- ^ Maybe the function to float past, and maybe a proof of its strictness. --- -> Rewrite c HermitM CoreExpr --- caseFloatArgR mfstrict = prefixFailMsg "Case floating from App argument failed: " $ --- withPatFailMsg "App f (Case s w ty alts)" $ --- do App f (Case s w _ alts) <- idR --- whenJust (\ (f', mstrict) -> --- do guardMsg (exprAlphaEq f f') "given function does not match current application." --- whenJust (verifyStrictT f) mstrict --- ) --- mfstrict +-- | @f (case s of alt1 -> e1; alt2 -> e2)@ ==> @case s of alt1 -> f e1; alt2 -> f e2@ +-- Only safe if @f@ is strict, so introduces a lemma to prove. +caseFloatArgLemmaR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasHermitMEnv m + , HasHscEnv m, HasDynFlags m, HasLemmas m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) + => LemmaName -> Rewrite c m CoreExpr +caseFloatArgLemmaR nm = prefixFailMsg "Case floating from application argument failed: " $ + withPatFailMsg "App f (Case s w ty alts)" $ do + App f (Case s w _ alts) <- idR --- let fvs = freeVarsExpr f --- altCaptures = map (intersectVarSet fvs . mkVarSet . altVars) alts --- bndrCapture = elemVarSet w fvs + let fvs = freeVarsExpr f + altCaptures = map (intersectVarSet fvs . mkVarSet . altVars) alts + bndrCapture = elemVarSet w fvs --- if | bndrCapture -> appAllR idR (alphaCaseBinderR Nothing) >>> caseFloatArgR Nothing --- | all isEmptyVarSet altCaptures -> let new_alts = mapAlts (App f) alts --- in return $ Case s w (coreAltsType new_alts) new_alts --- | otherwise -> appAllR idR (caseAllR idR idR idR (\ n -> let vs = varSetElems (altCaptures !! n) --- in if null vs then idR else alphaAltVarsR vs --- ) --- ) >>> caseFloatArgR Nothing + if | bndrCapture -> + appAllR idR (alphaCaseBinderR Nothing) >>> caseFloatArgR Nothing Nothing + | all isEmptyVarSet altCaptures -> do + let new_alts = mapAlts (App f) alts + buildStrictnessLemmaT nm f + return $ Case s w (coreAltsType new_alts) new_alts + | otherwise -> + appAllR idR (caseAllR idR idR idR (\ n -> let vs = varSetElems (altCaptures !! n) + in if null vs then idR else alphaAltVarsR vs + ) + ) >>> caseFloatArgR Nothing Nothing -- | case (case s1 of alt11 -> e11; alt12 -> e12) of alt21 -> e21; alt22 -> e22 -- ==> -- case s1 of -- alt11 -> case e11 of alt21 -> e21; alt22 -> e22 -- alt12 -> case e12 of alt21 -> e21; alt22 -> e22 -caseFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr caseFloatCaseR = prefixFailMsg "Case floating from Case failed: " $ do - captures <- caseT (map mkVarSet <$> caseAltVarsT) idR mempty (const $ arr freeVarsAlt) (\ vss w () fvs -> map (intersectVarSet (delVarSet (unionVarSets fvs) w)) vss) + captures <- caseT (liftM (map mkVarSet) caseAltVarsT) idR mempty (const $ arr freeVarsAlt) (\ vss w () fvs -> map (intersectVarSet (delVarSet (unionVarSets fvs) w)) vss) -- does the binder of the inner case, shadow a free variable in any of the outer case alts? bndrCapture <- caseT caseBinderIdT idR mempty (const $ arr freeVarsAlt) (\ innerBndr w () fvs -> innerBndr `elemVarSet` (delVarSet (unionVarSets fvs) w)) caseT ((if not bndrCapture then idR else alphaCaseBinderR Nothing) @@ -235,7 +244,8 @@ (\ (Case s1 b1 _ alts1) b2 ty alts2 -> Case s1 b1 ty $ mapAlts (\s -> Case s b2 ty alts2) alts1) -- | let v = case s of alt1 -> e1 in e ==> case s of alt1 -> let v = e1 in e -caseFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr caseFloatLetR = prefixFailMsg "Case floating from Let failed: " $ do vs <- letNonRecT idR caseAltVarsT mempty (\ letVar caseVars () -> letVar `elem` concat caseVars) let bdsAction = if not vs then idR else nonRecAllR idR alphaCaseR @@ -252,7 +262,8 @@ -- | caseFloatR = caseFloatAppR <+ caseFloatCaseR <+ caseFloatLetR <+ caseFloatCastR -- Note: does NOT include caseFloatArg -caseFloatR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseFloatR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr caseFloatR = setFailMsg "Unsuitable expression for Case floating." $ caseFloatAppR <+ caseFloatCaseR <+ caseFloatLetR <+ caseFloatCastR @@ -288,20 +299,18 @@ ------------------------------------------------------------------------------ --- | Inline the case scrutinee (if it is an identifier), and then perform case reduction. --- If first argument is True, perform substitution in RHS, if False, build let expressions. -caseReduceIdR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Bool -> Rewrite c HermitM CoreExpr -caseReduceIdR subst = caseAllR inlineR idR idR (const idR) >>> caseReduceR subst - --- | Inline the case scrutinee (if it is an identifier), and then perform case reduction. +-- | Unfold the case scrutinee and then perform case reduction. -- If first argument is True, perform substitution in RHS, if False, build let expressions. -caseReduceUnfoldR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Bool -> Rewrite c HermitM CoreExpr +caseReduceUnfoldR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m ) + => Bool -> Rewrite c m CoreExpr caseReduceUnfoldR subst = caseAllR unfoldR idR idR (const idR) >>> caseReduceR subst -- | Case of Known Constructor. -- Eliminate a case if the scrutinee is a data constructor or a literal. -- If first argument is True, perform substitution in RHS, if False, build let expressions. -caseReduceR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Bool -> Rewrite c HermitM CoreExpr +caseReduceR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m) + => Bool -> Rewrite c m CoreExpr caseReduceR subst = setFailMsg "Unsuitable expression for Case reduction." $ caseReduceDataconR subst <+ caseReduceLiteralR subst @@ -315,12 +324,8 @@ prefixFailMsg "Case reduction failed: " $ withPatFailMsg (wrongExprForm "Case (Lit l) v t alts") $ do Case s bndr _ alts <- idR -#if __GLASGOW_HASKELL__ > 706 let in_scope = mkInScopeSet (localFreeVarsExpr s) case exprIsLiteral_maybe (in_scope, idUnfolding) s of -#else - case exprIsLiteral_maybe idUnfolding s of -#endif Nothing -> fail "scrutinee is not a literal." Just l -> do guardMsg (not (litIsLifted l)) "cannot case-reduce lifted literals" -- see Trac #5603 case findAlt (LitAlt l) alts of @@ -332,19 +337,17 @@ -- | Case of Known Constructor. -- Eliminate a case if the scrutinee is a data constructor. -- If first argument is True, perform substitution in RHS, if False, build let expressions. -caseReduceDataconR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Bool -> Rewrite c HermitM CoreExpr +caseReduceDataconR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, MonadCatch m, MonadUnique m ) + => Bool -> Rewrite c m CoreExpr caseReduceDataconR subst = prefixFailMsg "Case reduction failed: " $ withPatFailMsg (wrongExprForm "Case e v t alts") go where - go :: Rewrite c HermitM CoreExpr + go :: Rewrite c m CoreExpr go = do Case e bndr _ alts <- idR -#if __GLASGOW_HASKELL__ > 706 let in_scope = mkInScopeSet (localFreeVarsExpr e) case exprIsConApp_maybe (in_scope, idUnfolding) e of -#else - case exprIsConApp_maybe idUnfolding e of -#endif Nothing -> fail "head of scrutinee is not a data constructor." Just (dc, univTys, es) -> case findAlt (DataAlt dc) alts of Nothing -> fail "no matching alternative." @@ -367,12 +370,12 @@ -- e ==> case i of i -- [] -> e -- (a:as) -> e -caseSplitR :: (Id -> Bool) -> Rewrite c HermitM CoreExpr +caseSplitR :: (MonadCatch m, MonadUnique m) => (Id -> Bool) -> Rewrite c m CoreExpr caseSplitR idPred = prefixFailMsg "caseSplit failed: " $ do i <- matchingFreeIdT idPred (tycon, tys) <- splitTyConAppM (idType i) let aNms = map (:[]) $ cycle ['a'..'z'] - contextfreeT $ \ e -> do dcsAndVars <- mapM (\ dc -> (dc,) <$> sequence [ newIdH a ty | (a,ty) <- zip aNms $ dataConInstArgTys dc tys ]) + contextfreeT $ \ e -> do dcsAndVars <- mapM (\ dc -> liftM (dc,) (sequence [ newIdH a ty | (a,ty) <- zip aNms $ dataConInstArgTys dc tys ])) (tyConDataCons tycon) w <- cloneVarH (++ "'") i let e' = substCoreExpr i (Var w) e @@ -384,7 +387,7 @@ -- -- e -> case v of v -- _ -> e -caseIntroSeqR :: (Id -> Bool) -> Rewrite c HermitM CoreExpr +caseIntroSeqR :: (MonadCatch m, MonadUnique m) => (Id -> Bool) -> Rewrite c m CoreExpr caseIntroSeqR idPred = prefixFailMsg "case-intro-seq failed: " $ do i <- matchingFreeIdT idPred contextfreeT $ \ e -> do guardMsg (not $ isTyCoArg e) "cannot case on a type or coercion." @@ -406,25 +409,33 @@ -- for each occurance of the named variable. -- -- > caseSplitInline idPred = caseSplit idPred >>> caseInlineAlternativeR -caseSplitInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => (Id -> Bool) -> Rewrite c HermitM CoreExpr +caseSplitInlineR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m ) + => (Id -> Bool) -> Rewrite c m CoreExpr caseSplitInlineR idPred = caseSplitR idPred >>> caseInlineAlternativeR ------------------------------------------------------------------------------ -caseInlineBinderR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => CaseBinderInlineOption -> Rewrite c HermitM CoreExpr +caseInlineBinderR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m ) + => CaseBinderInlineOption -> Rewrite c m CoreExpr caseInlineBinderR opt = do w <- caseBinderIdT caseAllR idR idR idR $ \ _ -> setFailMsg "no inlinable occurrences." $ do depth <- varBindingDepthT w - extractR $ anybuR (promoteExprR (configurableInlineR (CaseBinderOnly opt) (varIsOccurrenceOfT w depth)) :: Rewrite c HermitM Core) + extractR $ anybuR (promoteExprR (configurableInlineR (CaseBinderOnly opt) (varIsOccurrenceOfT w depth)) :: Rewrite c m Core) -- | Inline the case binder as the case scrutinee everywhere in the case alternatives. -caseInlineScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr +caseInlineScrutineeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m ) + => Rewrite c m CoreExpr caseInlineScrutineeR = prefixFailMsg "case-inline-scrutinee failed: " $ caseInlineBinderR Scrutinee -- | Inline the case binder as the case-alternative pattern everywhere in the case alternatives. -caseInlineAlternativeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr +caseInlineAlternativeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m ) + => Rewrite c m CoreExpr caseInlineAlternativeR = prefixFailMsg "case-inline-alternative failed: " $ caseInlineBinderR Alternative @@ -444,31 +455,42 @@ return $ Case e w ty [(DEFAULT,[],head rhss)] -- | In the case alternatives, fold any occurrences of the case alt patterns to the case binder. -caseFoldBinderR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr +caseFoldBinderR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m ) + => Rewrite c m CoreExpr caseFoldBinderR = prefixFailMsg "case-fold-binder failed: " $ do w <- caseBinderIdT caseAllR idR idR idR $ \ _ -> do depth <- varBindingDepthT w - extractR $ anybuR (promoteExprR (foldVarR w (Just depth)) :: Rewrite c HermitM Core) + extractR $ anybuR (promoteExprR (foldVarR (Just depth) w) :: Rewrite c m Core) -- | A cleverer version of 'mergeCaseAlts' that first attempts to abstract out any occurrences of the alternative pattern using the case binder. -caseMergeAltsWithBinderR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr +caseMergeAltsWithBinderR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m ) + => Rewrite c m CoreExpr caseMergeAltsWithBinderR = prefixFailMsg "merge-case-alts-with-binder failed: " $ withPatFailMsg (wrongExprForm "Case e w ty alts") $ tryR caseFoldBinderR >>> caseMergeAltsR -- | Eliminate a case, inlining any occurrences of the case binder as the scrutinee. -caseElimInlineScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr +caseElimInlineScrutineeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m ) + => Rewrite c m CoreExpr caseElimInlineScrutineeR = alphaCaseBinderR Nothing >>> tryR caseInlineScrutineeR >>> caseElimR --- | Eliminate a case, merging the case alternatives into a single default alternative and inlining the case binder as the scrutinee (if possible). -caseElimMergeAltsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr +-- | Eliminate a case, merging the case alternatives into a single default alternative +-- and inlining the case binder as the scrutinee (if possible). +caseElimMergeAltsR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m ) + => Rewrite c m CoreExpr caseElimMergeAltsR = tryR caseFoldBinderR >>> tryR caseMergeAltsR >>> caseElimInlineScrutineeR ------------------------------------------------------------------------------ -- | Eliminate a case that corresponds to a pointless 'seq'. -caseElimSeqR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr +caseElimSeqR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c + , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m ) + => Rewrite c m CoreExpr caseElimSeqR = prefixFailMsg "case-elim-seq failed: " $ withPatFailMsg "not a seq case." $ do Case s w _ [(DEFAULT,[],rhs)] <- idR diff --git a/src/HERMIT/Dictionary/Local/Cast.hs b/src/HERMIT/Dictionary/Local/Cast.hs --- a/src/HERMIT/Dictionary/Local/Cast.hs +++ b/src/HERMIT/Dictionary/Local/Cast.hs @@ -70,11 +70,7 @@ withPatFailMsg (wrongExprForm "App (Cast e1 co) e2") $ do App (Cast e1 co) e2 <- idR case co of -#if __GLASGOW_HASKELL__ > 706 TyConAppCo _r t [c1, c2] -> do -#else - TyConAppCo t [c1, c2] -> do -#endif True <- return (isFunTyCon t) return $ Cast (App e1 (Cast e2 (SymCo c1))) c2 ForAllCo t c2 -> do @@ -82,14 +78,12 @@ return (Cast (App e1 e2) (Coercion.substCo (Coercion.extendTvSubst emptyCvSubst t x') c2)) _ -> fail "castFloatApp" -#if __GLASGOW_HASKELL__ > 706 -- | Attempts to tease a coercion apart into a type constructor and the application -- of a number of coercion arguments to that constructor splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) splitTyConAppCo_maybe (Refl ro ty) = (fmap . second . map) (Refl ro) (splitTyConApp_maybe ty) splitTyConAppCo_maybe (TyConAppCo _r tc cs) = Just (tc, cs) splitTyConAppCo_maybe _ = Nothing -#endif -- TODO: revisit castElimSymPlusR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreExpr diff --git a/src/HERMIT/Dictionary/Local/Let.hs b/src/HERMIT/Dictionary/Local/Let.hs --- a/src/HERMIT/Dictionary/Local/Let.hs +++ b/src/HERMIT/Dictionary/Local/Let.hs @@ -1,48 +1,49 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, MultiWayIf, LambdaCase #-} module HERMIT.Dictionary.Local.Let - ( -- * Rewrites on Let Expressions - externals - -- ** Let Elimination - , letNonRecSubstR - , letNonRecSubstSafeR - , letSubstR - , letSubstSafeR - , letElimR - , letNonRecElimR - , letRecElimR - , progBindElimR - , progBindNonRecElimR - , progBindRecElimR - -- ** Let Introduction - , letIntroR - , letNonRecIntroR - , progNonRecIntroR - , nonRecIntroR - , letIntroUnfoldingR - -- ** Let Floating Out - , letFloatAppR - , letFloatArgR - , letFloatLetR - , letFloatLamR - , letFloatCaseR - , letFloatCastR - , letFloatExprR - , letFloatTopR - -- ** Let Floating In - , letFloatInR - , letFloatInAppR - , letFloatInCaseR - , letFloatInLamR - -- ** Miscallaneous - , reorderNonRecLetsR - , letTupleR - , letToCaseR - ) -where + ( -- * Rewrites on Let Expressions + externals + -- ** Let Elimination + , letNonRecSubstR + , letNonRecSubstSafeR + , letSubstR + , letSubstSafeR + , letElimR + , letNonRecElimR + , letRecElimR + , progBindElimR + , progBindNonRecElimR + , progBindRecElimR + -- ** Let Introduction + , letIntroR + , letNonRecIntroR + , progNonRecIntroR + , nonRecIntroR + , letIntroUnfoldingR + -- ** Let Floating Out + , letFloatAppR + , letFloatArgR + , letFloatLetR + , letFloatLamR + , letFloatCaseR + , letFloatCaseAltR + , letFloatCastR + , letFloatExprR + , letFloatTopR + -- ** Let Floating In + , letFloatInR + , letFloatInAppR + , letFloatInCaseR + , letFloatInLamR + -- ** Miscallaneous + , reorderNonRecLetsR + , letTupleR + , letToCaseR + ) where import Control.Arrow import Control.Monad +import Control.Monad.IO.Class import Data.List import Data.Monoid @@ -53,6 +54,7 @@ import HERMIT.Kure import HERMIT.External import HERMIT.GHC +import HERMIT.Name import HERMIT.Utilities import HERMIT.Dictionary.Common @@ -83,7 +85,7 @@ -- , "only matches non-recursive lets" ] .+ Deep .+ Eval , external "let-intro" (promoteExprR . letIntroR :: String -> RewriteH Core) [ "e => (let v = e in v), name of v is provided" ] .+ Shallow .+ Introduce - , external "let-intro-unfolding" (promoteExprR . letIntroUnfoldingR :: String -> RewriteH Core) + , external "let-intro-unfolding" (promoteExprR . letIntroUnfoldingR :: HermitName -> RewriteH Core) [ "e => let f' = defn[f'/f] in e[f'/f], name of f is provided" ] , external "let-elim" (promoteExprR letElimR :: RewriteH Core) [ "Remove an unused let binding." @@ -102,6 +104,13 @@ [ "let v = (let w = ew in ev) in e ==> let w = ew in let v = ev in e" ] .+ Commute .+ Shallow , external "let-float-case" (promoteExprR letFloatCaseR :: RewriteH Core) [ "case (let v = ev in e) of ... ==> let v = ev in case e of ..." ] .+ Commute .+ Shallow .+ Eval + , external "let-float-case-alt" (promoteExprR (letFloatCaseAltR Nothing) :: RewriteH Core) + [ "case s of { ... ; p -> let v = ev in e ; ... } " + , "==> let v = ev in case s of { ... ; p -> e ; ... } " ] .+ Commute .+ Shallow .+ Eval + , external "let-float-case-alt" (promoteExprR . letFloatCaseAltR . Just :: Int -> RewriteH Core) + [ "Float a let binding from specified alternative." + , "case s of { ... ; p -> let v = ev in e ; ... } " + , "==> let v = ev in case s of { ... ; p -> e ; ... } " ] .+ Commute .+ Shallow .+ Eval , external "let-float-cast" (promoteExprR letFloatCastR :: RewriteH Core) [ "cast (let bnds in e) co ==> let bnds in cast e co" ] .+ Commute .+ Shallow , external "let-float-top" (promoteProgR letFloatTopR :: RewriteH Core) @@ -157,6 +166,29 @@ do Let (NonRec v rhs) body <- idR return (substCoreExpr v rhs body) +{- +TODO: This was written very early in the project by Andy. + It was later modified somewhat by Neil, but without reassessing the heurisitc as a whole. + It may need revisiting. + +Safe Subst Heuristic +-------------------- + +Substitution is safe if (A) OR (B) OR (C). + +(A) The let-bound variable is a type or coercion. + +(B) The let-bound value is either: + (i) a variable; + (ii) a lambda; + (iii) an application that requires more value arguments before it can perform any computation. + +(C) In the body, the let-bound variable must NOT occur: + (i) more than once; + (ii) inside a lambda. + +-} + -- | Currently we always substitute types and coercions, and use a heuristic to decide whether to substitute expressions. -- This may need revisiting. letNonRecSubstSafeR :: forall c m. (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, ReadBindings c, HasEmptyContext c, MonadCatch m) => Rewrite c m CoreExpr @@ -270,7 +302,8 @@ ------------------------------------------------------------------------------------------- -- | @let v = ev in e@ ==> @case ev of v -> e@ -letToCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +letToCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr letToCaseR = prefixFailMsg "Converting Let to Case failed: " $ withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $ do Let (NonRec v ev) _ <- idR @@ -281,7 +314,8 @@ ------------------------------------------------------------------------------------------- -- | @(let v = ev in e) x@ ==> @let v = ev in e x@ -letFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +letFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr letFloatAppR = prefixFailMsg "Let floating from App function failed: " $ withPatFailMsg (wrongExprForm "App (Let bnds body) e") $ do App (Let bnds body) e <- idR @@ -291,7 +325,8 @@ else appAllR (alphaLetVarsR $ varSetElems vs) idR >>> letFloatAppR -- | @f (let v = ev in e)@ ==> @let v = ev in f e@ -letFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +letFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr letFloatArgR = prefixFailMsg "Let floating from App argument failed: " $ withPatFailMsg (wrongExprForm "App f (Let bnds body)") $ do App f (Let bnds body) <- idR @@ -301,7 +336,8 @@ else appAllR idR (alphaLetVarsR $ varSetElems vs) >>> letFloatArgR -- | @let v = (let bds in e1) in e2@ ==> @let bds in let v = e1 in e2@ -letFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +letFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr letFloatLetR = prefixFailMsg "Let floating from Let failed: " $ withPatFailMsg (wrongExprForm "Let (NonRec v (Let bds e1)) e2") $ do Let (NonRec v (Let bds e1)) e2 <- idR @@ -313,20 +349,22 @@ -- | @(\ v -> let binds in e2)@ ==> @let binds in (\ v1 -> e2)@ -- Fails if @v@ occurs in the RHS of @binds@. -- If @v@ is shadowed in binds, then @v@ will be alpha-renamed. -letFloatLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +letFloatLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr letFloatLamR = prefixFailMsg "Let floating from Lam failed: " $ withPatFailMsg (wrongExprForm "Lam v1 (Let bds body)") $ do Lam v (Let binds body) <- idR let bs = bindVars binds fvs = freeVarsBind binds - guardMsg (v `notElemVarSet` fvs) (var2String v ++ " occurs in the RHS of the let-bindings.") + guardMsg (v `notElemVarSet` fvs) (unqualifiedName v ++ " occurs in the RHS of the let-bindings.") if v `elem` bs then alphaLamR Nothing >>> letFloatLamR else return $ Let binds (Lam v body) -- | @case (let bnds in e) of bndr alts@ ==> @let bnds in (case e of bndr alts)@ -- Fails if any variables bound in @bnds@ occurs in @alts@. -letFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +letFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr letFloatCaseR = prefixFailMsg "Let floating from Case failed: " $ withPatFailMsg (wrongExprForm "Case (Let bnds e) w ty alts") $ do Case (Let bnds e) w ty alts <- idR @@ -335,6 +373,57 @@ then return $ Let bnds (Case e w ty alts) else caseAllR (alphaLetVarsR $ varSetElems captures) idR idR (const idR) >>> letFloatCaseR +-- | case e of w { ... ; p -> let b = rhs in body ; ... } ==> +-- let b = rhs in case e of { ... ; p -> body ; ... } +-- +-- where no variable in `p` or `w` occurs freely in `rhs`, +-- and where `b` does not capture a free variable in the overall case, +-- and where `w` is not rebound in `b`. +letFloatCaseAltR :: MonadCatch m => Maybe Int -> Rewrite c m CoreExpr +letFloatCaseAltR maybeN = prefixFailMsg "Let float from case alternative failed: " $ + withPatFailMsg (wrongExprForm "Case s w ty alts") $ do + -- Perform the first safe let-floating out of a case alternative + let letFloatOneAltM :: MonadCatch m => Id -> VarSet -> [CoreAlt] -> m (CoreBind,[CoreAlt]) + letFloatOneAltM w fvs = go + where go [] = fail "no lets can be safely floated from alternatives." + go (alt:rest) = (do (bind,alt') <- letFloatAltM w fvs alt + return (bind,alt':rest)) + <+ liftM (second (alt :)) (go rest) + + -- (p -> let bnds in body) ==> (bnds, p -> body) + letFloatAltM :: Monad m => Id -> VarSet -> CoreAlt -> m (CoreBind,CoreAlt) + letFloatAltM w fvs (con, vs, Let bnds body) = do + let bSet = mkVarSet (bindVars bnds) + vSet = mkVarSet (w:vs) + + -- 'w' is not in 'fvs', but if it is rebound by 'b', doing this rewrite + -- would cause it to bind things that were previously bound by 'b'. + guardMsg (not (w `elemVarSet` bSet)) "floating would allow case binder to capture variables." + + -- no free vars in 'rhs' are bound by 'p' or 'w' + guardMsg (isEmptyVarSet $ vSet `intersectVarSet` freeVarsBind bnds) + "floating would cause variables in rhs to become unbound." + + -- no free vars in overall case are bound by 'b' + guardMsg (isEmptyVarSet $ bSet `intersectVarSet` fvs) + "floating would cause let binders to capture variables in case expression." + + return (bnds, (con, vs, body)) + letFloatAltM _ _ _ = fail "no let expression on alternative right-hand side." + + Case e w ty alts <- idR + fvs <- arr freeVarsExpr + let l = length alts - 1 + case maybeN of + Just n | n < 0 || n > l -> fail $ "valid alternative indices: 0 to " ++ show l + | otherwise -> do + let (pre, alt:suf) = splitAt n alts + (bnds,alt') <- letFloatAltM w fvs alt + return $ Let bnds $ Case e w ty $ pre ++ (alt':suf) + Nothing -> do + (bnds,alts') <- letFloatOneAltM w fvs alts + return $ Let bnds $ Case e w ty alts' + -- | @cast (let bnds in e) co@ ==> @let bnds in cast e co@ letFloatCastR :: MonadCatch m => Rewrite c m CoreExpr letFloatCastR = prefixFailMsg "Let floating from Cast failed: " $ @@ -343,12 +432,15 @@ return $ Let bnds (Cast e co) -- | Float a 'Let' through an expression, whatever the context. -letFloatExprR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr -letFloatExprR = setFailMsg "Unsuitable expression for Let floating." $ - letFloatArgR <+ letFloatAppR <+ letFloatLetR <+ letFloatLamR <+ letFloatCaseR <+ letFloatCastR +letFloatExprR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr +letFloatExprR = setFailMsg "Unsuitable expression for Let floating." + $ letFloatArgR <+ letFloatAppR <+ letFloatLetR <+ letFloatLamR + <+ letFloatCaseR <+ letFloatCaseAltR Nothing <+ letFloatCastR -- | @'ProgCons' ('NonRec' v ('Let' bds e)) p@ ==> @'ProgCons' bds ('ProgCons' ('NonRec' v e) p)@ -letFloatTopR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreProg +letFloatTopR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m) + => Rewrite c m CoreProg letFloatTopR = prefixFailMsg "Let floating to top level failed: " $ withPatFailMsg (wrongExprForm "NonRec v (Let bds e) `ProgCons` p") $ do ProgCons (NonRec v (Let bds e)) p <- idR @@ -362,12 +454,14 @@ ------------------------------------------------------------------------------------------- -- | Float in a 'Let' if possible. -letFloatInR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) => Rewrite c HermitM CoreExpr +letFloatInR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr letFloatInR = letFloatInCaseR <+ letFloatInAppR <+ letFloatInLamR -- | @let v = ev in case s of p -> e@ ==> @case (let v = ev in s) of p -> let v = ev in e@, -- if @v@ does not shadow a pattern binder in @p@ -letFloatInCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) => Rewrite c HermitM CoreExpr +letFloatInCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr letFloatInCaseR = prefixFailMsg "Let floating in to case failed: " $ withPatFailMsg (wrongExprForm "Let bnds (Case s w ty alts)") $ do Let bnds (Case s w ty alts) <- idR @@ -379,7 +473,8 @@ return (Case (Let bnds s) w ty alts) >>> caseAllR idR idR idR (\_ -> altAllR idR (\_ -> idR) (arr (Let bnds) >>> alphaLetR)) -- | @let v = ev in f a@ ==> @(let v = ev in f) (let v = ev in a)@ -letFloatInAppR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) => Rewrite c HermitM CoreExpr +letFloatInAppR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m) + => Rewrite c m CoreExpr letFloatInAppR = prefixFailMsg "Let floating in to app failed: " $ withPatFailMsg (wrongExprForm "Let bnds (App e1 e2)") $ do Let bnds (App e1 e2) <- idR @@ -434,7 +529,7 @@ -- | Combine nested non-recursive lets into case of a tuple. -- E.g. let {v1 = e1 ; v2 = e2 ; v3 = e3} in body ==> case (e1,e2,e3) of {(v1,v2,v3) -> body} -letTupleR :: String -> Rewrite c HermitM CoreExpr +letTupleR :: (MonadCatch m, MonadUnique m) => String -> Rewrite c m CoreExpr letTupleR nm = prefixFailMsg "Let-tuple failed: " $ do (bnds, body) <- arr collectLets let numBnds = length bnds @@ -465,32 +560,29 @@ -- This code could be factored better. -- | @e@ ==> @let v = e in v@ -letIntroR :: String -> Rewrite c HermitM CoreExpr +letIntroR :: (MonadCatch m, MonadUnique m) => String -> Rewrite c m CoreExpr letIntroR nm = do e <- idR Let (NonRec v e') _ <- letNonRecIntroR nm e return $ Let (NonRec v e') (varToCoreExpr v) -- | @body@ ==> @let v = e in body@ -letNonRecIntroR :: String -> CoreExpr -> Rewrite c HermitM CoreExpr +letNonRecIntroR :: (MonadCatch m, MonadUnique m) => String -> CoreExpr -> Rewrite c m CoreExpr letNonRecIntroR nm e = prefixFailMsg "Let-introduction failed: " $ - contextfreeT $ \ body -> do let tyk = exprKindOrType e - v <- if | isTypeArg e -> newTyVarH nm tyk - | isCoArg e -> newCoVarH nm tyk - | otherwise -> newIdH nm tyk + contextfreeT $ \ body -> do v <- newVarH nm $ exprKindOrType e return $ Let (NonRec v e) body -- This isn't a "Let", but it's serving the same role. Maybe create a Local/Prog module? -- | @prog@ ==> @'ProgCons' (v = e) prog@ -progNonRecIntroR :: String -> CoreExpr -> Rewrite c HermitM CoreProg +progNonRecIntroR :: (MonadCatch m, MonadUnique m) => String -> CoreExpr -> Rewrite c m CoreProg progNonRecIntroR nm e = prefixFailMsg "Top-level binding introduction failed: " $ do guardMsg (not $ isTyCoArg e) "Top-level type or coercion definitions are prohibited." contextfreeT $ \ prog -> do i <- newIdH nm (exprType e) return $ ProgCons (NonRec i e) prog -- | nonRecIntroR nm e = 'letNonRecIntroR nm e' <+ 'progNonRecIntroR nm e' -nonRecIntroR :: String -> CoreExpr -> Rewrite c HermitM Core +nonRecIntroR :: (MonadCatch m, MonadUnique m) => String -> CoreExpr -> Rewrite c m Core nonRecIntroR nm e = readerT $ \case ExprCore{} -> promoteExprR (letNonRecIntroR nm e) ProgCore{} -> promoteProgR (progNonRecIntroR nm e) @@ -498,7 +590,9 @@ -- | Introduce a local definition for a (possibly imported) identifier. -- Rewrites occurences of the identifier to point to this new local definiton. -letIntroUnfoldingR :: (BoundVars c, ReadBindings c) => String -> Rewrite c HermitM CoreExpr +letIntroUnfoldingR :: ( BoundVars c, ReadBindings c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m + , MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) + => HermitName -> Rewrite c m CoreExpr letIntroUnfoldingR nm = do i <- findIdT nm (rhs,_) <- getUnfoldingT AllBinders <<< return i diff --git a/src/HERMIT/Dictionary/Navigation.hs b/src/HERMIT/Dictionary/Navigation.hs --- a/src/HERMIT/Dictionary/Navigation.hs +++ b/src/HERMIT/Dictionary/Navigation.hs @@ -1,33 +1,35 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, FlexibleInstances, InstanceSigs #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, InstanceSigs, ScopedTypeVariables, TypeFamilies #-} module HERMIT.Dictionary.Navigation - ( -- * Navigation - externals - , occurrenceOfT - , bindingOfT - , bindingGroupOfT - , rhsOfT - , parentOfT - , occurrenceOfTargetsT - , bindingOfTargetsT - , bindingGroupOfTargetsT - , rhsOfTargetsT - , Considerable(..) - , considerables - , considerConstructT - , nthArgPath - ) -where + ( -- * Navigation + externals + , occurrenceOfT + , bindingOfT + , bindingGroupOfT + , rhsOfT + , parentOfT + , occurrenceOfTargetsT + , bindingOfTargetsT + , bindingGroupOfTargetsT + , rhsOfTargetsT + , Considerable(..) + , considerables + , considerConstructT + , nthArgPath + , string2considerable + ) where +import Data.Dynamic (Typeable) import Data.Monoid import Control.Arrow import HERMIT.Core import HERMIT.Context -import HERMIT.Kure import HERMIT.External import HERMIT.GHC hiding ((<>)) +import HERMIT.Kure +import HERMIT.Name import HERMIT.Dictionary.Navigation.Crumbs @@ -35,32 +37,33 @@ -- | 'External's involving navigating to named entities. externals :: [External] -externals = crumbExternals ++ map (.+ Navigation) - [ external "rhs-of" (rhsOfT . cmpString2Var :: String -> TransformH Core LocalPathH) - [ "Find the path to the RHS of the binding of the named variable." ] - , external "binding-group-of" (bindingGroupOfT . cmpString2Var :: String -> TransformH CoreTC LocalPathH) - [ "Find the path to the binding group of the named variable." ] - , external "binding-of" (bindingOfT . cmpString2Var :: String -> TransformH CoreTC LocalPathH) - [ "Find the path to the binding of the named variable." ] - , external "occurrence-of" (occurrenceOfT . cmpString2Var :: String -> TransformH CoreTC LocalPathH) - [ "Find the path to the first occurrence of the named variable." ] - , external "consider" (considerConstruct :: String -> TransformH Core LocalPathH) - [ "consider focuses on the first construct .", - recognizedConsiderables] - , external "arg" (promoteExprT . nthArgPath :: Int -> TransformH Core LocalPathH) - [ "arg n focuses on the (n-1)th argument of a nested application." ] - , external "lams-body" (promoteExprT lamsBodyT :: TransformH Core LocalPathH) - [ "Descend into the body after a sequence of lambdas." ] - , external "lets-body" (promoteExprT letsBodyT :: TransformH Core LocalPathH) - [ "Descend into the body after a sequence of let bindings." ] - , external "prog-end" (promoteModGutsT gutsProgEndT <+ promoteProgT progEndT :: TransformH Core LocalPathH) - [ "Descend to the end of a program." ] - - , external "parent-of" (parentOfT :: TransformH Core LocalPathH -> TransformH Core LocalPathH) - [ "Focus on the parent of another focal point." ] - , external "parent-of" (parentOfT :: TransformH CoreTC LocalPathH -> TransformH CoreTC LocalPathH) - [ "Focus on the parent of another focal point." ] - ] +externals = crumbExternals + ++ map (.+ Navigation) + [ external "rhs-of" (rhsOfT . mkRhsOfPred :: RhsOfName -> TransformH Core LocalPathH) + [ "Find the path to the RHS of the binding of the named variable." ] + , external "binding-group-of" (bindingGroupOfT . cmpString2Var :: String -> TransformH CoreTC LocalPathH) + [ "Find the path to the binding group of the named variable." ] + , external "binding-of" (bindingOfT . mkBindingPred :: BindingName -> TransformH CoreTC LocalPathH) + [ "Find the path to the binding of the named variable." ] + , external "occurrence-of" (occurrenceOfT . mkOccPred :: OccurrenceName -> TransformH CoreTC LocalPathH) + [ "Find the path to the first occurrence of the named variable." ] + , external "application-of" (applicationOfT . mkOccPred :: OccurrenceName -> TransformH CoreTC LocalPathH) + [ "Find the path to the first application of the named variable." ] + , external "consider" (considerConstructT :: Considerable -> TransformH Core LocalPathH) + [ "consider focuses on the first construct .", recognizedConsiderables ] + , external "arg" (promoteExprT . nthArgPath :: Int -> TransformH Core LocalPathH) + [ "arg n focuses on the (n-1)th argument of a nested application." ] + , external "lams-body" (promoteExprT lamsBodyT :: TransformH Core LocalPathH) + [ "Descend into the body after a sequence of lambdas." ] + , external "lets-body" (promoteExprT letsBodyT :: TransformH Core LocalPathH) + [ "Descend into the body after a sequence of let bindings." ] + , external "prog-end" (promoteModGutsT gutsProgEndT <+ promoteProgT progEndT :: TransformH Core LocalPathH) + [ "Descend to the end of a program." ] + , external "parent-of" (parentOfT :: TransformH Core LocalPathH -> TransformH Core LocalPathH) + [ "Focus on the parent of another focal point." ] + , external "parent-of" (parentOfT :: TransformH CoreTC LocalPathH -> TransformH CoreTC LocalPathH) + [ "Focus on the parent of another focal point." ] + ] --------------------------------------------------------------------------------------- @@ -99,6 +102,12 @@ occurrenceOfT p = prefixFailMsg ("occurrence-of failed: ") $ oneNonEmptyPathToT (arr $ occurrenceOf p) +-- | Find the path to an application of a given function. +applicationOfT :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, MonadCatch m, ReadPath c Crumb) + => (Var -> Bool) -> Transform c m CoreTC LocalPathH +applicationOfT p = prefixFailMsg "application-of failed:" $ oneNonEmptyPathToT go + where go = promoteExprT (appT (extractT go) successT const) <+ arr (occurrenceOf p) + ----------------------------------------------------------------------- bindingGroupOf :: (Var -> Bool) -> CoreBind -> Bool @@ -186,7 +195,13 @@ -- | Language constructs that can be zoomed to. data Considerable = Binding | Definition | CaseAlt | Variable | Literal | Application | Lambda | LetExpr | CaseOf | Casty | Ticky | TypeExpr | CoercionExpr + deriving Typeable +instance Extern Considerable where + type Box Considerable = Considerable + box = id + unbox = id + recognizedConsiderables :: String recognizedConsiderables = "Recognized constructs are: " ++ show (map fst considerables) @@ -206,12 +221,6 @@ , ("type",TypeExpr) , ("coerce",CoercionExpr) ] - -considerConstruct :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => String -> Transform c m Core LocalPathH -considerConstruct str = case string2considerable str of - Nothing -> fail $ "Unrecognized construct \"" ++ str ++ "\". Perhaps you meant \"binding-of '" ++ str ++ "\"? " - ++ recognizedConsiderables ++ "." - Just c -> considerConstructT c -- | Find the path to the first matching construct. considerConstructT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Considerable -> Transform c m Core LocalPathH diff --git a/src/HERMIT/Dictionary/Query.hs b/src/HERMIT/Dictionary/Query.hs --- a/src/HERMIT/Dictionary/Query.hs +++ b/src/HERMIT/Dictionary/Query.hs @@ -1,13 +1,12 @@ {-# LANGUAGE CPP, LambdaCase, FlexibleContexts #-} module HERMIT.Dictionary.Query - ( -- * Queries and Predicates - externals - , infoT - , compareCoreAtT - , compareBoundIdsT - ) -where + ( -- * Queries and Predicates + externals + , infoT + , compareCoreAtT + , compareBoundIdsT + ) where import Control.Arrow @@ -20,6 +19,7 @@ import HERMIT.GHC import HERMIT.Kure import HERMIT.Monad +import HERMIT.Name import HERMIT.Dictionary.AlphaConversion hiding (externals) import HERMIT.Dictionary.Common @@ -31,13 +31,13 @@ -- | Externals that reflect GHC functions, or are derived from GHC functions. externals :: [External] externals = - [ external "info" (infoT :: TransformH CoreTC String) - [ "Display information about the current node." ] .+ Query - , external "compare-bound-ids" (compareBoundIds :: String -> String -> TransformH CoreTC ()) - [ "Compare the definitions of two in-scope identifiers for alpha equality."] .+ Query .+ Predicate - , external "compare-core-at" (compareCoreAtT :: TransformH Core LocalPathH -> TransformH Core LocalPathH -> TransformH Core ()) - [ "Compare the core fragments at the end of the given paths for alpha-equality."] .+ Query .+ Predicate - ] + [ external "info" (infoT :: TransformH CoreTC String) + [ "Display information about the current node." ] .+ Query + , external "compare-bound-ids" (compareBoundIds :: HermitName -> HermitName -> TransformH CoreTC ()) + [ "Compare the definitions of two in-scope identifiers for alpha equality."] .+ Query .+ Predicate + , external "compare-core-at" (compareCoreAtT :: TransformH Core LocalPathH -> TransformH Core LocalPathH -> TransformH Core ()) + [ "Compare the core fragments at the end of the given paths for alpha-equality."] .+ Query .+ Predicate + ] -------------------------------------------------------- @@ -52,7 +52,7 @@ pa = "Path: " ++ showCrumbs (snocPathToPath $ absPath c) children = "Children: " ++ showCrumbs crumbs bds = "Local bindings in scope: " ++ concat - [ "\n " ++ var2String k ++ " : " ++ hermitBindingSummary hbs + [ "\n " ++ unqualifiedName k ++ " : " ++ hermitBindingSummary hbs | (k,hbs) <- Map.toList (hermitBindings c) ] freevars = [ "Free local identifiers: " ++ showVarSet (filterVarSet isLocalId fvs) @@ -63,11 +63,14 @@ typeId = case coreTC of Core (ExprCore e) -> let tyK = exprKindOrType e + modName i = case nameModule_maybe (getName i) of + Nothing -> "no module name." + Just m -> moduleNameString (moduleName m) in [(if isKind tyK then "Kind: " else "Type: ") ++ showPpr dynFlags tyK] ++ case e of Var i -> [ "" , "OccName: " ++ getOccString i - , if isLocalVar i then "Local" else "Global" + , if isLocalVar i then "Local" else "Global: " ++ modName i , "Unique: " ++ show (getUnique i) , "Identifier arity: " ++ show (arityOf c i) , "Identifier binding depth: " ++ runKureM show id (lookupHermitBindingDepth i c) @@ -151,14 +154,10 @@ TransCo{} -> "TransCo" NthCo{} -> "NthCo" InstCo{} -> "InstCo" -#if __GLASGOW_HASKELL__ > 706 AxiomRuleCo{} -> "AxiomRuleCo" LRCo{} -> "LRCo" SubCo{} -> "SubCo" UnivCo{} -> "UnivCo" -#else - UnsafeCo{} -> "UnsafeCo" -#endif -------------------------------------------------------- @@ -180,7 +179,8 @@ guardMsg (e1 `exprAlphaEq` e2) "bindings are not alpha-equivalent." -- | Compare the definitions of the two named identifiers for alpha-equality. -compareBoundIds :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => String -> String -> Transform c HermitM x () +compareBoundIds :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) + => HermitName -> HermitName -> Transform c HermitM x () compareBoundIds nm1 nm2 = do i1 <- findIdT nm1 i2 <- findIdT nm2 compareBoundIdsT i1 i2 diff --git a/src/HERMIT/Dictionary/Reasoning.hs b/src/HERMIT/Dictionary/Reasoning.hs --- a/src/HERMIT/Dictionary/Reasoning.hs +++ b/src/HERMIT/Dictionary/Reasoning.hs @@ -4,16 +4,19 @@ module HERMIT.Dictionary.Reasoning ( -- * Equational Reasoning externals - , CoreExprEquality(..) - , RewriteCoreExprEqualityBox(..) - , TransformCoreExprEqualityStringBox(..) - , CoreExprEqualityProof - , flipCoreExprEquality + , EqualityProof + , flipEquality , eqLhsIntroR , eqRhsIntroR , birewrite , extensionalityR - -- ** Lifting transformations over 'CoreExprEquality' + , getLemmasT + , getLemmaByNameT + , insertLemmaR + , lemmaR + , markLemmaUsedR + , modifyLemmaR + -- ** Lifting transformations over 'Equality' , lhsT , rhsT , bothT @@ -21,9 +24,9 @@ , lhsR , rhsR , bothR - , ppCoreExprEqualityT - , proveCoreExprEqualityT - , verifyCoreExprEqualityT + , ppEqualityT + , proveEqualityT + , verifyEqualityT , verifyEqualityLeftToRightT , verifyEqualityCommonTargetT , verifyIsomorphismT @@ -38,36 +41,34 @@ , discardUniVars ) where -import Control.Applicative -import Control.Arrow -import Control.Monad -import Control.Monad.IO.Class - -import Data.List (nubBy) -import Data.Maybe (fromMaybe) -import Data.Monoid -import Data.Typeable - -import HERMIT.Context -import HERMIT.Core -import HERMIT.External -import HERMIT.GHC -import HERMIT.Kure -import HERMIT.Monad -import HERMIT.ParserCore -#if __GLASGOW_HASKELL__ >= 708 -import HERMIT.ParserType -#endif -import HERMIT.Utilities +import Control.Applicative +import Control.Arrow +import Control.Monad +import Control.Monad.IO.Class -import HERMIT.Dictionary.AlphaConversion hiding (externals) -import HERMIT.Dictionary.Common -import HERMIT.Dictionary.Fold hiding (externals) -import HERMIT.Dictionary.GHC hiding (externals) -import HERMIT.Dictionary.Local.Let (nonRecIntroR) -import HERMIT.Dictionary.Unfold hiding (externals) +import qualified Data.Map as Map +import Data.List (nubBy) +import Data.Maybe (fromMaybe) +import Data.Monoid -import HERMIT.PrettyPrinter.Common +import HERMIT.Context +import HERMIT.Core +import HERMIT.External +import HERMIT.GHC +import HERMIT.Kure +import HERMIT.Monad +import HERMIT.Name +import HERMIT.ParserCore +import HERMIT.ParserType +import HERMIT.PrettyPrinter.Common +import HERMIT.Utilities + +import HERMIT.Dictionary.AlphaConversion hiding (externals) +import HERMIT.Dictionary.Common +import HERMIT.Dictionary.Fold hiding (externals) +import HERMIT.Dictionary.GHC hiding (externals) +import HERMIT.Dictionary.Local.Let (nonRecIntroR) +import HERMIT.Dictionary.Unfold hiding (externals) import qualified Text.PrettyPrint.MarkedHughesPJ as PP @@ -88,72 +89,91 @@ [ "Alpha-rename a universally quantified variable." ] , external "unshadow-equality" unshadowEqualityR [ "Unshadow an equality." ] + , external "lemma" (promoteExprBiR . lemmaR :: LemmaName -> BiRewriteH Core) + [ "Generate a bi-directional rewrite from a lemma." ] + , external "lemma-lhs-intro" (lemmaLhsIntroR :: LemmaName -> RewriteH Core) + [ "Introduce the LHS of a lemma as a non-recursive binding, in either an expression or a program." + , "body ==> let v = lhs in body" ] .+ Introduce .+ Shallow + , external "lemma-rhs-intro" (lemmaRhsIntroR :: LemmaName -> RewriteH Core) + [ "Introduce the RHS of a lemma as a non-recursive binding, in either an expression or a program." + , "body ==> let v = rhs in body" ] .+ Introduce .+ Shallow + , external "inst-lemma" (\ nm v cs -> modifyLemmaR nm id (instantiateEqualityVarR (cmpString2Var v) cs) id id :: RewriteH Core) + [ "Instantiate one of the universally quantified variables of the given lemma," + , "with the given Core expression, creating a new lemma. Instantiating an" + , "already proven lemma will result in the new lemma being considered proven." ] + , external "inst-lemma-dictionaries" (\ nm -> modifyLemmaR nm id instantiateDictsR id id :: RewriteH Core) + [ "Instantiate all of the universally quantified dictionaries of the given lemma." + , "Only works on dictionaries whose types are monomorphic (no free type variables)." ] + , external "copy-lemma" (\ nm newName -> modifyLemmaR nm (const newName) idR id id :: RewriteH Core) + [ "Copy a given lemma, with a new name." ] + , external "modify-lemma" (\ nm rr -> modifyLemmaR nm id rr (const False) (const False) :: RewriteH Core) + [ "Modify a given lemma. Resets the proven status to Not Proven and used status to Not Used." ] + , external "query-lemma" ((\ nm t -> getLemmaByNameT nm >>> arr lemmaEq >>> t) :: LemmaName -> TransformH Equality String -> TransformH Core String) + [ "Apply a transformation to a lemma, returning the result." ] + , external "extensionality" (extensionalityR . Just :: String -> RewriteH Equality) + [ "Given a name 'x, then" + , "f == g ==> forall x. f x == g x" ] + , external "extensionality" (extensionalityR Nothing :: RewriteH Equality) + [ "f == g ==> forall x. f x == g x" ] + , external "lhs" (lhsR . extractR :: RewriteH Core -> RewriteH Equality) + [ "Apply a rewrite to the LHS of an equality." ] + , external "lhs" (lhsT . extractT :: TransformH CoreTC String -> TransformH Equality String) + [ "Apply a transformation to the LHS of an equality." ] + , external "rhs" (rhsR . extractR :: RewriteH Core -> RewriteH Equality) + [ "Apply a rewrite to the RHS of an equality." ] + , external "rhs" (rhsT . extractT :: TransformH CoreTC String -> TransformH Equality String) + [ "Apply a transformation to the RHS of an equality." ] + , external "both" (bothR . extractR :: RewriteH Core -> RewriteH Equality) + [ "Apply a rewrite to both sides of an equality, succeeding if either succeed." ] + , external "both" ((\t -> liftM (\(r,s) -> unlines [r,s]) (bothT (extractT t))) :: TransformH CoreTC String -> TransformH Equality String) + [ "Apply a transformation to the RHS of an equality." ] ] ------------------------------------------------------------------------------ --- | An equality is represented as a set of universally quantified binders, and then the LHS and RHS of the equality. -data CoreExprEquality = CoreExprEquality [CoreBndr] CoreExpr CoreExpr - -data RewriteCoreExprEqualityBox = - RewriteCoreExprEqualityBox (RewriteH CoreExprEquality) deriving Typeable - -instance Extern (RewriteH CoreExprEquality) where - type Box (RewriteH CoreExprEquality) = RewriteCoreExprEqualityBox - box = RewriteCoreExprEqualityBox - unbox (RewriteCoreExprEqualityBox r) = r - -data TransformCoreExprEqualityStringBox = - TransformCoreExprEqualityStringBox (TransformH CoreExprEquality String) deriving Typeable - -instance Extern (TransformH CoreExprEquality String) where - type Box (TransformH CoreExprEquality String) = TransformCoreExprEqualityStringBox - box = TransformCoreExprEqualityStringBox - unbox (TransformCoreExprEqualityStringBox t) = t - -type CoreExprEqualityProof c m = (Rewrite c m CoreExpr, Rewrite c m CoreExpr) +type EqualityProof c m = (Rewrite c m CoreExpr, Rewrite c m CoreExpr) --- | Flip the LHS and RHS of a 'CoreExprEquality'. -flipCoreExprEquality :: CoreExprEquality -> CoreExprEquality -flipCoreExprEquality (CoreExprEquality xs lhs rhs) = CoreExprEquality xs rhs lhs +-- | Flip the LHS and RHS of a 'Equality'. +flipEquality :: Equality -> Equality +flipEquality (Equality xs lhs rhs) = Equality xs rhs lhs -- | f == g ==> forall x. f x == g x -extensionalityR :: Maybe String -> Rewrite c HermitM CoreExprEquality +extensionalityR :: Maybe String -> Rewrite c HermitM Equality extensionalityR mn = prefixFailMsg "extensionality failed: " $ - do CoreExprEquality vs lhs rhs <- idR + do Equality vs lhs rhs <- idR let tyL = exprKindOrType lhs tyR = exprKindOrType rhs guardMsg (tyL `typeAlphaEq` tyR) "type mismatch between sides of equality. This shouldn't happen, so is probably a bug." -- TODO: use the fresh-name-generator in AlphaConversion to avoid shadowing. - (argTy,_) <- splitFunTypeM tyL + (_,argTy,_) <- splitFunTypeM tyL v <- constT $ newVarH (fromMaybe "x" mn) argTy let x = varToCoreExpr v - return $ CoreExprEquality (vs ++ [v]) - (mkCoreApp lhs x) - (mkCoreApp rhs x) + return $ Equality (vs ++ [v]) (mkCoreApp lhs x) (mkCoreApp rhs x) ------------------------------------------------------------------------------ -- | @e@ ==> @let v = lhs in e@ -eqLhsIntroR :: CoreExprEquality -> Rewrite c HermitM Core -eqLhsIntroR (CoreExprEquality bs lhs _) = nonRecIntroR "lhs" (mkCoreLams bs lhs) +eqLhsIntroR :: Equality -> Rewrite c HermitM Core +eqLhsIntroR (Equality bs lhs _) = nonRecIntroR "lhs" (mkCoreLams bs lhs) -- | @e@ ==> @let v = rhs in e@ -eqRhsIntroR :: CoreExprEquality -> Rewrite c HermitM Core -eqRhsIntroR (CoreExprEquality bs _ rhs) = nonRecIntroR "rhs" (mkCoreLams bs rhs) +eqRhsIntroR :: Equality -> Rewrite c HermitM Core +eqRhsIntroR (Equality bs _ rhs) = nonRecIntroR "rhs" (mkCoreLams bs rhs) ------------------------------------------------------------------------------ --- | Create a 'BiRewrite' from a 'CoreExprEquality'. +-- | Create a 'BiRewrite' from a 'Equality'. -- -- The high level idea: create a temporary function with two definitions. -- Fold one of the defintions, then immediately unfold the other. -birewrite :: (AddBindings c, ReadBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c) => CoreExprEquality -> BiRewrite c HermitM CoreExpr -birewrite (CoreExprEquality bnds l r) = bidirectional (foldUnfold l r) (foldUnfold r l) +birewrite :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c + , ReadPath c Crumb, MonadCatch m, MonadUnique m ) + => Equality -> BiRewrite c m CoreExpr +birewrite (Equality bnds l r) = bidirectional (foldUnfold l r) (foldUnfold r l) where foldUnfold lhs rhs = transform $ \ c e -> do let lhsLam = mkCoreLams bnds lhs -- we use a unique, transitory variable for the 'function' we are folding @@ -163,46 +183,46 @@ -- create a temporary context with an unfolding for the -- transitory function so we can reuse unfoldR. c' = addHermitBindings [(v, NONREC rhsLam, mempty)] c - apply unfoldR c' e' + applyT unfoldR c' e' --- | Lift a transformation over 'CoreExpr' into a transformation over the left-hand side of a 'CoreExprEquality'. -lhsT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m CoreExprEquality b -lhsT t = idR >>= \ (CoreExprEquality vs lhs _) -> return lhs >>> withVarsInScope vs t +-- | Lift a transformation over 'CoreExpr' into a transformation over the left-hand side of a 'Equality'. +lhsT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m Equality b +lhsT t = idR >>= \ (Equality vs lhs _) -> return lhs >>> withVarsInScope vs t --- | Lift a transformation over 'CoreExpr' into a transformation over the right-hand side of a 'CoreExprEquality'. -rhsT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m CoreExprEquality b -rhsT t = idR >>= \ (CoreExprEquality vs _ rhs) -> return rhs >>> withVarsInScope vs t +-- | Lift a transformation over 'CoreExpr' into a transformation over the right-hand side of a 'Equality'. +rhsT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m Equality b +rhsT t = idR >>= \ (Equality vs _ rhs) -> return rhs >>> withVarsInScope vs t --- | Lift a transformation over 'CoreExpr' into a transformation over both sides of a 'CoreExprEquality'. -bothT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m CoreExprEquality (b,b) +-- | Lift a transformation over 'CoreExpr' into a transformation over both sides of a 'Equality'. +bothT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m Equality (b,b) bothT t = liftM2 (,) (lhsT t) (rhsT t) -- Can't wait for Applicative to be a superclass of Monad --- | Lift a transformation over '[Var]' into a transformation over the universally quantified variables of a 'CoreExprEquality'. -forallVarsT :: Monad m => Transform c m [Var] b -> Transform c m CoreExprEquality b -forallVarsT t = idR >>= \ (CoreExprEquality vs _ _) -> return vs >>> t +-- | Lift a transformation over '[Var]' into a transformation over the universally quantified variables of a 'Equality'. +forallVarsT :: Monad m => Transform c m [Var] b -> Transform c m Equality b +forallVarsT t = idR >>= \ (Equality vs _ _) -> return vs >>> t --- | Lift a rewrite over 'CoreExpr' into a rewrite over the left-hand side of a 'CoreExprEquality'. -lhsR :: (AddBindings c, Monad m, ReadPath c Crumb) => Rewrite c m CoreExpr -> Rewrite c m CoreExprEquality +-- | Lift a rewrite over 'CoreExpr' into a rewrite over the left-hand side of a 'Equality'. +lhsR :: (AddBindings c, Monad m, ReadPath c Crumb) => Rewrite c m CoreExpr -> Rewrite c m Equality lhsR r = do - CoreExprEquality vs lhs rhs <- idR + Equality vs lhs rhs <- idR lhs' <- withVarsInScope vs r <<< return lhs - return $ CoreExprEquality vs lhs' rhs + return $ Equality vs lhs' rhs --- | Lift a rewrite over 'CoreExpr' into a rewrite over the right-hand side of a 'CoreExprEquality'. -rhsR :: (AddBindings c, Monad m, ReadPath c Crumb) => Rewrite c m CoreExpr -> Rewrite c m CoreExprEquality +-- | Lift a rewrite over 'CoreExpr' into a rewrite over the right-hand side of a 'Equality'. +rhsR :: (AddBindings c, Monad m, ReadPath c Crumb) => Rewrite c m CoreExpr -> Rewrite c m Equality rhsR r = do - CoreExprEquality vs lhs rhs <- idR + Equality vs lhs rhs <- idR rhs' <- withVarsInScope vs r <<< return rhs - return $ CoreExprEquality vs lhs rhs' + return $ Equality vs lhs rhs' --- | Lift a rewrite over 'CoreExpr' into a rewrite over both sides of a 'CoreExprEquality'. -bothR :: (AddBindings c, MonadCatch m, ReadPath c Crumb) => Rewrite c m CoreExpr -> Rewrite c m CoreExprEquality +-- | Lift a rewrite over 'CoreExpr' into a rewrite over both sides of a 'Equality'. +bothR :: (AddBindings c, MonadCatch m, ReadPath c Crumb) => Rewrite c m CoreExpr -> Rewrite c m Equality bothR r = lhsR r >+> rhsR r ------------------------------------------------------------------------------ -ppCoreExprEqualityT :: PrettyPrinter -> TransformH CoreExprEquality DocH -ppCoreExprEqualityT pp = do +ppEqualityT :: PrettyPrinter -> TransformH Equality DocH +ppEqualityT pp = do let pos = pOptions pp d1 <- forallVarsT (liftPrettyH pos $ pForall pp) (d2,d3) <- bothT (liftPrettyH pos $ extractT $ pCoreTC pp) @@ -219,30 +239,30 @@ -- -- TODO: need to know type of 'x' to generate a variable. class BuildEquality a where - mkEquality :: a -> HermitM CoreExprEquality + mkEquality :: a -> HermitM Equality instance BuildEquality (CoreExpr,CoreExpr) where - mkEquality :: (CoreExpr,CoreExpr) -> HermitM CoreExprEquality - mkEquality (lhs,rhs) = return $ CoreExprEquality [] lhs rhs + mkEquality :: (CoreExpr,CoreExpr) -> HermitM Equality + mkEquality (lhs,rhs) = return $ Equality [] lhs rhs instance BuildEquality a => BuildEquality (CoreExpr -> a) where - mkEquality :: (CoreExpr -> a) -> HermitM CoreExprEquality + mkEquality :: (CoreExpr -> a) -> HermitM Equality mkEquality f = do x <- newIdH "x" (error "need to create a type") - CoreExprEquality bnds lhs rhs <- mkEquality (f (varToCoreExpr x)) - return $ CoreExprEquality (x:bnds) lhs rhs + Equality bnds lhs rhs <- mkEquality (f (varToCoreExpr x)) + return $ Equality (x:bnds) lhs rhs ------------------------------------------------------------------------------ --- | Verify that a 'CoreExprEquality' holds, by applying a rewrite to each side, and checking that the results are equal. -proveCoreExprEqualityT :: forall c m. (AddBindings c, Monad m, ReadPath c Crumb) - => CoreExprEqualityProof c m -> Transform c m CoreExprEquality () -proveCoreExprEqualityT (l,r) = lhsR l >>> rhsR r >>> verifyCoreExprEqualityT +-- | Verify that a 'Equality' holds, by applying a rewrite to each side, and checking that the results are equal. +proveEqualityT :: forall c m. (AddBindings c, Monad m, ReadPath c Crumb) + => EqualityProof c m -> Transform c m Equality () +proveEqualityT (l,r) = lhsR l >>> rhsR r >>> verifyEqualityT --- | Verify that the left- and right-hand sides of a 'CoreExprEquality' are alpha equivalent. -verifyCoreExprEqualityT :: Monad m => Transform c m CoreExprEquality () -verifyCoreExprEqualityT = do - CoreExprEquality _ lhs rhs <- idR +-- | Verify that the left- and right-hand sides of a 'Equality' are alpha equivalent. +verifyEqualityT :: Monad m => Transform c m Equality () +verifyEqualityT = do + Equality _ lhs rhs <- idR guardMsg (exprAlphaEq lhs rhs) "the two sides of the equality do not match." ------------------------------------------------------------------------------ @@ -257,7 +277,7 @@ guardMsg (exprAlphaEq targetExpr resultExpr) "result of running proof on lhs of equality does not match rhs of equality." -- | Given two expressions, and a rewrite to apply to each, verify that the resulting expressions are equal. -verifyEqualityCommonTargetT :: MonadCatch m => CoreExpr -> CoreExpr -> CoreExprEqualityProof c m -> Transform c m a () +verifyEqualityCommonTargetT :: MonadCatch m => CoreExpr -> CoreExpr -> EqualityProof c m -> Transform c m a () verifyEqualityCommonTargetT lhs rhs (l,r) = prefixFailMsg "equality verification failed: " $ do lhsResult <- l <<< return lhs @@ -317,16 +337,14 @@ ------------------------------------------------------------------------------ -- TODO: revisit this for binder re-ordering issue -instantiateDictsR :: RewriteH CoreExprEquality -#if __GLASGOW_HASKELL__ >= 708 +instantiateDictsR :: RewriteH Equality instantiateDictsR = prefixFailMsg "Dictionary instantiation failed: " $ do bs <- forallVarsT idR let dArgs = filter (\b -> isId b && isDictTy (varType b)) bs uniqDs = nubBy (\ b1 b2 -> eqType (varType b1) (varType b2)) dArgs guardMsg (not (null uniqDs)) "no universally quantified dictionaries can be instantiated." ds <- forM uniqDs $ \ b -> constT $ do - guts <- getModGuts - (i,bnds) <- liftCoreM $ buildDictionary guts b + (i,bnds) <- buildDictionary b let dExpr = case bnds of [NonRec v e] | i == v -> e -- the common case that we would have gotten a single non-recursive let _ -> mkCoreLets bnds (varToCoreExpr i) @@ -344,15 +362,12 @@ then return $ lookup3 b ds else buildSubst b contextfreeT $ instantiateEquality allDs -#else -instantiateDictsR = fail "Dictionaries cannot be instantiated in GHC 7.6" -#endif ------------------------------------------------------------------------------ -alphaEqualityR :: (Var -> Bool) -> (String -> String) -> RewriteH CoreExprEquality +alphaEqualityR :: (Var -> Bool) -> (String -> String) -> RewriteH Equality alphaEqualityR p f = prefixFailMsg "Alpha-renaming binder in equality failed: " $ do - CoreExprEquality bs lhs rhs <- idR + Equality bs lhs rhs <- idR guardMsg (any p bs) "specified variable is not universally quantified." let (bs',i:vs) = break p bs -- this is safe because we know i is in bs @@ -363,11 +378,11 @@ (subst', vs') = substBndrs subst vs lhs' = substExpr (text "coreExprEquality-lhs") subst' lhs rhs' = substExpr (text "coreExprEquality-rhs") subst' rhs - return $ CoreExprEquality (bs'++(i':vs')) lhs' rhs' + return $ Equality (bs'++(i':vs')) lhs' rhs' -unshadowEqualityR :: RewriteH CoreExprEquality +unshadowEqualityR :: RewriteH Equality unshadowEqualityR = prefixFailMsg "Unshadowing equality failed: " $ do - c@(CoreExprEquality bs _ _) <- idR + c@(Equality bs _ _) <- idR bvs <- boundVarsT let visible = unionVarSets [bvs , freeVarsEquality c] ss <- varSetElems <$> detectShadowsM bs visible @@ -375,39 +390,35 @@ let f = freshNameGenAvoiding Nothing . extendVarSet visible andR [ alphaEqualityR (==s) (f s) | s <- reverse ss ] >>> bothR (tryR unshadowExprR) -freeVarsEquality :: CoreExprEquality -> VarSet -freeVarsEquality (CoreExprEquality bs lhs rhs) = +freeVarsEquality :: Equality -> VarSet +freeVarsEquality (Equality bs lhs rhs) = delVarSetList (unionVarSets (map freeVarsExpr [lhs,rhs])) bs ------------------------------------------------------------------------------ -instantiateEqualityVarR :: (Var -> Bool) -> CoreString -> RewriteH CoreExprEquality +instantiateEqualityVarR :: (Var -> Bool) -> CoreString -> RewriteH Equality instantiateEqualityVarR p cs = prefixFailMsg "instantiation failed: " $ do bs <- forallVarsT idR (e,new) <- case filter p bs of [] -> fail "no universally quantified variables match predicate." (b:_) | isId b -> let (before,_) = break (==b) bs in liftM (,[]) $ withVarsInScope before $ parseCoreExprT cs -#if __GLASGOW_HASKELL__ >= 708 | otherwise -> do let (before,_) = break (==b) bs (ty, tvs) <- withVarsInScope before $ parseTypeWithHolesT cs return (Type ty, tvs) -#else - | otherwise -> fail "cannot instantiate type binders in GHC 7.6" -#endif eq <- contextfreeT $ instantiateEqualityVar p e new (_,_) <- return eq >>> bothT lintExprT -- sanity check return eq --- | Instantiate one of the universally quantified variables in a 'CoreExprEquality'. +-- | Instantiate one of the universally quantified variables in a 'Equality'. -- Note: assumes implicit ordering of variables, such that substitution happens to the right -- as it does in case alternatives. Only first variable that matches predicate is -- instantiated. instantiateEqualityVar :: MonadIO m => (Var -> Bool) -- predicate to select var -> CoreExpr -- expression to instantiate with -> [Var] -- new binders to add in place of var - -> CoreExprEquality -> m CoreExprEquality -instantiateEqualityVar p e new (CoreExprEquality bs lhs rhs) + -> Equality -> m Equality +instantiateEqualityVar p e new (Equality bs lhs rhs) | not (any p bs) = fail "specified variable is not universally quantified." | otherwise = do let (bs',i:vs) = break p bs -- this is safe because we know i is in bs @@ -427,21 +438,68 @@ let inS = delVarSetList (unionVarSets (map localFreeVarsExpr [lhs, rhs, e] ++ map freeVarsVar vs)) (i:vs) subst = extendSubst (mkEmptySubst (mkInScopeSet inS)) i e (subst', vs') = substBndrs subst vs - lhs' = substExpr (text "coreExprEquality-lhs") subst' lhs - rhs' = substExpr (text "coreExprEquality-rhs") subst' rhs - instantiateEquality (noAdds tvs) $ CoreExprEquality (bs'++new++vs') lhs' rhs' + lhs' = substExpr (text "equality-lhs") subst' lhs + rhs' = substExpr (text "equality-rhs") subst' rhs + instantiateEquality (noAdds tvs) $ Equality (bs'++new++vs') lhs' rhs' noAdds :: [(Var,CoreExpr)] -> [(Var,CoreExpr,[Var])] noAdds ps = [ (v,e,[]) | (v,e) <- ps ] --- | Instantiate a set of universally quantified variables in a 'CoreExprEquality'. +-- | Instantiate a set of universally quantified variables in a 'Equality'. -- It is important that all type variables appear before any value-level variables in the first argument. -instantiateEquality :: MonadIO m => [(Var,CoreExpr,[Var])] -> CoreExprEquality -> m CoreExprEquality +instantiateEquality :: MonadIO m => [(Var,CoreExpr,[Var])] -> Equality -> m Equality instantiateEquality = flip (foldM (\ eq (v,e,vs) -> instantiateEqualityVar (==v) e vs eq)) . reverse -- foldM is a left-to-right fold, so the reverse is important to do substitutions in reverse order -- which is what we want (all value variables should be instantiated before type variables). ------------------------------------------------------------------------------ -discardUniVars :: CoreExprEquality -> CoreExprEquality -discardUniVars (CoreExprEquality _ lhs rhs) = CoreExprEquality [] lhs rhs +discardUniVars :: Equality -> Equality +discardUniVars (Equality _ lhs rhs) = Equality [] lhs rhs + +------------------------------------------------------------------------------ + +getLemmasT :: HasLemmas m => Transform c m x Lemmas +getLemmasT = constT getLemmas + +getLemmaByNameT :: (HasLemmas m, Monad m) => LemmaName -> Transform c m x Lemma +getLemmaByNameT nm = getLemmasT >>= maybe (fail $ "No lemma named: " ++ show nm) return . Map.lookup nm + +lemmaR :: LemmaName -> BiRewriteH CoreExpr +lemmaR nm = afterBiR (beforeBiR (getLemmaByNameT nm) (birewrite . lemmaEq)) (markLemmaUsedR nm) + +------------------------------------------------------------------------------ + +-- We use sideEffectR because only rewrites generate new state in the Kernel. + +insertLemmaR :: (HasLemmas m, Monad m) => LemmaName -> Lemma -> Rewrite c m a +insertLemmaR nm l = sideEffectR $ \ _ _ -> insertLemma nm l + +modifyLemmaR :: (HasLemmas m, Monad m) + => LemmaName + -> (LemmaName -> LemmaName) -- ^ modify lemma name + -> Rewrite c m Equality -- ^ rewrite the equality + -> (Bool -> Bool) -- ^ modify proven status + -> (Bool -> Bool) -- ^ modify used status + -> Rewrite c m a +modifyLemmaR nm nFn rr pFn uFn = do + Lemma eq p u <- getLemmaByNameT nm + eq' <- rr <<< return eq + sideEffectR $ \ _ _ -> insertLemma (nFn nm) $ Lemma eq' (pFn p) (uFn u) + +markLemmaUsedR :: (HasLemmas m, Monad m) => LemmaName -> Rewrite c m a +markLemmaUsedR nm = modifyLemmaR nm id idR id (const True) + +------------------------------------------------------------------------------ + +lemmaNameToEqualityT :: (HasLemmas m, Monad m) => LemmaName -> Transform c m x Equality +lemmaNameToEqualityT nm = liftM lemmaEq $ getLemmaByNameT nm + +-- | @e@ ==> @let v = lhs in e@ (also works in a similar manner at Program nodes) +lemmaLhsIntroR :: LemmaName -> RewriteH Core +lemmaLhsIntroR = lemmaNameToEqualityT >=> eqLhsIntroR + +-- | @e@ ==> @let v = rhs in e@ (also works in a similar manner at Program nodes) +lemmaRhsIntroR :: LemmaName -> RewriteH Core +lemmaRhsIntroR = lemmaNameToEqualityT >=> eqRhsIntroR + diff --git a/src/HERMIT/Dictionary/Rules.hs b/src/HERMIT/Dictionary/Rules.hs --- a/src/HERMIT/Dictionary/Rules.hs +++ b/src/HERMIT/Dictionary/Rules.hs @@ -1,33 +1,31 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TypeFamilies #-} module HERMIT.Dictionary.Rules - ( -- * GHC Rewrite Rules and Specialisation - externals - -- ** Rules - , RuleNameString - , ruleR - , rulesR - , ruleToEqualityT - , ruleNameToEqualityT - , getHermitRuleT - , getHermitRulesT - -- , verifyCoreRuleT - -- , verifyRuleT - -- , ruleLhsIntroR - -- , ruleRhsIntroR - -- ** Specialisation - , specConstrR - ) -where + ( -- * GHC Rewrite Rules and Specialisation + externals + -- ** Rules + , RuleName(..) + , RuleNameListBox(..) + , ruleR + , rulesR + , ruleToEqualityT + , ruleNameToEqualityT + , getHermitRuleT + , getHermitRulesT + -- ** Specialisation + , specConstrR + , specialiseR + ) where -import IOEnv hiding (liftIO) import qualified SpecConstr import qualified Specialise import Control.Arrow import Control.Monad +import Data.Dynamic (Typeable) import Data.Function (on) import Data.List (deleteFirstsBy,intercalate) +import Data.String (IsString(..)) import HERMIT.Core import HERMIT.Context @@ -36,166 +34,117 @@ import HERMIT.External import HERMIT.GHC -import HERMIT.Dictionary.Common (inScope,callT) import HERMIT.Dictionary.GHC (dynFlagsT) --- import HERMIT.Dictionary.Induction import HERMIT.Dictionary.Kure (anyCallR) import HERMIT.Dictionary.Reasoning hiding (externals) -import HERMIT.Dictionary.Unfold (cleanupUnfoldR) +import HERMIT.Dictionary.Unfold (betaReducePlusR) +import IOEnv hiding (liftIO) + ------------------------------------------------------------------------ --- | Externals that reflect GHC functions, or are derived from GHC functions. +-- | Externals dealing with GHC rewrite rules. externals :: [External] externals = - [ external "rules-help-list" (rulesHelpListT :: TransformH CoreTC String) - [ "List all the rules in scope." ] .+ Query - , external "rule-help" (ruleHelpT :: RuleNameString -> TransformH CoreTC String) - [ "Display details on the named rule." ] .+ Query - , external "apply-rule" (promoteExprR . ruleR :: RuleNameString -> RewriteH Core) - [ "Apply a named GHC rule" ] .+ Shallow - , external "apply-rules" (promoteExprR . rulesR :: [RuleNameString] -> RewriteH Core) - [ "Apply named GHC rules, succeed if any of the rules succeed" ] .+ Shallow - , external "add-rule" ((\ rule_name id_name -> promoteModGutsR (addCoreBindAsRule rule_name id_name)) :: String -> String -> RewriteH Core) - [ "add-rule \"rule-name\" -- adds a new rule that freezes the right hand side of the "] .+ Introduce - , external "unfold-rule" ((\ nm -> promoteExprR (ruleR nm >>> cleanupUnfoldR)) :: String -> RewriteH Core) - [ "Unfold a named GHC rule" ] .+ Deep .+ Context .+ TODO -- TODO: does not work with rules with no arguments - , external "spec-constr" (promoteModGutsR specConstrR :: RewriteH Core) - [ "Run GHC's SpecConstr pass, which performs call pattern specialization."] .+ Deep - , external "specialise" (promoteModGutsR specialise :: RewriteH Core) - [ "Run GHC's specialisation pass, which performs type and dictionary specialisation."] .+ Deep - ] + [ external "rule-help" (rulesHelpListT :: TransformH CoreTC String) + [ "List all the rules in scope." ] .+ Query + , external "rule-help" (ruleHelpT :: RuleName -> TransformH CoreTC String) + [ "Display details on the named rule." ] .+ Query + , external "apply-rule" (promoteExprR . ruleR :: RuleName -> RewriteH Core) + [ "Apply a named GHC rule" ] .+ Shallow + , external "apply-rules" (promoteExprR . rulesR :: [RuleName] -> RewriteH Core) + [ "Apply named GHC rules, succeed if any of the rules succeed" ] .+ Shallow + , external "unfold-rule" ((\ nm -> promoteExprR (ruleR nm >>> tryR betaReducePlusR)) :: RuleName -> RewriteH Core) + [ "Unfold a named GHC rule" ] .+ Deep .+ Context .+ TODO -- TODO: does not work with rules with no arguments + , external "rule-to-lemma" (\nm -> do eq <- ruleNameToEqualityT nm + insertLemmaR (fromString (show nm)) $ Lemma eq False False :: RewriteH Core) + [ "Create a lemma from a GHC RULE." ] + , external "spec-constr" (promoteModGutsR specConstrR :: RewriteH Core) + [ "Run GHC's SpecConstr pass, which performs call pattern specialization."] .+ Deep + , external "specialise" (promoteModGutsR specialiseR :: RewriteH Core) + [ "Run GHC's specialisation pass, which performs type and dictionary specialisation."] .+ Deep + ] ------------------------------------------------------------------------ -{- -lookupRule :: (Activation -> Bool) -- When rule is active - -> IdUnfoldingFun -- When Id can be unfolded - -> InScopeSet - -> Id -> [CoreExpr] - -> [CoreRule] -> Maybe (CoreRule, CoreExpr) - -GHC HEAD: -type InScopeEnv = (InScopeSet, IdUnfoldingFun) +newtype RuleName = RuleName String deriving (Eq, Typeable) -lookupRule :: DynFlags -> InScopeEnv - -> (Activation -> Bool) -- When rule is active - -> Id -> [CoreExpr] - -> [CoreRule] -> Maybe (CoreRule, CoreExpr) --} +instance Extern RuleName where + type Box RuleName = RuleName + box = id + unbox = id --- Neil: Commented this out as it's not (currently) used. --- rulesToEnv :: [CoreRule] -> Map.Map String (Rewrite c m CoreExpr) --- rulesToEnv rs = Map.fromList --- [ ( unpackFS (ruleName r), rulesToRewrite c m [r] ) --- | r <- rs --- ] +instance IsString RuleName where fromString = RuleName +instance Show RuleName where show (RuleName s) = s -type RuleNameString = String +newtype RuleNameListBox = RuleNameListBox [RuleName] deriving Typeable --- TODO: deprecate this (and related functions) in favor of 'biRuleUnsafeR' -#if __GLASGOW_HASKELL__ > 706 -rulesToRewriteH :: (ReadBindings c, HasDynFlags m, MonadCatch m) => [CoreRule] -> Rewrite c m CoreExpr -#else -rulesToRewriteH :: (ReadBindings c, MonadCatch m) => [CoreRule] -> Rewrite c m CoreExpr -#endif -rulesToRewriteH rs = prefixFailMsg "RulesToRewrite failed: " $ - withPatFailMsg "rule not matched." $ do - (Var fn, args) <- callT - transform $ \ c e -> do - let in_scope = mkInScopeSet (mkVarEnv [ (v,v) | v <- varSetElems (localFreeVarsExpr e) ]) -#if __GLASGOW_HASKELL__ > 706 - dflags <- getDynFlags - case lookupRule dflags (in_scope, const NoUnfolding) (const True) fn args [r | r <- rs, ru_fn r == idName fn] of -#else - case lookupRule (const True) (const NoUnfolding) in_scope fn args [r | r <- rs, ru_fn r == idName fn] of -#endif - Nothing -> fail "rule not matched" - Just (r, expr) -> do - let e' = mkApps expr (drop (ruleArity r) args) - if all (inScope c) $ varSetElems $ localFreeVarsExpr e' -- TODO: The problem with this check, is that it precludes the case where this is an intermediate transformation. I can imagine situations where some variables would be out-of-scope at this point, but in scope again after a subsequent transformation. - then return e' - else fail $ unlines ["Resulting expression after rule application contains variables that are not in scope." - ,"This can probably be solved by running the flatten-module command at the top level."] +instance Extern [RuleName] where + type Box [RuleName] = RuleNameListBox + box = RuleNameListBox + unbox (RuleNameListBox l) = l --- | Lookup a rule and attempt to construct a corresponding rewrite. -ruleR :: (ReadBindings c, HasCoreRules c) => RuleNameString -> Rewrite c HermitM CoreExpr -ruleR r = do - theRules <- getHermitRulesT - case lookup r theRules of - Nothing -> fail $ "failed to find rule: " ++ show r ++ ". If you think the rule exists, try running the flatten-module command at the top level." - Just rr -> rulesToRewriteH [rr] +-- | Lookup a rule by name, attempt to apply it. If successful, record it as an unproven lemma. +ruleR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) + => RuleName -> Rewrite c m CoreExpr +ruleR nm = do + eq <- ruleNameToEqualityT nm + forwardT (birewrite eq) >>> sideEffectR (\ _ _ -> addLemma (fromString (show nm)) $ Lemma eq False True) -rulesR :: (ReadBindings c, HasCoreRules c) => [RuleNameString] -> Rewrite c HermitM CoreExpr +rulesR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) + => [RuleName] -> Rewrite c m CoreExpr rulesR = orR . map ruleR --- | Return all the RULES (including specialization RULES on binders) currently in scope. -getHermitRulesT :: HasCoreRules c => Transform c HermitM a [(RuleNameString, CoreRule)] +-- | Return all in-scope CoreRules (including specialization RULES on binders), with their names. +getHermitRulesT :: (HasCoreRules c, HasHermitMEnv m, LiftCoreM m, MonadIO m) => Transform c m a [(RuleName, CoreRule)] getHermitRulesT = contextonlyT $ \ c -> do rb <- liftCoreM getRuleBase mgRules <- liftM mg_rules getModGuts hscEnv <- liftCoreM getHscEnv rb' <- liftM eps_rule_base $ liftIO $ runIOEnv () $ readMutVar (hsc_EPS hscEnv) - return [ (unpackFS (ruleName r), r) - | r <- hermitCoreRules c ++ mgRules ++ concat (nameEnvElts rb) ++ concat (nameEnvElts rb') - ] + let allRules = hermitCoreRules c ++ mgRules ++ concat (nameEnvElts rb) ++ concat (nameEnvElts rb') + return [ (fromString (unpackFS (ruleName r)), r) | r <- allRules ] -getHermitRuleT :: HasCoreRules c => RuleNameString -> Transform c HermitM a CoreRule +-- | Get a GHC CoreRule by name. +getHermitRuleT :: (HasCoreRules c, HasHermitMEnv m, LiftCoreM m, MonadIO m) => RuleName -> Transform c m a CoreRule getHermitRuleT name = do rulesEnv <- getHermitRulesT case filter ((name ==) . fst) rulesEnv of - [] -> fail ("Rule \"" ++ name ++ "\" not found.") + [] -> fail $ "failed to find rule: " ++ show name ++ ". If you think the rule exists, " + ++ "try running the flatten-module command at the top level." [(_,r)] -> return r - _ -> fail ("Rule name \"" ++ name ++ "\" is ambiguous.") + _ -> fail ("Rule name \"" ++ show name ++ "\" is ambiguous.") -rulesHelpListT :: HasCoreRules c => Transform c HermitM a String +-- | List names of all CoreRules in scope. +rulesHelpListT :: (HasCoreRules c, HasHermitMEnv m, LiftCoreM m, MonadIO m) => Transform c m a String rulesHelpListT = do rulesEnv <- getHermitRulesT - return (intercalate "\n" $ reverse $ map fst rulesEnv) - -ruleHelpT :: HasCoreRules c => RuleNameString -> Transform c HermitM a String -ruleHelpT name = showSDoc <$> dynFlagsT <*> ((pprRulesForUser . (:[])) <$> getHermitRuleT name) - --- Too much information. --- rulesHelpT :: HasCoreRules c => Transform c HermitM a String --- rulesHelpT = do --- rulesEnv <- getHermitRulesT --- dynFlags <- dynFlagsT --- return $ (show (map fst rulesEnv) ++ "\n") ++ --- showSDoc dynFlags (pprRulesForUser $ concatMap snd rulesEnv) + return (intercalate "\n" $ reverse $ map (show.fst) rulesEnv) -makeRule :: RuleNameString -> Id -> CoreExpr -> CoreRule -makeRule rule_name nm = mkRule True -- auto-generated - False -- local - (mkFastString rule_name) - NeverActive -- because we need to call for these - (varName nm) - [] - [] +-- | Print a named CoreRule using GHC's pretty printer for rewrite rules. +-- TODO: use our own Equality pretty printer. +ruleHelpT :: (HasCoreRules c, HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadIO m) + => RuleName -> Transform c m a String +ruleHelpT nm = do + r <- getHermitRuleT nm + dflags <- dynFlagsT + return $ showSDoc dflags $ pprRulesForUser [r] --- TODO: check if a top-level binding -addCoreBindAsRule :: Monad m => RuleNameString -> String -> Rewrite c m ModGuts -addCoreBindAsRule rule_name nm = contextfreeT $ \ modGuts -> - case [ (v,e) - | bnd <- mg_binds modGuts - , (v,e) <- bindToVarExprs bnd - , nm `cmpString2Var` v - ] of - [] -> fail $ "cannot find binding " ++ nm - [(v,e)] -> return $ modGuts { mg_rules = mg_rules modGuts - ++ [makeRule rule_name v e] - } - _ -> fail $ "found multiple bindings for " ++ nm +-- | Build an Equality from a named GHC rewrite rule. +ruleNameToEqualityT :: ( BoundVars c, HasCoreRules c, HasDynFlags m, HasHermitMEnv m + , LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m ) + => RuleName -> Transform c m a Equality +ruleNameToEqualityT name = getHermitRuleT name >>> ruleToEqualityT --- | Returns the universally quantified binders, the LHS, and the RHS. -ruleToEqualityT :: (BoundVars c, HasDynFlags m, HasModGuts m, MonadThings m, MonadCatch m) => Transform c m CoreRule CoreExprEquality +-- | Transform GHC's CoreRule into an Equality. +ruleToEqualityT :: (BoundVars c, HasDynFlags m, HasHermitMEnv m, MonadThings m, MonadCatch m) + => Transform c m CoreRule Equality ruleToEqualityT = withPatFailMsg "HERMIT cannot handle built-in rules yet." $ do r@Rule{} <- idR -- other possibility is "BuiltinRule" - f <- lookupId $ ru_fn r - return $ CoreExprEquality (ru_bndrs r) (mkCoreApps (Var f) (ru_args r)) (ru_rhs r) - -ruleNameToEqualityT :: (BoundVars c, HasCoreRules c) => RuleNameString -> Transform c HermitM a CoreExprEquality -ruleNameToEqualityT name = getHermitRuleT name >>> ruleToEqualityT + f <- lookupId $ ru_fn r + return $ Equality (ru_bndrs r) (mkCoreApps (Var f) (ru_args r)) (ru_rhs r) ------------------------------------------------------------------------ @@ -207,20 +156,20 @@ rs' <- return e' >>> extractT specRules let specRs = deleteFirstsBy ((==) `on` ru_name) rs' rs guardMsg (notNull specRs) "no rules created." - return e' >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewriteH specRs))) + let applyAllR = extractR + $ repeatR + $ anyCallR + $ promoteExprR + $ rulesToRewrite specRs + return e' >>> applyAllR -- | Run GHC's specialisation pass, and apply any rules generated. -specialise :: RewriteH ModGuts -specialise = prefixFailMsg "specialisation failed: " $ do +specialiseR :: RewriteH ModGuts +specialiseR = prefixFailMsg "specialisation failed: " $ do gRules <- arr mg_rules lRules <- extractT specRules -#if __GLASGOW_HASKELL__ <= 706 - dflags <- dynFlagsT - guts <- contextfreeT $ liftCoreM . Specialise.specProgram dflags -#else guts <- contextfreeT $ liftCoreM . Specialise.specProgram -#endif lRules' <- return guts >>> extractT specRules -- spec rules on bindings in this module let gRules' = mg_rules guts -- plus spec rules on imported bindings @@ -229,7 +178,7 @@ specRs = gSpecRs ++ lSpecRs guardMsg (notNull specRs) "no rules created." liftIO $ putStrLn $ unlines $ map (unpackFS . ru_name) specRs - return guts >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewriteH specRs))) + return guts >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewrite specRs))) -- | Get all the specialization rules on a binding. -- These are created by SpecConstr and other GHC passes. @@ -246,5 +195,13 @@ -- | Find all specialization rules in a Core fragment. specRules :: TransformH Core [CoreRule] specRules = crushtdT $ promoteBindT bindSpecRules + +-- | Turn a list of rules into a rewrite which succeeds on the first successful rule. +-- Note: this should only be used for built-in and compiler-generated rules which we assume +-- are correct, because it does not record a lemma obligation for the rules used. +rulesToRewrite :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , HasDynFlags m, HasHermitMEnv m, MonadCatch m, MonadThings m, MonadUnique m ) + => [CoreRule] -> Rewrite c m CoreExpr +rulesToRewrite rs = catchesM [ (return r >>> ruleToEqualityT) >>= forwardT . birewrite | r <- rs ] ------------------------------------------------------------------------ diff --git a/src/HERMIT/Dictionary/Undefined.hs b/src/HERMIT/Dictionary/Undefined.hs --- a/src/HERMIT/Dictionary/Undefined.hs +++ b/src/HERMIT/Dictionary/Undefined.hs @@ -3,6 +3,7 @@ ( -- * Working with Undefined Values -- | Note that many of these operations require 'GHC.Err.undefined' to be explicitly imported if it is not used in the source file. externals + , buildStrictnessLemmaT , verifyStrictT , mkUndefinedValT , isUndefinedValT @@ -18,12 +19,12 @@ , undefinedCaseR , undefinedCastR , undefinedTickR - ) -where + ) where -import Control.Monad ((>=>)) +import Control.Monad ((>=>), liftM) import Control.Monad.IO.Class import Data.Monoid +import Data.String (fromString) import HERMIT.Context import HERMIT.Core @@ -31,6 +32,7 @@ import HERMIT.GHC hiding ((<>)) import HERMIT.Kure import HERMIT.Monad +import HERMIT.Name import HERMIT.Dictionary.Common import HERMIT.Dictionary.GHC (substR) @@ -43,7 +45,7 @@ [ external "replace-current-expr-with-undefined" (promoteExprR replaceCurrentExprWithUndefinedR :: RewriteH Core) [ "Set the current expression to \"undefined\"." ] .+ Shallow .+ Context .+ Unsafe - , external "replace-id-with-undefined" (replaceIdWithUndefined :: String -> RewriteH Core) + , external "replace-id-with-undefined" (replaceIdWithUndefined :: HermitName -> RewriteH Core) [ "Replace the specified identifier with \"undefined\"." ] .+ Deep .+ Context .+ Unsafe , external "error-to-undefined" (promoteExprR errorToUndefinedR :: RewriteH Core) @@ -79,48 +81,46 @@ ------------------------------------------------------------------------ -undefinedLocation :: String -undefinedLocation = "GHC.Err.undefined" +undefinedLocation :: HermitName +undefinedLocation = fromString "GHC.Err.undefined" --- TODO: will crash if 'undefined' is not used (or explicitly imported) in the source file. -findUndefinedIdT :: (BoundVars c, MonadCatch m, HasModGuts m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id +findUndefinedIdT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id findUndefinedIdT = findIdT undefinedLocation -- | Check if the current expression is an undefined value. -isUndefinedValT :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m CoreExpr () +isUndefinedValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m CoreExpr () isUndefinedValT = prefixFailMsg "not an undefined value: " $ withPatFailMsg (wrongExprForm "App (Var undefined) (Type ty)") $ do App (Var un) (Type _) <- idR un' <- findUndefinedIdT - guardMsg (un == un') ("identifier is not " ++ undefinedLocation) + guardMsg (un == un') ("identifier is not " ++ show undefinedLocation) ------------------------------------------------------------------------ -errorLocation :: String -errorLocation = "GHC.Err.error" +errorLocation :: HermitName +errorLocation = fromString "GHC.Err.error" --- TODO: will crash if 'error' is not used (or explicitly imported) in the source file. -findErrorIdT :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id +findErrorIdT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id findErrorIdT = findIdT errorLocation -- | Check if the current expression is an undefined value. -isErrorValT :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m CoreExpr () +isErrorValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m CoreExpr () isErrorValT = prefixFailMsg "not an error value: " $ withPatFailMsg (wrongExprForm "App (App (Var error) (Type ty)) string") $ do App (App (Var er) (Type _)) _ <- idR er' <- findErrorIdT - guardMsg (er == er') ("identifier is not " ++ errorLocation) + guardMsg (er == er') ("identifier is not " ++ show errorLocation) ------------------------------------------------------------------------ -- | error ty string ==> undefined ty -errorToUndefinedR :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr +errorToUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr errorToUndefinedR = prefixFailMsg "error-to-undefined failed: " (isErrorValT >> replaceCurrentExprWithUndefinedR) ------------------------------------------------------------------------ -- | Make an undefined value of the given type. -mkUndefinedValT :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Type -> Transform c m a CoreExpr +mkUndefinedValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Type -> Transform c m a CoreExpr mkUndefinedValT ty = do un <- findUndefinedIdT return $ App (varToCoreExpr un) (Type ty) @@ -128,67 +128,67 @@ ------------------------------------------------------------------------------------------------------ -- | Set the current expression to 'undefined'. -replaceCurrentExprWithUndefinedR :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr +replaceCurrentExprWithUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr replaceCurrentExprWithUndefinedR = contextfreeT exprTypeM >>= mkUndefinedValT -- | Replace all occurrences of the specified identifier with 'undefined'. -replaceIdWithUndefinedR :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Id -> Rewrite c m Core +replaceIdWithUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Id -> Rewrite c m Core replaceIdWithUndefinedR i = mkUndefinedValT (idType i) >>= substR i -replaceIdWithUndefined :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => String -> Rewrite c m Core +replaceIdWithUndefined :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => HermitName -> Rewrite c m Core replaceIdWithUndefined = findIdT >=> replaceIdWithUndefinedR ------------------------------------------------------------------------------------------------------ -- | undefinedExprR = undefinedAppR <+ undefinedLamR <+ undefinedLetR <+ undefinedCastR <+ undefinedTickR <+ undefinedCaseR -undefinedExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr +undefinedExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedExprR = setFailMsg "undefined-expr failed." (undefinedAppR <+ undefinedLamR <+ undefinedLetR <+ undefinedCastR <+ undefinedTickR <+ undefinedCaseR) ------------------------------------------------------------------------------------------------------ -- | @(undefined ty1) e@ ==> @undefined ty2@ -undefinedAppR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr +undefinedAppR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedAppR = prefixFailMsg "undefined-app failed: " $ do appT isUndefinedValT successT (<>) replaceCurrentExprWithUndefinedR -- | @(\ v -> undefined ty1)@ ==> @undefined ty2@ (where v is not a 'TyVar') -undefinedLamR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr +undefinedLamR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedLamR = prefixFailMsg "undefined-lam failed: " $ do lamT successT isUndefinedValT (<>) replaceCurrentExprWithUndefinedR -- | let bds in (undefined ty) ==> undefined ty -undefinedLetR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr +undefinedLetR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedLetR = prefixFailMsg "undefined-let failed: " $ do letT successT isUndefinedValT (<>) replaceCurrentExprWithUndefinedR -- | Cast (undefined ty1) co ==> undefined ty2 -undefinedCastR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr +undefinedCastR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedCastR = prefixFailMsg "undefined-cast failed: " $ do castT isUndefinedValT successT (<>) replaceCurrentExprWithUndefinedR -- | Tick tick (undefined ty1) ==> undefined ty1 -undefinedTickR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr +undefinedTickR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedTickR = prefixFailMsg "undefined-tick failed: " $ do tickT successT isUndefinedValT (<>) replaceCurrentExprWithUndefinedR -- | undefinedCaseR = undefinedCaseScrutineeR <+ undefinedCaseAltsR -undefinedCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr +undefinedCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseR = setFailMsg "undefined-case failed" (undefinedCaseScrutineeR <+ undefinedCaseAltsR) -- | case (undefined ty) of alts ==> undefined ty -undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr +undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseScrutineeR = prefixFailMsg "undefined-case failed: " $ do caseT isUndefinedValT successT successT (const successT) (\ _ _ _ _ -> ()) replaceCurrentExprWithUndefinedR -- | case e of {pat_1 -> undefined ty ; pat_2 -> undefined ty ; ... ; pat_n -> undefined ty} ==> undefined ty -undefinedCaseAltsR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr +undefinedCaseAltsR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseAltsR = prefixFailMsg "undefined-case-alts failed: " $ do caseAltT successT successT successT (const (successT,const successT,isUndefinedValT)) (\ _ _ _ _ -> ()) replaceCurrentExprWithUndefinedR @@ -196,12 +196,30 @@ ------------------------------------------------------------------------ -- | Verify that the given rewrite is a proof that the given expression is a strict function. -verifyStrictT :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => CoreExpr -> Rewrite c m CoreExpr -> Transform c m a () +verifyStrictT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => CoreExpr -> Rewrite c m CoreExpr -> Transform c m a () verifyStrictT f r = prefixFailMsg "strictness verification failed: " $ - do (argTy, resTy) <- constT (funExprArgResTypes f) + do (_, argTy, resTy) <- constT (funExprArgResTypesM f) undefArg <- mkUndefinedValT argTy rhs <- mkUndefinedValT resTy let lhs = App f undefArg verifyEqualityLeftToRightT lhs rhs r + +-- | Apply the given expression to undefined, at the proper type. +applyToUndefinedT :: (BoundVars c, HasDynFlags m, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m) + => CoreExpr -> Transform c m x CoreExpr +applyToUndefinedT f = do + let (tvs, body) = collectTyBinders f + (_,dom,_) <- splitFunTypeM (exprType body) + undef <- mkUndefinedValT dom + return $ mkCoreLams tvs $ mkCoreApp body undef + +-- | Add a lemma for the strictness of a function. +-- Note: assumes added lemma has been used +buildStrictnessLemmaT :: (BoundVars c, HasDynFlags m, HasHscEnv m, HasHermitMEnv m, HasLemmas m, MonadCatch m, MonadIO m, MonadThings m) + => LemmaName -> CoreExpr -> Transform c m x () +buildStrictnessLemmaT nm f = do + (tvs, lhs) <- liftM collectTyBinders $ applyToUndefinedT f + rhs <- mkUndefinedValT (exprType lhs) + constT $ insertLemma nm $ Lemma (Equality tvs lhs rhs) False True ------------------------------------------------------------------------ diff --git a/src/HERMIT/Dictionary/Unfold.hs b/src/HERMIT/Dictionary/Unfold.hs --- a/src/HERMIT/Dictionary/Unfold.hs +++ b/src/HERMIT/Dictionary/Unfold.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TupleSections, LambdaCase #-} module HERMIT.Dictionary.Unfold ( externals - , cleanupUnfoldR + , betaReducePlusR , rememberR , showStashT , unfoldR @@ -22,15 +22,16 @@ import HERMIT.PrettyPrinter.Common (DocH, PrettyH, TransformDocH(..), PrettyC) import HERMIT.Dictionary.Common +import HERMIT.Dictionary.GHC (substCoreExpr) import HERMIT.Dictionary.Inline (inlineR) -import HERMIT.Dictionary.Local.Let (letNonRecSubstR) import HERMIT.Core import HERMIT.Context -import HERMIT.Kure -import HERMIT.Monad import HERMIT.External import HERMIT.GHC +import HERMIT.Kure +import HERMIT.Monad +import HERMIT.Name import Prelude hiding (exp) @@ -40,17 +41,17 @@ externals :: [External] externals = - [ external "cleanup-unfold" (promoteExprR cleanupUnfoldR :: RewriteH Core) - [ "Clean up immediately nested fully-applied lambdas, from the bottom up" ] .+ Deep - , external "remember" (rememberR :: Label -> RewriteH Core) + [ external "beta-reduce-plus" (promoteExprR betaReducePlusR :: RewriteH Core) + [ "Perform one or more beta-reductions."] .+ Eval .+ Shallow + , external "remember" (rememberR :: RememberedName -> RewriteH Core) [ "Remember the current binding, allowing it to be folded/unfolded in the future." ] .+ Context - , external "unfold-remembered" (promoteExprR . unfoldStashR :: String -> RewriteH Core) + , external "unfold-remembered" (promoteExprR . unfoldStashR :: RememberedName -> RewriteH Core) [ "Unfold a remembered definition." ] .+ Deep .+ Context , external "unfold" (promoteExprR unfoldR :: RewriteH Core) [ "In application f x y z, unfold f." ] .+ Deep .+ Context - , external "unfold" (promoteExprR . unfoldNameR :: String -> RewriteH Core) + , external "unfold" (promoteExprR . unfoldNameR . unOccurrenceName :: OccurrenceName -> RewriteH Core) [ "Inline a definition, and apply the arguments; traditional unfold." ] .+ Deep .+ Context - , external "unfold" (promoteExprR . unfoldNamesR :: [String] -> RewriteH Core) + , external "unfold" (promoteExprR . unfoldNamesR . map unOccurrenceName:: [OccurrenceName] -> RewriteH Core) [ "Unfold a definition if it is named in the list." ] .+ Deep .+ Context , external "unfold-saturated" (promoteExprR unfoldSaturatedR :: RewriteH Core) [ "Unfold a definition only if the function is fully applied." ] .+ Deep .+ Context @@ -62,44 +63,41 @@ ------------------------------------------------------------------------ --- | cleanupUnfoldR cleans a unfold operation --- (for example, an inline or rule application) --- It is used at the level of the top-redex. --- Invariant: will not introduce let bindings -cleanupUnfoldR :: (AddBindings c, ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoreExpr -cleanupUnfoldR = do - (f, args) <- callT <+ arr (,[]) - let (vs, body) = collectBinders f - lenargs = length args - lenvs = length vs - comp = compare lenargs lenvs - body' = case comp of - LT -> mkCoreLams (drop lenargs vs) body - _ -> body - bnds = zipWith NonRec vs args - body'' <- andR (replicate (length bnds) letNonRecSubstR) <<< return (mkCoreLets bnds body') - return $ case comp of - GT -> mkCoreApps body'' $ drop lenvs args - _ -> body'' +-- | Perform one or more beta reductions. +betaReducePlusR :: MonadCatch m => Rewrite c m CoreExpr +betaReducePlusR = prefixFailMsg "Multi-beta-reduction failed: " $ do + (f,args) <- callT + let (f',args',atLeastOne) = reduceAll f args False + reduceAll (Lam v body) (a:as) _ = reduceAll (substCoreExpr v a body) as True + reduceAll e as b = (e,as,b) + guardMsg atLeastOne "no beta reductions possible." + return $ mkCoreApps f' args' -- | A more powerful 'inline'. Matches two cases: -- Var ==> inlines -- App ==> inlines the head of the function call for the app tree -unfoldR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr -unfoldR = prefixFailMsg "unfold failed: " (go >>> cleanupUnfoldR) - where go :: Rewrite c HermitM CoreExpr +unfoldR :: forall c m. ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c + , ReadBindings c, ReadPath c Crumb, MonadCatch m ) + => Rewrite c m CoreExpr +unfoldR = prefixFailMsg "unfold failed: " (go >>> tryR betaReducePlusR) + where go :: Rewrite c m CoreExpr go = appAllR go idR <+ inlineR -- this order gives better error messages -unfoldPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => (Id -> [CoreExpr] -> Bool) -> Rewrite c HermitM CoreExpr +unfoldPredR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb + , MonadCatch m ) + => (Id -> [CoreExpr] -> Bool) -> Rewrite c m CoreExpr unfoldPredR p = callPredT p >> unfoldR -unfoldNameR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => String -> Rewrite c HermitM CoreExpr -unfoldNameR nm = prefixFailMsg ("unfold '" ++ nm ++ " failed: ") (callNameT nm >> unfoldR) +unfoldNameR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c + , MonadCatch m ) + => HermitName -> Rewrite c m CoreExpr +unfoldNameR nm = prefixFailMsg ("unfold '" ++ show nm ++ " failed: ") (callNameT nm >> unfoldR) -unfoldNamesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [String] -> Rewrite c HermitM CoreExpr +unfoldNamesR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c + , MonadCatch m ) + => [HermitName] -> Rewrite c m CoreExpr unfoldNamesR [] = fail "unfold-names failed: no names given." -unfoldNamesR nms = setFailMsg "unfold-names failed." $ - orR (map unfoldNameR nms) +unfoldNamesR nms = setFailMsg "unfold-names failed." $ orR (map unfoldNameR nms) unfoldSaturatedR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr unfoldSaturatedR = callSaturatedT >> unfoldR @@ -112,7 +110,7 @@ -- | Stash a binding with a name for later use. -- Allows us to look at past definitions. -rememberR :: Label -> Rewrite c HermitM Core +rememberR :: RememberedName -> Rewrite c HermitM Core rememberR label = sideEffectR $ \ _ -> \case DefCore def -> saveDef label def BindCore (NonRec i e) -> saveDef label (Def i e) @@ -128,7 +126,7 @@ -- _ -> fail "remember: not a binding" -- | Apply a stashed definition (like inline, but looks in stash instead of context). -unfoldStashR :: ReadBindings c => String -> Rewrite c HermitM CoreExpr +unfoldStashR :: ReadBindings c => RememberedName -> Rewrite c HermitM CoreExpr unfoldStashR label = prefixFailMsg "Inlining stashed definition failed: " $ withPatFailMsg (wrongExprForm "Var v") $ do (c, Var v) <- exposeT @@ -139,12 +137,12 @@ in if all (inScope c) fvars then return rhs else fail $ "free variables " ++ intercalate "," (map (showPpr dflags) (filter (not . inScope c) fvars)) ++ " in stashed definition are no longer in scope." - else fail $ "stashed definition applies to " ++ var2String i ++ " not " ++ var2String v + else fail $ "stashed definition applies to " ++ unqualifiedName i ++ " not " ++ unqualifiedName v showStashT :: Injection CoreDef a => PrettyC -> PrettyH a -> Transform c HermitM a DocH showStashT pctx pp = do stash <- constT getStash docs <- forM (Map.toList stash) $ \ (l,d) -> do - dfn <- constT $ apply (extractT pp) pctx d - return $ PP.text ("[ " ++ l ++ " ]") PP.$+$ dfn PP.$+$ PP.space + dfn <- constT $ applyT (extractT pp) pctx d + return $ PP.text ("[ " ++ show l ++ " ]") PP.$+$ dfn PP.$+$ PP.space return $ PP.vcat docs diff --git a/src/HERMIT/Dictionary/Unsafe.hs b/src/HERMIT/Dictionary/Unsafe.hs --- a/src/HERMIT/Dictionary/Unsafe.hs +++ b/src/HERMIT/Dictionary/Unsafe.hs @@ -20,10 +20,10 @@ externals :: [External] externals = map (.+ Unsafe) [ external "unsafe-replace" (promoteExprR . unsafeReplaceR :: CoreString -> RewriteH Core) - [ "replace the currently focused expression with a new expression" + [ "replace the currently focused expression with a new expression" , "DOES NOT ensure that free variables in the replacement expression are in scope" ] - , external "unsafe-replace" (promoteExprR . unsafeReplaceStashR :: String -> RewriteH Core) - [ "replace the currently focused expression with an expression from the stash" + , external "unsafe-replace" (promoteExprR . unsafeReplaceStashR :: RememberedName -> RewriteH Core) + [ "replace the currently focused expression with a remembered expression" , "DOES NOT ensure that free variables in the replacement expression are in scope" ] ] @@ -36,7 +36,7 @@ guardMsg (eqType (exprKindOrType e) (exprKindOrType e')) "expression types differ." return e' -unsafeReplaceStashR :: String -> RewriteH CoreExpr +unsafeReplaceStashR :: RememberedName -> RewriteH CoreExpr unsafeReplaceStashR label = prefixFailMsg "unsafe-replace failed: " $ contextfreeT $ \ e -> do Def _ rhs <- lookupDef label diff --git a/src/HERMIT/Dictionary/WorkerWrapper/Common.hs b/src/HERMIT/Dictionary/WorkerWrapper/Common.hs --- a/src/HERMIT/Dictionary/WorkerWrapper/Common.hs +++ b/src/HERMIT/Dictionary/WorkerWrapper/Common.hs @@ -1,12 +1,82 @@ -module HERMIT.Dictionary.WorkerWrapper.Common where +{-# LANGUAGE CPP, DeriveDataTypeable, TypeFamilies #-} +module HERMIT.Dictionary.WorkerWrapper.Common + ( externals + , WWAssumptionTag(..) + , WWAssumption(..) + , assumptionAEqualityT + , assumptionBEqualityT + , assumptionCEqualityT + , split1BetaR + , split2BetaR + , workLabel + ) where -import HERMIT.Monad -import HERMIT.Kure +import Control.Monad.IO.Class + +import Data.String (fromString) +import Data.Typeable + +import HERMIT.Context +import HERMIT.Core +import HERMIT.External import HERMIT.GHC +import HERMIT.Kure +import HERMIT.Monad +import HERMIT.ParserCore +import HERMIT.Dictionary.Common +import HERMIT.Dictionary.Function hiding (externals) +import HERMIT.Dictionary.Reasoning hiding (externals) +import HERMIT.Name + -------------------------------------------------------------------------------------------------- -data WWAssumptionTag = A | B | C deriving (Eq,Ord,Show,Read) +-- | New Worker/Wrapper-related externals. +externals :: [External] +externals = map (.+ Proof) + [ external "intro-ww-assumption-A" + (\nm absC repC -> do + eq <- parse2BeforeT assumptionAEqualityT absC repC + insertLemmaR nm $ Lemma eq False False :: RewriteH Core) + [ "Introduce a lemma for worker/wrapper assumption A" + , "using given abs and rep functions." ] + , external "intro-ww-assumption-B" + (\nm absC repC bodyC -> do + eq <- parse3BeforeT assumptionBEqualityT absC repC bodyC + insertLemmaR nm $ Lemma eq False False :: RewriteH Core) + [ "Introduce a lemma for worker/wrapper assumption B" + , "using given abs, rep, and body functions." ] + , external "intro-ww-assumption-C" + (\nm absC repC bodyC -> do + eq <- parse3BeforeT assumptionCEqualityT absC repC bodyC + insertLemmaR nm $ Lemma eq False False :: RewriteH Core) + [ "Introduce a lemma for worker/wrapper assumption C" + , "using given abs, rep, and body functions." ] + , external "split-1-beta" (\ nm absC -> promoteExprR . parse2BeforeT (split1BetaR nm) absC :: CoreString -> RewriteH Core) + [ "split-1-beta " + , "Perform worker/wrapper split with condition 1-beta." + , "Given lemma name argument is used as prefix to two introduced lemmas." + , " -assumption: unproven lemma for w/w assumption C." + , " -fusion: assumed lemma for w/w fusion." + ] + , external "split-2-beta" (\ nm absC -> promoteExprR . parse2BeforeT (split2BetaR nm) absC :: CoreString -> RewriteH Core) + [ "split-2-beta " + , "Perform worker/wrapper split with condition 2-beta." + , "Given lemma name argument is used as prefix to two introduced lemmas." + , " -assumption: unproven lemma for w/w assumption C." + , " -fusion: assumed lemma for w/w fusion." + ] + ] + +-------------------------------------------------------------------------------------------------- + +data WWAssumptionTag = A | B | C deriving (Eq,Ord,Show,Read,Typeable) + +instance Extern WWAssumptionTag where + type Box WWAssumptionTag = WWAssumptionTag + box i = i + unbox i = i + data WWAssumption = WWAssumption WWAssumptionTag (RewriteH CoreExpr) -------------------------------------------------------------------------------------------------- @@ -17,7 +87,94 @@ -- That would have to exist at the Shell level though. -- This isn't entirely safe, as a malicious the user could define a label with this name. -workLabel :: Label -workLabel = "recursive-definition-of-work-for-use-by-ww-fusion" +workLabel :: RememberedName +workLabel = fromString "recursive-definition-of-work-for-use-by-ww-fusion" -------------------------------------------------------------------------------------------------- + +-- Given abs and rep expressions, build "abs . rep = id" +assumptionAEqualityT :: ( BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m + , MonadCatch m, MonadIO m, MonadThings m ) + => CoreExpr -> CoreExpr -> Transform c m x Equality +assumptionAEqualityT absE repE = prefixFailMsg "Building assumption A failed: " $ do + comp <- buildCompositionT absE repE + let (_,compBody) = collectTyBinders comp + (tvs, xTy, _) <- splitFunTypeM (exprType comp) + idE <- buildIdT xTy + return $ Equality tvs compBody idE + +-- Given abs, rep, and f expressions, build "abs . rep . f = f" +assumptionBEqualityT :: ( BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m + , MonadCatch m, MonadIO m, MonadThings m) + => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Equality +assumptionBEqualityT absE repE fE = prefixFailMsg "Building assumption B failed: " $ do + repAfterF <- buildCompositionT repE fE + comp <- buildCompositionT absE repAfterF + let (tvs,lhs) = collectTyBinders comp + rhs <- appArgM 5 lhs >>= appArgM 5 -- get f with proper tvs applied + return $ Equality tvs lhs rhs + +-- Given abs, rep, and f expressions, build "fix (abs . rep . f) = fix f" +assumptionCEqualityT :: (BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) + => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Equality +assumptionCEqualityT absE repE fE = prefixFailMsg "Building assumption C failed: " $ do + Equality vs lhs rhs <- assumptionBEqualityT absE repE fE + lhs' <- buildFixT lhs + rhs' <- buildFixT rhs + return $ Equality vs lhs' rhs' + +-- Given abs, rep, and 'fix g' expressions, build "rep (abs (fix g)) = fix g" +wwFusionEqualityT :: (HasDynFlags m, MonadCatch m, MonadIO m) + => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Equality +wwFusionEqualityT absE repE fixgE = prefixFailMsg "Building worker/wrapper fusion lemma failed: " $ do + protoLhs <- buildApplicationM repE =<< buildApplicationM absE fixgE + let (tvs, lhs) = collectTyBinders protoLhs + -- This way, the rhs is applied to the proper type variables. + rhs <- case lhs of + (App _ (App _ rhs)) -> return rhs + _ -> fail "lhs malformed" + return $ Equality tvs lhs rhs + +-- Perform the worker/wrapper split using condition 1-beta, introducing +-- an unproven lemma for assumption C, and an appropriate w/w fusion lemma. +split1BetaR :: ( BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m, HasLemmas m + , MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) + => LemmaName -> CoreExpr -> CoreExpr -> Rewrite c m CoreExpr +split1BetaR nm absE repE = do + (_fixId, [_tyA, f]) <- callNameT $ fromString "Data.Function.fix" + + g <- buildCompositionT repE =<< buildCompositionT f absE + gId <- constT $ newIdH "g" $ exprType g + + workRhs <- buildFixT $ varToCoreExpr gId + workId <- constT $ newIdH "worker" $ exprType workRhs + + newRhs <- buildApplicationM absE (varToCoreExpr workId) + + assumptionEq <- assumptionCEqualityT absE repE f + _ <- insertLemmaR (fromString (show nm ++ "-assumption")) $ Lemma assumptionEq False True -- unproven, used + + wwFusionEq <- wwFusionEqualityT absE repE workRhs + _ <- insertLemmaR (fromString (show nm ++ "-fusion")) $ Lemma wwFusionEq True False -- proven (assumed), unused + + return $ mkCoreLets [NonRec gId g, NonRec workId workRhs] newRhs + +split2BetaR :: ( BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m, HasLemmas m + , MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) + => LemmaName -> CoreExpr -> CoreExpr -> Rewrite c m CoreExpr +split2BetaR nm absE repE = do + (_fixId, [_tyA, f]) <- callNameT $ fromString "Data.Function.fix" + fixfE <- idR + + repFixFE <- buildApplicationM repE fixfE + workId <- constT $ newIdH "worker" $ exprType repFixFE + + newRhs <- buildApplicationM absE (varToCoreExpr workId) + + assumptionEq <- assumptionCEqualityT absE repE f + _ <- insertLemmaR (fromString (show nm ++ "-assumption")) $ Lemma assumptionEq False True -- unproven, used + + wwFusionEq <- wwFusionEqualityT absE repE (varToCoreExpr workId) + _ <- insertLemmaR (fromString (show nm ++ "-fusion")) $ Lemma wwFusionEq True False -- proven (assumed), unused + + return $ mkCoreLets [NonRec workId repFixFE] newRhs diff --git a/src/HERMIT/Dictionary/WorkerWrapper/Fix.hs b/src/HERMIT/Dictionary/WorkerWrapper/Fix.hs --- a/src/HERMIT/Dictionary/WorkerWrapper/Fix.hs +++ b/src/HERMIT/Dictionary/WorkerWrapper/Fix.hs @@ -1,28 +1,30 @@ module HERMIT.Dictionary.WorkerWrapper.Fix - ( -- * The Worker/Wrapper Transformation - -- | Note that many of these operations require 'Data.Function.fix' to be in scope. - HERMIT.Dictionary.WorkerWrapper.Fix.externals - , wwFacBR - , wwSplitR - , wwSplitStaticArg - , wwGenerateFusionR - , wwFusionBR - , wwAssA - , wwAssB - , wwAssC - ) -where + ( -- * The Worker/Wrapper Transformation + -- | Note that many of these operations require 'Data.Function.fix' to be in scope. + HERMIT.Dictionary.WorkerWrapper.Fix.externals + , wwFacBR + , wwSplitR + , wwSplitStaticArg + , wwGenerateFusionR + , wwFusionBR + , wwAssA + , wwAssB + , wwAssC + ) where import Control.Applicative import Control.Arrow +import Data.String (fromString) + import HERMIT.Core -import HERMIT.Monad -import HERMIT.Kure import HERMIT.External import HERMIT.GHC -import HERMIT.Utilities +import HERMIT.Kure +import HERMIT.Monad +import HERMIT.Name import HERMIT.ParserCore +import HERMIT.Utilities import HERMIT.Dictionary.AlphaConversion import HERMIT.Dictionary.Common @@ -171,7 +173,7 @@ guardMsg (eqType tyA tA) ("wrapper/unwrapper types do not match fix body type.") whenJust (verifyWWAss wrap unwrap f) mAss b <- constT (newIdH "x" tyB) - App wrap <$> mkFixT (Lam b (App unwrap (App f (App wrap (Var b))))) + App wrap <$> buildFixT (Lam b (App unwrap (App f (App wrap (Var b))))) wwR :: RewriteH CoreExpr wwR = prefixFailMsg "(reverse) worker/wrapper factorisation failed: " $ @@ -183,7 +185,7 @@ guardMsg (equivalentBy exprAlphaEq [wrap, wrap1, wrap2]) "wrappers do not match." guardMsg (exprAlphaEq unwrap unwrap1) "unwrappers do not match." whenJust (verifyWWAss wrap unwrap f) mAss - mkFixT f + buildFixT f wrongFixBody :: String wrongFixBody = "body of fix does not have the form Lam b (App unwrap (App f (App wrap (Var b))))" @@ -251,11 +253,11 @@ -- | \\ wrap unwrap -> (@prog = expr@ ==> @prog = let f = \\ prog -> expr in let work = unwrap (f (wrap work)) in wrap work)@ wwSplitR :: Maybe WWAssumption -> CoreExpr -> CoreExpr -> RewriteH CoreDef wwSplitR mAss wrap unwrap = - fixIntroR + fixIntroRecR >>> defAllR idR ( appAllR idR (letIntroR "f") >>> letFloatArgR >>> letAllR idR ( forwardT (wwFacBR mAss wrap unwrap) - >>> appAllR idR ( unfoldNameR "fix" + >>> appAllR idR ( unfoldNameR (fromString "Data.Function.fix") >>> alphaLetWithR ["work"] >>> letRecAllR (\ _ -> defAllR idR (betaReduceR >>> letNonRecSubstR) >>> extractR (wwGenerateFusionR mAss) @@ -440,8 +442,8 @@ prefixFailMsg ("verification of worker/wrapper assumption C failed: ") $ do (tyA,_) <- wrapUnwrapTypes wrap unwrap a <- constT (newIdH "a" tyA) - rhs <- mkFixT f - lhs <- mkFixT (Lam a (App wrap (App unwrap (App f (Var a))))) + rhs <- buildFixT f + lhs <- buildFixT (Lam a (App wrap (App unwrap (App f (Var a))))) verifyEqualityLeftToRightT lhs rhs assC -------------------------------------------------------------------------------------------------- diff --git a/src/HERMIT/Dictionary/WorkerWrapper/FixResult.hs b/src/HERMIT/Dictionary/WorkerWrapper/FixResult.hs --- a/src/HERMIT/Dictionary/WorkerWrapper/FixResult.hs +++ b/src/HERMIT/Dictionary/WorkerWrapper/FixResult.hs @@ -1,31 +1,33 @@ {-# LANGUAGE TupleSections #-} module HERMIT.Dictionary.WorkerWrapper.FixResult - ( -- * The Worker/Wrapper Transformation (Result Variant) - -- | Note that many of these operations require 'Data.Function.fix' to be in scope. - HERMIT.Dictionary.WorkerWrapper.FixResult.externals - , wwResultFacBR - , wwResultSplitR - , wwResultSplitStaticArg - , wwResultGenerateFusionR - , wwResultFusionBR - , wwResultAssA - , wwResultAssB - , wwResultAssC - ) -where + ( -- * The Worker/Wrapper Transformation (Result Variant) + -- | Note that many of these operations require 'Data.Function.fix' to be in scope. + HERMIT.Dictionary.WorkerWrapper.FixResult.externals + , wwResultFacBR + , wwResultSplitR + , wwResultSplitStaticArg + , wwResultGenerateFusionR + , wwResultFusionBR + , wwResultAssA + , wwResultAssB + , wwResultAssC + ) where import Prelude hiding (abs) import Control.Arrow +import Data.String (fromString) + import HERMIT.Core -import HERMIT.Monad -import HERMIT.Kure import HERMIT.External import HERMIT.GHC -import HERMIT.Utilities +import HERMIT.Kure +import HERMIT.Monad +import HERMIT.Name import HERMIT.ParserCore +import HERMIT.Utilities import HERMIT.Dictionary.AlphaConversion import HERMIT.Dictionary.Common @@ -172,7 +174,7 @@ wwL :: Type -> Type -> RewriteH CoreExpr wwL tyA tyB = prefixFailMsg "worker/wrapper factorisation failed: " $ do (tyXA,f) <- isFixExprT - (tyX,tA) <- constT (splitFunTypeM tyXA) + (_,tyX,tA) <- constT (splitFunTypeM tyXA) let tyXB = FunTy tyX tyB h <- constT (newIdH "h" tyXB) guardMsg (eqType tyA tA) ("abs/rep types do not match fix body type.") @@ -182,7 +184,7 @@ whenJust (verifyWWAss abs rep f) mAss - work <- mkFixT (Lam h (Lam x1 (App rep + work <- buildFixT (Lam h (Lam x1 (App rep (App (App f (Lam x2 (App abs (App (Var h) (Var x2))))) (Var x1) ) @@ -203,7 +205,7 @@ guardMsg (equivalentBy exprAlphaEq [abs, abs1, abs2]) "abs's do not match." guardMsg (exprAlphaEq rep rep1) "rep's do not match." whenJust (verifyWWAss abs rep f) mAss - mkFixT f + buildFixT f wrongForm :: String wrongForm = wrongExprForm "\\ x1 -> abs (fix (\\ h x2 -> rep (f (\\ x3 -> abs (h x3)) x2)) x1)" @@ -282,11 +284,11 @@ -- | \\ abs rep -> (@prog = expr@ ==> @prog = let f = \\ prog -> expr in let work = \\ x1 -> rep (f (\\ x2 -> abs (work x2)) x1) in \\ x0 -> abs (work x0)@) wwResultSplitR :: Maybe WWAssumption -> CoreExpr -> CoreExpr -> RewriteH CoreDef wwResultSplitR mAss abs rep = - fixIntroR + fixIntroRecR >>> defAllR idR ( appAllR idR (letIntroR "f") >>> letFloatArgR >>> letAllR idR ( forwardT (wwResultFacBR mAss abs rep) - >>> lamAllR idR (appAllR idR (appAllR ( unfoldNameR "fix" + >>> lamAllR idR (appAllR idR (appAllR ( unfoldNameR (fromString "Data.Function.fix") >>> alphaLetWithR ["work"] >>> letRecAllR (\ _ -> defAllR idR (betaReduceR >>> letNonRecSubstR) >>> extractR (wwResultGenerateFusionR mAss) @@ -461,9 +463,9 @@ -> TransformH x () verifyAssB abs rep f assB = prefixFailMsg ("verification of worker/wrapper assumption B failed: ") $ - do (tyA,_) <- absRepTypes abs rep - tyXA <- constT (endoFunExprType f) - (tyX,tA) <- constT (splitFunTypeM tyXA) + do (tyA,_) <- absRepTypes abs rep + (_,tyXA) <- constT (endoFunExprTypeM f) + (_,tyX,tA) <- constT (splitFunTypeM tyXA) guardMsg (eqType tyA tA) "type of program body does not match types of abs/rep." h <- constT (newIdH "h" tyXA) x <- constT (newIdH "x" tyX) @@ -478,14 +480,14 @@ -> TransformH a () verifyAssC abs rep f assC = prefixFailMsg ("verification of worker/wrapper assumption C failed: ") $ - do (tyA,_) <- absRepTypes abs rep - tyXA <- constT (endoFunExprType f) - (tyX,tA) <- constT (splitFunTypeM tyXA) + do (tyA,_) <- absRepTypes abs rep + (_,tyXA) <- constT (endoFunExprTypeM f) + (_,tyX,tA) <- constT (splitFunTypeM tyXA) guardMsg (eqType tyA tA) "type of program body does not match types of abs/rep." h <- constT (newIdH "h" tyXA) x <- constT (newIdH "x" tyX) - rhs <- mkFixT f - lhs <- mkFixT (Lam h (Lam x (App abs (App rep (App (App f (Var h)) (Var x)))))) + rhs <- buildFixT f + lhs <- buildFixT (Lam h (Lam x (App abs (App rep (App (App f (Var h)) (Var x)))))) verifyEqualityLeftToRightT lhs rhs assC -------------------------------------------------------------------------------------------------- diff --git a/src/HERMIT/Driver.hs b/src/HERMIT/Driver.hs --- a/src/HERMIT/Driver.hs +++ b/src/HERMIT/Driver.hs @@ -1,9 +1,10 @@ {-# LANGUAGE ViewPatterns #-} -module HERMIT.Driver +module HERMIT.Driver ( hermitVersion , ghcFlags , hermitDriver , usage + , usageOutput ) where import Data.List (isPrefixOf, partition) @@ -14,7 +15,7 @@ import System.Process import System.Exit -hermitVersion :: String +hermitVersion :: String hermitVersion = "HERMIT v" ++ showVersion P.version ghcFlags :: [String] @@ -26,11 +27,9 @@ -- , "-v0" ] -usage :: IO () -usage = putStrLn $ unlines - [hermitVersion - ,"" - ,"usage: hermit File.hs SCRIPTNAME" +usageOutput :: String +usageOutput = unlines + ["usage: hermit File.hs SCRIPTNAME" ," - OR -" ," hermit File.hs [HERMIT_ARGS] [+module_name [MOD_ARGS]]* [-- [ghc-args]]" ,"" @@ -45,6 +44,7 @@ ,"" ,"HERMIT_ARGS" ," -opt=MODULE : where MODULE is the module containing a HERMIT optimization plugin" + ," -pN : where 0<=N<=17 is the stage in the optimization pipeline HERMIT targets" ," -vN : controls verbosity, where N is one of the following values:" ," 0 : suppress HERMIT messages, pass -v0 to GHC" ," 1 : suppress HERMIT messages" @@ -56,7 +56,10 @@ ," resume : skip interactive mode and resume compilation after any scripts" ] --- | Entry point for HERMIT driver executable. +usage :: IO () +usage = mapM_ putStrLn [hermitVersion, "", usageOutput] + +-- | Entry point for HERMIT driver executable. -- First String in list is expected to be target file name. hermitDriver :: [String] -> IO () hermitDriver [] = usage diff --git a/src/HERMIT/External.hs b/src/HERMIT/External.hs --- a/src/HERMIT/External.hs +++ b/src/HERMIT/External.hs @@ -1,54 +1,52 @@ {-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances, DeriveDataTypeable #-} module HERMIT.External - ( - -- * Externals - External - , ExternalName - , ExternalHelp - , externName - , externDyn - , externHelp - , externTypeString - , externTypeArgResString - , Dictionary - , toDictionary - , addToDictionary - , toHelp - , external - , Extern(..) - , matchingExternals - -- * Tags - , CmdTag(..) - , TagE - , Tag((.+),remTag,tagMatch) - , (.&) - , (.||) - , notT - , externTags - , dictionaryOfTags - -- * Boxes - -- | Boxes are used by the 'Extern' class. - , TagBox(..) - , IntBox(..) - , RewriteCoreBox(..) - , RewriteCoreTCBox(..) - , BiRewriteCoreBox(..) - , TransformCoreStringBox(..) - , TransformCoreTCStringBox(..) - , TransformCoreCheckBox(..) - , TransformCoreTCCheckBox(..) - , TransformCorePathBox(..) - , TransformCoreTCPathBox(..) - , CoreString(..) - , CoreBox(..) - , CrumbBox(..) - , PathBox(..) - , StringBox(..) - , StringListBox(..) - , IntListBox(..) - , RewriteCoreListBox(..) -) where + ( -- * Externals + External + , ExternalName + , ExternalHelp + , externName + , externDyn + , externHelp + , externTypeString + , externTypeArgResString + , splitFunTyArgs + , toHelp + , external + , Extern(..) + , matchingExternals + -- * Tags + , CmdTag(..) + , TagE + , Tag((.+),remTag,tagMatch) + , (.&) + , (.||) + , notT + , externTags + , dictionaryOfTags + -- * Boxes + -- | Boxes are used by the 'Extern' class. + , BiRewriteCoreBox(..) + , CoreString(..) + , CrumbBox(..) + , IntBox(..) + , IntListBox(..) + , PathBox(..) + , RewriteCoreBox(..) + , RewriteCoreListBox(..) + , RewriteCoreTCBox(..) + , RewriteEqualityBox(..) + , StringBox(..) + , StringListBox(..) + , TagBox(..) + , TransformCoreCheckBox(..) + , TransformCorePathBox(..) + , TransformCoreStringBox(..) + , TransformCoreTCCheckBox(..) + , TransformCoreTCPathBox(..) + , TransformCoreTCStringBox(..) + , TransformEqualityStringBox(..) + ) where import Data.Map hiding (map) import Data.Dynamic @@ -58,6 +56,7 @@ import HERMIT.Core import HERMIT.Context (LocalPathH) import HERMIT.Kure +import HERMIT.Monad ----------------------------------------------------------------- @@ -80,11 +79,12 @@ | Deep -- ^ Command may make a deep change, can be O(n). | Shallow -- ^ Command operates on local nodes only, O(1). | Navigation -- ^ Uses 'Path' or 'Lens' to focus onto something. - | Query -- ^ A question we ask. + | Query -- ^ Extract information from an expression. | Predicate -- ^ Something that passes or fails. | Introduce -- ^ Introduce something, like a new name. | Commute -- ^ Commute is when you swap nested terms. | PreCondition -- ^ Operation has a (perhaps undocumented) precondition. + | Strictness -- ^ Alters the strictness of the expression. | Debug -- ^ Commands specifically to help debugging. | VersionControl -- ^ Version control for Core syntax. | Context -- ^ A command that uses its context, such as inlining. @@ -96,22 +96,6 @@ | Experiment -- ^ Things we are trying out. | Deprecated -- ^ A command that will be removed in a future release; -- it has probably been renamed or subsumed by another command. - - --- Unsure about these -{- - | Local -- local thing, O(1) - | CaseCmd -- works on case statements - | Context -- something that uses the context - | GHC -- a tunnel into GHC - | Lens -- focuses into a specific node - | LetCmd -- works on let statements - | Meta -- combines other commands - | Restful -- RESTful API commands - | Slow -- this command is slow --} - -- Other String - -- etc deriving (Eq, Show, Read, Bounded, Enum) -- | Lists all the tags paired with a short description of what they're about. @@ -121,31 +105,30 @@ , tag `notElem` map fst notes ] where notes = - -- These should give the user a clue about what the sub-commands - -- might do - [ (Shell, "Shell-specific command.") - , (Eval, "The arrow of evaluation (reduces a term).") - , (KURE, "Direct reflection of a combinator from the KURE DSL.") - , (Loop, "Command may operate multiple times.") - , (Deep, "Command may make a deep change, can be O(n).") - , (Shallow, "Command operates on local nodes only, O(1).") - , (Navigation, "Navigate via focus, or directional command.") - , (Query, "A question we ask.") - , (Predicate, "Something that passes or fails.") - , (Introduce, "Introduce something, like a new name.") - , (Commute, "Commute is when you swap nested terms.") - , (PreCondition, "Operation has a (perhaps undocumented) precondition.") - , (Debug, "A command specifically to help debugging.") - , (VersionControl,"Version control for Core syntax.") - , (Context, "A command that uses its context, such as inlining.") - , (Unsafe, "Commands that are not type safe (may cause Core Lint to fail), or may otherwise change the semantics of the program.") - , (Proof, "Commands related to proving lemmas.") - , (TODO, "An incomplete or potentially buggy command.") - , (Experiment, "Things we are trying out, use at your own risk.") - , (Deprecated, "A command that will be removed in a future release; it has probably been renamed or subsumed by another command.") + -- These should give the user a clue about what the sub-commands might do + [ (Shell, "Shell-specific command.") + , (Eval, "The arrow of evaluation (reduces a term).") + , (KURE, "Direct reflection of a combinator from the KURE DSL.") + , (Loop, "Command may operate multiple times.") + , (Deep, "Command may make a deep change, can be O(n).") + , (Shallow, "Command operates on local nodes only, O(1).") + , (Navigation, "Navigate via focus, or directional command.") + , (Query, "Extract information from an expression.") + , (Predicate, "Something that passes or fails.") + , (Introduce, "Introduce something, like a new name.") + , (Commute, "Commute is when you swap nested terms.") + , (PreCondition, "Operation has a (perhaps undocumented) precondition.") + , (Strictness, "Alters the strictness of an expression.") + , (Debug, "A command specifically to help debugging.") + , (VersionControl, "Version control for Core syntax.") + , (Context, "A command that uses its context, such as inlining.") + , (Unsafe, "Commands that are not type safe (may cause Core Lint to fail), or may otherwise change the semantics of the program.") + , (Proof, "Commands related to proving lemmas.") + , (TODO, "An incomplete or potentially buggy command.") + , (Experiment, "Things we are trying out, use at your own risk.") + , (Deprecated, "A command that will be removed in a future release; it has probably been renamed or subsumed by another command.") ] - -- Unfortunately, record update syntax seems to associate to the right. -- These operators save us some parentheses. infixl 3 .+ @@ -234,20 +217,6 @@ matchingExternals tag exts = [ (e,tr) | e <- exts, tagMatch tag e , Just tr <- [fmap unbox $ fromDynamic $ externDyn e] ] --- | A 'Dictionary' is a collection of 'Dynamic's. --- Looking up a 'Dynamic' (via an 'ExternalName' key) returns a list, as there can be multiple 'Dynamic's with the same name. -type Dictionary = Map ExternalName [Dynamic] - --- | Build a 'Data.Map' from names to 'Dynamic' values. -toDictionary :: [External] -> Dictionary -toDictionary = fromListWith (++) . map toEntry - -toEntry :: External -> (ExternalName, [Dynamic]) -toEntry e = (externName e, [externDyn e]) - -addToDictionary :: External -> Dictionary -> Dictionary -addToDictionary ex d = fromListWith (++) $ toEntry ex : toList d - -- | Build a 'Data.Map' from names to help information. toHelp :: [External] -> Map ExternalName ExternalHelp toHelp = fromListWith (++) . map toH @@ -266,9 +235,9 @@ -- | Remove the word 'Box' from a string. deBoxify :: String -> String -deBoxify xs +deBoxify xs | "CLSBox -> " `isPrefixOf` xs = deBoxify (drop 10 xs) -deBoxify xs +deBoxify xs | "Box" `isPrefixOf` xs = deBoxify (drop 3 xs) deBoxify (x:xs) = x : deBoxify xs deBoxify [] = [] @@ -435,14 +404,12 @@ ----------------------------------------------------------------- --- TODO: Is this deliberately called "CoreBox" rather than "CoreStringBox"? -newtype CoreString = CoreString { unCoreString :: String } -data CoreBox = CoreBox CoreString deriving Typeable +newtype CoreString = CoreString { unCoreString :: String } deriving Typeable instance Extern CoreString where - type Box CoreString = CoreBox - box = CoreBox - unbox (CoreBox s) = s + type Box CoreString = CoreString + box = id + unbox = id ----------------------------------------------------------------- @@ -479,5 +446,37 @@ type Box [RewriteH Core] = RewriteCoreListBox box = RewriteCoreListBox unbox (RewriteCoreListBox l) = l + +----------------------------------------------------------------- + +instance Extern RememberedName where + type Box RememberedName = RememberedName + box = id + unbox = id + +----------------------------------------------------------------- + +instance Extern LemmaName where + type Box LemmaName = LemmaName + box = id + unbox = id + +----------------------------------------------------------------- + +data RewriteEqualityBox = RewriteEqualityBox (RewriteH Equality) deriving Typeable + +instance Extern (RewriteH Equality) where + type Box (RewriteH Equality) = RewriteEqualityBox + box = RewriteEqualityBox + unbox (RewriteEqualityBox r) = r + +----------------------------------------------------------------- + +data TransformEqualityStringBox = TransformEqualityStringBox (TransformH Equality String) deriving Typeable + +instance Extern (TransformH Equality String) where + type Box (TransformH Equality String) = TransformEqualityStringBox + box = TransformEqualityStringBox + unbox (TransformEqualityStringBox t) = t ----------------------------------------------------------------- diff --git a/src/HERMIT/GHC.hs b/src/HERMIT/GHC.hs --- a/src/HERMIT/GHC.hs +++ b/src/HERMIT/GHC.hs @@ -1,7 +1,5 @@ {-# LANGUAGE CPP, InstanceSigs, TypeSynonymInstances, FlexibleInstances #-} -#if __GLASGOW_HASKELL__ > 706 {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -#endif -- Above shadowing disabled because the eqExprX function has lots of shadowing module HERMIT.GHC ( -- * GHC Imports @@ -9,101 +7,95 @@ module GhcPlugins , ppIdInfo , zapVarOccInfo - , var2String , thRdrNameGuesses , varNameNS , isQualified , cmpString2Name , cmpString2Var - , fqName - , uqName - , findNamesFromString + , qualifiedName + , unqualifiedName , alphaTyVars , Type(..) , TyLit(..) , GhcException(..) , throwGhcException , exprArity - , occurAnalyseExpr + , occurAnalyseExpr_NoBinderSwap , isKind , isLiftedTypeKindCon -#if __GLASGOW_HASKELL__ > 706 - , coAxiomName - , CoAxiom.BranchIndex - , CoAxiom.CoAxiom - , CoAxiom.Branched -#endif , notElemVarSet , varSetToStrings , showVarSet , Pair(..) , bndrRuleAndUnfoldingVars -#if __GLASGOW_HASKELL__ <= 706 - , exprType - , Control.Monad.IO.Class.liftIO -#else - , runDsMtoCoreM - , runTcMtoCoreM - , buildTypeable - , buildDictionary + , coAxiomName + , CoAxiom.BranchIndex + , CoAxiom.CoAxiom + , CoAxiom.Branched + , Bag.foldBag , eqExprX - , lookupRdrNameInModuleForPlugins + , loadSysInterface + , lookupRdrNameInModule + , reportAllUnsolved + , zEncodeString +#ifdef mingw32_HOST_OS + , initStaticOpts #endif - , mkPhiTy - , mkSigmaTy + , module Class + , module DsBinds + , module DsMonad + , module ErrUtils + , module PrelNames + , module TcEnv + , module TcMType + , module TcRnMonad + , module TcRnTypes + , module TcSimplify + , module TcType + , module Unify , getHscEnvCoreM ) where -#if __GLASGOW_HASKELL__ <= 706 --- GHC 7.6 -import qualified Control.Monad.IO.Class -import qualified MonadUtils (MonadIO,liftIO) -import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, exprType, liftIO, PluginPass, getHscEnv) -import TysPrim (alphaTy, alphaTyVars) -import Panic (throwGhcException, GhcException(..)) -import PprCore (pprCoreExpr) -import Data.Monoid hiding ((<>)) -#else --- GHC 7.8 -import Finder (findImportedModule, cannotFindModule) --- we hide these so that they don't get inadvertently used. See Core.hs -import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, PluginPass, getHscEnv) -import LoadIface (loadPluginInterface) -import Panic (throwGhcException, throwGhcExceptionIO, GhcException(..)) -import TcRnMonad (initIfaceTcRn) -import TysPrim (alphaTyVars) -#endif - --- hacky direct GHC imports -import Convert (thRdrNameGuesses) -import CoreArity -import qualified CoreMonad -- for getHscEnv -import Kind (isKind,isLiftedTypeKindCon) -import qualified OccName -- for varName -import OccurAnal (occurAnalyseExpr) -import Pair (Pair(..)) -import TcType (mkPhiTy, mkSigmaTy) -import TypeRep (Type(..),TyLit(..)) - -#if __GLASGOW_HASKELL__ <= 706 -import Data.Maybe (isJust) -#else +-- Imports from GHC. import qualified Bag +import Class (classTyCon) import qualified CoAxiom -- for coAxiomName -import DsBinds (dsEvBinds) -import DsMonad (DsM, initDsTc) -import PrelNames (typeableClassName) -import TcEnv (tcLookupClass) -import TcMType (newWantedEvVar) -import TcRnMonad (getCtLoc) -import TcRnTypes (TcM, mkNonCanonical, mkFlatWC, CtEvidence(..), SkolemInfo(..), CtOrigin(..)) -import TcSimplify (solveWantedsTcM) - -import HERMIT.GHC.Typechecker +import Convert (thRdrNameGuesses) +import CoreArity +import qualified CoreMonad -- for getHscEnv +import DsBinds (dsEvBinds) +import DsMonad (DsM, initDsTc) +import Encoding (zEncodeString) +import ErrUtils (pprErrMsgBag) +import Finder (findImportedModule, cannotFindModule) +-- we hide these so that they don't get inadvertently used. +-- several are redefined in Core.hs and elsewhere +import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, PluginPass, getHscEnv, RuleName) +import Kind (isKind,isLiftedTypeKindCon) +import LoadIface (loadSysInterface) +import qualified OccName -- for varName +import OccurAnal (occurAnalyseExpr_NoBinderSwap) +import Pair (Pair(..)) +import Panic (throwGhcException, throwGhcExceptionIO, GhcException(..)) +import PrelNames (typeableClassName) +#if mingw32_HOST_OS +import StaticFlags #endif +import TcEnv (tcLookupClass) +import TcErrors (reportAllUnsolved) +import TcMType (newWantedEvVar) +import TcRnMonad (getCtLoc, initIfaceTcRn) +import TcRnTypes (TcM, mkNonCanonical, mkFlatWC, CtEvidence(..), SkolemInfo(..), CtOrigin(..)) +import TcSimplify (solveWantedsTcM) +import TcType (mkPhiTy, mkSigmaTy) +import TypeRep (Type(..),TyLit(..)) +import TysPrim (alphaTyVars) +import Unify (tcUnifyTys, BindFlag(..)) import Data.List (intercalate) +import HERMIT.GHC.Typechecker + -------------------------------------------------------------------------- -- | Rename this namespace, as 'varName' is already a function in Var. @@ -113,36 +105,11 @@ getHscEnvCoreM :: CoreM HscEnv getHscEnvCoreM = CoreMonad.getHscEnv -#if __GLASGOW_HASKELL__ <= 706 --- Note: prior to 7.8, the Let case was buggy for type --- bindings, so we provide a fixed definition here. -exprType :: CoreExpr -> Type --- ^ Recover the type of a well-typed Core expression. Fails when --- applied to the actual 'CoreSyn.Type' expression as it cannot --- really be said to have a type -exprType (Var var) = idType var -exprType (Lit lit) = literalType lit -exprType (Coercion co) = coercionType co -exprType (Let bind body) - | NonRec tv rhs <- bind - , Type ty <- rhs = substTyWith [tv] [ty] (exprType body) - | otherwise = exprType body -exprType (Case _ _ ty _) = ty -exprType (Cast _ co) = pSnd (coercionKind co) -exprType (Tick _ e) = exprType e -exprType (Lam binder expr) = mkPiType binder (exprType expr) -exprType e@(App _ _) - = case collectArgs e of - (fun, args) -> applyTypeToArgs e (exprType fun) args - -exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy -#endif - -------------------------------------------------------------------------- -- | Convert a 'VarSet' to a list of user-readable strings. varSetToStrings :: VarSet -> [String] -varSetToStrings = map var2String . varSetElems +varSetToStrings = map unqualifiedName . varSetElems -- | Show a human-readable version of a 'VarSet'. showVarSet :: VarSet -> String @@ -150,13 +117,8 @@ -------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ <= 706 --- coAxiomName :: CoAxiom -> Name --- coAxiomName = coAxiomName -#else coAxiomName :: CoAxiom.CoAxiom br -> Name coAxiomName = CoAxiom.coAxiomName -#endif -- varName :: Var -> Name -- nameOccName :: Name -> OccName @@ -166,24 +128,20 @@ -- getOccString :: NamedThing a => a -> String -- | Get the unqualified name from a 'NamedThing'. -uqName :: NamedThing nm => nm -> String -uqName = getOccString +unqualifiedName :: NamedThing nm => nm -> String +unqualifiedName = getOccString -- | Get the fully qualified name from a 'Name'. -fqName :: Name -> String -fqName nm = modStr ++ uqName nm +qualifiedName :: Name -> String +qualifiedName nm = modStr ++ unqualifiedName nm where modStr = maybe "" (\m -> moduleNameString (moduleName m) ++ ".") (nameModule_maybe nm) --- | Convert a variable to a neat string for printing (unqualfied name). -var2String :: Var -> String -var2String = uqName . varName - -- | Compare a 'String' to a 'Name' for equality. -- Strings containing a period are assumed to be fully qualified names. -- (Except for ".", which is an unqualified reference to composition.) cmpString2Name :: String -> Name -> Bool -cmpString2Name str nm | isQualified str = str == fqName nm - | otherwise = str == uqName nm +cmpString2Name str nm | isQualified str = str == qualifiedName nm + | otherwise = str == unqualifiedName nm isQualified :: String -> Bool isQualified [] = False @@ -193,12 +151,6 @@ cmpString2Var :: String -> Var -> Bool cmpString2Var str = cmpString2Name str . varName --- | Find 'Name's matching a given fully qualified or unqualified name. -findNamesFromString :: GlobalRdrEnv -> String -> [Name] -findNamesFromString rdrEnv str | isQualified str = res - | otherwise = res - where res = [ nm | elt <- globalRdrEnvElts rdrEnv, let nm = gre_name elt, cmpString2Name str nm ] - -- | Pretty-print an identifier. ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo v info @@ -224,12 +176,7 @@ has_caf_info = not (mayHaveCafRefs caf_info) str_info = strictnessInfo info - has_strictness = -#if __GLASGOW_HASKELL__ > 706 - True -#else - isJust str_info -#endif + has_strictness = True unf_info = unfoldingInfo info has_unf = hasSomeUnfolding unf_info @@ -255,23 +202,8 @@ notElemVarSet :: Var -> VarSet -> Bool notElemVarSet v vs = not (v `elemVarSet` vs) -#if __GLASGOW_HASKELL__ <= 706 -instance Monoid VarSet where - mempty :: VarSet - mempty = emptyVarSet - - mappend :: VarSet -> VarSet -> VarSet - mappend = unionVarSet - -------------------------------------------------------------------------- -instance Control.Monad.IO.Class.MonadIO CoreM where - liftIO :: IO a -> CoreM a - liftIO = MonadUtils.liftIO -#endif - --------------------------------------------------------------------------- - -- This function is copied from GHC, which defines but doesn't expose it. -- A 'let' can bind a type variable, and idRuleVars assumes -- it's seeing an Id. This function tests first. @@ -281,44 +213,6 @@ -------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 706 -runTcMtoCoreM :: ModGuts -> TcM a -> CoreM a -runTcMtoCoreM guts m = do - env <- CoreMonad.getHscEnv - -- What is the effect of HsSrcFile (should we be using something else?) - -- What should the boolean flag be set to? - (msgs, mr) <- liftIO $ initTcFromModGuts env guts HsSrcFile False m - -- There is probably something better for reporting the errors. - let dumpSDocs endMsg = Bag.foldBag (\ d r -> d ++ ('\n':r)) show endMsg - showMsgs (warns, errs) = "Errors:\n" ++ dumpSDocs ("Warnings:\n" ++ dumpSDocs "" warns) errs - maybe (fail $ showMsgs msgs) return mr - -runDsMtoCoreM :: ModGuts -> DsM a -> CoreM a -runDsMtoCoreM guts = runTcMtoCoreM guts . initDsTc - --- TODO: this is mostly an example, move somewhere? -buildTypeable :: ModGuts -> Type -> CoreM (Id, [CoreBind]) -buildTypeable guts ty = do - evar <- runTcMtoCoreM guts $ do - cls <- tcLookupClass typeableClassName - let predTy = mkClassPred cls [typeKind ty, ty] -- recall that Typeable is now poly-kinded - newWantedEvVar predTy - buildDictionary guts evar - --- | Build a dictionary for the given -buildDictionary :: ModGuts -> Id -> CoreM (Id, [CoreBind]) -buildDictionary guts evar = do - (i, bs) <- runTcMtoCoreM guts $ do - loc <- getCtLoc $ GivenOrigin UnkSkol - let predTy = varType evar - nonC = mkNonCanonical $ CtWanted { ctev_pred = predTy, ctev_evar = evar, ctev_loc = loc } - wCs = mkFlatWC [nonC] - (_wCs', bnds) <- solveWantedsTcM wCs - -- TODO: check for unsolved constraints? - return (evar, bnds) - bnds <- runDsMtoCoreM guts $ dsEvBinds bs - return (i,bnds) - -- This function used to be in GHC itself, but was removed. -- It compares core for equality modulo alpha. eqExprX :: IdUnfoldingFun -> RnEnv2 -> CoreExpr -> CoreExpr -> Bool @@ -391,10 +285,16 @@ -- * If the module could not be found -- * If we could not determine the imports of the module -- --- This is adapted from GHC's function of the same name, but using --- initTcFromModGuts instead of initTcInteractive. -lookupRdrNameInModuleForPlugins :: HscEnv -> ModGuts -> ModuleName -> RdrName -> IO (Maybe Name) -lookupRdrNameInModuleForPlugins hsc_env guts mod_name rdr_name = do +-- This is adapted from GHC's function called lookupRdrNameInModuleForPlugins, +-- but using initTcFromModGuts instead of initTcInteractive. Also, we ImportBySystem +-- instead of ImportByPlugin, so the EPS gets populated with RULES and instances from +-- the loaded module. +-- +-- TODO: consider importing by plugin first, then only importing by system when a name +-- is successfully found... as written we will load RULES/instances if the module loads +-- successfully, even if the name is not found. +lookupRdrNameInModule :: HscEnv -> ModGuts -> ModuleName -> RdrName -> IO (Maybe Name) +lookupRdrNameInModule hsc_env guts mod_name rdr_name = do -- First find the package the module resides in by searching exposed packages and home modules found_module <- findImportedModule hsc_env mod_name Nothing case found_module of @@ -402,7 +302,8 @@ -- Find the exports of the module (_, mb_iface) <- initTcFromModGuts hsc_env guts HsSrcFile False $ initIfaceTcRn $ - loadPluginInterface doc mod + loadSysInterface doc mod + case mb_iface of Just iface -> do -- Try and find the required name in the exports @@ -427,4 +328,3 @@ throwCmdLineError :: String -> IO a throwCmdLineError = throwGhcExceptionIO . CmdLineError -#endif diff --git a/src/HERMIT/GHC/Typechecker.hs b/src/HERMIT/GHC/Typechecker.hs --- a/src/HERMIT/GHC/Typechecker.hs +++ b/src/HERMIT/GHC/Typechecker.hs @@ -1,15 +1,11 @@ {-# LANGUAGE CPP, RankNTypes #-} -module HERMIT.GHC.Typechecker - ( -#if __GLASGOW_HASKELL__ > 706 +module HERMIT.GHC.Typechecker + ( initTcFromModGuts , mk_type_env , tcLookupGlobal -#endif ) where -#if __GLASGOW_HASKELL__ > 706 - import Annotations (emptyAnnEnv) import HsSyn import RdrName @@ -34,7 +30,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map -import Prelude +import Prelude import VarSet (emptyVarSet) -- Note: the contents of this module should eventually be folded into GHC proper. @@ -178,5 +174,3 @@ mk_dfun_n :: ModGuts -> OccSet -- TODO mk_dfun_n _ = emptyOccSet - -#endif diff --git a/src/HERMIT/Kernel.hs b/src/HERMIT/Kernel.hs --- a/src/HERMIT/Kernel.hs +++ b/src/HERMIT/Kernel.hs @@ -1,17 +1,18 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables, TupleSections, GADTs #-} module HERMIT.Kernel - ( -- * The HERMIT Kernel - AST - , Kernel - , hermitKernel - , resumeK - , abortK - , applyK - , queryK - , deleteK - , listK -) where + ( -- * The HERMIT Kernel + AST + , Kernel + , KernelEnv(..) + , hermitKernel + , resumeK + , abortK + , applyK + , queryK + , deleteK + , listK + ) where import Prelude hiding (lookup) @@ -27,12 +28,12 @@ -- For now, operations on a 'Kernel' are sequential, but later -- it will be possible to have two 'applyK's running in parallel. data Kernel = Kernel - { resumeK :: AST -> IO () -- ^ Halt the 'Kernel' and return control to GHC, which compiles the specified 'AST'. - , abortK :: IO () -- ^ Halt the 'Kernel' and abort GHC without compiling. - , applyK :: AST -> RewriteH ModGuts -> HermitMEnv -> IO (KureM AST) -- ^ Apply a 'Rewrite' to the specified 'AST' and return a handle to the resulting 'AST'. - , queryK :: forall a . AST -> TransformH ModGuts a -> HermitMEnv -> IO (KureM a) -- ^ Apply a 'TransformH' to the 'AST' and return the resulting value. - , deleteK :: AST -> IO () -- ^ Delete the internal record of the specified 'AST'. - , listK :: IO [AST] -- ^ List all the 'AST's tracked by the 'Kernel'. + { resumeK :: AST -> IO () -- ^ Halt the 'Kernel' and return control to GHC, which compiles the specified 'AST'. + , abortK :: IO () -- ^ Halt the 'Kernel' and abort GHC without compiling. + , applyK :: AST -> RewriteH ModGuts -> KernelEnv -> IO (KureM AST) -- ^ Apply a 'Rewrite' to the specified 'AST' and return a handle to the resulting 'AST'. + , queryK :: forall a . AST -> TransformH ModGuts a -> KernelEnv -> IO (KureM a) -- ^ Apply a 'TransformH' to the 'AST' and return the resulting value. + , deleteK :: AST -> IO () -- ^ Delete the internal record of the specified 'AST'. + , listK :: IO [AST] -- ^ List all the 'AST's tracked by the 'Kernel'. } -- | A /handle/ for a specific version of the 'ModGuts'. @@ -42,15 +43,28 @@ data Msg s r = forall a . Req (s -> CoreM (KureM (a,s))) (MVar (KureM a)) | Done (s -> CoreM r) -type KernelState = Map AST (DefStash, ModGuts) +type ASTMap = Map AST KernelState +data KernelState = KernelState { _ksStash :: DefStash + , _ksLemmas :: Lemmas + , ksGuts :: ModGuts + } + +fromHermitMResult :: HermitMResult ModGuts -> KernelState +fromHermitMResult hRes = sideEffectsOnly hRes (hResult hRes) + +sideEffectsOnly :: HermitMResult a -> ModGuts -> KernelState +sideEffectsOnly hRes = KernelState (hResStash hRes) (hResLemmas hRes) + +data KernelEnv = KernelEnv { kEnvChan :: DebugMessage -> HermitM () } + -- | Start a HERMIT client by providing an IO function that takes the initial 'Kernel' and inital 'AST' handle. -- The 'Modguts' to 'CoreM' Modguts' function required by GHC Plugins is returned. -- The callback is only ever called once. hermitKernel :: (Kernel -> AST -> IO ()) -> ModGuts -> CoreM ModGuts hermitKernel callback modGuts = do - msgMV :: MVar (Msg KernelState ModGuts) <- liftIO newEmptyMVar + msgMV :: MVar (Msg ASTMap ModGuts) <- liftIO newEmptyMVar nextASTname :: MVar AST <- liftIO newEmptyMVar @@ -58,38 +72,53 @@ loop (succ n) in loop 0 - let sendDone :: (KernelState -> CoreM ModGuts) -> IO () + let sendDone :: (ASTMap -> CoreM ModGuts) -> IO () sendDone = putMVar msgMV . Done - let sendReq :: (KernelState -> CoreM (KureM (a, KernelState))) -> IO (KureM a) + let sendReq :: (ASTMap -> CoreM (KureM (a, ASTMap))) -> IO (KureM a) sendReq fn = do rep <- newEmptyMVar putMVar msgMV (Req fn rep) takeMVar rep - let sendReqRead :: (KernelState -> CoreM (KureM a)) -> IO (KureM a) - sendReqRead fn = sendReq (\ st -> (fmap.fmap) (,st) $ fn st) + let sendReqRead :: (ASTMap -> CoreM (KureM a)) -> IO (KureM a) + sendReqRead fn = sendReq (\ st -> (fmap.fmap) (,st) $ fn st) -- >>= return . fmap fst - let sendReqWrite :: (KernelState -> CoreM KernelState) -> IO () - sendReqWrite fn = sendReq (fmap ( return . ((),) ) . fn) >>= liftKureM + let sendReqWrite :: (ASTMap -> CoreM ASTMap) -> IO () + sendReqWrite fn = sendReq (fmap ( return . ((),) ) . fn) >>= {- fmap fst . -} liftKureM let kernel :: Kernel kernel = Kernel - { resumeK = \ name -> sendDone $ \ st -> findWithErrMsg name st (\ msg -> throwGhcException $ ProgramError $ msg ++ ", exiting HERMIT and aborting GHC compilation.") (return.snd) + { resumeK = \ name -> + sendDone $ \ st -> + findWithErrMsg name + st + (\ msg -> throwGhcException + $ ProgramError + $ msg ++ ", exiting HERMIT and aborting GHC compilation.") + (return.ksGuts) - , abortK = sendDone $ \ _ -> throwGhcException (ProgramError "Exiting HERMIT and aborting GHC compilation.") + , abortK = sendDone $ \ _ -> throwGhcException + $ ProgramError "Exiting HERMIT and aborting GHC compilation." - , applyK = \ name r hm_env -> sendReq $ \ st -> findWithErrMsg name st fail $ \ (defs, guts) -> runHM (guts,hm_env) - defs - (\ defs' guts' -> do ast <- liftIO $ takeMVar nextASTname - return $ return (ast, insert ast (defs',guts') st)) - (return . fail) - (apply r (topLevelHermitC guts) guts) + , applyK = \ name r kEnv -> + sendReq $ \ st -> + findWithErrMsg name st fail $ \ (KernelState defs lemmas guts) -> + runHM (kEnvChan kEnv) + (mkEnv guts defs lemmas) + (\ hRes -> do + ast <- liftIO $ takeMVar nextASTname + return $ return (ast, insert ast (fromHermitMResult hRes) st)) + (return . fail) + (applyT r (topLevelHermitC guts) guts) - , queryK = \ name t hm_env -> sendReqRead $ \ st -> findWithErrMsg name st fail $ \ (defs, guts) -> runHM (guts,hm_env) - defs - (\ _ -> return.return) - (return . fail) - (apply t (topLevelHermitC guts) guts) + , queryK = \ name t kEnv -> + sendReqRead $ \ st -> + findWithErrMsg name st fail $ \ (KernelState defs lemmas guts) -> + runHM (kEnvChan kEnv) + (mkEnv guts defs lemmas) + (return . return . hResult) + (return . fail) + (applyT t (topLevelHermitC guts) guts) , deleteK = \ name -> sendReqWrite (return . delete name) @@ -99,7 +128,7 @@ -- We always start with AST 0 ast0 <- liftIO $ takeMVar nextASTname - let loop :: KernelState -> CoreM ModGuts + let loop :: ASTMap -> CoreM ModGuts loop st = do m <- liftIO $ takeMVar msgMV case m of @@ -109,7 +138,7 @@ _pid <- liftIO $ forkIO $ callback kernel ast0 - loop (singleton ast0 (empty, modGuts)) + loop (singleton ast0 $ KernelState empty empty modGuts) -- (Kill the pid'd thread? do we need to?) diff --git a/src/HERMIT/Kernel/Scoped.hs b/src/HERMIT/Kernel/Scoped.hs --- a/src/HERMIT/Kernel/Scoped.hs +++ b/src/HERMIT/Kernel/Scoped.hs @@ -22,7 +22,6 @@ import HERMIT.Context import HERMIT.Kure import HERMIT.GHC hiding (Direction,L) -import HERMIT.Monad import HERMIT.Kernel ---------------------------------------------------------------------------- @@ -59,22 +58,22 @@ -- | An alternative HERMIT kernel, that provides scoping. data ScopedKernel = ScopedKernel - { resumeS :: (MonadIO m, MonadCatch m) => SAST -> m () - , abortS :: MonadIO m => m () + { resumeS :: (MonadIO m, MonadCatch m) => SAST -> m () + , abortS :: MonadIO m => m () , applyS :: (MonadIO m, MonadCatch m, Injection ModGuts g, Walker HermitC g) - => RewriteH g -> HermitMEnv -> SAST -> m SAST + => RewriteH g -> KernelEnv -> SAST -> m SAST , queryS :: (MonadIO m, MonadCatch m, Injection ModGuts g, Walker HermitC g) - => TransformH g a -> HermitMEnv -> SAST -> m a - , deleteS :: (MonadIO m, MonadCatch m) => SAST -> m () - , listS :: MonadIO m => m [SAST] - , pathS :: (MonadIO m, MonadCatch m) => SAST -> m [PathH] + => TransformH g a -> KernelEnv -> SAST -> m a + , deleteS :: (MonadIO m, MonadCatch m) => SAST -> m () + , listS :: MonadIO m => m [SAST] + , pathS :: (MonadIO m, MonadCatch m) => SAST -> m [PathH] , modPathS :: (MonadIO m, MonadCatch m) - => (LocalPathH -> LocalPathH) -> HermitMEnv -> SAST -> m SAST - , beginScopeS :: (MonadIO m, MonadCatch m) => SAST -> m SAST - , endScopeS :: (MonadIO m, MonadCatch m) => SAST -> m SAST + => (LocalPathH -> LocalPathH) -> KernelEnv -> SAST -> m SAST + , beginScopeS :: (MonadIO m, MonadCatch m) => SAST -> m SAST + , endScopeS :: (MonadIO m, MonadCatch m) => SAST -> m SAST -- means of accessing the underlying kernel, obviously for unsafe purposes - , kernelS :: Kernel - , toASTS :: (MonadIO m, MonadCatch m) => SAST -> m AST + , kernelS :: Kernel + , toASTS :: (MonadIO m, MonadCatch m) => SAST -> m AST } -- | A /handle/ for an 'AST' combined with scoping information. @@ -111,9 +110,10 @@ , applyS = \ rr env (SAST sAst) -> safeTakeTMVar store $ \ m -> do (ast, base, rel) <- get sAst m applyK kernel ast (focusR (pathStackToLens base rel) rr) env - >>= runKureM (\ ast' -> atomically $ do k <- newKey - putTMVar store $ I.insert k (ast', base, rel) m - return $ SAST k) + >>= runKureM (\ ast' -> atomically $ do + k <- newKey + putTMVar store $ I.insert k (ast', base, rel) m + return (SAST k)) fail , queryS = \ t env (SAST sAst) -> liftAndCatchIO $ do m <- atomically $ readTMVar store diff --git a/src/HERMIT/Kure.hs b/src/HERMIT/Kure.hs --- a/src/HERMIT/Kure.hs +++ b/src/HERMIT/Kure.hs @@ -69,18 +69,11 @@ , forAllCoT, forAllCoAllR, forAllCoAnyR, forAllCoOneR , coVarCoT, coVarCoR , axiomInstCoT, axiomInstCoAllR, axiomInstCoAnyR, axiomInstCoOneR -#if __GLASGOW_HASKELL__ > 706 -#else - , unsafeCoT, unsafeCoAllR, unsafeCoAnyR, unsafeCoOneR -#endif , symCoT, symCoR , transCoT, transCoAllR, transCoAnyR, transCoOneR , nthCoT, nthCoAllR, nthCoAnyR, nthCoOneR , instCoT, instCoAllR, instCoAnyR, instCoOneR -#if __GLASGOW_HASKELL__ > 706 , lrCoT, lrCoAllR, lrCoAnyR, lrCoOneR -#else -#endif -- * Conversion to deprecated Int representation , deprecatedIntToCrumbT , deprecatedIntToPathT @@ -129,12 +122,12 @@ allR :: forall m. MonadCatch m => Rewrite c m Core -> Rewrite c m Core allR r = prefixFailMsg "allR failed: " $ rewrite $ \ c -> \case - GutsCore guts -> inject <$> apply allRmodguts c guts - ProgCore p -> inject <$> apply allRprog c p - BindCore bn -> inject <$> apply allRbind c bn - DefCore def -> inject <$> apply allRdef c def - AltCore alt -> inject <$> apply allRalt c alt - ExprCore e -> inject <$> apply allRexpr c e + GutsCore guts -> inject <$> applyT allRmodguts c guts + ProgCore p -> inject <$> applyT allRprog c p + BindCore bn -> inject <$> applyT allRbind c bn + DefCore def -> inject <$> applyT allRdef c def + AltCore alt -> inject <$> applyT allRalt c alt + ExprCore e -> inject <$> applyT allRexpr c e where allRmodguts :: MonadCatch m => Rewrite c m ModGuts allRmodguts = modGutsR (extractR r) @@ -203,12 +196,8 @@ TransCo{} -> transCoAllR r r NthCo{} -> nthCoAllR idR r InstCo{} -> instCoAllR r idR -#if __GLASGOW_HASKELL__ > 706 LRCo{} -> lrCoAllR idR r AxiomInstCo{} -> axiomInstCoAllR idR idR (const r) -#else - AxiomInstCo{} -> axiomInstCoAllR idR (const r) -#endif _ -> idR --------------------------------------------------------------------- @@ -219,8 +208,8 @@ allR :: forall m. MonadCatch m => Rewrite c m TyCo -> Rewrite c m TyCo allR r = prefixFailMsg "allR failed: " $ rewrite $ \ c -> \case - TypeCore ty -> inject <$> apply (allR $ extractR r) c ty -- exploiting the fact that types do not contain coercions - CoercionCore co -> inject <$> apply allRcoercion c co + TypeCore ty -> inject <$> applyT (allR $ extractR r) c ty -- exploiting the fact that types do not contain coercions + CoercionCore co -> inject <$> applyT allRcoercion c co where allRcoercion :: MonadCatch m => Rewrite c m Coercion allRcoercion = readerT $ \case @@ -228,20 +217,12 @@ TyConAppCo{} -> tyConAppCoAllR idR (const $ extractR r) -- we don't descend into the TyCon AppCo{} -> appCoAllR (extractR r) (extractR r) ForAllCo{} -> forAllCoAllR idR (extractR r) -- we don't descend into the TyVar -#if __GLASGOW_HASKELL__ > 706 -#else - UnsafeCo{} -> unsafeCoAllR (extractR r) (extractR r) -#endif SymCo{} -> symCoR (extractR r) TransCo{} -> transCoAllR (extractR r) (extractR r) InstCo{} -> instCoAllR (extractR r) (extractR r) NthCo{} -> nthCoAllR idR (extractR r) -- we don't descend into the Int -#if __GLASGOW_HASKELL__ > 706 LRCo{} -> lrCoAllR idR (extractR r) AxiomInstCo{} -> axiomInstCoAllR idR idR (const $ extractR r) -- we don't descend into the axiom or index -#else - AxiomInstCo{} -> axiomInstCoAllR idR (const $ extractR r) -- we don't descend into the axiom -#endif _ -> idR {-# INLINE allRcoercion #-} @@ -253,13 +234,13 @@ allR :: forall m. MonadCatch m => Rewrite c m CoreTC -> Rewrite c m CoreTC allR r = prefixFailMsg "allR failed: " $ rewrite $ \ c -> \case - Core (GutsCore guts) -> inject <$> apply allRmodguts c guts - Core (ProgCore p) -> inject <$> apply allRprog c p - Core (BindCore bn) -> inject <$> apply allRbind c bn - Core (DefCore def) -> inject <$> apply allRdef c def - Core (AltCore alt) -> inject <$> apply allRalt c alt - Core (ExprCore e) -> inject <$> apply allRexpr c e - TyCo tyCo -> inject <$> apply (allR $ extractR r) c tyCo -- exploiting the fact that only types and coercions appear within types and coercions + Core (GutsCore guts) -> inject <$> applyT allRmodguts c guts + Core (ProgCore p) -> inject <$> applyT allRprog c p + Core (BindCore bn) -> inject <$> applyT allRbind c bn + Core (DefCore def) -> inject <$> applyT allRdef c def + Core (AltCore alt) -> inject <$> applyT allRalt c alt + Core (ExprCore e) -> inject <$> applyT allRexpr c e + TyCo tyCo -> inject <$> applyT (allR $ extractR r) c tyCo -- exploiting the fact that only types and coercions appear within types and coercions where allRmodguts :: MonadCatch m => Rewrite c m ModGuts allRmodguts = modGutsR (extractR r) @@ -307,7 +288,7 @@ -- | Transform a module. -- Slightly different to the other congruence combinators: it passes in /all/ of the original to the reconstruction function. modGutsT :: (ExtendPath c Crumb, HasEmptyContext c, Monad m) => Transform c m CoreProg a -> (ModGuts -> a -> b) -> Transform c m ModGuts b -modGutsT t f = transform $ \ c guts -> f guts <$> apply t (setEmptyContext c @@ ModGuts_Prog) (bindsToProg $ mg_binds guts) +modGutsT t f = transform $ \ c guts -> f guts <$> applyT t (setEmptyContext c @@ ModGuts_Prog) (bindsToProg $ mg_binds guts) {-# INLINE modGutsT #-} -- | Rewrite the 'CoreProg' child of a module. @@ -327,7 +308,7 @@ -- | Transform a program of the form: ('CoreBind' @:@ 'CoreProg') progConsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m CoreBind a1 -> Transform c m CoreProg a2 -> (a1 -> a2 -> b) -> Transform c m CoreProg b progConsT t1 t2 f = transform $ \ c -> \case - ProgCons bd p -> f <$> apply t1 (c @@ ProgCons_Head) bd <*> apply t2 (addBindingGroup bd c @@ ProgCons_Tail) p + ProgCons bd p -> f <$> applyT t1 (c @@ ProgCons_Head) bd <*> applyT t2 (addBindingGroup bd c @@ ProgCons_Tail) p _ -> fail "not a non-empty program." {-# INLINE progConsT #-} @@ -351,7 +332,7 @@ -- | Transform a binding group of the form: @NonRec@ 'Var' 'CoreExpr' nonRecT :: (ExtendPath c Crumb, Monad m) => Transform c m Var a1 -> Transform c m CoreExpr a2 -> (a1 -> a2 -> b) -> Transform c m CoreBind b nonRecT t1 t2 f = transform $ \ c -> \case - NonRec v e -> f <$> apply t1 (c @@ NonRec_Var) v <*> apply t2 (c @@ NonRec_RHS) e + NonRec v e -> f <$> applyT t1 (c @@ NonRec_Var) v <*> applyT t2 (c @@ NonRec_RHS) e _ -> fail "not a non-recursive binding group." {-# INLINE nonRecT #-} @@ -375,7 +356,7 @@ recT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Transform c m CoreDef a) -> ([a] -> b) -> Transform c m CoreBind b recT t f = transform $ \ 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 + f <$> sequence [ applyT (t n) (addDefBindingsExcept n bds c @@ Rec_Def n) (Def i e) -- here we convert from (Id,CoreExpr) to CoreDef | ((i,e),n) <- zip bds [0..] ] _ -> fail "not a recursive binding group." @@ -400,7 +381,7 @@ -- | Transform a recursive definition of the form: @Def@ 'Id' 'CoreExpr' defT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m Id a1 -> Transform c m CoreExpr a2 -> (a1 -> a2 -> b) -> Transform c m CoreDef b -defT t1 t2 f = transform $ \ c (Def i e) -> f <$> apply t1 (c @@ Def_Id) i <*> apply t2 (addDefBinding i c @@ Def_RHS) e +defT t1 t2 f = transform $ \ c (Def i e) -> f <$> applyT t1 (c @@ Def_Id) i <*> applyT t2 (addDefBinding i c @@ Def_RHS) e {-# INLINE defT #-} -- | Rewrite all children of a recursive definition of the form: @Def@ 'Id' 'CoreExpr' @@ -422,9 +403,9 @@ -- | Transform a case alternative of the form: ('AltCon', ['Var'], 'CoreExpr') altT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m AltCon a1 -> (Int -> Transform c m Var a2) -> Transform c m CoreExpr a3 -> (a1 -> [a2] -> a3 -> b) -> Transform c m CoreAlt b -altT t1 ts t2 f = transform $ \ 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 +altT t1 ts t2 f = transform $ \ c (con,vs,e) -> f <$> applyT t1 (c @@ Alt_Con) con + <*> sequence [ applyT (ts n) (c @@ Alt_Var n) v | (v,n) <- zip vs [1..] ] + <*> applyT t2 (addAltBindings vs c @@ Alt_RHS) e {-# INLINE altT #-} -- | Rewrite all children of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr') @@ -447,7 +428,7 @@ -- | Transform an expression of the form: @Var@ 'Id' varT :: (ExtendPath c Crumb, Monad m) => Transform c m Id b -> Transform c m CoreExpr b varT t = transform $ \ c -> \case - Var v -> apply t (c @@ Var_Id) v + Var v -> applyT t (c @@ Var_Id) v _ -> fail "not a variable." {-# INLINE varT #-} @@ -460,7 +441,7 @@ -- | Transform an expression of the form: @Lit@ 'Literal' litT :: (ExtendPath c Crumb, Monad m) => Transform c m Literal b -> Transform c m CoreExpr b litT t = transform $ \ c -> \case - Lit x -> apply t (c @@ Lit_Lit) x + Lit x -> applyT t (c @@ Lit_Lit) x _ -> fail "not a literal." {-# INLINE litT #-} @@ -473,7 +454,7 @@ -- | Transform an expression of the form: @App@ 'CoreExpr' 'CoreExpr' appT :: (ExtendPath c Crumb, Monad m) => Transform c m CoreExpr a1 -> Transform c m CoreExpr a2 -> (a1 -> a2 -> b) -> Transform c m CoreExpr b appT t1 t2 f = transform $ \ c -> \case - App e1 e2 -> f <$> apply t1 (c @@ App_Fun) e1 <*> apply t2 (c @@ App_Arg) e2 + App e1 e2 -> f <$> applyT t1 (c @@ App_Fun) e1 <*> applyT t2 (c @@ App_Arg) e2 _ -> fail "not an application." {-# INLINE appT #-} @@ -496,7 +477,7 @@ -- | Transform an expression of the form: @Lam@ 'Var' 'CoreExpr' lamT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m Var a1 -> Transform c m CoreExpr a2 -> (a1 -> a2 -> b) -> Transform c m CoreExpr b lamT t1 t2 f = transform $ \ c -> \case - Lam v e -> f <$> apply t1 (c @@ Lam_Var) v <*> apply t2 (addLambdaBinding v c @@ Lam_Body) e + Lam v e -> f <$> applyT t1 (c @@ Lam_Var) v <*> applyT t2 (addLambdaBinding v c @@ Lam_Body) e _ -> fail "not a lambda." {-# INLINE lamT #-} @@ -521,7 +502,7 @@ letT t1 t2 f = transform $ \ 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. - f <$> apply t1 (c @@ Let_Bind) bds <*> apply t2 (addBindingGroup bds c @@ Let_Body) e + f <$> applyT t1 (c @@ Let_Bind) bds <*> applyT t2 (addBindingGroup bds c @@ Let_Body) e _ -> fail "not a let node." {-# INLINE letT #-} @@ -550,10 +531,10 @@ -> (e -> w -> ty -> [alt] -> b) -> Transform c m CoreExpr b caseT te tw tty talts f = transform $ \ c -> \case - Case e w ty alts -> f <$> apply te (c @@ Case_Scrutinee) e - <*> apply tw (c @@ Case_Binder) w - <*> apply tty (c @@ Case_Type) ty - <*> sequence [ apply (talts n) (addCaseBinderBinding (w,e,alt) c @@ Case_Alt n) alt + Case e w ty alts -> f <$> applyT te (c @@ Case_Scrutinee) e + <*> applyT tw (c @@ Case_Binder) w + <*> applyT tty (c @@ Case_Type) ty + <*> sequence [ applyT (talts n) (addCaseBinderBinding (w,e,alt) c @@ Case_Alt n) alt | (alt,n) <- zip alts [0..] ] _ -> fail "not a case." @@ -593,7 +574,7 @@ -- | Transform an expression of the form: @Cast@ 'CoreExpr' 'Coercion' castT :: (ExtendPath c Crumb, Monad m) => Transform c m CoreExpr a1 -> Transform c m Coercion a2 -> (a1 -> a2 -> b) -> Transform c m CoreExpr b castT t1 t2 f = transform $ \ c -> \case - Cast e co -> f <$> apply t1 (c @@ Cast_Expr) e <*> apply t2 (c @@ Cast_Co) co + Cast e co -> f <$> applyT t1 (c @@ Cast_Expr) e <*> applyT t2 (c @@ Cast_Co) co _ -> fail "not a cast." {-# INLINE castT #-} @@ -616,7 +597,7 @@ -- | Transform an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr' tickT :: (ExtendPath c Crumb, Monad m) => Transform c m CoreTickish a1 -> Transform c m CoreExpr a2 -> (a1 -> a2 -> b) -> Transform c m CoreExpr b tickT t1 t2 f = transform $ \ c -> \case - Tick tk e -> f <$> apply t1 (c @@ Tick_Tick) tk <*> apply t2 (c @@ Tick_Expr) e + Tick tk e -> f <$> applyT t1 (c @@ Tick_Tick) tk <*> applyT t2 (c @@ Tick_Expr) e _ -> fail "not a tick." {-# INLINE tickT #-} @@ -639,7 +620,7 @@ -- | Transform an expression of the form: @Type@ 'Type' typeT :: (ExtendPath c Crumb, Monad m) => Transform c m Type b -> Transform c m CoreExpr b typeT t = transform $ \ c -> \case - Type ty -> apply t (c @@ Type_Type) ty + Type ty -> applyT t (c @@ Type_Type) ty _ -> fail "not a type." {-# INLINE typeT #-} @@ -652,7 +633,7 @@ -- | Transform an expression of the form: @Coercion@ 'Coercion' coercionT :: (ExtendPath c Crumb, Monad m) => Transform c m Coercion b -> Transform c m CoreExpr b coercionT t = transform $ \ c -> \case - Coercion co -> apply t (c @@ Co_Co) co + Coercion co -> applyT t (c @@ Co_Co) co _ -> fail "not a coercion." {-# INLINE coercionT #-} @@ -910,7 +891,7 @@ -- | Transform a type of the form: @TyVarTy@ 'TyVar' tyVarT :: (ExtendPath c Crumb, Monad m) => Transform c m TyVar b -> Transform c m Type b tyVarT t = transform $ \ c -> \case - TyVarTy v -> apply t (c @@ TyVarTy_TyVar) v + TyVarTy v -> applyT t (c @@ TyVarTy_TyVar) v _ -> fail "not a type variable." {-# INLINE tyVarT #-} @@ -923,7 +904,7 @@ -- | Transform a type of the form: @LitTy@ 'TyLit' litTyT :: (ExtendPath c Crumb, Monad m) => Transform c m TyLit b -> Transform c m Type b litTyT t = transform $ \ c -> \case - LitTy x -> apply t (c @@ LitTy_TyLit) x + LitTy x -> applyT t (c @@ LitTy_TyLit) x _ -> fail "not a type literal." {-# INLINE litTyT #-} @@ -936,7 +917,7 @@ -- | Transform a type of the form: @AppTy@ 'Type' 'Type' appTyT :: (ExtendPath c Crumb, Monad m) => Transform c m Type a1 -> Transform c m Type a2 -> (a1 -> a2 -> b) -> Transform c m Type b appTyT t1 t2 f = transform $ \ c -> \case - AppTy ty1 ty2 -> f <$> apply t1 (c @@ AppTy_Fun) ty1 <*> apply t2 (c @@ AppTy_Arg) ty2 + AppTy ty1 ty2 -> f <$> applyT t1 (c @@ AppTy_Fun) ty1 <*> applyT t2 (c @@ AppTy_Arg) ty2 _ -> fail "not a type application." {-# INLINE appTyT #-} @@ -959,7 +940,7 @@ -- | Transform a type of the form: @FunTy@ 'Type' 'Type' funTyT :: (ExtendPath c Crumb, Monad m) => Transform c m Type a1 -> Transform c m Type a2 -> (a1 -> a2 -> b) -> Transform c m Type b funTyT t1 t2 f = transform $ \ c -> \case - FunTy ty1 ty2 -> f <$> apply t1 (c @@ FunTy_Dom) ty1 <*> apply t2 (c @@ FunTy_CoDom) ty2 + FunTy ty1 ty2 -> f <$> applyT t1 (c @@ FunTy_Dom) ty1 <*> applyT t2 (c @@ FunTy_CoDom) ty2 _ -> fail "not a function type." {-# INLINE funTyT #-} @@ -982,7 +963,7 @@ -- | Transform a type of the form: @ForAllTy@ 'Var' 'Type' forAllTyT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m Var a1 -> Transform c m Type a2 -> (a1 -> a2 -> b) -> Transform c m Type b forAllTyT t1 t2 f = transform $ \ c -> \case - ForAllTy v ty -> f <$> apply t1 (c @@ ForAllTy_Var) v <*> apply t2 (addForallBinding v c @@ ForAllTy_Body) ty + ForAllTy v ty -> f <$> applyT t1 (c @@ ForAllTy_Var) v <*> applyT t2 (addForallBinding v c @@ ForAllTy_Body) ty _ -> fail "not a forall type." {-# INLINE forAllTyT #-} @@ -1005,7 +986,7 @@ -- | Transform a type of the form: @TyConApp@ 'TyCon' ['KindOrType'] tyConAppT :: (ExtendPath c Crumb, Monad m) => Transform c m TyCon a1 -> (Int -> Transform c m KindOrType a2) -> (a1 -> [a2] -> b) -> Transform c m Type b tyConAppT t ts f = transform $ \ c -> \case - TyConApp con tys -> f <$> apply t (c @@ TyConApp_TyCon) con <*> sequence [ apply (ts n) (c @@ TyConApp_Arg n) ty | (ty,n) <- zip tys [0..] ] + TyConApp con tys -> f <$> applyT t (c @@ TyConApp_TyCon) con <*> sequence [ applyT (ts n) (c @@ TyConApp_Arg n) ty | (ty,n) <- zip tys [0..] ] _ -> fail "not a type-constructor application." {-# INLINE tyConAppT #-} @@ -1030,43 +1011,23 @@ -- Coercions -- TODO: review and bring all these up-to-date for Coercions w/ Roles in 7.8 -#if __GLASGOW_HASKELL__ > 706 -- | Transform a coercion of the form: @Refl@ 'Role' 'Type' reflT :: (ExtendPath c Crumb, Monad m) => Transform c m Type a1 -> (Role -> a1 -> b) -> Transform c m Coercion b reflT t f = transform $ \ c -> \case - Refl r ty -> f r <$> apply t (c @@ Refl_Type) ty + Refl r ty -> f r <$> applyT t (c @@ Refl_Type) ty _ -> fail "not a reflexive coercion." -- | Rewrite the 'Type' child of a coercion of the form: @Refl@ 'Role' 'Type' reflR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Type -> Rewrite c m Coercion reflR r = reflT r Refl -#else --- | Transform a coercion of the form: @Refl@ 'Type' -reflT :: (ExtendPath c Crumb, Monad m) => Transform c m Type b -> Transform c m Coercion b -reflT t = transform $ \ c -> \case - Refl ty -> apply t (c @@ Refl_Type) ty - _ -> fail "not a reflexive coercion." - --- | Rewrite the 'Type' child of a coercion of the form: @Refl@ 'Type' -reflR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Type -> Rewrite c m Coercion -reflR r = reflT (Refl <$> r) -#endif {-# INLINE reflT #-} {-# INLINE reflR #-} -#if __GLASGOW_HASKELL__ > 706 -- | Transform a coercion of the form: @TyConAppCo@ 'Role' 'TyCon' ['Coercion'] tyConAppCoT :: (ExtendPath c Crumb, Monad m) => Transform c m TyCon a1 -> (Int -> Transform c m Coercion a2) -> (Role -> a1 -> [a2] -> b) -> Transform c m Coercion b tyConAppCoT t ts f = transform $ \ c -> \case - TyConAppCo r con coes -> f r <$> apply t (c @@ TyConAppCo_TyCon) con <*> sequence [ apply (ts n) (c @@ TyConAppCo_Arg n) co | (co,n) <- zip coes [0..] ] + TyConAppCo r con coes -> f r <$> applyT t (c @@ TyConAppCo_TyCon) con <*> sequence [ applyT (ts n) (c @@ TyConAppCo_Arg n) co | (co,n) <- zip coes [0..] ] _ -> fail "not a type-constructor coercion." -#else --- | Transform a coercion of the form: @TyConAppCo@ 'TyCon' ['Coercion'] -tyConAppCoT :: (ExtendPath c Crumb, Monad m) => Transform c m TyCon a1 -> (Int -> Transform c m Coercion a2) -> (a1 -> [a2] -> b) -> Transform c m Coercion b -tyConAppCoT t ts f = transform $ \ c -> \case - TyConAppCo con coes -> f <$> apply t (c @@ TyConAppCo_TyCon) con <*> sequence [ apply (ts n) (c @@ TyConAppCo_Arg n) co | (co,n) <- zip coes [0..] ] - _ -> fail "not a type-constructor coercion." -#endif {-# INLINE tyConAppCoT #-} -- | Rewrite all children of a coercion of the form: @TyConAppCo@ 'TyCon' ['Coercion'] @@ -1088,7 +1049,7 @@ -- | Transform a coercion of the form: @AppCo@ 'Coercion' 'Coercion' appCoT :: (ExtendPath c Crumb, Monad m) => Transform c m Coercion a1 -> Transform c m Coercion a2 -> (a1 -> a2 -> b) -> Transform c m Coercion b appCoT t1 t2 f = transform $ \ c -> \case - AppCo co1 co2 -> f <$> apply t1 (c @@ AppCo_Fun) co1 <*> apply t2 (c @@ AppCo_Arg) co2 + AppCo co1 co2 -> f <$> applyT t1 (c @@ AppCo_Fun) co1 <*> applyT t2 (c @@ AppCo_Arg) co2 _ -> fail "not a coercion application." {-# INLINE appCoT #-} @@ -1111,7 +1072,7 @@ -- | Transform a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion' forAllCoT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m TyVar a1 -> Transform c m Coercion a2 -> (a1 -> a2 -> b) -> Transform c m Coercion b forAllCoT t1 t2 f = transform $ \ c -> \case - ForAllCo v co -> f <$> apply t1 (c @@ ForAllCo_TyVar) v <*> apply t2 (addForallBinding v c @@ ForAllCo_Body) co + ForAllCo v co -> f <$> applyT t1 (c @@ ForAllCo_TyVar) v <*> applyT t2 (addForallBinding v c @@ ForAllCo_Body) co _ -> fail "not a forall coercion." {-# INLINE forAllCoT #-} @@ -1134,7 +1095,7 @@ -- | Transform a coercion of the form: @CoVarCo@ 'CoVar' coVarCoT :: (ExtendPath c Crumb, Monad m) => Transform c m CoVar b -> Transform c m Coercion b coVarCoT t = transform $ \ c -> \case - CoVarCo v -> apply t (c @@ CoVarCo_CoVar) v + CoVarCo v -> applyT t (c @@ CoVarCo_CoVar) v _ -> fail "not a coercion variable." {-# INLINE coVarCoT #-} @@ -1143,83 +1104,33 @@ coVarCoR r = coVarCoT (CoVarCo <$> r) {-# INLINE coVarCoR #-} -#if __GLASGOW_HASKELL__ > 706 -- | Transform a coercion of the form: @AxiomInstCo@ ('CoAxiom' 'Branched') 'BranchIndex' ['Coercion'] axiomInstCoT :: (ExtendPath c Crumb, Monad m) => Transform c m (CoAxiom Branched) a1 -> Transform c m BranchIndex a2 -> (Int -> Transform c m Coercion a3) -> (a1 -> a2 -> [a3] -> b) -> Transform c m Coercion b axiomInstCoT t1 t2 ts f = transform $ \ c -> \case - AxiomInstCo ax idx coes -> f <$> apply t1 (c @@ AxiomInstCo_Axiom) ax <*> apply t2 (c @@ AxiomInstCo_Index) idx <*> sequence [ apply (ts n) (c @@ AxiomInstCo_Arg n) co | (co,n) <- zip coes [0..] ] + AxiomInstCo ax idx coes -> f <$> applyT t1 (c @@ AxiomInstCo_Axiom) ax <*> applyT t2 (c @@ AxiomInstCo_Index) idx <*> sequence [ applyT (ts n) (c @@ AxiomInstCo_Arg n) co | (co,n) <- zip coes [0..] ] _ -> fail "not a coercion axiom instantiation." -#else --- | Transform a coercion of the form: @AxiomInstCo@ 'CoAxiom' ['Coercion'] -axiomInstCoT :: (ExtendPath c Crumb, Monad m) => Transform c m CoAxiom a1 -> (Int -> Transform c m Coercion a2) -> (a1 -> [a2] -> b) -> Transform c m Coercion b -axiomInstCoT t ts f = transform $ \ c -> \case - AxiomInstCo ax coes -> f <$> apply t (c @@ AxiomInstCo_Axiom) ax <*> sequence [ apply (ts n) (c @@ AxiomInstCo_Arg n) co | (co,n) <- zip coes [0..] ] - _ -> fail "not a coercion axiom instantiation." -#endif {-# INLINE axiomInstCoT #-} -#if __GLASGOW_HASKELL__ > 706 -- | Rewrite all children of a coercion of the form: @AxiomInstCo@ ('CoAxiom' 'Branched') 'BranchIndex' ['Coercion'] axiomInstCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m (CoAxiom Branched) -> Rewrite c m BranchIndex -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion axiomInstCoAllR r1 r2 rs = axiomInstCoT r1 r2 rs AxiomInstCo -#else --- | Rewrite all children of a coercion of the form: @AxiomInstCo@ 'CoAxiom' ['Coercion'] -axiomInstCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoAxiom -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion -axiomInstCoAllR r rs = axiomInstCoT r rs AxiomInstCo -#endif {-# INLINE axiomInstCoAllR #-} -#if __GLASGOW_HASKELL__ > 706 -- | Rewrite any children of a coercion of the form: @AxiomInstCo@ ('CoAxiom' 'Branched') 'BranchIndex' ['Coercion'] axiomInstCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m (CoAxiom Branched) -> Rewrite c m BranchIndex -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion axiomInstCoAnyR r1 r2 rs = unwrapAnyR $ axiomInstCoAllR (wrapAnyR r1) (wrapAnyR r2) (wrapAnyR . rs) -#else --- | Rewrite any children of a coercion of the form: @AxiomInstCo@ 'CoAxiom' ['Coercion'] -axiomInstCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoAxiom -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion -axiomInstCoAnyR r rs = unwrapAnyR $ axiomInstCoAllR (wrapAnyR r) (wrapAnyR . rs) -#endif {-# INLINE axiomInstCoAnyR #-} -#if __GLASGOW_HASKELL__ > 706 -- | Rewrite one child of a coercion of the form: @AxiomInstCo@ ('CoAxiom' 'Branched') 'BranchIndex' ['Coercion'] axiomInstCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m (CoAxiom Branched) -> Rewrite c m BranchIndex -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion axiomInstCoOneR r1 r2 rs = unwrapOneR $ axiomInstCoAllR (wrapOneR r1) (wrapOneR r2) (wrapOneR . rs) -#else --- | Rewrite one child of a coercion of the form: @AxiomInstCo@ 'CoAxiom' ['Coercion'] -axiomInstCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoAxiom -> (Int -> Rewrite c m Coercion) -> Rewrite c m Coercion -axiomInstCoOneR r rs = unwrapOneR $ axiomInstCoAllR (wrapOneR r) (wrapOneR . rs) -#endif {-# INLINE axiomInstCoOneR #-} -#if __GLASGOW_HASKELL__ > 706 -#else --- | Transform a coercion of the form: @UnsafeCo@ 'Type' 'Type' -unsafeCoT :: (ExtendPath c Crumb, Monad m) => Transform c m Type a1 -> Transform c m Type a2 -> (a1 -> a2 -> b) -> Transform c m Coercion b -unsafeCoT t1 t2 f = transform $ \ c -> \case - UnsafeCo ty1 ty2 -> f <$> apply t1 (c @@ UnsafeCo_Left) ty1 <*> apply t2 (c @@ UnsafeCo_Right) ty2 - _ -> fail "not an unsafe coercion." -{-# INLINE unsafeCoT #-} --- | Rewrite all children of a coercion of the form: @UnsafeCo@ 'Type' 'Type' -unsafeCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Coercion -unsafeCoAllR r1 r2 = unsafeCoT r1 r2 UnsafeCo -{-# INLINE unsafeCoAllR #-} - --- | Rewrite any children of a coercion of the form: @UnsafeCo@ 'Type' 'Type' -unsafeCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Coercion -unsafeCoAnyR r1 r2 = unwrapAnyR $ unsafeCoAllR (wrapAnyR r1) (wrapAnyR r2) -{-# INLINE unsafeCoAnyR #-} - --- | Rewrite one child of a coercion of the form: @UnsafeCo@ 'Type' 'Type' -unsafeCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Coercion -unsafeCoOneR r1 r2 = unwrapOneR $ unsafeCoAllR (wrapOneR r1) (wrapOneR r2) -{-# INLINE unsafeCoOneR #-} -#endif - -- | Transform a coercion of the form: @SymCo@ 'Coercion' symCoT :: (ExtendPath c Crumb, Monad m) => Transform c m Coercion b -> Transform c m Coercion b symCoT t = transform $ \ c -> \case - SymCo co -> apply t (c @@ SymCo_Co) co + SymCo co -> applyT t (c @@ SymCo_Co) co _ -> fail "not a symmetric coercion." {-# INLINE symCoT #-} @@ -1232,7 +1143,7 @@ -- | Transform a coercion of the form: @TransCo@ 'Coercion' 'Coercion' transCoT :: (ExtendPath c Crumb, Monad m) => Transform c m Coercion a1 -> Transform c m Coercion a2 -> (a1 -> a2 -> b) -> Transform c m Coercion b transCoT t1 t2 f = transform $ \ c -> \case - TransCo co1 co2 -> f <$> apply t1 (c @@ TransCo_Left) co1 <*> apply t2 (c @@ TransCo_Right) co2 + TransCo co1 co2 -> f <$> applyT t1 (c @@ TransCo_Left) co1 <*> applyT t2 (c @@ TransCo_Right) co2 _ -> fail "not a transitive coercion." {-# INLINE transCoT #-} @@ -1255,7 +1166,7 @@ -- | Transform a coercion of the form: @NthCo@ 'Int' 'Coercion' nthCoT :: (ExtendPath c Crumb, Monad m) => Transform c m Int a1 -> Transform c m Coercion a2 -> (a1 -> a2 -> b) -> Transform c m Coercion b nthCoT t1 t2 f = transform $ \ c -> \case - NthCo n co -> f <$> apply t1 (c @@ NthCo_Int) n <*> apply t2 (c @@ NthCo_Co) co + NthCo n co -> f <$> applyT t1 (c @@ NthCo_Int) n <*> applyT t2 (c @@ NthCo_Co) co _ -> fail "not an Nth coercion." {-# INLINE nthCoT #-} @@ -1275,11 +1186,10 @@ {-# INLINE nthCoOneR #-} -#if __GLASGOW_HASKELL__ > 706 -- | Transform a coercion of the form: @LRCo@ 'LeftOrRight' 'Coercion' lrCoT :: (ExtendPath c Crumb, Monad m) => Transform c m LeftOrRight a1 -> Transform c m Coercion a2 -> (a1 -> a2 -> b) -> Transform c m Coercion b lrCoT t1 t2 f = transform $ \ c -> \case - LRCo lr co -> f <$> apply t1 (c @@ LRCo_LR) lr <*> apply t2 (c @@ LRCo_Co) co + LRCo lr co -> f <$> applyT t1 (c @@ LRCo_LR) lr <*> applyT t2 (c @@ LRCo_Co) co _ -> fail "not a left/right coercion." {-# INLINE lrCoT #-} @@ -1297,14 +1207,12 @@ lrCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m LeftOrRight -> Rewrite c m Coercion -> Rewrite c m Coercion lrCoOneR r1 r2 = unwrapOneR $ lrCoAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE lrCoOneR #-} -#else -#endif -- | Transform a coercion of the form: @InstCo@ 'Coercion' 'Type' instCoT :: (ExtendPath c Crumb, Monad m) => Transform c m Coercion a1 -> Transform c m Type a2 -> (a1 -> a2 -> b) -> Transform c m Coercion b instCoT t1 t2 f = transform $ \ c -> \case - InstCo co ty -> f <$> apply t1 (c @@ InstCo_Co) co <*> apply t2 (c @@ InstCo_Type) ty + InstCo co ty -> f <$> applyT t1 (c @@ InstCo_Co) co <*> applyT t2 (c @@ InstCo_Type) ty _ -> fail "not a coercion instantiation." {-# INLINE instCoT #-} @@ -1356,3 +1264,6 @@ --------------------------------------------------------------------- --------------------------------------------------------------------- + +instance HasDynFlags m => HasDynFlags (Transform c m a) where + getDynFlags = constT getDynFlags diff --git a/src/HERMIT/Monad.hs b/src/HERMIT/Monad.hs --- a/src/HERMIT/Monad.hs +++ b/src/HERMIT/Monad.hs @@ -1,42 +1,51 @@ -{-# LANGUAGE CPP, InstanceSigs #-} +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, GADTs, InstanceSigs, KindSignatures #-} module HERMIT.Monad - ( - -- * The HERMIT Monad - HermitM - , runHM - , liftCoreM - , newGlobalIdH - , newIdH - , newTyVarH - , newCoVarH - , newVarH - , cloneVarH - -- * Saving Definitions - , Label - , DefStash - , saveDef - , lookupDef - , getStash - -- * Reader Information - , HasHermitMEnv(..) - , HasModGuts(..) - , HasHscEnv(..) - -- * Messages - , HermitMEnv(..) - , DebugMessage(..) - , mkHermitMEnv - , sendDebugMessage -) where + ( -- * The HERMIT Monad + HermitM + , runHM + , embedHermitM + , HermitMEnv(..) + , HermitMResult(..) + , LiftCoreM(..) + , runTcM + , runDsM + -- * Saving Definitions + , RememberedName(..) + , DefStash + , saveDef + , lookupDef + , HasStash(..) + -- * Lemmas + , Equality(..) + , LemmaName(..) + , Lemma(..) + , Lemmas + , addLemma + -- * Reader Information + , HasHermitMEnv(..) + , mkEnv + , getModGuts + , HasHscEnv(..) + -- * Writer Information + , HasLemmas(..) + -- * Messages + , HasDebugChan(..) + , DebugMessage(..) + , sendDebugMessage + ) where import Prelude hiding (lookup) +import Data.Dynamic (Typeable) import Data.Map +import Data.String (IsString(..)) -import Control.Monad -import Control.Monad.IO.Class import Control.Applicative import Control.Arrow +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.IO.Class import Language.KURE @@ -44,78 +53,93 @@ import HERMIT.Context import HERMIT.Kure.SumTypes import HERMIT.GHC - -#if __GLASGOW_HASKELL__ > 706 import HERMIT.GHC.Typechecker -#endif ---------------------------------------------------------------------------- --- | A label for individual definitions. -type Label = String - --- | A store of saved definitions. -type DefStash = Map Label CoreDef - --- | A way of sending messages to top level -newtype HermitMEnv = HermitMEnv { hs_debugChan :: DebugMessage -> HermitM () } +-- | A label for individual definitions. Use a newtype so we can tab-complete in shell. +newtype RememberedName = RememberedName String deriving (Eq, Ord, Typeable) --- | The HERMIT monad is kept abstract. -newtype HermitM a = HermitM ((ModGuts,HermitMEnv) -> DefStash -> CoreM (KureM (DefStash, a))) +instance IsString RememberedName where fromString = RememberedName +instance Show RememberedName where show (RememberedName s) = s -runHermitM :: HermitM a -> (ModGuts,HermitMEnv) -> DefStash -> CoreM (KureM (DefStash, a)) -runHermitM (HermitM f) = f +-- | A store of saved definitions. +type DefStash = Map RememberedName CoreDef --- | Eliminator for 'HermitM'. -runHM :: (ModGuts,HermitMEnv) -> DefStash -> (DefStash -> a -> CoreM b) -> (String -> CoreM b) -> HermitM a -> CoreM b -runHM env s success failure ma = runHermitM ma env s >>= runKureM (\ (a,b) -> success a b) failure +-- | An equality is represented as a set of universally quantified binders, and the LHS and RHS of the equality. +data Equality = Equality [CoreBndr] CoreExpr CoreExpr ----------------------------------------------------------------------------- +-- | A name for lemmas. Use a newtype so we can tab-complete in shell. +newtype LemmaName = LemmaName String deriving (Eq, Ord, Typeable) --- | Get the stash of saved definitions. -getStash :: HermitM DefStash -getStash = HermitM (\ _ s -> return $ return (s, s)) +instance IsString LemmaName where fromString = LemmaName +instance Show LemmaName where show (LemmaName s) = s --- | Replace the stash of saved definitions. -putStash :: DefStash -> HermitM () -putStash s = HermitM (\ _ _ -> return $ return (s, ())) +-- | An equality with a proven status. +data Lemma = Lemma { lemmaEq :: Equality + , lemmaP :: Bool -- whether lemma has been proven + , lemmaU :: Bool -- whether lemma has been used + } -class HasHermitMEnv m where - -- | Get the HermitMEnv - getHermitMEnv :: m HermitMEnv +-- | A collectin of named lemmas. +type Lemmas = Map LemmaName Lemma -instance HasHermitMEnv HermitM where - getHermitMEnv = HermitM (\ rdr s -> return $ return (s, snd rdr)) +-- | The HermitM reader environment. +data HermitMEnv = HermitMEnv { hEnvModGuts :: ModGuts -- ^ Note: this is a snapshot of the ModGuts from + -- before the current transformation. + , hEnvStash :: DefStash + , hEnvLemmas :: Lemmas + } -class HasModGuts m where - -- | Get the ModGuts (Note: this is a snapshot of the ModGuts from before the current transformation.) - getModGuts :: m ModGuts +mkEnv :: ModGuts -> DefStash -> Lemmas -> HermitMEnv +mkEnv = HermitMEnv -instance HasModGuts HermitM where - getModGuts = HermitM (\ rdr s -> return $ return (s, fst rdr)) +-- | The HermitM result record. +data HermitMResult a = HermitMResult { hResStash :: DefStash + , hResLemmas :: Lemmas + , hResult :: a + } -class HasHscEnv m where - getHscEnv :: m HscEnv +mkResult :: DefStash -> Lemmas -> a -> HermitMResult a +mkResult = HermitMResult -instance HasHscEnv CoreM where - getHscEnv = getHscEnvCoreM +mkResultEnv :: HermitMEnv -> a -> HermitMResult a +mkResultEnv env = mkResult (hEnvStash env) (hEnvLemmas env) -instance HasHscEnv HermitM where - getHscEnv = liftCoreM getHscEnv +-- | The HERMIT monad is kept abstract. +-- +-- It provides a reader for ModGuts, state for DefStash and Lemmas, +-- and access to a debugging channel. +newtype HermitM a = HermitM { runHermitM :: DebugChan -> HermitMEnv -> CoreM (KureM (HermitMResult a)) } -sendDebugMessage :: DebugMessage -> HermitM () -sendDebugMessage msg = do env <- getHermitMEnv - hs_debugChan env msg +type DebugChan = DebugMessage -> HermitM () --- | Save a definition for future use. -saveDef :: Label -> CoreDef -> HermitM () -saveDef l d = getStash >>= (insert l d >>> putStash) +-- | Eliminator for 'HermitM'. +runHM :: DebugChan -- debug chan + -> HermitMEnv -- env + -> (HermitMResult a -> CoreM b) -- success + -> (String -> CoreM b) -- failure + -> HermitM a -- ma + -> CoreM b +runHM chan env success failure ma = runHermitM ma chan env >>= runKureM success failure --- | Lookup a previously saved definition. -lookupDef :: Label -> HermitM CoreDef -lookupDef l = getStash >>= (lookup l >>> maybe (fail "Definition not found.") return) +-- | Allow HermitM to be embedded in another monad with proper capabilities. +embedHermitM :: (HasDebugChan m, HasHermitMEnv m, HasLemmas m, HasStash m, LiftCoreM m) => HermitM a -> m a +embedHermitM hm = do + env <- getHermitMEnv + c <- liftCoreM $ liftIO newTChanIO -- we are careful to do IO within liftCoreM to avoid the MonadIO constraint + r <- liftCoreM (runHermitM hm (liftIO . atomically . writeTChan c) env) >>= runKureM return fail + chan <- getDebugChan + let relayDebugMessages = do + mm <- liftCoreM $ liftIO $ atomically $ tryReadTChan c + case mm of + Nothing -> return () + Just dm -> chan dm >> relayDebugMessages ----------------------------------------------------------------------------- + relayDebugMessages + putStash $ hResStash r + forM_ (toList (hResLemmas r)) $ uncurry insertLemma + return $ hResult r instance Functor HermitM where fmap :: (a -> b) -> HermitM a -> HermitM b @@ -130,24 +154,22 @@ instance Monad HermitM where return :: a -> HermitM a - return a = HermitM $ \ _ s -> return (return (s,a)) + return a = HermitM $ \ _ env -> return (return (mkResultEnv env a)) (>>=) :: HermitM a -> (a -> HermitM b) -> HermitM b - (HermitM gcm) >>= f = HermitM $ \ env -> gcm env >=> runKureM (\ (s', a) -> runHermitM (f a) env s') (return . fail) + (HermitM gcm) >>= f = + HermitM $ \ chan env -> gcm chan env >>= runKureM (\ (HermitMResult s ls a) -> + let env' = env { hEnvStash = s, hEnvLemmas = ls } + in runHermitM (f a) chan env') + (return . fail) fail :: String -> HermitM a fail msg = HermitM $ \ _ _ -> return (fail msg) instance MonadCatch HermitM where catchM :: HermitM a -> (String -> HermitM a) -> HermitM a - (HermitM gcm) `catchM` f = HermitM $ \ env s -> gcm env s >>= runKureM (return.return) (\ msg -> runHermitM (f msg) env s) - ----------------------------------------------------------------------------- - --- | 'CoreM' can be lifted to 'HermitM'. -liftCoreM :: CoreM a -> HermitM a -liftCoreM ma = HermitM $ \ _ s -> do a <- ma - return (return (s,a)) + (HermitM gcm) `catchM` f = HermitM $ \ chan env -> gcm chan env >>= runKureM (return.return) + (\ msg -> runHermitM (f msg) chan env) instance MonadIO HermitM where liftIO :: IO a -> HermitM a @@ -170,65 +192,120 @@ -- *most* things from the current module. However, -- some Ids, such as class method selectors, are not -- explicitly bound in the core, so will not be in - -- the context. These are instead kept in the + -- the context. These are instead kept in the -- ModGuts' list of instances. Which this will find. - lookupThing nm = do -#if __GLASGOW_HASKELL__ < 708 - liftCoreM (lookupThing nm) -#else - guts <- getModGuts - liftCoreM $ runTcMtoCoreM guts $ tcLookupGlobal nm -#endif + lookupThing nm = runTcM $ tcLookupGlobal nm instance HasDynFlags HermitM where - getDynFlags :: HermitM DynFlags - getDynFlags = liftCoreM getDynFlags + getDynFlags :: HermitM DynFlags + getDynFlags = liftCoreM getDynFlags ---------------------------------------------------------------------------- -newName :: String -> HermitM Name -newName nm = mkSystemVarName <$> getUniqueM <*> pure (mkFastString nm) +class HasStash m where + -- | Get the stash of saved definitions. + getStash :: m DefStash --- | Make a unique global identifier for a specified type, using a provided name. -newGlobalIdH :: String -> Type -> HermitM Id -newGlobalIdH nm ty = mkVanillaGlobal <$> newName nm <*> pure ty + -- | Replace the stash of saved definitions. + putStash :: DefStash -> m () --- | Make a unique identifier for a specified type, using a provided name. -newIdH :: String -> Type -> HermitM Id -newIdH nm ty = mkLocalId <$> newName nm <*> pure ty +instance HasStash HermitM where + getStash = HermitM $ \ _ env -> return $ return $ mkResultEnv env $ hEnvStash env --- | Make a unique type variable for a specified kind, using a provided name. -newTyVarH :: String -> Kind -> HermitM TyVar -newTyVarH nm k = mkTyVar <$> newName nm <*> pure k + putStash s = HermitM $ \ _ env -> return $ return $ mkResult s (hEnvLemmas env) () --- | Make a unique coercion variable for a specified type, using a provided name. -newCoVarH :: String -> Type -> HermitM TyVar -newCoVarH nm ty = mkCoVar <$> newName nm <*> pure ty +-- | Save a definition for future use. +saveDef :: (HasStash m, Monad m) => RememberedName -> CoreDef -> m () +saveDef l d = getStash >>= (insert l d >>> putStash) --- TODO: not sure if the predicates are correct. --- | Experimental, use at your own risk. -newVarH :: String -> KindOrType -> HermitM Var -newVarH name tk | isCoVarType tk = newCoVarH name tk - | isKind tk = newTyVarH name tk - | otherwise = newIdH name tk +-- | Lookup a previously saved definition. +lookupDef :: (HasStash m, Monad m) => RememberedName -> m CoreDef +lookupDef l = getStash >>= (lookup l >>> maybe (fail "Definition not found.") return) --- | Make a new variable of the same type, with a modified textual name. -cloneVarH :: (String -> String) -> Var -> HermitM Var -cloneVarH nameMod v | isTyVar v = newTyVarH name ty - | isCoVar v = newCoVarH name ty - | isId v = newIdH name ty - | otherwise = fail "If this variable isn't a type, coercion or identifier, then what is it?" - where - name = nameMod (uqName v) - ty = varType v +---------------------------------------------------------------------------- +class HasHermitMEnv m where + -- | Get the HermitMEnv + getHermitMEnv :: m HermitMEnv + +instance HasHermitMEnv HermitM where + getHermitMEnv = HermitM $ \ _ env -> return $ return $ mkResultEnv env env + +getModGuts :: (HasHermitMEnv m, Monad m) => m ModGuts +getModGuts = liftM hEnvModGuts getHermitMEnv + ---------------------------------------------------------------------------- --- | A message packet. -data DebugMessage = DebugTick String - | DebugCore String HermitC CoreTC +class HasDebugChan m where + -- | Get the debugging channel + getDebugChan :: m (DebugMessage -> m ()) -mkHermitMEnv :: (DebugMessage -> HermitM ()) -> HermitMEnv -mkHermitMEnv debugger = HermitMEnv { hs_debugChan = debugger } +instance HasDebugChan HermitM where + getDebugChan = HermitM $ \ chan env -> return $ return $ mkResultEnv env chan +sendDebugMessage :: (HasDebugChan m, Monad m) => DebugMessage -> m () +sendDebugMessage msg = getDebugChan >>= ($ msg) + ---------------------------------------------------------------------------- + +class HasHscEnv m where + getHscEnv :: m HscEnv + +instance HasHscEnv CoreM where + getHscEnv = getHscEnvCoreM + +instance HasHscEnv HermitM where + getHscEnv = liftCoreM getHscEnv + +---------------------------------------------------------------------------- + +class HasLemmas m where + -- | Add (or replace) a named lemma. + insertLemma :: LemmaName -> Lemma -> m () + + getLemmas :: m Lemmas + +instance HasLemmas HermitM where + insertLemma nm l = HermitM $ \ _ env -> return $ return $ mkResult (hEnvStash env) (insert nm l $ hEnvLemmas env) () + + getLemmas = HermitM $ \ _ env -> return $ return $ mkResultEnv env (hEnvLemmas env) + +-- | Only adds a lemma if doesn't already exist. +addLemma :: (HasLemmas m, Monad m) => LemmaName -> Lemma -> m () +addLemma nm l = do + ls <- getLemmas + maybe (insertLemma nm l) (\ _ -> return ()) (lookup nm ls) + +---------------------------------------------------------------------------- + +class Monad m => LiftCoreM m where + -- | 'CoreM' can be lifted to this monad. + liftCoreM :: CoreM a -> m a + +instance LiftCoreM HermitM where + liftCoreM coreM = HermitM $ \ _ env -> coreM >>= return . return . mkResultEnv env + +---------------------------------------------------------------------------- + +-- | A message packet. +data DebugMessage :: * where + DebugTick :: String -> DebugMessage + DebugCore :: (ReadBindings c, ReadPath c Crumb) => String -> c -> CoreTC -> DebugMessage + +---------------------------------------------------------------------------- + +runTcM :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadIO m) => TcM a -> m a +runTcM m = do + env <- getHscEnv + dflags <- getDynFlags + guts <- getModGuts + -- What is the effect of HsSrcFile (should we be using something else?) + -- What should the boolean flag be set to? + (msgs, mr) <- liftIO $ initTcFromModGuts env guts HsSrcFile False m + let showMsgs (warns, errs) = showSDoc dflags $ vcat + $ text "Errors:" : pprErrMsgBag errs + ++ text "Warnings:" : pprErrMsgBag warns + maybe (fail $ showMsgs msgs) return mr + +runDsM :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadIO m) => DsM a -> m a +runDsM = runTcM . initDsTc diff --git a/src/HERMIT/Name.hs b/src/HERMIT/Name.hs --- a/src/HERMIT/Name.hs +++ b/src/HERMIT/Name.hs @@ -1,15 +1,23 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ <= 706 -{-# LANGUAGE ScopedTypeVariables #-} -#endif -module HERMIT.Name +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, TypeFamilies #-} +module HERMIT.Name ( HermitName + , cmpHN2Name + , cmpHN2Var , fromRdrName , toRdrName , toRdrNames , hnModuleName , hnUnqualified , parseName + , showName + -- * Wrappers + , OccurrenceName(..) + , OccurrenceNameListBox(..) + , mkOccPred + , BindingName(..) + , mkBindingPred + , RhsOfName(..) + , mkRhsOfPred -- * Namespaces , Named(..) , varToNamed @@ -18,37 +26,36 @@ , tyConClassNS , tyVarNS , varNS + -- * Variable Creation + , newGlobalIdH + , newIdH + , newTyVarH + , newCoVarH + , newVarH + , cloneVarH -- * Name Lookup , findId -#if __GLASGOW_HASKELL__ > 706 , findVar , findTyCon , findType , findInNameSpace , findInNameSpaces -#endif ) where import Control.Monad import Control.Monad.IO.Class -#if __GLASGOW_HASKELL__ <= 706 import Data.List (intercalate) -#endif +import Data.Dynamic (Typeable) +import Data.String (IsString(..)) import HERMIT.Context +import HERMIT.External import HERMIT.GHC import HERMIT.Kure import HERMIT.Monad --- | A 'HermitName' is an optionally fully-qualified name, --- like GHC's 'RdrName', but without specifying which 'NameSpace' --- the name is found in. -data HermitName = HermitName { hnModuleName :: Maybe ModuleName - , hnUnqualified :: String - } - --- | Possible results from name lookup. +-- | Possible results from name lookup. -- Invariant: One constructor for each NameSpace. data Named = NamedId Id | NamedDataCon DataCon @@ -88,15 +95,63 @@ ---------------------------------------------------------- +-- | A 'HermitName' is an optionally fully-qualified name, +-- like GHC's 'RdrName', but without specifying which 'NameSpace' +-- the name is found in. +data HermitName = HermitName { hnModuleName :: Maybe ModuleName + , hnUnqualified :: String + } + deriving (Eq, Typeable) + +instance Extern HermitName where + type Box HermitName = HermitName + box = id + unbox = id + +instance IsString HermitName where fromString = parseName +instance Show HermitName where show = showName + +-- | Compare a HermitName to a Var. +-- +-- Only compare module names if the HermitName is fully qualified. +-- Otherwise match variables from any module with appropriate occurrence name. +cmpHN2Var :: HermitName -> Var -> Bool +cmpHN2Var hn = cmpHN2Name hn . varName + +cmpHN2Name :: HermitName -> Name -> Bool +cmpHN2Name (HermitName hm nm) n + | Just mn <- hm + , Just m <- nameModule_maybe n = (mn == moduleName m) && sameOccName + | otherwise = sameOccName + where sameOccName = nm == unqualifiedName n + +-- | Make a qualified HermitName from a String representing the module name +-- and a String representing the occurrence name. mkQualified :: String -> String -> HermitName mkQualified mnm nm = HermitName (Just $ mkModuleName mnm) nm --- mkOccName --- mkRdrQual +-- | Make an unqualified HermitName from a String. mkUnqualified :: String -> HermitName mkUnqualified = HermitName Nothing --- mkRdrUnqual +-- | Parse a HermitName from a String. +parseName :: String -> HermitName +parseName s | isQualified s = parseQualified s + | otherwise = mkUnqualified s + +-- | Parse a qualified HermitName from a String. +parseQualified :: String -> HermitName +parseQualified [] = error "parseQualified: empty string" +parseQualified s = mkQualified mnm nm + where (c:cs) = reverse s -- we are careful to parse 'Prelude..' correctly + (rNm, _dot:rMod) = break (=='.') cs + (nm, mnm) = (reverse (c:rNm), reverse rMod) + +-- | Turn a HermitName into a (possibly fully-qualified) String. +showName :: HermitName -> String +showName (HermitName mnm nm) = maybe id (\ m n -> moduleNameString m ++ ('.' : n)) mnm nm + +-- | Make a HermitName from a RdrName fromRdrName :: RdrName -> HermitName fromRdrName nm = case isQual_maybe nm of Nothing -> HermitName Nothing (occNameString $ rdrNameOcc nm) @@ -111,26 +166,55 @@ toRdrNames :: [NameSpace] -> HermitName -> [RdrName] toRdrNames nss hnm = [ toRdrName ns hnm | ns <- nss ] -parseQualified :: String -> HermitName -parseQualified [] = error "parseQualified: empty string" -parseQualified s = mkQualified mnm nm - where (c:cs) = reverse s -- we are careful to parse 'Prelude..' correctly - (rNm, _dot:rMod) = break (=='.') cs - (nm, mnm) = (reverse (c:rNm), reverse rMod) +-------------------------------------------------------------------------------------------------- --- | Parse a HermitName from a String. -parseName :: String -> HermitName -parseName s | isQualified s = parseQualified s - | otherwise = mkUnqualified s +-- Newtype wrappers used for type-based command completion +newtype BindingName = BindingName { unBindingName :: HermitName } deriving Typeable + +instance Extern BindingName where + type Box BindingName = BindingName + box = id + unbox = id + +mkBindingPred :: BindingName -> Var -> Bool +mkBindingPred (BindingName hnm) = cmpHN2Var hnm + +newtype OccurrenceName = OccurrenceName { unOccurrenceName :: HermitName } deriving Typeable + +instance Extern OccurrenceName where + type Box OccurrenceName = OccurrenceName + box = id + unbox = id + +mkOccPred :: OccurrenceName -> Var -> Bool +mkOccPred (OccurrenceName hnm) = cmpHN2Var hnm + +newtype OccurrenceNameListBox = OccurrenceNameListBox [OccurrenceName] deriving Typeable + +instance Extern [OccurrenceName] where + type Box [OccurrenceName] = OccurrenceNameListBox + box = OccurrenceNameListBox + unbox (OccurrenceNameListBox l) = l + +newtype RhsOfName = RhsOfName { unRhsOfName :: HermitName } deriving Typeable + +instance Extern RhsOfName where + type Box RhsOfName = RhsOfName + box = id + unbox = id + +mkRhsOfPred :: RhsOfName -> Var -> Bool +mkRhsOfPred (RhsOfName hnm) = cmpHN2Var hnm + -------------------------------------------------------------------------------------------------- -- | An instance of 'MonadThings' for 'Transform', which looks in the context first. -- -- NB: we store TyVars in the context, but the 'TyThing' return type is not rich enough --- to return them. So 'lookupThing' cannot be used to look up TyVars. +-- to return them. So 'lookupThing' cannot be used to look up TyVars. -- TODO: add function for this, or modify GHC's 'TyThing'? -instance (MonadThings m, BoundVars c) => MonadThings (Transform c m a) where +instance (MonadThings m, BoundVars c) => MonadThings (Transform c m a) where lookupThing nm = contextonlyT $ \ c -> case varSetElems $ filterVarSet ((== nm) . varName) (boundVars c) of (i:_) | isVarName nm -> return $ AnId i @@ -140,9 +224,8 @@ -------------------------------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 706 -findId :: (BoundVars c, HasHscEnv m, HasModGuts m, MonadCatch m, MonadIO m, MonadThings m) - => String -> c -> m Id +findId :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m) + => HermitName -> c -> m Id findId nm c = do nmd <- findInNameSpaces [varNS, dataConNS] nm c case nmd of @@ -150,8 +233,8 @@ NamedDataCon dc -> return $ dataConWrapId dc other -> fail $ "findId: impossible Named returned: " ++ show other -findVar :: (BoundVars c, HasHscEnv m, HasModGuts m, MonadCatch m, MonadIO m, MonadThings m) - => String -> c -> m Var +findVar :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m) + => HermitName -> c -> m Var findVar nm c = do nmd <- findInNameSpaces [varNS, tyVarNS, dataConNS] nm c case nmd of @@ -160,16 +243,16 @@ NamedDataCon dc -> return $ dataConWrapId dc other -> fail $ "findVar: impossible Named returned: " ++ show other -findTyCon :: (BoundVars c, HasHscEnv m, HasModGuts m, MonadCatch m, MonadIO m, MonadThings m) - => String -> c -> m TyCon +findTyCon :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m) + => HermitName -> c -> m TyCon findTyCon nm c = do nmd <- findInNameSpace tyConClassNS nm c case nmd of NamedTyCon tc -> return tc other -> fail $ "findTyCon: impossible Named returned: " ++ show other -findType :: (BoundVars c, HasHscEnv m, HasModGuts m, MonadCatch m, MonadIO m, MonadThings m) - => String -> c -> m Type +findType :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m) + => HermitName -> c -> m Type findType nm c = do nmd <- findInNameSpaces [tyVarNS, tyConClassNS] nm c case nmd of @@ -179,21 +262,21 @@ -------------------------------------------------------------------------------------------------- -findInNameSpaces :: (BoundVars c, HasHscEnv m, HasModGuts m, MonadCatch m, MonadIO m, MonadThings m) - => [NameSpace] -> String -> c -> m Named +findInNameSpaces :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m) + => [NameSpace] -> HermitName -> c -> m Named findInNameSpaces nss nm c = setFailMsg "Variable not in scope." -- because catchesM clobbers failure messages. $ catchesM [ findInNameSpace ns nm c | ns <- nss ] -findInNameSpace :: (BoundVars c, HasHscEnv m, HasModGuts m, MonadIO m, MonadThings m) - => NameSpace -> String -> c -> m Named -findInNameSpace ns nm c = - case filter ((== ns) . occNameSpace . getOccName) $ varSetElems (findBoundVars nm c) of +findInNameSpace :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadIO m, MonadThings m) + => NameSpace -> HermitName -> c -> m Named +findInNameSpace ns nm c = + case varSetElems $ filterVarSet ((== ns) . occNameSpace . getOccName) $ findBoundVars (cmpHN2Var nm) c of _ : _ : _ -> fail "multiple matching variables in scope." [v] -> return $ varToNamed v - [] -> findInNSModGuts ns (parseName nm) + [] -> findInNSModGuts ns nm -- | Looks for Named in current GlobalRdrEnv. If not present, calls 'findInNSPackageDB'. -findInNSModGuts :: (HasHscEnv m, HasModGuts m, MonadIO m, MonadThings m) +findInNSModGuts :: (HasHscEnv m, HasHermitMEnv m, MonadIO m, MonadThings m) => NameSpace -> HermitName -> m Named findInNSModGuts ns nm = do rdrEnv <- liftM mg_rdr_env getModGuts @@ -203,37 +286,37 @@ _ -> fail "findInNSModGuts: multiple names returned" -- | Looks for Named in package database, or built-in packages. -findInNSPackageDB :: (HasHscEnv m, HasModGuts m, MonadIO m, MonadThings m) +findInNSPackageDB :: (HasHscEnv m, HasHermitMEnv m, MonadIO m, MonadThings m) => NameSpace -> HermitName -> m Named findInNSPackageDB ns nm = do mnm <- lookupName ns nm case mnm of - Nothing -> findNamedBuiltIn ns (hnUnqualified nm) + Nothing -> findNamedBuiltIn ns nm Just n -> nameToNamed n --- | Helper to call GHC's lookupRdrNameInModuleForPlugins -lookupName :: (HasModGuts m, HasHscEnv m, MonadIO m) => NameSpace -> HermitName -> m (Maybe Name) +-- | Helper to call lookupRdrNameInModule +lookupName :: (HasHermitMEnv m, HasHscEnv m, MonadIO m) => NameSpace -> HermitName -> m (Maybe Name) lookupName ns nm = case isQual_maybe rdrName of Nothing -> return Nothing -- we can't use lookupName on the current module Just (m,_) -> do hscEnv <- getHscEnv guts <- getModGuts - liftIO $ lookupRdrNameInModuleForPlugins hscEnv guts m rdrName + liftIO $ lookupRdrNameInModule hscEnv guts m rdrName where rdrName = toRdrName ns nm -- | Looks for Named amongst GHC's built-in DataCons/TyCons. -findNamedBuiltIn :: Monad m => NameSpace -> String -> m Named -findNamedBuiltIn ns str - | isValNameSpace ns = - case [ dc | tc <- wiredInTyCons, dc <- tyConDataCons tc, str == getOccString dc ] of +findNamedBuiltIn :: Monad m => NameSpace -> HermitName -> m Named +findNamedBuiltIn ns hnm + | isValNameSpace ns = + case [ dc | tc <- wiredInTyCons, dc <- tyConDataCons tc, cmpHN2Name hnm (getName dc) ] of [] -> fail "name not in scope." [dc] -> return $ NamedDataCon dc - dcs -> fail $ "multiple DataCons match: " ++ show (map getOccString dcs) - | isTcClsNameSpace ns = - case [ tc | tc <- wiredInTyCons, str == getOccString tc ] of + dcs -> fail $ "multiple DataCons match: " ++ intercalate ", " (map unqualifiedName dcs) + | isTcClsNameSpace ns = + case [ tc | tc <- wiredInTyCons, cmpHN2Name hnm (getName tc) ] of [] -> fail "type name not in scope." [tc] -> return $ NamedTyCon tc - tcs -> fail $ "multiple TyCons match: " ++ show (map getOccString tcs) + tcs -> fail $ "multiple TyCons match: " ++ intercalate ", " (map unqualifiedName tcs) | otherwise = fail "findNameBuiltIn: unusable NameSpace" -- | We have a name, find the corresponding Named. @@ -244,49 +327,47 @@ | isTyVarName n = fail "nameToNamed: impossible, TyVars are not exported and cannot be looked up." | otherwise = fail "nameToNamed: unknown name type" -#else - --- | Looks for Id with given name in the context. If it is not present, calls 'findIdMG'. -findId :: (BoundVars c, HasModGuts m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> c -> m Id -findId nm c = case varSetElems (findBoundVars nm c) of - [] -> findIdMG (parseName nm) - [v] -> return v - _ : _ : _ -> fail "multiple matching variables in scope." - -findIdMG :: (HasModGuts m, MonadThings m) => HermitName -> m Id -findIdMG hnm = do - let nm = hnUnqualified hnm - rdrEnv <- liftM mg_rdr_env getModGuts - case filter isValName $ findNamesFromString rdrEnv nm of - [] -> findIdBuiltIn nm - [n] -> nameToId n - ns -> fail $ "multiple matches found:\n" ++ intercalate ", " (map getOccString ns) +-- Someday, when Applicative is a superclass of monad, we can uncomment the +-- nicer applicative definitions. For now, we don't want the extra constraint. --- | We have a name, find the corresponding Id. -nameToId :: MonadThings m => Name -> m Id -nameToId n | isVarName n = lookupId n - | isDataConName n = liftM dataConWrapId $ lookupDataCon n - | otherwise = fail "nameToId: unknown name type" +-- | Make a 'Name' from a string. +newName :: MonadUnique m => String -> m Name +newName nm = getUniqueM >>= return . flip mkSystemVarName (mkFastString nm) +-- newName nm = mkSystemVarName <$> getUniqueM <*> pure (mkFastString nm) -findIdBuiltIn :: forall m. Monad m => String -> m Id -findIdBuiltIn = go - where go ":" = dataConId consDataCon - go "[]" = dataConId nilDataCon +-- | Make a unique global identifier for a specified type, using a provided name. +newGlobalIdH :: MonadUnique m => String -> Type -> m Id +newGlobalIdH nm ty = newName nm >>= return . flip mkVanillaGlobal ty +-- newGlobalIdH nm ty = mkVanillaGlobal <$> newName nm <*> pure ty - go "True" = return trueDataConId - go "False" = return falseDataConId +-- | Make a unique identifier for a specified type, using a provided name. +newIdH :: MonadUnique m => String -> Type -> m Id +newIdH nm ty = newName nm >>= return . flip mkLocalId ty +-- newIdH nm ty = mkLocalId <$> newName nm <*> pure ty - go "<" = return ltDataConId - go "==" = return eqDataConId - go ">" = return gtDataConId +-- | Make a unique type variable for a specified kind, using a provided name. +newTyVarH :: MonadUnique m => String -> Kind -> m TyVar +newTyVarH nm k = newName nm >>= return . flip mkTyVar k +-- newTyVarH nm k = mkTyVar <$> newName nm <*> pure k - go "I#" = dataConId intDataCon +-- | Make a unique coercion variable for a specified type, using a provided name. +newCoVarH :: MonadUnique m => String -> Type -> m TyVar +newCoVarH nm ty = newName nm >>= return . flip mkCoVar ty +-- newCoVarH nm ty = mkCoVar <$> newName nm <*> pure ty - go "()" = return unitDataConId - -- TODO: add more as needed - -- http://www.haskell.org/ghc/docs/latest/html/libraries/ghc/TysWiredIn.html - go _ = fail "variable not in scope." +-- TODO: not sure if the predicates are correct. +-- | Experimental, use at your own risk. +newVarH :: MonadUnique m => String -> KindOrType -> m Var +newVarH name tk | isCoVarType tk = newCoVarH name tk + | isKind tk = newTyVarH name tk + | otherwise = newIdH name tk - dataConId :: DataCon -> m Id - dataConId = return . dataConWorkId -#endif +-- | Make a new variable of the same type, with a modified textual name. +cloneVarH :: MonadUnique m => (String -> String) -> Var -> m Var +cloneVarH nameMod v | isTyVar v = newTyVarH name ty + | isCoVar v = newCoVarH name ty + | isId v = newIdH name ty + | otherwise = fail "If this variable isn't a type, coercion or identifier, then what is it?" + where + name = nameMod (unqualifiedName v) + ty = varType v diff --git a/src/HERMIT/Parser.y b/src/HERMIT/Parser.y --- a/src/HERMIT/Parser.y +++ b/src/HERMIT/Parser.y @@ -5,6 +5,7 @@ , unparseScript , unparseExprH , ExprH(..) + , parseExprH ) where import Data.Char (isSpace) @@ -16,7 +17,8 @@ } -%name parser +%name parser scoped +%name exprParser ExprH %tokentype { Token } %error { parseError } %monad { Either String } { >>= } { return } @@ -162,6 +164,9 @@ parseScript :: String -> Either String Script parseScript = lexer >=> parser + +parseExprH :: String -> Either String ExprH +parseExprH = lexer >=> exprParser --------------------------------------------- diff --git a/src/HERMIT/ParserCore.y b/src/HERMIT/ParserCore.y --- a/src/HERMIT/ParserCore.y +++ b/src/HERMIT/ParserCore.y @@ -3,6 +3,8 @@ module HERMIT.ParserCore ( parseCore , parseCoreExprT + , parse2BeforeT + , parse3BeforeT , parse2beforeBiR , parse3beforeBiR , parse4beforeBiR @@ -89,21 +91,17 @@ { mkIntExpr' :: Integer -> CoreParseM CoreExpr -#if __GLASGOW_HASKELL__ > 706 mkIntExpr' i = do dflags <- lift getDynFlags return $ mkIntExpr dflags i -#else -mkIntExpr' i = return $ mkIntExpr i -#endif lookupName :: String -> CoreParseM CoreExpr lookupName nm = do - c <- ask - v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId nm c + vset <- ask + v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId (parseName nm) vset return $ varToCoreExpr v -type CoreParseM a = ReaderT HermitC HermitM a +type CoreParseM a = ReaderT VarSet HermitM a parseError :: Monad m => [Token] -> m a parseError ts = fail $ "core parse error: " ++ show ts @@ -170,19 +168,30 @@ --------------------------------------------- -parseCore :: CoreString -> HermitC -> HermitM CoreExpr +parseCore :: BoundVars c => CoreString -> c -> HermitM CoreExpr parseCore (CoreString s) c = case lexer s of Left msg -> fail msg - Right tokens -> runReaderT (parser tokens) c + Right tokens -> runReaderT (parser tokens) (boundVars c) --------------------------------------------- -- These should probably go somewhere else. -- | Parse a 'CoreString' to a 'CoreExpr', using the current context. -parseCoreExprT :: CoreString -> TransformH a CoreExpr -parseCoreExprT = contextonlyT . parseCore +parseCoreExprT :: (BoundVars c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, HasStash m, LiftCoreM m) + => CoreString -> Transform c m a CoreExpr +parseCoreExprT cs = contextonlyT $ embedHermitM . parseCore cs + +parse2BeforeT :: (BoundVars c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, HasStash m, LiftCoreM m) + => (CoreExpr -> CoreExpr -> Translate c m a b) + -> CoreString -> CoreString -> Translate c m a b +parse2BeforeT f s1 s2 = parseCoreExprT s1 &&& parseCoreExprT s2 >>= uncurry f + +parse3BeforeT :: (BoundVars c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, HasStash m, LiftCoreM m) + => (CoreExpr -> CoreExpr -> CoreExpr -> Translate c m a b) + -> CoreString -> CoreString -> CoreString -> Translate c m a b +parse3BeforeT f s1 s2 s3 = (parseCoreExprT s1 &&& parseCoreExprT s2) &&& parseCoreExprT s3 >>= (uncurry . uncurry $ f) parse2beforeBiR :: (CoreExpr -> CoreExpr -> BiRewriteH a) -> CoreString -> CoreString -> BiRewriteH a diff --git a/src/HERMIT/ParserType.y b/src/HERMIT/ParserType.y --- a/src/HERMIT/ParserType.y +++ b/src/HERMIT/ParserType.y @@ -1,15 +1,11 @@ { {-# LANGUAGE CPP #-} module HERMIT.ParserType -#if __GLASGOW_HASKELL__ <= 706 - () where -#else ( parseType , parseTypeT , parseTypeWithHoles , parseTypeWithHolesT ) where -#endif import Control.Arrow import Control.Monad.State @@ -87,14 +83,10 @@ tyvar : NAME {% lookupName $1 } { -#if __GLASGOW_HASKELL__ <= 706 -findType = error "findType cannot be called in < GHC 7.8" -#endif - lookupName :: String -> TypeParseM Type lookupName nm = do c <- getContext - et <- lift $ attemptM $ findType nm c + et <- lift $ attemptM $ findType (parseName nm) c either (const (addTyVar nm)) return et catchFrees :: Type -> TypeParseM ([TyVar], Type) @@ -117,7 +109,7 @@ addTyVar :: String -> TypeParseM Type addTyVar tvStr = do used <- gets tpUsed - case [ tv | tv <- used, getOccString tv == tvStr ] of + case [ tv | tv <- used, unqualifiedName tv == tvStr ] of [] -> do tv <- lift $ newTyVarH tvStr liftedTypeKind modify $ \ st -> st { tpUsed = tv : tpUsed st } return $ mkTyVarTy tv diff --git a/src/HERMIT/Plugin.hs b/src/HERMIT/Plugin.hs --- a/src/HERMIT/Plugin.hs +++ b/src/HERMIT/Plugin.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE KindSignatures, GADTs, FlexibleContexts, GeneralizedNewtypeDeriving, LambdaCase #-} +{-# LANGUAGE KindSignatures, GADTs, FlexibleContexts, GeneralizedNewtypeDeriving, LambdaCase, CPP #-} module HERMIT.Plugin ( -- * The HERMIT Plugin hermitPlugin @@ -12,15 +12,15 @@ , setPrettyOptions -- ** Active modifiers , at - , phase + , pass , after , before , until - , allPhases - , firstPhase - , lastPhase + , allPasses + , firstPass + , lastPass -- ** Knobs and Dials - , getPhaseInfo + , getPassInfo , modifyCLS -- ** Types , defPS @@ -31,7 +31,11 @@ import Control.Applicative import Control.Arrow import Control.Concurrent.STM +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except hiding (guard) +#else import Control.Monad.Error hiding (guard) +#endif import Control.Monad.Operational import Control.Monad.State hiding (guard) @@ -40,12 +44,12 @@ import HERMIT.Dictionary import HERMIT.External hiding (Query, Shell) +import HERMIT.Kernel (KernelEnv) import HERMIT.Kernel.Scoped import HERMIT.Context import HERMIT.Kure import HERMIT.GHC hiding (singleton, liftIO, display, (<>)) import qualified HERMIT.GHC as GHC -import HERMIT.Monad import HERMIT.Plugin.Builder import qualified HERMIT.Plugin.Display as Display @@ -59,13 +63,11 @@ import Prelude hiding (until) -import System.Console.Haskeline (defaultBehavior) - hermitPlugin :: ([CommandLineOption] -> HPM ()) -> Plugin -hermitPlugin f = buildPlugin $ \ phaseInfo -> runHPM phaseInfo . f +hermitPlugin f = buildPlugin $ \ passInfo -> runHPM passInfo . f -defPS :: SAST -> ScopedKernel -> PhaseInfo -> IO PluginState -defPS initSAST kernel phaseInfo = do +defPS :: SAST -> ScopedKernel -> PassInfo -> IO PluginState +defPS initSAST kernel passInfo = do emptyTick <- liftIO $ atomically $ newTVar M.empty return $ PluginState { ps_cursor = initSAST @@ -76,12 +78,12 @@ , ps_diffonly = False , ps_failhard = False , ps_kernel = kernel - , ps_phase = phaseInfo + , ps_pass = passInfo } data HPMInst :: * -> * where Shell :: [External] -> [CommandLineOption] -> HPMInst () - Guard :: (PhaseInfo -> Bool) -> HPM () -> HPMInst () + Guard :: (PassInfo -> Bool) -> HPM () -> HPMInst () Focus :: (Injection ModGuts g, Walker HermitC g) => TransformH g LocalPathH -> HPM a -> HPMInst a RR :: (Injection ModGuts g, Walker HermitC g) => RewriteH g -> HPMInst () Query :: (Injection ModGuts g, Walker HermitC g) => TransformH g a -> HPMInst a @@ -89,14 +91,18 @@ newtype HPM a = HPM { unHPM :: ProgramT HPMInst PluginM a } deriving (Functor, Applicative, Monad, MonadIO) -runHPM :: PhaseInfo -> HPM () -> ModGuts -> CoreM ModGuts -runHPM phaseInfo pass = scopedKernel $ \ kernel initSAST -> do - ps <- defPS initSAST kernel phaseInfo - (r,st) <- hpmToIO ps pass +runHPM :: PassInfo -> HPM () -> ModGuts -> CoreM ModGuts +runHPM passInfo hpass = scopedKernel $ \ kernel initSAST -> do + ps <- defPS initSAST kernel passInfo + (r,st) <- hpmToIO ps hpass + let cleanup sast = do + if sast /= initSAST -- only do this if we actually changed the AST + then applyS kernel occurAnalyseAndDezombifyR (mkKernelEnv st) sast >>= resumeS kernel + else resumeS kernel sast either (\case PAbort -> abortS kernel - PResume sast -> resumeS kernel sast + PResume sast -> cleanup sast PError err -> putStrLn err >> abortS kernel) - (\ _ -> resumeS kernel $ ps_cursor st) r + (\ _ -> cleanup $ ps_cursor st) r hpmToIO :: PluginState -> HPM a -> IO (Either PException a, PluginState) hpmToIO initState = runPluginT initState . eval . unHPM @@ -113,11 +119,11 @@ -- We want to discard the current focus, open the shell at -- the top level, then restore the current focus. paths <- resetScoping env - clm (commandLine os defaultBehavior es) + clm (commandLine interpShellCommand os es) _ <- resetScoping env restoreScoping env paths eval $ k () - Guard p (HPM m) :>>= k -> gets (p . ps_phase) >>= \ b -> when b (eval m) >>= eval . k + Guard p (HPM m) :>>= k -> gets (p . ps_pass) >>= \ b -> when b (eval m) >>= eval . k Focus tp (HPM m) :>>= k -> do p <- runK (queryS kernel tp env) -- run the pathfinding translation runS $ beginScopeS kernel -- remember the current path @@ -128,7 +134,7 @@ ------------------------- Shell-related helpers -------------------------------------- -resetScoping :: HermitMEnv -> PluginM [PathH] +resetScoping :: KernelEnv -> PluginM [PathH] resetScoping env = do kernel <- gets ps_kernel paths <- runK $ pathS kernel @@ -137,7 +143,7 @@ catchM (runS $ modPathS kernel (const mempty) env) (const (return ())) return paths -restoreScoping :: HermitMEnv -> [PathH] -> PluginM () +restoreScoping :: KernelEnv -> [PathH] -> PluginM () restoreScoping _ [] = return () restoreScoping env (h:t) = do kernel <- gets ps_kernel @@ -172,41 +178,41 @@ ----------------------------- guards ------------------------------ -guard :: (PhaseInfo -> Bool) -> HPM () -> HPM () +guard :: (PassInfo -> Bool) -> HPM () -> HPM () guard p = HPM . singleton . Guard p at :: TransformH CoreTC LocalPathH -> HPM a -> HPM a at tp = HPM . singleton . Focus tp -phase :: Int -> HPM () -> HPM () -phase n = guard ((n ==) . phaseNum) +pass :: Int -> HPM () -> HPM () +pass n = guard ((n ==) . passNum) after :: CorePass -> HPM () -> HPM () -after cp = guard (\phaseInfo -> case phasesDone phaseInfo of +after cp = guard (\passInfo -> case passesDone passInfo of [] -> False xs -> last xs == cp) before :: CorePass -> HPM () -> HPM () -before cp = guard (\phaseInfo -> case phasesLeft phaseInfo of +before cp = guard (\passInfo -> case passesLeft passInfo of (x:_) | cp == x -> True _ -> False) until :: CorePass -> HPM () -> HPM () -until cp = guard ((cp `elem`) . phasesLeft) +until cp = guard ((cp `elem`) . passesLeft) -allPhases :: HPM () -> HPM () -allPhases = guard (const True) +allPasses :: HPM () -> HPM () +allPasses = guard (const True) -firstPhase :: HPM () -> HPM () -firstPhase = guard (null . phasesDone) +firstPass :: HPM () -> HPM () +firstPass = guard (null . passesDone) -lastPhase :: HPM () -> HPM () -lastPhase = guard (null . phasesLeft) +lastPass :: HPM () -> HPM () +lastPass = guard (null . passesLeft) ----------------------------- other ------------------------------ -getPhaseInfo :: HPM PhaseInfo -getPhaseInfo = HPM $ lift $ gets ps_phase +getPassInfo :: HPM PassInfo +getPassInfo = HPM $ lift $ gets ps_pass display :: HPM () display = HPM $ lift $ Display.display Nothing diff --git a/src/HERMIT/Plugin/Builder.hs b/src/HERMIT/Plugin/Builder.hs --- a/src/HERMIT/Plugin/Builder.hs +++ b/src/HERMIT/Plugin/Builder.hs @@ -7,8 +7,8 @@ , CorePass(..) , getCorePass , ghcPasses - , PhaseInfo(..) - , getPhaseFlag + , PassInfo(..) + , getPassFlag ) where import Data.List @@ -17,7 +17,7 @@ import HERMIT.GHC -- | Given a list of 'CommandLineOption's, produce the 'ModGuts' to 'ModGuts' function required to build a plugin. -type PluginPass = PhaseInfo -> [CommandLineOption] -> ModGuts -> CoreM ModGuts +type PluginPass = PassInfo -> [CommandLineOption] -> ModGuts -> CoreM ModGuts -- | Build a plugin. This mainly handles the per-module options. buildPlugin :: PluginPass -> Plugin @@ -31,6 +31,9 @@ liftIO $ hSetBuffering stdout NoBuffering #ifdef mingw32_HOST_OS liftIO $ hSetEncoding stdout utf8 + -- This is a hacky workaround of a bug in Windows GHC. + -- See https://ghc.haskell.org/trac/ghc/ticket/8276 + liftIO initStaticOpts #endif let todos' = flattenTodos todos @@ -38,12 +41,12 @@ allPasses = foldr (\ (n,p,seen,notyet) r -> mkPass n seen notyet : p : r) [mkPass (length todos') passes []] (zip4 [0..] todos' (inits passes) (tails passes)) - mkPass n ps ps' = CoreDoPluginPass ("HERMIT" ++ show n) $ modFilter hp (PhaseInfo n ps ps') opts + mkPass n ps ps' = CoreDoPluginPass ("HERMIT" ++ show n) $ modFilter hp (PassInfo n ps ps') opts return allPasses -- | Determine whether to act on this module, choose plugin pass. --- NB: we have the ability to stick module info in the phase info here +-- NB: we have the ability to stick module info in the pass info here modFilter :: PluginPass -> PluginPass modFilter hp pInfo opts guts | null modOpts && notNull opts = return guts -- don't process this module @@ -64,7 +67,7 @@ where modName = moduleNameString $ moduleName $ mg_module guts len = length modName + 1 -- for the colon --- | An enumeration type for GHC's phases. +-- | An enumeration type for GHC's passes. data CorePass = FloatInwards | LiberateCase | PrintCore @@ -112,26 +115,26 @@ ] getCorePass :: CoreToDo -> CorePass -getCorePass CoreDoFloatInwards = FloatInwards -getCorePass CoreLiberateCase = LiberateCase -getCorePass CoreDoPrintCore = PrintCore -getCorePass CoreDoStaticArgs = StaticArgs -getCorePass CoreDoStrictness = Strictness -getCorePass CoreDoWorkerWrapper = WorkerWrapper -getCorePass CoreDoSpecialising = Specialising -getCorePass CoreDoSpecConstr = SpecConstr -getCorePass CoreCSE = CSE -getCorePass CoreDoVectorisation = Vectorisation -getCorePass CoreDesugar = Desugar -getCorePass CoreDesugarOpt = DesugarOpt -getCorePass CoreTidy = Tidy -getCorePass CorePrep = Prep -getCorePass (CoreDoSimplify {}) = Simplify +getCorePass CoreDoFloatInwards = FloatInwards +getCorePass CoreLiberateCase = LiberateCase +getCorePass CoreDoPrintCore = PrintCore +getCorePass CoreDoStaticArgs = StaticArgs +getCorePass CoreDoStrictness = Strictness +getCorePass CoreDoWorkerWrapper = WorkerWrapper +getCorePass CoreDoSpecialising = Specialising +getCorePass CoreDoSpecConstr = SpecConstr +getCorePass CoreCSE = CSE +getCorePass CoreDoVectorisation = Vectorisation +getCorePass CoreDesugar = Desugar +getCorePass CoreDesugarOpt = DesugarOpt +getCorePass CoreTidy = Tidy +getCorePass CorePrep = Prep +getCorePass (CoreDoSimplify {}) = Simplify getCorePass (CoreDoFloatOutwards {}) = FloatOutwards -getCorePass (CoreDoRuleCheck {}) = RuleCheck -getCorePass (CoreDoPasses {}) = Passes -- these should be flattened out in practice -getCorePass (CoreDoPluginPass nm _) = PluginPass nm -getCorePass CoreDoNothing = NoOp +getCorePass (CoreDoRuleCheck {}) = RuleCheck +getCorePass (CoreDoPasses {}) = Passes -- these should be flattened out in practice +getCorePass (CoreDoPluginPass nm _) = PluginPass nm +getCorePass CoreDoNothing = NoOp -- getCorePass _ = Unknown flattenTodos :: [CoreToDo] -> [CoreToDo] @@ -140,16 +143,16 @@ f CoreDoNothing = [] f other = [other] -data PhaseInfo = - PhaseInfo { phaseNum :: Int - , phasesDone :: [CorePass] - , phasesLeft :: [CorePass] - } +data PassInfo = + PassInfo { passNum :: Int + , passesDone :: [CorePass] + , passesLeft :: [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 +getPassFlag :: [CommandLineOption] -> Maybe (Int, [CommandLineOption]) +getPassFlag opts = case partition ("-p" `isPrefixOf`) opts of ([],_) -> Nothing (ps,r) -> Just (read (drop 2 (last ps)), r) diff --git a/src/HERMIT/Plugin/Renderer.hs b/src/HERMIT/Plugin/Renderer.hs --- a/src/HERMIT/Plugin/Renderer.hs +++ b/src/HERMIT/Plugin/Renderer.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP, FlexibleContexts #-} module HERMIT.Plugin.Renderer where import Control.Arrow @@ -11,9 +11,16 @@ import HERMIT.Kure import HERMIT.Plugin.Types import HERMIT.PrettyPrinter.Common +#ifdef mingw32_HOST_OS +import HERMIT.Win32.IO (hPutStr, hPutStrLn) +#endif import System.Console.ANSI +#ifdef mingw32_HOST_OS +import System.IO hiding (hPutStr, hPutStrLn) +#else import System.IO +#endif import System.IO.Temp import System.Process diff --git a/src/HERMIT/Plugin/Types.hs b/src/HERMIT/Plugin/Types.hs --- a/src/HERMIT/Plugin/Types.hs +++ b/src/HERMIT/Plugin/Types.hs @@ -1,11 +1,15 @@ -{-# LANGUAGE TypeFamilies, DeriveDataTypeable, FlexibleContexts, +{-# LANGUAGE TypeFamilies, DeriveDataTypeable, FlexibleContexts, LambdaCase, GADTs, GeneralizedNewtypeDeriving, - ScopedTypeVariables, FlexibleInstances #-} + ScopedTypeVariables, FlexibleInstances, CPP #-} module HERMIT.Plugin.Types where import Control.Applicative import Control.Concurrent.STM +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except +#else import Control.Monad.Error +#endif import Control.Monad.State import Data.Dynamic @@ -13,6 +17,7 @@ import HERMIT.Kure import HERMIT.External +import HERMIT.Kernel (KernelEnv(..)) import HERMIT.Kernel.Scoped import HERMIT.Monad import HERMIT.Plugin.Builder @@ -21,11 +26,19 @@ import System.IO type PluginM = PluginT IO +#if MIN_VERSION_mtl(2,2,1) +newtype PluginT m a = PluginT { unPluginT :: ExceptT PException (StateT PluginState m) a } +#else newtype PluginT m a = PluginT { unPluginT :: ErrorT PException (StateT PluginState m) a } +#endif deriving (Functor, Applicative, Monad, MonadIO, MonadError PException, MonadState PluginState) runPluginT :: PluginState -> PluginT m a -> m (Either PException a, PluginState) +#if MIN_VERSION_mtl(2,2,1) +runPluginT ps = flip runStateT ps . runExceptT . unPluginT +#else runPluginT ps = flip runStateT ps . runErrorT . unPluginT +#endif instance MonadTrans PluginT where lift = PluginT . lift . lift @@ -53,12 +66,14 @@ , ps_failhard :: Bool -- ^ if true, abort on *any* failure -- this should be in a reader , ps_kernel :: ScopedKernel - , ps_phase :: PhaseInfo + , ps_pass :: PassInfo } deriving (Typeable) data PException = PAbort | PResume SAST | PError String +#if !(MIN_VERSION_mtl(2,2,1)) instance Error PException where strMsg = PError +#endif newtype PSBox = PSBox PluginState deriving Typeable instance Extern PluginState where @@ -76,25 +91,25 @@ writeTVar var (M.insert msg c m) return c -mkKernelEnv :: PluginState -> HermitMEnv +mkKernelEnv :: PluginState -> KernelEnv mkKernelEnv st = let pp = ps_pretty st out str = liftIO $ ps_render st stdout (pOptions pp) (Left $ str ++ "\n") - in mkHermitMEnv $ \ msg -> case msg of + in KernelEnv $ \ msg -> case msg of DebugTick msg' -> do c <- liftIO $ tick (ps_tick st) msg' out $ "<" ++ show c ++ "> " ++ msg' DebugCore msg' cxt core -> do out $ "[" ++ msg' ++ "]" - doc :: DocH <- apply (pCoreTC pp) (liftPrettyC (pOptions pp) cxt) (inject core) + doc :: DocH <- applyT (pCoreTC pp) (liftPrettyC (pOptions pp) cxt) (inject core) liftIO $ ps_render st stdout (pOptions pp) (Right doc) iokm' :: (MonadIO m, MonadCatch m) => String -> (a -> m b) -> IO (KureM a) -> m b iokm' msg ret m = liftIO m >>= runKureM ret (fail . (msg ++)) -iokm :: (MonadIO m, MonadCatch m) => String -> IO (KureM a) -> m a +iokm :: (MonadIO m, MonadCatch m) => String -> IO (KureM a) -> m a iokm msg = iokm' msg return -iokm'' :: (MonadIO m, MonadCatch m) => IO (KureM a) -> m a +iokm'' :: (MonadIO m, MonadCatch m) => IO (KureM a) -> m a iokm'' = iokm "" diff --git a/src/HERMIT/PrettyPrinter/AST.hs b/src/HERMIT/PrettyPrinter/AST.hs --- a/src/HERMIT/PrettyPrinter/AST.hs +++ b/src/HERMIT/PrettyPrinter/AST.hs @@ -115,19 +115,12 @@ <+ transCoT ppCoercion ppCoercion (\ co1 co2 -> coText "TransCo" $$ nest 2 (cat [parens co1, parens co2])) <+ nthCoT (arr $ coText . show) ppCoercion (\ n co -> coText "NthCo" <+> n $$ parens co) <+ instCoT ppCoercion ppKindOrType (\ co ty -> coText "InstCo" $$ nest 2 (cat [parens co, parens ty])) -#if __GLASGOW_HASKELL__ > 706 -- TODO: Figure out how to properly pp new branched Axioms and Left/Right Coercions <+ reflT ppKindOrType (\ r ty -> coText "Refl" <+> coText (showRole r) $$ nest 2 (parens ty)) <+ axiomInstCoT ppSDoc ppSDoc (const ppCoercion) (\ ax idx coes -> coText "AxiomInstCo" <+> ax <+> idx $$ nest 2 (vlist $ map parens coes)) <+ lrCoT ppSDoc ppCoercion (\ lr co -> coText "LRCo" <+> lr $$ nest 2 (parens co)) <+ tyConAppCoT ppSDoc (const ppCoercion) (\ r con coes -> coText "TyConAppCo" <+> coText (showRole r) <+> con $$ nest 2 (vlist $ map parens coes)) -- TODO: add UnivCo and SubCo -#else - <+ reflT (ppKindOrType >>^ \ ty -> coText "Refl" $$ nest 2 (parens ty)) - <+ tyConAppCoT ppSDoc (const ppCoercion) (\ con coes -> coText "TyConAppCo" <+> con $$ nest 2 (vlist $ map parens coes)) - <+ unsafeCoT ppKindOrType ppKindOrType (\ ty1 ty2 -> coText "UnsafeCo" $$ nest 2 (cat [parens ty1, parens ty2])) - <+ axiomInstCoT ppSDoc (const ppCoercion) (\ ax coes -> coText "AxiomInstCo" <+> ax $$ nest 2 (vlist $ map parens coes)) -#endif ppVar :: PrettyH Var ppVar = readerT $ \ v -> ppSDoc >>^ modCol v diff --git a/src/HERMIT/PrettyPrinter/Clean.hs b/src/HERMIT/PrettyPrinter/Clean.hs --- a/src/HERMIT/PrettyPrinter/Clean.hs +++ b/src/HERMIT/PrettyPrinter/Clean.hs @@ -1,19 +1,18 @@ {-# LANGUAGE CPP, LambdaCase, MultiWayIf #-} module HERMIT.PrettyPrinter.Clean - ( -- * HERMIT's Clean Pretty-Printer for GHC Core - pretty - , ppCoreTC - , ppModGuts - , ppCoreProg - , ppCoreBind - , ppCoreExpr - , ppCoreAlt - , ppKindOrType - , ppCoercion - , ppForallQuantification - ) -where + ( -- * HERMIT's Clean Pretty-Printer for GHC Core + pretty + , ppCoreTC + , ppModGuts + , ppCoreProg + , ppCoreBind + , ppCoreExpr + , ppCoreAlt + , ppKindOrType + , ppCoercion + , ppForallQuantification + ) where import Control.Arrow hiding ((<+>)) import Control.Applicative ((<$>)) @@ -24,16 +23,12 @@ import HERMIT.Context import HERMIT.Core -import HERMIT.GHC hiding ((<+>), (<>), ($$), ($+$), sep, hsep, empty, nest, vcat, char, text, keyword, hang) +import HERMIT.Dictionary (dynFlagsT) +import HERMIT.GHC hiding ((<+>), (<>), ($$), ($+$), cat, sep, fsep, hsep, empty, nest, vcat, char, text, keyword, hang) import HERMIT.Kure import HERMIT.Monad -import HERMIT.Syntax - -import HERMIT.Dictionary (dynFlagsT) - import HERMIT.PrettyPrinter.Common - -import Pair +import HERMIT.Syntax import Text.PrettyPrint.MarkedHughesPJ as PP @@ -50,11 +45,13 @@ | RetLet AbsolutePathH [DocH] AbsolutePathH DocH | RetApp DocH [(AbsolutePathH,RetExpr)] | RetForAll AbsolutePathH [DocH] AbsolutePathH DocH - | RetArrowType DocH [(AbsolutePathH,DocH)] -- f -> (a -> (b -> c)) The path is for each arrow, starting from the left. + | RetArrowType ArrowType DocH [(AbsolutePathH,DocH)] -- f -> (a -> (b -> c)) The path is for each arrow, starting from the left. | RetExpr DocH | RetAtom DocH -- parens not needed | RetEmpty +data ArrowType = ATType | ATCoercion deriving (Eq, Show) + retApp :: AbsolutePathH -> Crumb -> Crumb -> RetExpr -> RetExpr -> RetExpr retApp _ _ _ f RetEmpty = f retApp _ _ _ RetEmpty e = e @@ -87,16 +84,11 @@ ty -> RetForAll p [v] (p @@ cr) (normalExpr ty) -- This is very hacky. There must be a better way of handling arrow types. -retArrowType :: AbsolutePathH -> Crumb -> Crumb -> RetExpr -> RetExpr -> RetExpr -retArrowType p cr1 cr2 ty1 = \case - RetArrowType ty2 ptys -> RetArrowType (normalParensExceptApp (p @@ cr1) ty1) ((p,ty2) : ptys) - ty2 -> RetArrowType (normalParensExceptApp (p @@ cr1) ty1) [(p , normalParensExceptApp (p @@ cr2) ty2)] - ------------------------------------------------------------------------------------------------- - -isAtom :: RetExpr -> Bool -isAtom (RetAtom _) = True -isAtom _ = False +retArrowType :: ArrowType -> AbsolutePathH -> Crumb -> Crumb -> RetExpr -> RetExpr -> RetExpr +retArrowType at@ATType p cr1 _cr2 ty1 (RetArrowType _ ty2 ptys) + = RetArrowType at (normalParensExceptApp (p @@ cr1) ty1) ((p,ty2) : ptys) +retArrowType at p cr1 cr2 ty1 ty2 + = RetArrowType at (normalParensExceptApp (p @@ cr1) ty1) [(p , normalParensExceptApp (p @@ cr2) ty2)] ------------------------------------------------------------------------------------------------ @@ -106,11 +98,12 @@ normalExpr (RetExpr e) = e normalExpr (RetLam p vs pb e) = hang (specialSymbol p LambdaSymbol <+> hsep vs <+> specialSymbol pb RightArrowSymbol) 2 e normalExpr (RetLet p vs pb e) = sep [ keyword p "let" <+> vcat vs, keyword pb "in" <+> e ] -normalExpr (RetApp f pes) = let (pAtoms,pExprs) = span (isAtom.snd) pes - in sep [ hsep (f : map (normalExpr.snd) pAtoms) - , nest 2 (sep $ map (uncurry normalParens) pExprs) ] +normalExpr (RetApp f pes) = f <+> fsep (map (uncurry normalParens) pes) normalExpr (RetForAll p vs pb ty) = specialSymbol p ForallSymbol <+> hsep vs <+> symbol pb '.' <+> ty -normalExpr (RetArrowType ty ptys) = foldl (\ ty1 (p,ty2) -> ty1 <+> typeArrow p <+> ty2) ty ptys +normalExpr (RetArrowType at ty ptys) = let a = case at of + ATType -> typeArrow + ATCoercion -> coArrow + in foldl (\ ty1 (p,ty2) -> ty1 <+> a p <+> ty2) ty ptys ------------------------------------------------------------------------------------------------ @@ -175,7 +168,14 @@ coKeyword :: AbsolutePathH -> String -> DocH coKeyword = coText -- An alternative would be keyword. +coArrow :: AbsolutePathH -> DocH +coArrow p = coSymbol p RightArrowSymbol +coTypeSymbol :: AbsolutePathH -> DocH +coTypeSymbol p = coSymbol p TypeOfSymbol + +------------------------------------------------------------------------------------------------ + tyChar :: AbsolutePathH -> Char -> DocH tyChar p = attrP p . typeColor . char @@ -222,6 +222,7 @@ then return (cleanParens p (idText p doc)) else return (idText p doc) +-- For var bindings ppVar :: PrettyH Var ppVar = readerT $ \ v -> varName ^>> ppName (varColor v) @@ -241,7 +242,9 @@ ppName :: SyntaxForColor -> PrettyH Name ppName color = do p <- absPathT - name <- arr uqName + c <- contextT + name <- arr (\ n -> unqualifiedName n ++ (if po_showUniques (prettyC_options c) + then '_' : show (getUnique n) else "")) let doc = attrP p $ markColor color $ text name -- TODO: is "isScriptInfixId" the right predicate to use here? if all isScriptInfixIdChar name @@ -312,7 +315,7 @@ ) (\ _ -> ppBinderMode) ppCoreExpr - (\ con vs e -> hang (con <+> hsep vs <+> specialSymbol p RightArrowSymbol) 2 e) + (\ con vs e -> hang (con <+> fsep vs <+> specialSymbol p RightArrowSymbol) 2 e) ppCoreDef :: PrettyH CoreDef ppCoreDef = defT idR (ppCoreExprR &&& ppTypeSig) (,) >>> ppDef Def_RHS @@ -349,14 +352,15 @@ lamT ppBinderMode ppCoreExprR (retLam p) <+ 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))) + <+ caseT ppCoreExpr ppVar (ppTypeModeR >>> parenExpr) (const ppCoreAlt) + (\ s w ty alts -> RetExpr (hang (keyword p "case" <+> s) 1 (keyword p "of" <+> w <+> ty) $+$ nest 2 (vcat alts))) <+ varT (RetAtom <$> ppVarOcc) <+ litT (RetAtom <$> ppSDoc) <+ typeT ppTypeModeR <+ coercionT ppCoercionModeR <+ (castT ppCoreExprR (ppCoercionModeR >>> parenExpr) (,) >>> readerT (\ (_,co) -> if isEmpty co then arr fst - else toFst parenExprExceptApp >>^ \ e -> RetExpr (e <+> castSymbol p <+> co) + else toFst parenExprExceptApp >>^ \ e -> RetExpr (hang e 2 (castSymbol p <+> co)) )) <+ tickT ppSDoc (ppCoreExprR >>> parenExpr) (\ tk e -> RetExpr $ attrP p (text "Tick") $$ nest 2 (tk <+> e)) @@ -381,10 +385,10 @@ tyVarT (RetAtom <$> ppVarOcc) <+ litTyT (RetAtom <$> ppLitTy) <+ appTyT ppKindOrTypeR ppKindOrTypeR (retApp p AppTy_Fun AppTy_Arg) - <+ funTyT ppKindOrTypeR ppKindOrTypeR (retArrowType p FunTy_Dom FunTy_CoDom) + <+ funTyT ppKindOrTypeR ppKindOrTypeR (retArrowType ATType p FunTy_Dom FunTy_CoDom) <+ forAllTyT ppVar ppKindOrTypeR (retForAll p ForAllTy_Body) <+ tyConAppT (forkFirst ppTyCon) (\ _ -> ppKindOrTypeR) - (\ (pCon,tyCon) tys -> if | isFunTyCon tyCon && length tys == 2 -> let [ty1,ty2] = tys in retArrowType p (TyConApp_Arg 0) (TyConApp_Arg 1) ty1 ty2 + (\ (pCon,tyCon) tys -> if | isFunTyCon tyCon && length tys == 2 -> let [ty1,ty2] = tys in retArrowType ATType p (TyConApp_Arg 0) (TyConApp_Arg 1) ty1 ty2 | tyCon == listTyCon -> RetAtom $ tyChar p '[' <> (case tys of [] -> empty t:_ -> normalExpr t) @@ -419,7 +423,7 @@ Omit -> return RetEmpty Abstract -> return (RetAtom $ coercionSymbol p) Show -> ppCoercionR - Kind -> ppCoKind >>^ (\ k -> RetExpr (coercionSymbol p <+> typeOfSymbol p <+> k)) + Kind -> ppCoKind >>^ (\ k -> RetExpr (coercionSymbol p <+> coTypeSymbol p <+> k)) ppCoercionR :: Transform PrettyC HermitM Coercion RetExpr ppCoercionR = absPathT >>= ppCoercionPR @@ -436,26 +440,25 @@ else RetExpr (cop2 <+> coChar p '@' <+> ty) ) <+ appCoT ppCoercionR ppCoercionR (retApp p AppCo_Fun AppCo_Arg) -#if __GLASGOW_HASKELL__ > 706 -- TODO: Figure out how to properly pp new branched Axioms and Left/Right Coercions <+ reflT (ppTypeModeR >>^ normalExpr) (\ r ty -> RetAtom $ if isEmpty ty then coText p "refl" else coChar p '<' <> coText p (showRole r ++ ":") <> ty <> coChar p '>') - <+ tyConAppCoT ppTyConCo (const ppCoercionR) (\ r tc -> retApps p TyConApp_Arg $ coText p (showRole r ++ ":") <> tc) + <+ tyConAppCoT (forkFirst ppTyConCo) (const ppCoercionR) + (\ r (ptc, tc) cs -> if isFunTyCon tc && (length cs == 2) + then let [c1,c2] = cs + in retArrowType ATCoercion p (TyConApp_Arg 0) (TyConApp_Arg 1) c1 c2 + else retApps p TyConApp_Arg (coText p (showRole r ++ ":") <> ptc) cs) <+ axiomInstCoT (coAxiomName ^>> ppName CoercionColor) ppSDoc (\ _ -> ppCoercionR >>> parenExpr) (\ ax idx coes -> RetExpr (coText p "axiomInst" <+> ax <+> idx <+> sep coes)) <+ lrCoT ppSDoc (ppCoercionR >>> parenExpr) (\ lr co -> RetExpr (coercionColor lr <+> co)) -- TODO: UnivCo and SubCo <+ constT (return . RetAtom $ text "Unsupported Coercion Constructor") -#else - <+ reflT (ppTypeModeR >>^ normalExpr >>^ \ ty -> RetAtom $ if isEmpty ty then coText p "refl" else coChar p '<' <> ty <> coChar p '>') - <+ tyConAppCoT ppTyConCo (const ppCoercionR) (retApps p TyConApp_Arg) - <+ unsafeCoT (ppTypeModeR >>> parenExpr) (ppTypeModeR >>> parenExpr) (\ ty1 ty2 -> (if isEmpty ty1 && isEmpty ty2 then RetAtom else RetExpr) - (coKeyword p "unsafe" <+> ty1 <+> ty2) - ) - <+ axiomInstCoT (coAxiomName ^>> ppName CoercionColor) (\ _ -> ppCoercionR >>> parenExpr) (\ ax coes -> RetExpr (coText p "axiomInst" <+> ax <+> sep coes)) -#endif ppCoKind :: PrettyH Coercion -ppCoKind = do p <- absPathT - (coercionKind >>> unPair) ^>> ((ppTypeModeR >>> parenExprExceptApp) *** (ppTypeModeR >>> parenExprExceptApp)) >>^ ( \(ty1,ty2) -> ty1 <+> coText p "~#" <+> ty2) +ppCoKind = do + p <- absPathT + (r, Pair co1 co2) <- arr (coercionRole &&& coercionKind) + ty1 <- return co1 >>> ppTypeModeR >>> parenExprExceptApp + ty2 <- return co2 >>> ppTypeModeR >>> parenExprExceptApp + return $ cat [ty1, pad (coText p ("~" ++ showRole r)), ty2] -------------------------------------------------------------------- diff --git a/src/HERMIT/PrettyPrinter/Common.hs b/src/HERMIT/PrettyPrinter/Common.hs --- a/src/HERMIT/PrettyPrinter/Common.hs +++ b/src/HERMIT/PrettyPrinter/Common.hs @@ -40,11 +40,10 @@ , updateTypeShowOption , updateWidthOption -- * Utilities + , pad , hlist , vlist -#if __GLASGOW_HASKELL__ > 706 , showRole -#endif ) where import Data.Char @@ -56,18 +55,16 @@ import HERMIT.Context import HERMIT.Core import HERMIT.External -import HERMIT.GHC hiding (($$), (<>), (<+>)) +import HERMIT.GHC hiding (($$), (<>), (<+>), char) import HERMIT.Kure import HERMIT.Monad import Text.PrettyPrint.MarkedHughesPJ as PP -#if __GLASGOW_HASKELL__ > 706 showRole :: Role -> String -showRole Nominal = "Nominal" -showRole Representational = "Representational" -showRole Phantom = "Phantom" -#endif +showRole Nominal = "N" +showRole Representational = "R" +showRole Phantom = "P" -- A HERMIT document type DocH = MDoc HermitMark @@ -201,6 +198,7 @@ , po_exprTypes :: ShowOption -- ^ Do you hide types, and type arguments, as <>? , po_coercions :: ShowOption -- ^ Do you hide coercions? , po_typesForBinders :: ShowOption -- ^ Do you give the types for all bindings? + , po_showUniques :: Bool -- ^ Append uniques to OccNames? (Like GHC does) , po_focus :: Maybe PathH -- ^ This region should be highlighted (is the current focus) , po_depth :: Maybe Int -- ^ below this depth are ..., Nothing => infinite , po_notes :: Bool -- ^ notes might be added to output @@ -225,8 +223,9 @@ def = PrettyOptions { po_fullyQualified = False , po_exprTypes = Abstract - , po_coercions = Abstract + , po_coercions = Kind , po_typesForBinders = Omit + , po_showUniques = False , po_focus = Nothing , po_depth = Nothing , po_notes = False @@ -487,5 +486,9 @@ vlist, hlist :: [MDoc a] -> MDoc a vlist = listify ($$) hlist = listify (<+>) + +-- | wrap a document in spaces +pad :: MDoc a -> MDoc a +pad d = char ' ' <> d <> char ' ' ------------------------------------------------------------------------------- diff --git a/src/HERMIT/Shell/Command.hs b/src/HERMIT/Shell/Command.hs --- a/src/HERMIT/Shell/Command.hs +++ b/src/HERMIT/Shell/Command.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE LambdaCase, ScopedTypeVariables, GADTs, FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, CPP, FlexibleContexts, GADTs, LambdaCase, ScopedTypeVariables, TypeFamilies #-} module HERMIT.Shell.Command ( -- * The HERMIT Command-line Shell commandLine + , interpShellCommand , unicodeConsole , diffDocH , diffR @@ -14,14 +15,14 @@ , evalScript ) where -import Control.Concurrent import Control.Monad.State -import Control.Monad.Error import Data.Char import Data.List (isPrefixOf, partition) import Data.Maybe +import Data.Monoid +import HERMIT.Context import HERMIT.External import qualified HERMIT.GHC as GHC import HERMIT.Kernel.Scoped hiding (abortS, resumeS) @@ -31,6 +32,9 @@ import HERMIT.Plugin.Display import HERMIT.Plugin.Renderer +import HERMIT.PrettyPrinter.Common + +import HERMIT.Shell.Completion import HERMIT.Shell.Externals import HERMIT.Shell.Interpreter import HERMIT.Shell.KernelEffect @@ -39,6 +43,10 @@ import HERMIT.Shell.ShellEffect import HERMIT.Shell.Types +#ifdef mingw32_HOST_OS +import HERMIT.Win32.Console +#endif + import System.IO -- import System.Console.ANSI @@ -72,44 +80,58 @@ , "==============================================================" ] +#ifdef mingw32_HOST_OS +cygwinWarning :: String +cygwinWarning = unlines + [ "WARNING: HERMIT invoked in a Unix-like shell such as Cygwin." + , "Cygwin does not handle Ctrl-C or tab completion well in some" + , "Haskell executables. It is recommended that you use a native" + , "Windows console (such as cmd.exe or PowerShell) instead." + ] +#endif + -- | The first argument includes a list of files to load. -commandLine :: [GHC.CommandLineOption] -> Behavior -> [External] -> CLT IO () -commandLine opts behavior exts = do +commandLine :: forall m. (MonadCatch m, MonadException m, CLMonad m) + => [Interp m ()] -> [GHC.CommandLineOption] -> [External] -> m () +commandLine intp opts exts = do let (flags, filesToLoad) = partition (isPrefixOf "-") opts ws_complete = " ()" modify $ \ st -> st { cl_externals = shell_externals ++ exts } - clState <- get - completionMVar <- liftIO $ newMVar clState - - let loop :: CLT (InputT IO) () + let loop :: InputT m () loop = do - st <- get + st <- lift get let SAST n = cl_cursor st mLine <- if cl_nav st then liftIO getNavCmd - else do liftIO $ modifyMVar_ completionMVar (const $ return st) -- so the completion can get the current state - lift $ getInputLine $ "hermit<" ++ show n ++ "> " + else getInputLine $ "hermit<" ++ show n ++ "> " case mLine of - Nothing -> performShellEffect Resume + Nothing -> lift $ performShellEffect Resume Just ('-':'-':_) -> loop Just line -> if all isSpace line then loop - else (evalScript line `catchFailHard` cl_putStrLn) >> loop + else lift (evalScript intp line `catchFailHard` cl_putStrLn) >> loop -- Display the banner if any (`elem` ["-v0", "-v1"]) flags then return () else cl_putStrLn banner +#ifdef mingw32_HOST_OS + isCyg <- liftIO isCygwinConsole + if isCyg + then cl_putStrLn cygwinWarning + else return () +#endif + -- Load and run any scripts setRunningScript $ Just [] sequence_ [ case fileName of "abort" -> performShellEffect Abort "resume" -> performShellEffect Resume - _ -> performScriptEffect runExprH $ loadAndRun fileName + _ -> performScriptEffect (runExprH intp) $ loadAndRun fileName | fileName <- reverse filesToLoad , not (null fileName) ] `catchFailHard` \ msg -> cl_putStrLn $ "Booting Failure: " ++ msg @@ -117,26 +139,41 @@ -- Start the CLI showWindow - let settings = setComplete (completeWordWithPrev Nothing ws_complete (shellComplete completionMVar)) defaultSettings - (r,s) <- get >>= liftIO . runInputTBehavior behavior settings . flip runCLT loop - either throwError (\v -> put s >> return v) r + let settings = setComplete (completeWordWithPrev Nothing ws_complete shellComplete) defaultSettings + runInputT settings loop -- | Like 'catchM', but checks the 'cl_failhard' setting and does so if needed. -catchFailHard :: MonadIO m => CLT m () -> (String -> CLT m ()) -> CLT m () +catchFailHard :: (MonadCatch m, CLMonad m) => m () -> (String -> m ()) -> m () catchFailHard m failure = catchM m $ \ msg -> ifM (gets cl_failhard) (performQuery Display (CmdName "display") >> cl_putStrLn msg >> abort) (failure msg) -evalScript :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => String -> m () -evalScript = parseScriptCLT >=> mapM_ runExprH +evalScript :: (MonadCatch m, CLMonad m) => [Interp m ()] -> String -> m () +evalScript intp = parseScriptCLT >=> mapM_ (runExprH intp) -runExprH :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => ExprH -> m () -runExprH expr = prefixFailMsg ("Error in expression: " ++ unparseExprH expr ++ "\n") $ do - shellCmd <- interpExprH interpShellCommand expr - case shellCmd of - KernelEffect effect -> performKernelEffect effect expr - ScriptEffect effect -> performScriptEffect runExprH effect - ShellEffect effect -> performShellEffect effect - QueryFun query -> performQuery query expr - ProofCommand cmd -> performProofCommand cmd +runExprH :: (MonadCatch m, CLMonad m) => [Interp m ()] -> ExprH -> m () +runExprH intp expr = prefixFailMsg ("Error in expression: " ++ unparseExprH expr ++ "\n") $ interpExprH intp expr + +-- | Interpret a boxed thing as one of the four possible shell command types. +interpShellCommand :: (MonadCatch m, MonadException m, CLMonad m) => [Interp m ()] +interpShellCommand = + [ interpEM $ \ (RewriteCoreBox rr) -> applyRewrite rr + , interpEM $ \ (RewriteCoreTCBox rr) -> applyRewrite rr + , interpEM $ \ (BiRewriteCoreBox br) -> applyRewrite $ whicheverR br + , interpEM $ \ (CrumbBox cr) -> setPath (return (mempty @@ cr) :: TransformH CoreTC LocalPathH) + , interpEM $ \ (PathBox p) -> setPath (return p :: TransformH CoreTC LocalPathH) + , interpEM $ \ (TransformCorePathBox tt) -> setPath tt + , interpEM $ \ (TransformCoreTCPathBox tt) -> setPath tt + , interpEM $ \ (StringBox str) -> performQuery (message str) + , interpEM $ \ (TransformCoreStringBox tt) -> performQuery (QueryString tt) + , interpEM $ \ (TransformCoreTCStringBox tt) -> performQuery (QueryString tt) + , interpEM $ \ (TransformCoreTCDocHBox tt) -> performQuery (QueryDocH $ unTransformDocH tt) + , interpEM $ \ (TransformCoreCheckBox tt) -> performQuery (CorrectnessCritera tt) + , interpEM $ \ (TransformCoreTCCheckBox tt) -> performQuery (CorrectnessCritera tt) + , interpEM $ \ (effect :: KernelEffect) -> flip performKernelEffect effect + , interpM $ \ (effect :: ShellEffect) -> performShellEffect effect + , interpM $ \ (effect :: ScriptEffect) -> performScriptEffect (runExprH interpShellCommand) effect + , interpEM $ \ (query :: QueryFun) -> performQuery query + , interpM $ \ (cmd :: ProofCommand) -> performProofCommand cmd + ] ------------------------------------------------------------------------------- diff --git a/src/HERMIT/Shell/Completion.hs b/src/HERMIT/Shell/Completion.hs new file mode 100644 --- /dev/null +++ b/src/HERMIT/Shell/Completion.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FlexibleContexts, LambdaCase #-} +module HERMIT.Shell.Completion (shellComplete) where + +import Control.Applicative +import Control.Arrow +import Control.Monad.State + +import Data.Dynamic +import Data.List (isPrefixOf, nub) +import Data.Map (keys) +import Data.Maybe (fromMaybe) + +import HERMIT.Kure +import HERMIT.External +import qualified HERMIT.GHC as GHC +import HERMIT.Kernel.Scoped +import HERMIT.Monad +import HERMIT.Parser + +import HERMIT.Dictionary.Inline +import HERMIT.Dictionary.Navigation +import HERMIT.Dictionary.Reasoning +import HERMIT.Dictionary.Rules + +import HERMIT.Shell.Interpreter +import HERMIT.Shell.Types + +import System.Console.Haskeline hiding (catch, display) + +---------------------------------------------------------------------------------- + +shellComplete :: (MonadCatch m, MonadIO m, MonadState CommandLineState m) => String -> String -> m [Completion] +shellComplete rPrev so_far = do + let (partial, _) = toUnmatched rPrev + if null partial + then completionsFor so_far [CommandC] + else case parseExprH partial of + Left _ -> return [] + Right e -> do + eds <- attemptM $ exprToDyns e + case eds of + Left msg -> liftIO $ putStrLn ("\n" ++ msg) >> return [] + Right ds -> do + let ts = [ head args | d <- ds + , let args = fst (splitFunTyArgs (dynTypeRep d)) + , not (null args) ] + completionsFor so_far $ filterUnknowns $ map (completionType.show) ts + +completionsFor :: (MonadCatch m, MonadIO m, MonadState CommandLineState m) + => String -> [CompletionType] -> m [Completion] +completionsFor so_far cts = do + qs <- mapM completionQuery cts + (k,(env,sast)) <- gets (cl_kernel &&& cl_kernel_env &&& cl_cursor) + cls <- forM qs $ \ q -> catchM (queryS k q env sast) (\_ -> return []) + return $ map simpleCompletion $ nub $ filter (so_far `isPrefixOf`) $ concat cls + +data CompletionType = ConsiderC -- considerable constructs and (deprecated) bindingOfT + | BindingOfC -- bindingOfT + | BindingGroupOfC -- bindingGroupOfT + | RhsOfC -- rhsOfT + | OccurrenceOfC -- occurrenceOfT + | InlineC -- complete with names that can be inlined + | InScopeC -- complete with in-scope variable names + | LemmaC -- complete with list of lemmas + | CommandC -- complete using dictionary commands (default) + | CoreC -- complete with opening Core fragment bracket [| + | NothingC -- no completion + | RuleC -- complete with GHC rewrite rule name + | StashC -- complete with remembered labels + | StringC -- complete with open quotes + | UnknownC String -- unknown Extern instance (empty completion) + +completionType :: String -> CompletionType +completionType s = fromMaybe (UnknownC s) (lookup s m) + where m = [ ("BindingName" , BindingOfC) + , ("Considerable" , ConsiderC) + , ("CoreBox" , CoreC) + , ("HermitName" , NothingC) + , ("IntBox" , NothingC) + , ("LemmaName" , LemmaC) + , ("OccurrenceName", OccurrenceOfC) + , ("RememberedName", StashC) + , ("RewriteCoreBox", CommandC) -- be more specific than CommandC? + , ("RhsOfName" , RhsOfC) + , ("RuleName" , RuleC) + , ("StringBox" , StringC) + ] + +filterUnknowns :: [CompletionType] -> [CompletionType] +filterUnknowns l = if null l' then l else l' + where l' = filter (\case UnknownC _ -> False ; _ -> True) l + +completionQuery :: (MonadIO m, MonadState CommandLineState m) => CompletionType -> m (TransformH CoreTC [String]) +completionQuery ConsiderC = return $ pure $ map fst considerables +completionQuery OccurrenceOfC = return $ occurrenceOfTargetsT >>^ GHC.varSetToStrings >>^ map ('\'':) +completionQuery BindingOfC = return $ bindingOfTargetsT >>^ GHC.varSetToStrings >>^ map ('\'':) +completionQuery BindingGroupOfC = return $ bindingGroupOfTargetsT >>^ GHC.varSetToStrings >>^ map ('\'':) +completionQuery RhsOfC = return $ rhsOfTargetsT >>^ GHC.varSetToStrings >>^ map ('\'':) +completionQuery InlineC = return $ promoteT inlineTargetsT >>^ map ('\'':) +completionQuery InScopeC = return $ pure ["'"] -- TODO +completionQuery LemmaC = return $ liftM (map show . keys) $ getLemmasT +completionQuery NothingC = return $ pure [] +completionQuery RuleC = return $ liftM (map (show . fst)) $ getHermitRulesT +completionQuery StashC = return $ liftM (map show . keys) $ constT getStash +completionQuery StringC = return $ pure ["\""] +completionQuery CommandC = gets cl_externals >>= return . pure . map externName +completionQuery CoreC = return $ pure ["[|"] +-- Need to modify opts in completionType function to add this type. +completionQuery (UnknownC s) = do + liftIO $ putStrLn $ "\nCannot tab complete: unknown argument type: " ++ s + return (pure []) + +-- | Take a reversed string, find substring back to first unmatched open paren (or the end). +-- Returns that substring (unreversed), and remaining (reversed) string. +-- +-- ex 1. toUnmatched "zab rab( oof" ==> ("bar baz" , "( oof") +-- ex 2. toUnmatched ")xuuq zab( rab( oof" ==> ("bar (baz quux)", "( oof") +toUnmatched :: String -> (String, String) +toUnmatched = go 0 "" + where go :: Int -> String -> String -> (String, String) + go n acc s@('(':cs) + | n > 0 = go (n-1) ('(':acc) cs + | otherwise = (acc, s) + go n acc (')':cs) = go (n+1) (')':acc) cs + go n acc (c:cs) = go n (c:acc) cs + go _ acc [] = (acc, []) + diff --git a/src/HERMIT/Shell/Dictionary.hs b/src/HERMIT/Shell/Dictionary.hs --- a/src/HERMIT/Shell/Dictionary.hs +++ b/src/HERMIT/Shell/Dictionary.hs @@ -1,11 +1,13 @@ {-# LANGUAGE ScopedTypeVariables #-} module HERMIT.Shell.Dictionary - ( mkDict + ( mkDictionary + , addToDictionary , pp_dictionary ) where +import Data.Dynamic import Data.List -import Data.Map (Map, fromList, toList) +import Data.Map (Map, fromList, toList, fromListWith) import HERMIT.External @@ -16,9 +18,24 @@ -------------------------------------------------------------------------- +-- | A 'Dictionary' is a collection of 'Dynamic's. +-- Looking up a 'Dynamic' (via an 'ExternalName' key) returns a list, as there +-- can be multiple 'Dynamic's with the same name. +type Dictionary = Map ExternalName [Dynamic] + +-- | Build a 'Data.Map' from names to 'Dynamic' values. +toDictionary :: [External] -> Dictionary +toDictionary = fromListWith (++) . map toEntry + +toEntry :: External -> (ExternalName, [Dynamic]) +toEntry e = (externName e, [externDyn e]) + +addToDictionary :: External -> Dictionary -> Dictionary +addToDictionary ex d = fromListWith (++) $ toEntry ex : toList d + -- | Create a dictionary from a list of 'External's. -mkDict :: [External] -> Dictionary -mkDict externs = toDictionary externs' +mkDictionary :: [External] -> Dictionary +mkDictionary externs = toDictionary externs' where msg = layoutTxt 60 (map (show . fst) dictionaryOfTags) externs' = externs ++ diff --git a/src/HERMIT/Shell/Externals.hs b/src/HERMIT/Shell/Externals.hs --- a/src/HERMIT/Shell/Externals.hs +++ b/src/HERMIT/Shell/Externals.hs @@ -4,7 +4,6 @@ import Control.Applicative -import Data.Monoid import Data.List (intercalate) import qualified Data.Map as M import Control.Monad (liftM) @@ -19,7 +18,6 @@ import HERMIT.PrettyPrinter.Common import HERMIT.Shell.Dictionary -import HERMIT.Shell.Interpreter import HERMIT.Shell.KernelEffect import HERMIT.Shell.Proof as Proof import HERMIT.Shell.ScriptToRewrite @@ -28,36 +26,6 @@ ---------------------------------------------------------------------------------- --- | There are five types of commands. -data ShellCommand = KernelEffect KernelEffect -- ^ Command that modifies the state of the (scoped) kernel. - | ScriptEffect ScriptEffect -- ^ Command that deals with script files. - | ShellEffect ShellEffect -- ^ Command that modifies the state of the shell. - | QueryFun QueryFun -- ^ Command that queries the AST with a Transform (read only). - | ProofCommand ProofCommand -- ^ Command that deals with proofs. - --- | Interpret a boxed thing as one of the four possible shell command types. -interpShellCommand :: [Interp ShellCommand] -interpShellCommand = - [ interp $ \ (RewriteCoreBox rr) -> KernelEffect (Apply rr) - , interp $ \ (RewriteCoreTCBox rr) -> KernelEffect (Apply rr) - , interp $ \ (BiRewriteCoreBox br) -> KernelEffect (Apply $ whicheverR br) - , interp $ \ (CrumbBox cr) -> KernelEffect (Pathfinder (return (mempty @@ cr) :: TransformH CoreTC LocalPathH)) - , interp $ \ (PathBox p) -> KernelEffect (Pathfinder (return p :: TransformH CoreTC LocalPathH)) - , interp $ \ (TransformCorePathBox tt) -> KernelEffect (Pathfinder tt) - , interp $ \ (TransformCoreTCPathBox tt) -> KernelEffect (Pathfinder tt) - , interp $ \ (StringBox str) -> QueryFun (message str) - , interp $ \ (TransformCoreStringBox tt) -> QueryFun (QueryString tt) - , interp $ \ (TransformCoreTCStringBox tt) -> QueryFun (QueryString tt) - , interp $ \ (TransformCoreTCDocHBox tt) -> QueryFun (QueryDocH $ unTransformDocH tt) - , interp $ \ (TransformCoreCheckBox tt) -> QueryFun (CorrectnessCritera tt) - , interp $ \ (TransformCoreTCCheckBox tt) -> QueryFun (CorrectnessCritera tt) - , interp $ \ (effect :: KernelEffect) -> KernelEffect effect - , interp $ \ (effect :: ShellEffect) -> ShellEffect effect - , interp $ \ (effect :: ScriptEffect) -> ScriptEffect effect - , interp $ \ (query :: QueryFun) -> QueryFun query - , interp $ \ (cmd :: ProofCommand) -> ProofCommand cmd - ] - shell_externals :: [External] shell_externals = map (.+ Shell) [ @@ -148,6 +116,11 @@ [(opt,"")] -> return $ setPrettyOpts st (updateCoShowOption opt (cl_pretty_opts st)) _ -> return st) ["set how to show coercions (Show|Abstact|Omit)"] + , external "set-pp-uniques" (\ str -> CLSModify $ \ st -> + case reads str of + [(b,"")] -> return $ setPrettyOpts st ((cl_pretty_opts st) { po_showUniques = b } ) + _ -> return st) + ["set whether uniques are printed with variable names"] , external "{" BeginScope ["push current lens onto a stack"] -- tag as internal , external "}" EndScope diff --git a/src/HERMIT/Shell/Interpreter.hs b/src/HERMIT/Shell/Interpreter.hs --- a/src/HERMIT/Shell/Interpreter.hs +++ b/src/HERMIT/Shell/Interpreter.hs @@ -1,14 +1,21 @@ -{-# LANGUAGE KindSignatures, GADTs, InstanceSigs, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds, KindSignatures, GADTs, InstanceSigs, + FlexibleContexts, ScopedTypeVariables, CPP #-} module HERMIT.Shell.Interpreter - ( -- * The HERMIT Interpreter - Interp - , interp - , interpExprH --- , runExprH - ) where + ( -- * The HERMIT Interpreter + Interp + , interp + , interpM + , interpEM + , interpExprH + , exprToDyns + ) where +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except +#else import Control.Monad.Error +#endif import Control.Monad.State import Data.Char @@ -16,48 +23,50 @@ import qualified Data.Map as M import HERMIT.External +import HERMIT.Kure +import HERMIT.Monad +import HERMIT.Name import HERMIT.Parser -import HERMIT.Kure +import HERMIT.Dictionary.Navigation +import HERMIT.Dictionary.Rules + import HERMIT.Shell.Dictionary import HERMIT.Shell.Types -- | An 'Interp' @cmd@ is a /possible/ means of converting a 'Typeable' value to a value of type @cmd@. -data Interp :: * -> * where - Interp :: Typeable a => (a -> cmd) -> Interp cmd +data Interp :: (* -> *) -> * -> * where + Interp :: Typeable b => (b -> ExprH -> m a) -> Interp m a --- | The primitive way of building an 'Interp'. -interp :: Typeable a => (a -> cmd) -> Interp cmd -interp = Interp +-- | An 'Interp' with no effects. +interp :: (Monad m, Typeable b) => (b -> a) -> Interp m a +interp f = Interp (const . return . f) -instance Functor Interp where - fmap :: (a -> b) -> Interp a -> Interp b - fmap f (Interp g) = Interp (f . g) +-- | An 'Interp' which can affect the shell. +interpM :: (CLMonad m, Typeable b) => (b -> m a) -> Interp m a +interpM f = Interp (const . f) -{- -runExprH :: forall m r. (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => ExprH -> m r -runExprH e = do - dyns <- interpExpr e - CmdInterps interps <- gets cl_interps - case [ performCommand $ f a | Interp f <- interps, Just a <- map fromDynamic dyns] of - [] -> fail $ "Does not type-check: " ++ unparseExprH e ++ "\n" - b:_ -> b :: m r --} +-- | Like 'InterpM', but with access to the original expression. +interpEM :: (CLMonad m, Typeable b) => (b -> ExprH -> m a) -> Interp m a +interpEM = Interp --- | Interpret an 'ExprH' by looking up the appropriate 'Dynamic'(s) in the provided 'Dictionary', --- then interpreting the 'Dynamic'(s) with the provided 'Interp's, returning the first --- interpretation to succeed (or an error string if none succeed). -interpExprH :: MonadState CommandLineState m => [Interp b] -> ExprH -> m b -interpExprH interps e = interpExpr e >>= runInterp e interps +instance Monad m => Functor (Interp m) where + fmap :: (a -> b) -> Interp m a -> Interp m b + fmap f (Interp g) = Interp (\ e -> liftM f . g e) -runInterp :: Monad m => ExprH -> [Interp b] -> [Dynamic] -> m b -runInterp e interps dyns = case [f a | Interp f <- interps, Just a <- map fromDynamic dyns] of - [] -> fail $ "Does not type-check: " ++ unparseExprH e ++ "\n" - b:_ -> return b +-- | Execute an 'ExprH' using a given interpreter. The given interpretations +-- are tried in order. The first one to match (have the proper type) will be executed. +interpExprH :: CLMonad m => [Interp m b] -> ExprH -> m b +interpExprH interps e = exprToDyns e >>= runInterp e interps -interpExpr :: MonadState CommandLineState m => ExprH -> m [Dynamic] -interpExpr = interpExpr' False +runInterp :: forall m b. CLMonad m => ExprH -> [Interp m b] -> [Dynamic] -> m b +runInterp e interps dyns = case [f a e :: m b | Interp f <- interps, Just a <- map fromDynamic dyns] of + [] -> fail $ "Does not type-check: " ++ unparseExprH e ++ "\n" + comp:_ -> comp +exprToDyns :: MonadState CommandLineState m => ExprH -> m [Dynamic] +exprToDyns = exprToDyns' False + -- input: list length n, each elem is a variable length list of possible interpretations -- output: variable length list, each elem is list of length n fromDynList :: [[Dynamic]] -> [[Dynamic]] @@ -67,39 +76,48 @@ toBoxedList :: (Extern a, Typeable b) => [[Dynamic]] -> ([a] -> b) -> [Dynamic] toBoxedList dyns boxCon = [ toDyn $ boxCon (map unbox l) | dl <- dyns, Just l <- [mapM fromDynamic dl] ] -interpExpr' :: MonadState CommandLineState m => Bool -> ExprH -> m [Dynamic] -interpExpr' _ (SrcName str) = return [ toDyn $ StringBox str ] -interpExpr' _ (CoreH str) = return [ toDyn $ CoreBox (CoreString str) ] -interpExpr' _ (ListH exprs) = do - dyns <- liftM fromDynList $ mapM (interpExpr' True) exprs +exprToDyns' :: MonadState CommandLineState m => Bool -> ExprH -> m [Dynamic] +exprToDyns' _ (SrcName str) = do + let hn = parseName str -- TODO: remove StringBox option below + -- TODO: change to SrcName :: HermitName -> ExprH + return [ toDyn hn, toDyn (BindingName hn), toDyn (OccurrenceName hn), toDyn (RhsOfName hn), toDyn (StringBox str) ] +exprToDyns' _ (CoreH str) = return [ toDyn $ CoreString str ] +exprToDyns' _ (ListH exprs) = do + dyns <- liftM fromDynList $ mapM (exprToDyns' True) exprs return $ toBoxedList dyns StringListBox ++ toBoxedList dyns (PathBox . pathToSnocPath) -- ugly hack. The whole dynamic stuff could do with overhauling. - ++ toBoxedList dyns (TransformCorePathBox . return . pathToSnocPath) + ++ toBoxedList dyns (TransformCorePathBox . return . pathToSnocPath) ++ toBoxedList dyns IntListBox + ++ toBoxedList dyns OccurrenceNameListBox ++ toBoxedList dyns RewriteCoreListBox + ++ toBoxedList dyns RuleNameListBox -interpExpr' rhs (CmdName str) +exprToDyns' rhs (CmdName str) | all isDigit str = do let i = read str return [ -- An Int is either a Path, or will be interpreted specially later. toDyn $ IntBox i -- TODO: Find a better long-term solution. - , toDyn $ TransformCorePathBox (deprecatedIntToPathT i) + , toDyn $ TransformCorePathBox (deprecatedIntToPathT i) ] | otherwise = do - dict <- gets (mkDict . cl_externals) + dict <- gets (mkDictionary . cl_externals) case M.lookup str dict of Just dyns -> do dyns' <- mapM provideState dyns return $ if rhs then toDyn (StringBox str) : dyns' else dyns' -- not a command, try as a string arg... worst case: dynApply fails with "bad type of expression" -- best case: 'help ls' works instead of 'help "ls"'. this is likewise done in the clause above - Nothing | rhs -> return [toDyn $ StringBox str] + Nothing | rhs -> let f = maybe id ((:) . toDyn) $ string2considerable str + in return $ f [ toDyn $ StringBox str + , toDyn $ LemmaName str + , toDyn $ RememberedName str + , toDyn $ RuleName str] | otherwise -> fail $ "User error, unrecognised HERMIT command: " ++ show str -interpExpr' _ (AppH e1 e2) = liftM2 dynCrossApply (interpExpr' False e1) (interpExpr' True e2) +exprToDyns' _ (AppH e1 e2) = liftM2 dynCrossApply (exprToDyns' False e1) (exprToDyns' True e2) --- We essentially treat externals of the type 'CommandLineState -> b' specially, +-- We treat externals of the type 'CommandLineState -> b' specially, -- providing them the shell state here, so they don't need a monadic return type -- in order to access it themselves. provideState :: MonadState CommandLineState m => Dynamic -> m Dynamic diff --git a/src/HERMIT/Shell/KernelEffect.hs b/src/HERMIT/Shell/KernelEffect.hs --- a/src/HERMIT/Shell/KernelEffect.hs +++ b/src/HERMIT/Shell/KernelEffect.hs @@ -1,12 +1,17 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, GADTs, TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts, LambdaCase, TypeFamilies #-} -module HERMIT.Shell.KernelEffect +module HERMIT.Shell.KernelEffect ( KernelEffect(..) , performKernelEffect + , applyRewrite + , setPath + , goDirection + , beginScope + , endScope + , deleteSAST ) where import Control.Monad.State -import Control.Monad.Error import Data.Monoid import Data.Typeable @@ -28,21 +33,11 @@ ------------------------------------------------------------------------------- --- GADTs can't have docs on constructors. See Haddock ticket #43. -- | KernelEffects are things that affect the state of the Kernel --- - Apply a rewrite (giving a whole new lower-level AST). --- - Change the current location using a computed path. --- - Change the currect location using directions. --- - Begin or end a scope. --- - Delete an AST --- - Run a precondition or other predicate that must not fail. -data KernelEffect :: * where - Apply :: (Injection GHC.ModGuts g, Walker HermitC g) => RewriteH g -> KernelEffect - Pathfinder :: (Injection GHC.ModGuts g, Walker HermitC g) => TransformH g LocalPathH -> KernelEffect - Direction :: Direction -> KernelEffect - BeginScope :: KernelEffect - EndScope :: KernelEffect - Delete :: SAST -> KernelEffect +data KernelEffect = Direction Direction -- Change the currect location using directions. + | BeginScope -- Begin scope. + | EndScope -- End scope. + | Delete SAST -- Delete an AST deriving Typeable instance Extern KernelEffect where @@ -50,12 +45,18 @@ box i = i unbox i = i -------------------------------------------------------------------------------- +performKernelEffect :: (MonadCatch m, CLMonad m) => ExprH -> KernelEffect -> m () +performKernelEffect e = \case + Direction dir -> goDirection dir e + BeginScope -> beginScope e + EndScope -> endScope e + Delete sast -> deleteSAST sast -performKernelEffect :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) - => KernelEffect -> ExprH -> m () +------------------------------------------------------------------------------- -performKernelEffect (Apply rr) expr = do +applyRewrite :: (Injection GHC.ModGuts g, Walker HermitC g, MonadCatch m, CLMonad m) + => RewriteH g -> ExprH -> m () +applyRewrite rr expr = do st <- get let sk = cl_kernel st @@ -79,7 +80,9 @@ (\ errs -> liftIO (deleteS sk sast') >> fail errs) else commit -performKernelEffect (Pathfinder t) expr = do +setPath :: (Injection GHC.ModGuts g, Walker HermitC g, MonadCatch m, CLMonad m) + => TransformH g LocalPathH -> ExprH -> m () +setPath t expr = do st <- get -- An extension to the Path p <- prefixFailMsg "Cannot find path: " $ queryS (cl_kernel st) t (cl_kernel_env st) (cl_cursor st) @@ -87,24 +90,28 @@ put $ newSAST expr ast st showWindow -performKernelEffect (Direction dir) expr = do +goDirection :: (MonadCatch m, CLMonad m) => Direction -> ExprH -> m () +goDirection dir expr = do st <- get ast <- prefixFailMsg "Invalid move: " $ modPathS (cl_kernel st) (moveLocally dir) (cl_kernel_env st) (cl_cursor st) put $ newSAST expr ast st showWindow -performKernelEffect BeginScope expr = do +beginScope :: (MonadCatch m, CLMonad m) => ExprH -> m () +beginScope expr = do st <- get ast <- beginScopeS (cl_kernel st) (cl_cursor st) put $ newSAST expr ast st showWindow -performKernelEffect EndScope expr = do +endScope :: (MonadCatch m, CLMonad m) => ExprH -> m () +endScope expr = do st <- get ast <- endScopeS (cl_kernel st) (cl_cursor st) put $ newSAST expr ast st showWindow -performKernelEffect (Delete sast) _ = gets cl_kernel >>= flip deleteS sast +deleteSAST :: (MonadCatch m, CLMonad m) => SAST -> m () +deleteSAST sast = gets cl_kernel >>= flip deleteS sast ------------------------------------------------------------------------------- diff --git a/src/HERMIT/Shell/Proof.hs b/src/HERMIT/Shell/Proof.hs --- a/src/HERMIT/Shell/Proof.hs +++ b/src/HERMIT/Shell/Proof.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, - ScopedTypeVariables, TypeFamilies, TypeSynonymInstances #-} +{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, LambdaCase, + MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeSynonymInstances, CPP #-} module HERMIT.Shell.Proof ( externals @@ -12,29 +12,36 @@ import Control.Arrow hiding (loop, (<+>)) import Control.Concurrent +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except +#else import Control.Monad.Error +#endif import Control.Monad.State import Data.Char (isSpace) import Data.Dynamic import Data.List (delete, isInfixOf) +import Data.Map (filterWithKey, toList) +import Data.String (fromString) import HERMIT.Core import HERMIT.External import HERMIT.GHC hiding (settings, (<>), text, sep, (<+>), ($+$), nest) import HERMIT.Kernel.Scoped import HERMIT.Kure +import HERMIT.Monad import HERMIT.Parser import HERMIT.Utilities import HERMIT.Dictionary.GHC hiding (externals) import HERMIT.Dictionary.Induction import HERMIT.Dictionary.Reasoning hiding (externals) -import HERMIT.Dictionary.Rules hiding (externals) import HERMIT.Plugin.Types import HERMIT.PrettyPrinter.Common +import HERMIT.Shell.Completion import HERMIT.Shell.Interpreter import HERMIT.Shell.KernelEffect import HERMIT.Shell.ScriptToRewrite @@ -49,59 +56,18 @@ -------------------------------------------------------------------------------------------------------- -- | Externals that get us into the prover shell, or otherwise deal with lemmas. +-- TODO: InteractiveProof is the only one that should be here, rest in Reasoning externals :: [External] externals = map (.+ Proof) - [ external "rule-to-lemma" RuleToLemma - [ "Create a lemma from a GHC RULE." ] - , external "show-lemma" (ShowLemmas . Just) + [ external "show-lemma" (ShowLemmas . Just) [ "List lemmas whose names match search string." ] , external "show-lemmas" (ShowLemmas Nothing) [ "List lemmas." ] - , external "lemma" ((\s -> promoteExprBiR . lemma False s) :: CommandLineState -> LemmaName -> BiRewriteH Core) - [ "Generate a bi-directional rewrite from a proven lemma." ] - , external "lemma-unsafe" ((\s -> promoteExprBiR . lemma True s) :: CommandLineState -> LemmaName -> BiRewriteH Core) - [ "Generate a bi-directional rewrite from a lemma, even if it is unproven." ] - , external "lemma-lhs-intro" (lemmaLhsIntroR :: CommandLineState -> LemmaName -> RewriteH Core) - [ "Introduce the LHS of a lemma as a non-recursive binding, in either an expression or a program." - , "body ==> let v = lhs in body" ] .+ Introduce .+ Shallow - , external "lemma-rhs-intro" (lemmaRhsIntroR :: CommandLineState -> LemmaName -> RewriteH Core) - [ "Introduce the RHS of a lemma as a non-recursive binding, in either an expression or a program." - , "body ==> let v = rhs in body" ] .+ Introduce .+ Shallow , external "prove-lemma" InteractiveProof [ "Proof a lemma interactively." ] - , external "inst-lemma" (\ nm v cs -> ModifyLemma nm id (instantiateEqualityVarR (cmpString2Var v) cs) id) - [ "Instantiate one of the universally quantified variables of the given lemma," - , "with the given Core expression, creating a new lemma. Instantiating an" - , "already proven lemma will result in the new lemma being considered proven." ] - , external "inst-lemma-dictionaries" (\ nm -> ModifyLemma nm id instantiateDictsR id) - [ "Instantiate all of the universally quantified dictionaries of the given lemma." - , "Only works on dictionaries whose types are monomorphic (no free type variables)." ] - , external "copy-lemma" (\ nm newName -> ModifyLemma nm (const newName) idR id) - [ "Copy a given lemma, with a new name." ] - , external "modify-lemma" (\ nm rr -> ModifyLemma nm id rr (const False)) - [ "Modify a given lemma. Resets the proven status to Not Proven." ] - , external "query-lemma" QueryLemma - [ "Apply a transformation to a lemma, returning the result." ] , external "dump-lemma" DumpLemma [ "Dump named lemma to a file." , "dump-lemma " ] - , external "extensionality" (extensionalityR . Just :: String -> RewriteH CoreExprEquality) - [ "Given a name 'x, then" - , "f == g ==> forall x. f x == g x" ] - , external "extensionality" (extensionalityR Nothing :: RewriteH CoreExprEquality) - [ "f == g ==> forall x. f x == g x" ] - , external "lhs" (lhsR . extractR :: RewriteH Core -> RewriteH CoreExprEquality) - [ "Apply a rewrite to the LHS of an equality." ] - , external "lhs" (lhsT . extractT :: TransformH CoreTC String -> TransformH CoreExprEquality String) - [ "Apply a transformation to the LHS of an equality." ] - , external "rhs" (rhsR . extractR :: RewriteH Core -> RewriteH CoreExprEquality) - [ "Apply a rewrite to the RHS of an equality." ] - , external "rhs" (rhsT . extractT :: TransformH CoreTC String -> TransformH CoreExprEquality String) - [ "Apply a transformation to the RHS of an equality." ] - , external "both" (bothR . extractR :: RewriteH Core -> RewriteH CoreExprEquality) - [ "Apply a rewrite to both sides of an equality, succeeding if either succeed." ] - , external "both" ((\t -> liftM (\(r,s) -> unlines [r,s]) (bothT (extractT t))) :: TransformH CoreTC String -> TransformH CoreExprEquality String) - [ "Apply a transformation to the RHS of an equality." ] ] -- | Externals that are added to the dictionary only when in interactive proof mode. @@ -109,7 +75,7 @@ proof_externals = map (.+ Proof) [ external "induction" (PCInduction . cmpString2Var :: String -> ProofShellCommand) [ "Perform induction on given universally quantified variable." - , "Each constructor case will generate a new CoreExprEquality to be proven." + , "Each constructor case will generate a new equality to be proven." ] , external "dump" PCDump [ "dump " ] @@ -122,10 +88,7 @@ -------------------------------------------------------------------------------------------------------- data ProofCommand - = RuleToLemma RuleNameString - | InteractiveProof LemmaName - | ModifyLemma LemmaName (String -> String) (RewriteH CoreExprEquality) (Bool -> Bool) - | QueryLemma LemmaName (TransformH CoreExprEquality String) + = InteractiveProof LemmaName | ShowLemmas (Maybe LemmaName) | DumpLemma LemmaName String String Int deriving (Typeable) @@ -137,135 +100,86 @@ -------------------------------------------------------------------------------------------------------- -getLemmaByName :: Monad m => CommandLineState -> LemmaName -> m Lemma -getLemmaByName st nm = - case [ lm | lm@(n,_,_) <- cl_lemmas st, n == nm ] of - [] -> fail ("No lemma named: " ++ nm) - (l:_) -> return l - -deleteLemmaByName :: MonadState CommandLineState m => LemmaName -> m () -deleteLemmaByName nm = modify $ \ st -> st { cl_lemmas = [ l | l@(n,_,_) <- cl_lemmas st, nm /= n ] } - -lemma :: Bool -> CommandLineState -> LemmaName -> BiRewriteH CoreExpr -lemma ok st nm = beforeBiR - (do (_,equality,proven) <- getLemmaByName st nm - guardMsg (proven || ok) ("Lemma " ++ nm ++ " has not been proven.") - return equality - ) - birewrite - --------------------------------------------------------------------------------------------------------- - -lemmaNameToEqualityT :: Monad m => CommandLineState -> LemmaName -> m CoreExprEquality -lemmaNameToEqualityT st nm = - do (_,eq,_) <- getLemmaByName st nm - return eq - --- | @e@ ==> @let v = lhs in e@ (also works in a similar manner at Program nodes) -lemmaLhsIntroR :: CommandLineState -> LemmaName -> RewriteH Core -lemmaLhsIntroR st = lemmaNameToEqualityT st >=> eqLhsIntroR - --- | @e@ ==> @let v = rhs in e@ (also works in a similar manner at Program nodes) -lemmaRhsIntroR :: CommandLineState -> LemmaName -> RewriteH Core -lemmaRhsIntroR st = lemmaNameToEqualityT st >=> eqRhsIntroR - --------------------------------------------------------------------------------------------------------- +performProofCommand :: (MonadCatch m, MonadException m, CLMonad m) => ProofCommand -> m () -performProofCommand :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => ProofCommand -> m () -performProofCommand (RuleToLemma nm) = do +performProofCommand (InteractiveProof nm) = do st <- gets cl_pstate - equality <- queryS (ps_kernel st) (ruleNameToEqualityT nm :: TransformH Core CoreExprEquality) (mkKernelEnv st) (ps_cursor st) - _ <- addLemmas [(nm,equality,False)] - return () - -performProofCommand (InteractiveProof nm) = get >>= flip getLemmaByName nm >>= interactiveProof True - -performProofCommand (ModifyLemma nm nFn rr pFn) = do - st <- get - (_,eq,p) <- getLemmaByName st nm - - -- query so lemma is transformed in current context - eq' <- queryS (cl_kernel st) (return eq >>> rr >>> (bothT lintExprT >> idR) :: TransformH Core CoreExprEquality) (cl_kernel_env st) (cl_cursor st) - deleteLemmaByName (nFn nm) - _ <- addLemmas [(nFn nm, eq', pFn p)] - return () - -performProofCommand (QueryLemma nm t) = do - st <- get - (_,eq,_) <- getLemmaByName st nm - - -- query so lemma is transformed in current context - res <- queryS (cl_kernel st) (return eq >>> t :: TransformH Core String) (cl_kernel_env st) (cl_cursor st) - cl_putStrLn res + l <- queryS (ps_kernel st) (getLemmaByNameT nm :: TransformH Core Lemma) (mkKernelEnv st) (ps_cursor st) + interactiveProof True False (nm,l) -performProofCommand (DumpLemma nm fn r w) = dump (\ st -> getLemmaByName st nm >>> ppLemmaT (cl_pretty st)) fn r w +performProofCommand (DumpLemma nm fn r w) = dump (\ st -> getLemmaByNameT nm >>> ppLemmaT (cl_pretty st) nm) fn r w performProofCommand (ShowLemmas mnm) = do - ls <- gets $ filter (maybe (const True) (\ nm (n,_,_) -> nm `isInfixOf` n) mnm) . cl_lemmas - forM_ ls printLemma + st <- gets cl_pstate + ls <- queryS (ps_kernel st) (getLemmasT :: TransformH Core Lemmas) (mkKernelEnv st) (ps_cursor st) + mapM_ printLemma $ toList $ filterWithKey (maybe (\ _ _ -> True) (\ nm n _ -> show nm `isInfixOf` show n) mnm) ls -------------------------------------------------------------------------------------------------------- -printLemma :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => Lemma -> m () -printLemma lem = do + +printLemma :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) + => (LemmaName,Lemma) -> m () +printLemma (nm,lem) = do st <- get - doc <- queryS (cl_kernel st) (return lem >>> ppLemmaT (cl_pretty st) :: TransformH Core DocH) (cl_kernel_env st) (cl_cursor st) + doc <- queryS (cl_kernel st) (return lem >>> ppLemmaT (cl_pretty st) nm :: TransformH Core DocH) (cl_kernel_env st) (cl_cursor st) liftIO $ cl_render st stdout (cl_pretty_opts st) (Right doc) -ppLemmaT :: PrettyPrinter -> TransformH Lemma DocH -ppLemmaT pp = do - (nm, eq, p) <- idR - eqDoc <- return eq >>> ppCoreExprEqualityT pp - let hDoc = text nm <+> text (if p then "(Proven)" else "(Not Proven)") +ppLemmaT :: PrettyPrinter -> LemmaName -> TransformH Lemma DocH +ppLemmaT pp nm = do + Lemma eq p u <- idR + eqDoc <- return eq >>> ppEqualityT pp + let hDoc = text (show nm) <+> text (if p then "(Proven)" else "(Not Proven)") + <+> text (if u then "(Used)" else "(Not Used)") return $ hDoc $+$ nest 2 eqDoc -------------------------------------------------------------------------------------------------------- -completeProof :: (MonadError CLException m, MonadIO m, MonadState CommandLineState m) => LemmaName -> m () -completeProof nm = do - cl_putStrLn $ "Successfully proven: " ++ nm - modify $ \ st -> st { cl_lemmas = [ (n,e, if n == nm then True else p) | (n,e,p) <- cl_lemmas st ] } - get >>= continue +type NamedLemma = (LemmaName, Lemma) -interactiveProof :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => Bool -> Lemma -> m () -interactiveProof topLevel lem = do - origEs <- addProofExternals topLevel +interactiveProof :: forall m. (MonadCatch m, MonadException m, CLMonad m) => Bool -> Bool -> NamedLemma -> m () +interactiveProof topLevel isTemporary lem@(nm,_) = do origSt <- get - completionMVar <- liftIO $ newMVar origSt + origEs <- addProofExternals topLevel let ws_complete = " ()" -- Main proof input loop - loop :: Lemma -> CLT (InputT IO) () + loop :: NamedLemma -> InputT m () loop l = do - mExpr <- popScriptLine + mExpr <- lift popScriptLine case mExpr of Nothing -> do - printLemma l - st <- get - liftIO $ modifyMVar_ completionMVar (const $ return st) -- so the completion can get the current state - mLine <- lift $ getInputLine $ "proof> " + lift $ printLemma l + mLine <- getInputLine $ "proof> " case mLine of Nothing -> fail "proof aborted (input: Nothing)" Just ('-':'-':_) -> loop l Just line -> if all isSpace line then loop l - else (evalProofScript l line `catchM` (\msg -> cl_putStrLn msg >> return l)) >>= loop - Just e -> (runExprH l e `catchM` (\msg -> setRunningScript Nothing >> cl_putStrLn msg >> return l)) >>= loop + else lift (evalProofScript l line `catchM` (\msg -> cl_putStrLn msg >> return l)) >>= loop + Just e -> lift (runExprH l e `catchM` (\msg -> setRunningScript Nothing >> cl_putStrLn msg >> return l)) >>= loop -- Display a proof banner? -- Start the CLI - let settings = setComplete (completeWordWithPrev Nothing ws_complete (shellComplete completionMVar)) defaultSettings + let settings = setComplete (completeWordWithPrev Nothing ws_complete shellComplete) defaultSettings cleanup s = put (s { cl_externals = origEs }) - (r,_s) <- get >>= liftIO . runInputTBehavior defaultBehavior settings . flip runCLT (loop lem) - case r of - Right _ -> return () -- this case isn't possible, loop never returns - Left CLAbort -> cleanup origSt >> unless topLevel abort -- abandon proof attempt, bubble out to regular shell - Left (CLContinue st') -> cleanup st' -- successfully proven - Left (CLError msg) -> fail $ "Prover error: " ++ msg - Left _ -> fail "unsupported exception in interactive prover" + catchError (runInputT settings (loop lem)) + (\case + CLAbort -> cleanup origSt >> unless topLevel abort -- abandon proof attempt, bubble out to regular shell + CLContinue st' -> do + cl_putStrLn $ "Successfully proven: " ++ show nm + if isTemporary + then cleanup st' -- successfully proven + else do sast <- applyS (cl_kernel st') + (modifyLemmaR nm id idR (const True) id :: RewriteH Core) + (mkKernelEnv $ cl_pstate st') + (cl_cursor st') + cleanup $ newSAST (CmdName "proven") sast st' + CLError msg -> fail $ "Prover error: " ++ msg + _ -> fail "unsupported exception in interactive prover") + addProofExternals :: MonadState CommandLineState m => Bool -> m [External] addProofExternals topLevel = do st <- get @@ -275,16 +189,16 @@ when topLevel $ modify $ \ s -> s { cl_externals = newEs } return es -evalProofScript :: MonadIO m => Lemma -> String -> CLT m Lemma +evalProofScript :: (MonadCatch m, MonadException m, CLMonad m) => NamedLemma -> String -> m NamedLemma evalProofScript lem = parseScriptCLT >=> foldM runExprH lem -runExprH :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => Lemma -> ExprH -> m Lemma +runExprH :: (MonadCatch m, MonadException m, CLMonad m) => NamedLemma -> ExprH -> m NamedLemma runExprH lem expr = prefixFailMsg ("Error in expression: " ++ unparseExprH expr ++ "\n") $ interpExprH interpProof expr >>= performProofShellCommand lem -- | Verify that the lemma has been proven. Throws an exception if it has not. -endProof :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => Lemma -> m () -endProof (nm, eq, _) = do +endProof :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => NamedLemma -> m () +endProof (nm, Lemma eq _ _) = do st <- get let sk = cl_kernel st @@ -292,11 +206,11 @@ sast = cl_cursor st -- Why do a query? We want to do our proof in the current context of the shell, whatever that is. - b <- (queryS sk (return eq >>> testM verifyCoreExprEqualityT :: TransformH Core Bool) kEnv sast) - if b then completeProof nm else fail $ "The two sides of " ++ nm ++ " are not alpha-equivalent." + b <- (queryS sk (return eq >>> testM verifyEqualityT :: TransformH Core Bool) kEnv sast) + if b then continue st else fail $ "The two sides of " ++ show nm ++ " are not alpha-equivalent." -performProofShellCommand :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => Lemma -> ProofShellCommand -> m Lemma -performProofShellCommand lem@(nm, eq, b) = go +performProofShellCommand :: (MonadCatch m, MonadException m, CLMonad m) => NamedLemma -> ProofShellCommand -> m NamedLemma +performProofShellCommand lem@(nm, Lemma eq p u) = go where go (PCRewrite rr) = do st <- get let sk = cl_kernel st @@ -304,8 +218,9 @@ sast = cl_cursor st -- Why do a query? We want to do our proof in the current context of the shell, whatever that is. - eq' <- queryS sk (return eq >>> rr >>> (bothT lintExprT >> idR) :: TransformH Core CoreExprEquality) kEnv sast - return (nm, eq', b) + -- TODO: query doesn't save side effects, which are needed for stash/lemmas + eq' <- queryS sk (return eq >>> rr >>> (bothT lintExprT >> idR) :: TransformH Core Equality) kEnv sast + return (nm, Lemma eq' p u) go (PCTransform t) = do st <- get let sk = cl_kernel st @@ -330,14 +245,14 @@ st <- get -- Why do a query? We want to do our proof in the current context of the shell, whatever that is. queryS (cl_kernel st) (return eq >>> t :: TransformH Core ()) (cl_kernel_env st) (cl_cursor st) - completeProof nm -- note: we assume that if 't' completes without failing, the lemma is proved, we don't actually check + continue st -- note: we assume that if 't' completes without failing, the lemma is proved, we don't actually check return lem -- never reached - go (PCDump fName r w) = dump (\ st -> return lem >>> ppLemmaT (cl_pretty st)) fName r w >> return lem + go (PCDump fName r w) = dump (\ st -> return (snd lem) >>> ppLemmaT (cl_pretty st) (fst lem)) fName r w >> return lem go PCEnd = endProof lem >> return lem go (PCUnsupported s) = cl_putStrLn (s ++ " command unsupported in proof mode.") >> return lem -performInduction :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => Lemma -> (Id -> Bool) -> m Lemma -performInduction lem@(nm, eq@(CoreExprEquality bs lhs rhs), _) idPred = do +performInduction :: (MonadCatch m, MonadException m, CLMonad m) => NamedLemma -> (Id -> Bool) -> m NamedLemma +performInduction lem@(nm, Lemma eq@(Equality bs lhs rhs) _ _) idPred = do st <- get let sk = cl_kernel st kEnv = cl_kernel_env st @@ -355,29 +270,38 @@ eqs <- forM vs_matching_i_type $ \ i' -> liftM discardUniVars $ instantiateEqualityVar (==i) (Var i') [] eq - let nms = [ "ind-hyp-" ++ show n | n :: Int <- [0..] ] - hypLemmas = zip3 nms eqs (repeat True) - caseLemma = ( nm ++ "-induction-on-" ++ getOccString i ++ "-case-" ++ maybe "undefined" getOccString mdc - , CoreExprEquality (delete i bs ++ vs) lhsE rhsE - , False ) + let nms = [ fromString ("ind-hyp-" ++ show n) | n :: Int <- [0..] ] + hypLemmas = zip nms $ zipWith3 Lemma eqs (repeat True) (repeat False) + lemmaName = fromString $ show nm ++ "-induction-on-" + ++ unqualifiedName i ++ "-case-" + ++ maybe "undefined" unqualifiedName mdc + caseLemma = Lemma (Equality (delete i bs ++ vs) lhsE rhsE) False False - origLemmas <- addLemmas hypLemmas - interactiveProof False caseLemma -- recursion! - modify $ \ s -> s { cl_lemmas = origLemmas } -- put original lemmas back + -- this is pretty hacky + sast' <- addLemmas hypLemmas -- add temporary lemmas + interactiveProof False True (lemmaName,caseLemma) -- recursion! + modify $ flip setCursor sast' -- discard temporary lemmas - completeProof nm + get >>= continue return lem -- this is never reached, but the type says we need it. -addLemmas :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => [Lemma] -> m [Lemma] +addLemmas :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) + => [NamedLemma] -> m SAST addLemmas lems = do ifM isRunningScript (return ()) $ forM_ lems printLemma + let addAllAtOnceR :: RewriteH Core + addAllAtOnceR = sideEffectR $ \ _ _ -> forM_ lems $ \ (nm,l) -> insertLemma nm l + st <- get - put $ st { cl_lemmas = cl_lemmas st ++ lems } - return $ cl_lemmas st + sast <- applyS (cl_kernel st) addAllAtOnceR (mkKernelEnv $ cl_pstate st) (cl_cursor st) + put $ newSAST (CmdName "adding lemmas") sast st + -- return original SAST + return $ cl_cursor st + data ProofShellCommand - = PCRewrite (RewriteH CoreExprEquality) - | PCTransform (TransformH CoreExprEquality String) + = PCRewrite (RewriteH Equality) + | PCTransform (TransformH Equality String) | PCInduction (Id -> Bool) | PCShell ShellEffect | PCScript ScriptEffect @@ -390,9 +314,9 @@ deriving Typeable -- keep abstract to avoid breaking things if we modify this later -newtype UserProofTechnique = UserProofTechnique (TransformH CoreExprEquality ()) +newtype UserProofTechnique = UserProofTechnique (TransformH Equality ()) -userProofTechnique :: TransformH CoreExprEquality () -> UserProofTechnique +userProofTechnique :: TransformH Equality () -> UserProofTechnique userProofTechnique = UserProofTechnique instance Extern ProofShellCommand where @@ -407,29 +331,29 @@ box = UserProofTechniqueBox unbox (UserProofTechniqueBox t) = t -interpProof :: [Interp ProofShellCommand] +interpProof :: Monad m => [Interp m ProofShellCommand] interpProof = - [ interp $ \ (RewriteCoreBox rr) -> PCRewrite $ bothR $ extractR rr - , interp $ \ (RewriteCoreTCBox rr) -> PCRewrite $ bothR $ extractR rr - , interp $ \ (BiRewriteCoreBox br) -> PCRewrite $ bothR $ (extractR (forwardT br) <+ extractR (backwardT br)) - , interp $ \ (effect :: ShellEffect) -> PCShell effect - , interp $ \ (effect :: ScriptEffect) -> PCScript effect - , interp $ \ (StringBox str) -> PCQuery (message str) - , interp $ \ (query :: QueryFun) -> PCQuery query - , interp $ \ (cmd :: ProofCommand) -> PCProofCommand cmd - , interp $ \ (RewriteCoreExprEqualityBox r) -> PCRewrite r - , interp $ \ (TransformCoreExprEqualityStringBox t) -> PCTransform t - , interp $ \ (UserProofTechniqueBox t) -> PCUser t - , interp $ \ (cmd :: ProofShellCommand) -> cmd - , interp $ \ (CrumbBox _cr) -> PCUnsupported "CrumbBox" - , interp $ \ (PathBox _p) -> PCUnsupported "PathBox" - , interp $ \ (TransformCorePathBox _tt) -> PCUnsupported "TransformCorePathBox" - , interp $ \ (TransformCoreTCPathBox _tt) -> PCUnsupported "TransformCoreTCPathBox" - , interp $ \ (TransformCoreStringBox _tt) -> PCUnsupported "TransformCoreStringBox" - , interp $ \ (TransformCoreTCStringBox _tt) -> PCUnsupported "TransformCoreTCStringBox" - , interp $ \ (TransformCoreTCDocHBox _tt) -> PCUnsupported "TransformCoreTCDocHBox" - , interp $ \ (TransformCoreCheckBox _tt) -> PCUnsupported "TransformCoreCheckBox" - , interp $ \ (TransformCoreTCCheckBox _tt) -> PCUnsupported "TransformCoreTCCheckBox" - , interp $ \ (_effect :: KernelEffect) -> PCUnsupported "KernelEffect" + [ interp $ \ (RewriteCoreBox rr) -> PCRewrite $ bothR $ extractR rr + , interp $ \ (RewriteCoreTCBox rr) -> PCRewrite $ bothR $ extractR rr + , interp $ \ (BiRewriteCoreBox br) -> PCRewrite $ bothR $ (extractR (forwardT br) <+ extractR (backwardT br)) + , interp $ \ (effect :: ShellEffect) -> PCShell effect + , interp $ \ (effect :: ScriptEffect) -> PCScript effect + , interp $ \ (StringBox str) -> PCQuery (message str) + , interp $ \ (query :: QueryFun) -> PCQuery query + , interp $ \ (cmd :: ProofCommand) -> PCProofCommand cmd + , interp $ \ (RewriteEqualityBox r) -> PCRewrite r + , interp $ \ (TransformEqualityStringBox t) -> PCTransform t + , interp $ \ (UserProofTechniqueBox t) -> PCUser t + , interp $ \ (cmd :: ProofShellCommand) -> cmd + , interp $ \ (CrumbBox _cr) -> PCUnsupported "CrumbBox" + , interp $ \ (PathBox _p) -> PCUnsupported "PathBox" + , interp $ \ (TransformCorePathBox _tt) -> PCUnsupported "TransformCorePathBox" + , interp $ \ (TransformCoreTCPathBox _tt) -> PCUnsupported "TransformCoreTCPathBox" + , interp $ \ (TransformCoreStringBox _tt) -> PCUnsupported "TransformCoreStringBox" + , interp $ \ (TransformCoreTCStringBox _tt) -> PCUnsupported "TransformCoreTCStringBox" + , interp $ \ (TransformCoreTCDocHBox _tt) -> PCUnsupported "TransformCoreTCDocHBox" + , interp $ \ (TransformCoreCheckBox _tt) -> PCUnsupported "TransformCoreCheckBox" + , interp $ \ (TransformCoreTCCheckBox _tt) -> PCUnsupported "TransformCoreTCCheckBox" + , interp $ \ (_effect :: KernelEffect) -> PCUnsupported "KernelEffect" ] diff --git a/src/HERMIT/Shell/ScriptToRewrite.hs b/src/HERMIT/Shell/ScriptToRewrite.hs --- a/src/HERMIT/Shell/ScriptToRewrite.hs +++ b/src/HERMIT/Shell/ScriptToRewrite.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, LambdaCase, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts, LambdaCase, + MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, CPP #-} module HERMIT.Shell.ScriptToRewrite ( -- * Converting Scripts to Rewrites @@ -15,7 +16,11 @@ ) where import Control.Arrow +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except +#else import Control.Monad.Error +#endif import Control.Monad.State import Control.Exception hiding (catch) @@ -66,7 +71,7 @@ popScriptLine = gets cl_running_script >>= maybe (return Nothing) (\case [] -> setRunningScript Nothing >> return Nothing (e:es) -> setRunningScript (Just es) >> return (Just e)) -performScriptEffect :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => (ExprH -> m ()) -> ScriptEffect -> m () +performScriptEffect :: (MonadCatch m, CLMonad m) => (ExprH -> m ()) -> ScriptEffect -> m () performScriptEffect runner = go where go (SeqMeta ms) = mapM_ go ms go (LoadFile scriptName fileName) = do @@ -74,7 +79,7 @@ res <- liftIO $ try (readFile fileName) case res of Left (err :: IOException) -> fail ("IO error: " ++ show err) - Right str -> do + Right str -> do script <- parseScriptCLT str modify $ \ st -> st {cl_scripts = (scriptName,script) : cl_scripts st} putStrToConsole ("Script \"" ++ scriptName ++ "\" loaded successfully from \"" ++ fileName ++ "\".") @@ -104,7 +109,7 @@ putStrToConsole ("Script \"" ++ scriptName ++ "\" ran successfully.") showWindow - go (SaveScript fileName scriptName) = do + go (SaveScript fileName scriptName) = do script <- lookupScript scriptName putStrToConsole $ "Saving script \"" ++ scriptName ++ "\" to file \"" ++ fileName ++ "\"." liftIO $ writeFile fileName $ unparseScript script @@ -164,7 +169,7 @@ ----------------------------------- -interpScriptR :: [Interp UnscopedScriptR] +interpScriptR :: Monad m => [Interp m UnscopedScriptR] interpScriptR = [ interp (\ (RewriteCoreBox r) -> ScriptPrimUn $ ScriptRewriteHCore r) , interp (\ (RewriteCoreTCBox _) -> ScriptUnsupported "rewrite that traverses types and coercions") -- TODO @@ -201,7 +206,7 @@ ----------------------------------- -scriptToRewrite :: MonadState CommandLineState m => Script -> m (RewriteH Core) +scriptToRewrite :: CLMonad m => Script -> m (RewriteH Core) scriptToRewrite scr = do unscoped <- mapM (interpExprH interpScriptR) scr scoped <- unscopedToScopedScriptR $ zip scr unscoped @@ -210,13 +215,13 @@ ----------------------------------- -- | Insert a script into the 'Dictionary'. -addScriptToDict :: MonadState CommandLineState m => ScriptName -> Script -> m () +addScriptToDict :: CLMonad m => ScriptName -> Script -> m () addScriptToDict nm scr = do r <- scriptToRewrite scr let ext = external nm r [ "User-loaded script." ] - modify $ \ st -> st { cl_externals = ext : cl_externals st } + modify $ \ st -> st { cl_externals = ext : cl_externals st } ----------------------------------- diff --git a/src/HERMIT/Shell/ShellEffect.hs b/src/HERMIT/Shell/ShellEffect.hs --- a/src/HERMIT/Shell/ShellEffect.hs +++ b/src/HERMIT/Shell/ShellEffect.hs @@ -2,18 +2,21 @@ DeriveDataTypeable, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, ScopedTypeVariables #-} -module HERMIT.Shell.ShellEffect +module HERMIT.Shell.ShellEffect ( ShellEffect(..) , performShellEffect , dump ) where +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except +#else import Control.Monad.Error +#endif import Control.Monad.State import Data.Typeable -import HERMIT.Dictionary import HERMIT.External import HERMIT.Kure import HERMIT.Kernel.Scoped @@ -33,7 +36,7 @@ | CLSModify (CommandLineState -> IO CommandLineState) -- ^ Modify shell state | PluginComp (PluginM ()) | Continue -- ^ exit the shell, but don't abort/resume - | Dump (CommandLineState -> TransformH CoreTC DocH) String String Int + | Dump (CommandLineState -> TransformH CoreTC DocH) String String Int | Resume deriving Typeable @@ -46,11 +49,7 @@ performShellEffect :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => ShellEffect -> m () performShellEffect Abort = abort -performShellEffect Resume = do - st <- get - sast' <- applyS (cl_kernel st) occurAnalyseAndDezombifyR (cl_kernel_env st) (cl_cursor st) - resume sast' - +performShellEffect Resume = gets cl_cursor >>= resume performShellEffect Continue = get >>= continue performShellEffect (Dump pp fileName renderer width) = dump pp fileName renderer width diff --git a/src/HERMIT/Shell/Types.hs b/src/HERMIT/Shell/Types.hs --- a/src/HERMIT/Shell/Types.hs +++ b/src/HERMIT/Shell/Types.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE CPP, KindSignatures, GADTs, FlexibleContexts, DeriveDataTypeable, +{-# LANGUAGE ConstraintKinds, CPP, KindSignatures, GADTs, FlexibleContexts, DeriveDataTypeable, FunctionalDependencies, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies #-} module HERMIT.Shell.Types where import Control.Applicative -import Control.Arrow -import Control.Concurrent import Control.Concurrent.STM import Control.Monad.State +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except +#else import Control.Monad.Error +#endif -import Data.Char (isSpace) import Data.Dynamic -import Data.List (intercalate, isPrefixOf, nub) +import Data.List (intercalate) import qualified Data.Map as M -import Data.Maybe (isJust) +import Data.Maybe (fromMaybe, isJust) import Data.Monoid (mempty) import HERMIT.Context @@ -23,9 +24,8 @@ import HERMIT.Kure import HERMIT.External import qualified HERMIT.GHC as GHC -import HERMIT.Kernel (AST, queryK) +import HERMIT.Kernel (AST, queryK, KernelEnv) import HERMIT.Kernel.Scoped -import HERMIT.Monad import HERMIT.Parser import HERMIT.PrettyPrinter.Common @@ -33,35 +33,17 @@ import HERMIT.Plugin.Renderer import HERMIT.Plugin.Types -import HERMIT.Dictionary.Inline -import HERMIT.Dictionary.Navigation -import HERMIT.Dictionary.Reasoning (CoreExprEquality) - import System.Console.Haskeline hiding (catch, display) import System.IO (Handle, stdout) -#ifndef mingw32_HOST_OS -import Data.Maybe (fromMaybe) +#ifdef mingw32_HOST_OS +import HERMIT.Win32.Console +#else import System.Console.Terminfo (setupTermFromEnv, getCapability, termColumns, termLines) #endif ---------------------------------------------------------------------------------- -{- --- | How to perform a given set of commands. --- --- Mnemonic: --- c = command type --- a = extra arguments type (use tuple for more than one) --- r = result type --- --- Often, a and r are (), but sometimes we need more clever things. -class ShellCommandSet c a r | c -> a r where - performCommand :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => c -> a -> m r --} - ----------------------------------------------------------------------------------- - data QueryFun :: * where QueryString :: (Injection GHC.ModGuts g, Walker HermitC g) => TransformH g String -> QueryFun @@ -80,8 +62,7 @@ box i = i unbox i = i -performQuery :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) - => QueryFun -> ExprH -> m () +performQuery :: (MonadCatch m, CLMonad m) => QueryFun -> ExprH -> m () performQuery (QueryString q) _ = do st <- get @@ -156,7 +137,9 @@ | CLContinue CommandLineState -- TODO: needed? | CLError String +#if !(MIN_VERSION_mtl(2,2,1)) instance Error CLException where strMsg = CLError +#endif abort :: MonadError CLException m => m () abort = throwError CLAbort @@ -181,16 +164,41 @@ ---------------------------------------------------------------------------------- -- | This type is similiar to PluginM, except that its exception and state types are --- supersets of those for PluginM, and it is a transformer. There are two functions: --- `clm` and `pluginM` for converting between the two. The reason we do this is to obtain --- a clean separation of plugin state from commandline state without nesting state --- transformers. Nesting StateT leads to a lot of awkward lifting and manual state +-- supersets of those for PluginM, and it is a transformer. There are two functions: +-- `clm` and `pluginM` for converting between the two. The reason we do this is to obtain +-- a clean separation of plugin state from commandline state without nesting state +-- transformers. Nesting StateT leads to a lot of awkward lifting and manual state -- management in the command line code. -- -- NB: an alternative to monad transformers, like Oleg's Extensible Effects, might be useful here. +#if MIN_VERSION_mtl(2,2,1) +newtype CLT m a = CLT { unCLT :: ExceptT CLException (StateT CommandLineState m) a } +#else newtype CLT m a = CLT { unCLT :: ErrorT CLException (StateT CommandLineState m) a } +#endif deriving (Functor, Applicative, MonadIO, MonadError CLException, MonadState CommandLineState) +-- Adapted from System.Console.Haskeline.MonadException, which hasn't provided an instance for ExceptT yet +#if MIN_VERSION_mtl(2,2,1) +instance MonadException m => MonadException (ExceptT e m) where + controlIO f = ExceptT $ controlIO $ \(RunIO run) -> let + run' = RunIO (fmap ExceptT . run . runExceptT) + in fmap runExceptT $ f run' +#endif + +instance MonadException m => MonadException (CLT m) where + controlIO f = CLT $ controlIO $ \(RunIO run) -> let run' = RunIO (fmap CLT . run . unCLT) + in fmap unCLT $ f run' + +-- This is copied verbatim from Haskeline, which provides an instance for strict State only. +-- This allows lazy State to enjoy the same benefits. +instance MonadException m => MonadException (StateT s m) where + controlIO f = StateT $ \s -> controlIO $ \(RunIO run) -> let + run' = RunIO (fmap (StateT . const) . run . flip runStateT s) + in fmap (flip runStateT s) $ f run' + +type CLMonad m = (MonadIO m, MonadState CommandLineState m, MonadError CLException m) + instance MonadTrans CLT where -- lift :: Monad m => m a -> CLT m a lift = CLT . lift . lift @@ -206,7 +214,11 @@ -- | Run a CLT computation. runCLT :: CommandLineState -> CLT m a -> m (Either CLException a, CommandLineState) +#if MIN_VERSION_mtl(2,2,1) +runCLT s = flip runStateT s . runExceptT . unCLT +#else runCLT s = flip runStateT s . runErrorT . unCLT +#endif -- | Lift a CLT IO computation into a CLT computation over an arbitrary MonadIO. clm2clt :: MonadIO m => CLT IO a -> CLT m a @@ -225,7 +237,7 @@ Right r' -> put (cl_pstate s') >> return r' -- | Lift a PluginM computation into the CLM monad. -pluginM :: (MonadError CLException m, MonadIO m, MonadState CommandLineState m) => PluginM a -> m a +pluginM :: CLMonad m => PluginM a -> m a pluginM m = do s <- get (r,ps) <- liftIO $ runPluginT (cl_pstate s) m @@ -268,7 +280,6 @@ -- because nested StateT is a pain. , cl_height :: Int -- ^ console height, in lines , cl_scripts :: [(ScriptName,Script)] - , cl_lemmas :: [Lemma] -- ^ list of lemmas, with flag indicating whether proven , cl_nav :: Bool -- ^ keyboard input the nav panel , cl_version :: VersionStore , cl_window :: PathH -- ^ path to beginning of window, always a prefix of focus path in kernel @@ -306,7 +317,7 @@ cl_kernel :: CommandLineState -> ScopedKernel cl_kernel = ps_kernel . cl_pstate -cl_kernel_env :: CommandLineState -> HermitMEnv +cl_kernel_env :: CommandLineState -> KernelEnv cl_kernel_env = mkKernelEnv . cl_pstate cl_pretty :: CommandLineState -> PrettyPrinter @@ -324,16 +335,15 @@ cl_render :: CommandLineState -> (Handle -> PrettyOptions -> Either String DocH -> IO ()) cl_render = ps_render . cl_pstate --- | Create default CommandLineState from PluginState. +-- | Create default CommandLineState from PluginState. -- Note: the dictionary (cl_dict) will be empty, and should be populated if needed. mkCLS :: PluginM CommandLineState mkCLS = do ps <- get - (w,h) <- liftIO getTermDimensions + (w,h) <- liftIO getTermDimensions let st = CommandLineState { cl_pstate = ps , cl_height = h , cl_scripts = [] - , cl_lemmas = [] , cl_nav = False , cl_version = VersionStore { vs_graph = [] , vs_tags = [] } , cl_window = mempty @@ -346,7 +356,8 @@ getTermDimensions :: IO (Int, Int) getTermDimensions = do #ifdef mingw32_HOST_OS - return (80,25) -- these are the standard windows CLI dimensions + consoleSz <- getConsoleWindowSize + return $ fromMaybe (80,25) consoleSz #else term <- setupTermFromEnv let w = fromMaybe 80 $ getCapability term termColumns @@ -361,8 +372,6 @@ box = CLSBox type ScriptName = String -type LemmaName = String -type Lemma = (LemmaName,CoreExprEquality,Bool) -- tick counter tick :: TVar (M.Map String Int) -> String -> IO Int @@ -374,10 +383,10 @@ writeTVar var (M.insert msg c m) return c -cl_putStr :: (MonadError CLException m, MonadIO m, MonadState CommandLineState m) => String -> m () +cl_putStr :: CLMonad m => String -> m () cl_putStr = pluginM . ps_putStr -cl_putStrLn :: (MonadError CLException m, MonadIO m, MonadState CommandLineState m) => String -> m () +cl_putStrLn :: CLMonad m => String -> m () cl_putStrLn = pluginM . ps_putStrLn isRunningScript :: MonadState CommandLineState m => m Bool @@ -387,65 +396,12 @@ setRunningScript ms = modify $ \st -> st { cl_running_script = ms } -- TODO: rename? -putStrToConsole :: (MonadError CLException m, MonadIO m, MonadState CommandLineState m) => String -> m () +putStrToConsole :: CLMonad m => String -> m () putStrToConsole str = ifM isRunningScript (return ()) (cl_putStrLn str) ------------------------------------------------------------------------------ -shellComplete :: MVar CommandLineState -> String -> String -> IO [Completion] -shellComplete mvar rPrev so_far = do - st <- readMVar mvar - targetQuery <- completionQuery st (completionType rPrev) - -- (liftM.liftM) (map simpleCompletion . nub . filter (so_far `isPrefixOf`)) - -- $ queryS (cl_kernel st) (cl_cursor (cl_session st)) targetQuery - -- TODO: I expect you want to build a silent version of the kernal_env for this query - cl <- catchM (queryS (cl_kernel st) targetQuery (cl_kernel_env st) (cl_cursor st)) (\_ -> return []) - return $ (map simpleCompletion . nub . filter (so_far `isPrefixOf`)) cl - -data CompletionType = ConsiderC -- considerable constructs and (deprecated) bindingOfT - | BindingOfC -- bindingOfT - | BindingGroupOfC -- bindingGroupOfT - | RhsOfC -- rhsOfT - | OccurrenceOfC -- occurrenceOfT - | InlineC -- complete with names that can be inlined - | CommandC -- complete using dictionary commands (default) - | AmbiguousC [CompletionType] -- completionType function needs to be more specific - deriving (Show) - --- TODO: reverse rPrev and parse it, to better figure out what possiblities are in context? --- for instance, completing "any-bu (inline " should be different than completing just "inline " --- this would also allow typed completion? -completionType :: String -> CompletionType -completionType = go . dropWhile isSpace - where go rPrev = case [ ty | (nm, ty) <- opts, reverse nm `isPrefixOf` rPrev ] of - [] -> CommandC - [t] -> t - ts -> AmbiguousC ts - opts = [ ("inline" , InlineC ) - , ("consider" , ConsiderC) - , ("binding-of" , BindingOfC) - , ("binding-group-of", BindingGroupOfC) - , ("rhs-of" , RhsOfC) - , ("occurrence-of" , OccurrenceOfC) - ] - -completionQuery :: CommandLineState -> CompletionType -> IO (TransformH CoreTC [String]) -completionQuery _ ConsiderC = return $ bindingOfTargetsT >>^ GHC.varSetToStrings >>^ map ('\'':) >>^ (++ map fst considerables) -- the use of bindingOfTargetsT here is deprecated -completionQuery _ OccurrenceOfC = return $ occurrenceOfTargetsT >>^ GHC.varSetToStrings >>^ map ('\'':) -completionQuery _ BindingOfC = return $ bindingOfTargetsT >>^ GHC.varSetToStrings >>^ map ('\'':) -completionQuery _ BindingGroupOfC = return $ bindingGroupOfTargetsT >>^ GHC.varSetToStrings >>^ map ('\'':) -completionQuery _ RhsOfC = return $ rhsOfTargetsT >>^ GHC.varSetToStrings >>^ map ('\'':) -completionQuery _ InlineC = return $ promoteT inlineTargetsT >>^ map ('\'':) -completionQuery s CommandC = return $ pure (map externName (cl_externals s)) --- Need to modify opts in completionType function. No key can be a suffix of another key. -completionQuery _ (AmbiguousC ts) = do - putStrLn "\nCannot tab complete: ambiguous completion type." - putStrLn $ "Possibilities: " ++ intercalate ", " (map show ts) - return (pure []) - ------------------------------------------------------------------------------- - -fixWindow :: (MonadError CLException m, MonadIO m, MonadState CommandLineState m) => m () +fixWindow :: CLMonad m => m () fixWindow = do st <- get -- check to make sure new path is still inside window @@ -457,7 +413,7 @@ $ put $ st { cl_window = focusPath } -} put $ st { cl_window = focusPath } -- TODO: temporary until we figure out a better highlight interface -showWindow :: (MonadError CLException m, MonadIO m, MonadState CommandLineState m) => m () +showWindow :: CLMonad m => m () showWindow = ifM isRunningScript (return ()) $ fixWindow >> gets cl_window >>= pluginM . display . Just ------------------------------------------------------------------------------ @@ -470,7 +426,7 @@ [ [ unparseExprH b ++ "\n" ++ showGraph graph tags c ] | (b,c) <- paths ]) - where + where paths = [ (b,c) | (a,b,c) <- graph, a == this ] ------------------------------------------------------------------------------ diff --git a/src/HERMIT/Utilities.hs b/src/HERMIT/Utilities.hs --- a/src/HERMIT/Utilities.hs +++ b/src/HERMIT/Utilities.hs @@ -1,15 +1,14 @@ module HERMIT.Utilities - ( -- * Utilities - nodups - , dups - , dupsBy - , soleElement - , equivalentBy - , equivalent - , whenJust - , maybeM - ) -where + ( -- * Utilities + nodups + , dups + , dupsBy + , soleElement + , equivalentBy + , equivalent + , whenJust + , maybeM + ) where ------------------------------------------------------------------------------ diff --git a/src/HERMIT/Win32/Console.hsc b/src/HERMIT/Win32/Console.hsc new file mode 100644 --- /dev/null +++ b/src/HERMIT/Win32/Console.hsc @@ -0,0 +1,105 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- | Taken from in the ansi-terminal package by batterseapower, licensed under BSD3 +module HERMIT.Win32.Console + ( + getConsoleWindowSize + , isCygwinConsole + ) where + +import Control.Applicative +import Control.Exception (try) + +import Foreign.C.Types +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable + +import System.Environment +import System.Win32.Types + +#include +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) + +type SHORT = CShort + +isCygwinConsole :: IO Bool +isCygwinConsole = do + result <- try $ getEnv "_" -- Cygwin defines this, Windows Cmd does not + return $ case (result :: Either IOError String) of + Left _ -> False + Right _ -> True + +getConsoleWindowSize :: IO (Maybe (Int, Int)) +getConsoleWindowSize = do + hStdout <- getStdHandle sTD_OUTPUT_HANDLE + csbiInfo <- getConsoleScreenBufferInfo hStdout + return $ fmap coords csbiInfo + where coords :: CONSOLE_SCREEN_BUFFER_INFO -> (Int, Int) + coords info = case csbi_maximum_window_size info of + (COORD x y) -> (fromIntegral x, fromIntegral y) + +sTD_OUTPUT_HANDLE :: DWORD +sTD_OUTPUT_HANDLE = #{const STD_OUTPUT_HANDLE} + +foreign import ccall unsafe "windows.h GetStdHandle" + getStdHandle :: DWORD -> IO HANDLE +foreign import ccall unsafe "windows.h GetConsoleScreenBufferInfo" + cGetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL + +getConsoleScreenBufferInfo :: HANDLE -> IO (Maybe CONSOLE_SCREEN_BUFFER_INFO) +getConsoleScreenBufferInfo handle = alloca $ \ptr_console_screen_buffer_info -> do + ret <- cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info + if ret then peek ptr_console_screen_buffer_info >>= return . Just + else return Nothing + +data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO { + _csbi_size :: COORD, + _csbi_cursor_position :: COORD, + _csbi_attributes :: WORD, + _csbi_window :: SMALL_RECT, + csbi_maximum_window_size :: COORD + } + +instance Storable CONSOLE_SCREEN_BUFFER_INFO where + sizeOf _ = #{size CONSOLE_SCREEN_BUFFER_INFO} + alignment _ = #{alignment CONSOLE_SCREEN_BUFFER_INFO} + peek ptr = CONSOLE_SCREEN_BUFFER_INFO <$> + #{peek CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr <*> + #{peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr <*> + #{peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr <*> + #{peek CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr <*> + #{peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr + poke ptr (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) = do + #{poke CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr size + #{poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr cursor_position + #{poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr attributes + #{poke CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr window + #{poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr maximum_window_size + +data COORD = COORD SHORT SHORT + +instance Storable COORD where + sizeOf _ = #{size COORD} + alignment _ = #{alignment COORD} + peek ptr = + COORD <$> #{peek COORD, X} ptr + <*> #{peek COORD, Y} ptr + poke ptr (COORD x y) = do + #{poke COORD, X} ptr x + #{poke COORD, Y} ptr y + +data SMALL_RECT = SMALL_RECT SHORT SHORT SHORT SHORT + +instance Storable SMALL_RECT where + sizeOf _ = #{size SMALL_RECT} + alignment _ = #{alignment SMALL_RECT} + peek ptr = + SMALL_RECT <$> #{peek SMALL_RECT, Left} ptr + <*> #{peek SMALL_RECT, Top} ptr + <*> #{peek SMALL_RECT, Right} ptr + <*> #{peek SMALL_RECT, Bottom} ptr + poke ptr (SMALL_RECT l t r b) = do + #{poke SMALL_RECT, Left} ptr l + #{poke SMALL_RECT, Top} ptr t + #{poke SMALL_RECT, Right} ptr r + #{poke SMALL_RECT, Bottom} ptr b diff --git a/src/HERMIT/Win32/IO.hsc b/src/HERMIT/Win32/IO.hsc new file mode 100644 --- /dev/null +++ b/src/HERMIT/Win32/IO.hsc @@ -0,0 +1,239 @@ +-- | Adapted from circular-ruin's StackOverflow answer at +{-# LANGUAGE ForeignFunctionInterface, CPP, NoImplicitPrelude #-} +module HERMIT.Win32.IO ( + HERMIT.Win32.IO.putChar + , HERMIT.Win32.IO.putStr + , HERMIT.Win32.IO.putStrLn + , HERMIT.Win32.IO.print + , ePutChar + , ePutStr + , ePutStrLn + , ePrint + , HERMIT.Win32.IO.hPutChar + , HERMIT.Win32.IO.hPutStr + , HERMIT.Win32.IO.hPutStrLn + , HERMIT.Win32.IO.hPrint + , trace + , traceIO + ) where + +#include + +import Control.Concurrent.MVar +import Control.Exception (bracket) + +import Data.Char (ord) +import Data.Typeable + +#if MIN_VERSION_base(4,7,0) +import Foreign +#else +import Foreign hiding (unsafePerformIO) +#endif +import Foreign.C.Types + +import GHC.IO.FD (FD(..)) -- A wrapper around an Int32 +import GHC.IO.Handle.Types (Handle(..), Handle__(..)) + +import Prelude hiding (putStr, putStrLn) --(IO, Read, Show, String) + +import qualified System.IO (hPutChar, hPutStr, hPutStrLn) +import System.IO hiding (putStr, putStrLn, hPutChar, hPutStr, hPutStrLn) +import System.IO.Unsafe (unsafePerformIO) +import System.Win32.Types (BOOL, HANDLE, DWORD, LPDWORD, LPWSTR, LPVOID) + +-- | +-- HANDLE WINAPI GetStdHandle(DWORD nStdHandle); +-- returns INVALID_HANDLE_VALUE, NULL, or a valid handle +foreign import ccall unsafe "GetStdHandle" + win32GetStdHandle :: DWORD -> IO HANDLE + +sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE :: DWORD +sTD_OUTPUT_HANDLE = (#const STD_OUTPUT_HANDLE) -- all DWORD arithmetic is performed modulo 2^n +sTD_ERROR_HANDLE = (#const STD_ERROR_HANDLE) + +-- | +-- DWORD WINAPI GetFileType(HANDLE hFile); +foreign import ccall unsafe "GetFileType" + win32GetFileType :: HANDLE -> IO DWORD + +fILE_TYPE_CHAR, fILE_TYPE_REMOTE :: DWORD +fILE_TYPE_CHAR = (#const FILE_TYPE_CHAR) +fILE_TYPE_REMOTE = (#const FILE_TYPE_REMOTE) + +-- | +-- BOOL WINAPI GetConsoleMode(HANDLE hConsole, LPDWORD lpMode); +foreign import ccall unsafe "GetConsoleMode" + win32GetConsoleMode :: HANDLE -> LPDWORD -> IO BOOL + +iNVALID_HANDLE_VALUE :: HANDLE +iNVALID_HANDLE_VALUE = intPtrToPtr $ -1 + +isAConsole :: HANDLE -> IO Bool +isAConsole handle + = if (handle == iNVALID_HANDLE_VALUE) then return False + else do ft <- win32GetFileType handle + if ((ft .&. complement fILE_TYPE_REMOTE) /= fILE_TYPE_CHAR) then return False + else do ptr <- malloc + cm <- win32GetConsoleMode handle ptr + free ptr + return cm + +-- | BOOL WINAPI WriteConsoleW(HANDLE hOutput, LPWSTR lpBuffer, DWORD nChars, +-- LPDWORD lpCharsWritten, LPVOID lpReserved); -} +foreign import ccall unsafe "WriteConsoleW" win32WriteConsoleW + :: HANDLE -> LPWSTR -> DWORD -> LPDWORD -> LPVOID -> IO BOOL + +data ConsoleInfo = ConsoleInfo Int (Ptr CWchar) (Ptr DWORD) HANDLE + +writeConsole :: ConsoleInfo -> String -> IO () +writeConsole (ConsoleInfo bufsize buf written handle) string + = let fillbuf :: Int -> String -> IO () + fillbuf i [] = emptybuf buf i [] + fillbuf i remain@(first:rest) + | i + 1 < bufsize && ordf <= 0xffff = do pokeElemOff buf i asWord + fillbuf (i+1) rest + | i + 1 < bufsize && ordf > 0xffff = do pokeElemOff buf i word1 + pokeElemOff buf (i+1) word2 + fillbuf (i+2) rest + | otherwise = emptybuf buf i remain + where ordf = ord first + asWord = fromInteger (toInteger ordf) :: CWchar + sub = ordf - 0x10000 + word1' = ((shiftR sub 10) .&. 0x3ff) + 0xD800 + word2' = (sub .&. 0x3FF) + 0xDC00 + word1 = fromInteger . toInteger $ word1' + word2 = fromInteger . toInteger $ word2' + + emptybuf :: (Ptr CWchar) -> Int -> String -> IO () + emptybuf _ 0 [] = return () + emptybuf _ 0 remain = fillbuf 0 remain + emptybuf ptr nLeft remain + = do let nLeft' = fromInteger . toInteger $ nLeft + ret <- win32WriteConsoleW handle ptr nLeft' written nullPtr + nWritten <- peek written + let nWritten' = fromInteger . toInteger $ nWritten + if ret && (nWritten > 0) + then emptybuf (ptr `plusPtr` (nWritten' * szWChar)) (nLeft - nWritten') remain + else fail "WriteConsoleW failed.\n" + + in fillbuf 0 string + +szWChar :: Int +szWChar = sizeOf (0 :: CWchar) + +makeConsoleInfo :: DWORD -> Handle -> IO (Either ConsoleInfo Handle) +makeConsoleInfo nStdHandle fallback = do + handle <- win32GetStdHandle nStdHandle + handleToConsoleInfo handle fallback + +handleToConsoleInfo :: HANDLE -> Handle -> IO (Either ConsoleInfo Handle) +handleToConsoleInfo handle fallback = do + isConsole <- isAConsole handle + let bufsize = 10000 + if not isConsole then return $ Right fallback + else do buf <- mallocBytes (szWChar * bufsize) + written <- malloc + return . Left $ ConsoleInfo bufsize buf written handle + +{-# NOINLINE stdoutConsoleInfo #-} +stdoutConsoleInfo :: Either ConsoleInfo Handle +stdoutConsoleInfo = unsafePerformIO $ makeConsoleInfo sTD_OUTPUT_HANDLE stdout + +{-# NOINLINE stderrConsoleInfo #-} +stderrConsoleInfo :: Either ConsoleInfo Handle +stderrConsoleInfo = unsafePerformIO $ makeConsoleInfo sTD_ERROR_HANDLE stderr + +conPutChar :: ConsoleInfo -> Char -> IO () +conPutChar ci = writeConsole ci . replicate 1 + +conPutStr :: ConsoleInfo -> String -> IO () +conPutStr = writeConsole + +conPutStrLn :: ConsoleInfo -> String -> IO () +conPutStrLn ci = writeConsole ci . (++ "\n") + +putChar :: Char -> IO () +putChar = (either conPutChar System.IO.hPutChar) stdoutConsoleInfo + +putStr :: String -> IO () +putStr = (either conPutStr System.IO.hPutStr) stdoutConsoleInfo + +putStrLn :: String -> IO () +putStrLn = (either conPutStrLn System.IO.hPutStrLn) stdoutConsoleInfo + +print :: Show a => a -> IO () +print = putStrLn . show + +ePutChar :: Char -> IO () +ePutChar = (either conPutChar System.IO.hPutChar) stderrConsoleInfo + +ePutStr :: String -> IO () +ePutStr = (either conPutStr System.IO.hPutStr) stderrConsoleInfo + +ePutStrLn :: String -> IO () +ePutStrLn = (either conPutStrLn System.IO.hPutStrLn) stderrConsoleInfo + +ePrint :: Show a => a -> IO () +ePrint = ePutStrLn . show + +hPutChar :: Handle -> Char -> IO () +hPutChar haskHandle c = withHandleToHANDLE haskHandle $ \ winHandle -> do + eitherHandle <- handleToConsoleInfo winHandle haskHandle + either conPutChar System.IO.hPutChar eitherHandle c + +hPutStr :: Handle -> String -> IO () +hPutStr haskHandle str = withHandleToHANDLE haskHandle $ \ winHandle -> do + eitherHandle <- handleToConsoleInfo winHandle haskHandle + either conPutStr System.IO.hPutStr eitherHandle str + +hPutStrLn :: Handle -> String -> IO () +hPutStrLn haskHandle str = withHandleToHANDLE haskHandle $ \ winHandle -> do + eitherHandle <- handleToConsoleInfo winHandle haskHandle + either conPutStrLn System.IO.hPutStrLn eitherHandle str + +hPrint :: Show a => Handle -> a -> IO () +hPrint = (. show) . hPutStrLn + +trace :: String -> a -> a +trace string expr = unsafePerformIO $ do + traceIO string + return expr + +traceIO :: String -> IO () +traceIO = ePutStrLn + +------------------------------------------------------------------------------- +-- All code that follows is taken from ansi-terminal by batterseapower, which +-- is licensed under BSD3 + +-- This essential function comes from the C runtime system. It is certainly provided by msvcrt, and also seems to be provided by the mingw C library - hurrah! +foreign import ccall unsafe "_get_osfhandle" + cget_osfhandle :: CInt -> IO HANDLE + +-- | This bit is all highly dubious. The problem is that we want to output ANSI to arbitrary Handles rather than forcing +-- people to use stdout. However, the Windows ANSI emulator needs a Windows HANDLE to work it's magic, so we need to be able +-- to extract one of those from the Haskell Handle. +-- +-- This code accomplishes this, albeit at the cost of only being compatible with GHC. +withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLE haskell_handle action = + -- Create a stable pointer to the Handle. This prevents the garbage collector + -- getting to it while we are doing horrible manipulations with it, and hence + -- stops it being finalized (and closed). + withStablePtr haskell_handle $ const $ do + -- Grab the write handle variable from the Handle + let write_handle_mvar = case haskell_handle of + FileHandle _ handle_mvar -> handle_mvar + DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, we could also take the "read" one + + Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) $ readMVar write_handle_mvar + + -- Finally, turn that (C-land) FD into a HANDLE using msvcrt + windows_handle <- cget_osfhandle fd + + -- Do what the user originally wanted + action windows_handle + +withStablePtr :: a -> (StablePtr a -> IO b) -> IO b +withStablePtr value = bracket (newStablePtr value) freeStablePtr