hermit 0.4.0.0 → 0.5.0.0
raw patch · 72 files changed
+3479/−1619 lines, 72 filesdep ~kuredep ~processdep ~temporary
Dependency ranges changed: kure, process, temporary
Files
- dist/build/HERMIT/Parser.hs +18/−6
- dist/build/HERMIT/ParserCore.hs +45/−22
- dist/build/HERMIT/ParserType.hs +592/−0
- driver/Main.hs +1/−92
- examples/concatVanishes/Flatten.hs +4/−0
- examples/concatVanishes/QSort.hs +5/−1
- examples/concatVanishes/Rev.hs +4/−0
- examples/evaluation/Eval.hs +4/−0
- examples/factorial/Fac.hs +5/−1
- examples/fib-stream/Fib.hs +4/−1
- examples/fib-tuple/Fib.hs +3/−0
- examples/flatten/Flatten.hs +4/−0
- examples/hanoi/Hanoi.hs +3/−0
- examples/last/Last.hs +5/−1
- examples/qsort/QSort.hs +5/−0
- examples/reverse/Reverse.hs +3/−0
- hermit.cabal +18/−12
- src/HERMIT/Context.hs +46/−49
- src/HERMIT/Core.hs +1/−1
- src/HERMIT/Dictionary/AlphaConversion.hs +71/−49
- src/HERMIT/Dictionary/Common.hs +55/−72
- src/HERMIT/Dictionary/Composite.hs +11/−11
- src/HERMIT/Dictionary/FixPoint.hs +5/−4
- src/HERMIT/Dictionary/Fold.hs +27/−7
- src/HERMIT/Dictionary/Function.hs +4/−4
- src/HERMIT/Dictionary/GHC.hs +10/−10
- src/HERMIT/Dictionary/Induction.hs +5/−4
- src/HERMIT/Dictionary/Inline.hs +27/−17
- src/HERMIT/Dictionary/Kure.hs +18/−14
- src/HERMIT/Dictionary/Local.hs +3/−3
- src/HERMIT/Dictionary/Local/Case.hs +21/−12
- src/HERMIT/Dictionary/Local/Let.hs +10/−11
- src/HERMIT/Dictionary/Navigation.hs +36/−31
- src/HERMIT/Dictionary/New.hs +5/−24
- src/HERMIT/Dictionary/Query.hs +17/−10
- src/HERMIT/Dictionary/Reasoning.hs +275/−48
- src/HERMIT/Dictionary/Rules.hs +32/−38
- src/HERMIT/Dictionary/Undefined.hs +24/−22
- src/HERMIT/Dictionary/Unfold.hs +10/−10
- src/HERMIT/Dictionary/Unsafe.hs +1/−1
- src/HERMIT/Dictionary/WorkerWrapper/Fix.hs +4/−4
- src/HERMIT/Dictionary/WorkerWrapper/FixResult.hs +4/−4
- src/HERMIT/Driver.hs +106/−3
- src/HERMIT/External.hs +41/−39
- src/HERMIT/GHC.hs +82/−11
- src/HERMIT/GHC/Typechecker.hs +5/−5
- src/HERMIT/Kernel.hs +5/−5
- src/HERMIT/Kernel/Scoped.hs +2/−2
- src/HERMIT/Kure.hs +158/−154
- src/HERMIT/Kure/SumTypes.hs +11/−11
- src/HERMIT/Monad.hs +64/−6
- src/HERMIT/Name.hs +292/−0
- src/HERMIT/ParserCore.y +27/−16
- src/HERMIT/ParserType.y +157/−0
- src/HERMIT/Plugin.hs +8/−11
- src/HERMIT/Plugin/Display.hs +6/−10
- src/HERMIT/Plugin/Renderer.hs +50/−7
- src/HERMIT/Plugin/Types.hs +5/−6
- src/HERMIT/PrettyPrinter/AST.hs +12/−2
- src/HERMIT/PrettyPrinter/Clean.hs +20/−10
- src/HERMIT/PrettyPrinter/Common.hs +26/−11
- src/HERMIT/PrettyPrinter/GHC.hs +13/−3
- src/HERMIT/Shell/Command.hs +21/−342
- src/HERMIT/Shell/Dictionary.hs +5/−6
- src/HERMIT/Shell/Externals.hs +53/−28
- src/HERMIT/Shell/Interpreter.hs +30/−18
- src/HERMIT/Shell/KernelEffect.hs +110/−0
- src/HERMIT/Shell/Proof.hs +323/−208
- src/HERMIT/Shell/ScriptToRewrite.hs +108/−25
- src/HERMIT/Shell/ShellEffect.hs +69/−0
- src/HERMIT/Shell/Types.hs +211/−84
- src/HERMIT/Utilities.hs +14/−0
dist/build/HERMIT/Parser.hs view
@@ -17,7 +17,7 @@ import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts --- parser produced by Happy Version 1.19.2+-- parser produced by Happy Version 1.19.3 newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11 = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607@@ -480,10 +480,10 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + {-# LINE 13 "templates/GenericTemplate.hs" #-} @@ -500,6 +500,7 @@ #define GTE(n,m) (n Happy_GHC_Exts.>=# m) #define EQ(n,m) (n Happy_GHC_Exts.==# m) #endif+ {-# LINE 46 "templates/GenericTemplate.hs" #-} @@ -509,12 +510,21 @@ + {-# LINE 67 "templates/GenericTemplate.hs" #-} + {-# LINE 77 "templates/GenericTemplate.hs" #-} -{-# LINE 86 "templates/GenericTemplate.hs" #-} ++++++++ infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) @@ -541,7 +551,7 @@ happyDoAction i tk st = {- nothing -}-+ case action of 0# -> {- nothing -}@@ -549,11 +559,11 @@ -1# -> {- nothing -} happyAccept i tk st n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}-+ (happyReduceArr Happy_Data_Array.! rule) i tk st where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) n -> {- nothing -}-+ happyShift new_state i tk st where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))@@ -587,6 +597,7 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) + {-# LINE 170 "templates/GenericTemplate.hs" #-} -----------------------------------------------------------------------------@@ -751,3 +762,4 @@ {-# NOINLINE happyFail #-} -- end of Happy Template.+
dist/build/HERMIT/ParserCore.hs view
@@ -1,7 +1,17 @@ {-# OPTIONS_GHC -w #-} {-# OPTIONS -fglasgow-exts -cpp #-} {-# LANGUAGE CPP #-}- module HERMIT.ParserCore (parseCore, parseCoreExprT, parse2beforeBiR, parse3beforeBiR, parse4beforeBiR, parse5beforeBiR) where+module HERMIT.ParserCore+ ( parseCore+ , parseCoreExprT+ , parse2beforeBiR+ , parse3beforeBiR+ , parse4beforeBiR+ , parse5beforeBiR+ , Token(..)+ , parseError+ , lexer+ ) where import Control.Arrow import Control.Monad.Reader@@ -12,15 +22,14 @@ import HERMIT.GHC import HERMIT.Kure import HERMIT.Monad+import HERMIT.Name import HERMIT.Syntax (isCoreInfixIdChar, isCoreIdFirstChar, isCoreIdChar) -import HERMIT.Dictionary.Common- import Language.KURE.MonadCatch (prefixFailMsg) import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts --- parser produced by Happy Version 1.19.2+-- parser produced by Happy Version 1.19.3 newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607@@ -140,7 +149,7 @@ happyReduction_5 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk- = happyThen (( lookupName "()" Var)+ = happyThen (( lookupName "()") ) (\r -> happyReturn (happyIn6 r)) happyReduce_6 = happySpecReduce_1 2# happyReduction_6@@ -182,7 +191,7 @@ happyReduction_11 (happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { (Tname happy_var_1) -> - ( lookupName happy_var_1 varToCoreExpr)}+ ( lookupName happy_var_1)} ) (\r -> happyReturn (happyIn9 r)) happyNewToken action sts stk [] =@@ -255,11 +264,11 @@ mkIntExpr' i = return $ mkIntExpr i #endif -lookupName :: String -> (Id -> CoreExpr) -> CoreParseM CoreExpr-lookupName nm k = do+lookupName :: String -> CoreParseM CoreExpr+lookupName nm = do c <- ask v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId nm c- return (k v)+ return $ varToCoreExpr v type CoreParseM a = ReaderT HermitC HermitM a @@ -289,6 +298,7 @@ | Tcoloneqcolon | Tstar | Tarrow+ | Tdoublearrow | Tlambda -- | Tat | Tdot@@ -304,13 +314,14 @@ lexer :: String -> Either String [Token] lexer [] = Right []-lexer ('_' :cs) = fmap (Twild:) $ lexer cs-lexer ('(' :cs) = fmap (Toparen:) $ lexer cs-lexer (')' :cs) = fmap (Tcparen:) $ lexer cs-lexer (':':':':cs) = fmap (Tcoloncolon:) $ lexer cs--- lexer (':' :cs) = fmap (Tcolon:) $ lexer cs-lexer ('\\':cs) = fmap (Tlambda:) $ lexer cs-lexer ('-':'>':cs) = fmap (Tarrow:) $ lexer cs+lexer ('_' :cs) = fmap (Twild:) $ lexer cs+lexer ('(' :cs) = fmap (Toparen:) $ lexer cs+lexer (')' :cs) = fmap (Tcparen:) $ lexer cs+lexer (':':':':cs) = fmap (Tcoloncolon:) $ lexer cs+-- lexer (':' :cs) = fmap (Tcolon:) $ lexer cs+lexer ('\\':cs) = fmap (Tlambda:) $ lexer cs+lexer ('-':'>':cs) = fmap (Tarrow:) $ lexer cs+lexer ('=':'>':cs) = fmap (Tdoublearrow:) $ lexer cs lexer ('\"':cs) = let (str,rest) = span (/='\"') cs in case rest of ('\"':cs') -> fmap (Tstring str:) $ lexer cs'@@ -337,7 +348,7 @@ -- These should probably go somewhere else. -- | Parse a 'CoreString' to a 'CoreExpr', using the current context.-parseCoreExprT :: CoreString -> TranslateH a CoreExpr+parseCoreExprT :: CoreString -> TransformH a CoreExpr parseCoreExprT = contextonlyT . parseCore parse2beforeBiR :: (CoreExpr -> CoreExpr -> BiRewriteH a)@@ -360,10 +371,10 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + {-# LINE 13 "templates/GenericTemplate.hs" #-} @@ -380,6 +391,7 @@ #define GTE(n,m) (n Happy_GHC_Exts.>=# m) #define EQ(n,m) (n Happy_GHC_Exts.==# m) #endif+ {-# LINE 46 "templates/GenericTemplate.hs" #-} @@ -389,12 +401,21 @@ + {-# LINE 67 "templates/GenericTemplate.hs" #-} + {-# LINE 77 "templates/GenericTemplate.hs" #-} -{-# LINE 86 "templates/GenericTemplate.hs" #-} ++++++++ infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) @@ -421,7 +442,7 @@ happyDoAction i tk st = {- nothing -}-+ case action of 0# -> {- nothing -}@@ -429,11 +450,11 @@ -1# -> {- nothing -} happyAccept i tk st n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}-+ (happyReduceArr Happy_Data_Array.! rule) i tk st where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) n -> {- nothing -}-+ happyShift new_state i tk st where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))@@ -467,6 +488,7 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) + {-# LINE 170 "templates/GenericTemplate.hs" #-} -----------------------------------------------------------------------------@@ -631,3 +653,4 @@ {-# NOINLINE happyFail #-} -- end of Happy Template.+
+ dist/build/HERMIT/ParserType.hs view
@@ -0,0 +1,592 @@+{-# OPTIONS_GHC -w #-}+{-# 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+import Data.Char (isSpace, isDigit)++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.Syntax (isCoreInfixIdChar, isCoreIdFirstChar, isCoreIdChar)++import Language.KURE.MonadCatch (prefixFailMsg)+import qualified Data.Array as Happy_Data_Array+import qualified GHC.Exts as Happy_GHC_Exts++-- parser produced by Happy Version 1.19.3++newtype HappyAbsSyn t4 t5 t6 t7 t8 = 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)+happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn4 #-}+happyOut4 :: (HappyAbsSyn t4 t5 t6 t7 t8) -> t4+happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut4 #-}+happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7 t8)+happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn5 #-}+happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8) -> t5+happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut5 #-}+happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8)+happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn6 #-}+happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8) -> t6+happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut6 #-}+happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8)+happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn7 #-}+happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8) -> t7+happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut7 #-}+happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8)+happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn8 #-}+happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8) -> t8+happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut8 #-}+happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8)+happyInTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8) -> (Token)+happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOutTok #-}+++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\xfa\xff\xfa\xff\xff\xff\xfa\xff\x00\x00\x00\x00\xf8\xff\x00\x00\xf1\xff\xf5\xff\x00\x00\xf6\xff\x00\x00\xfa\xff\xfa\xff\x00\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\x07\x00\x0b\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x0d\x00\x00\x00\x17\x00\x0d\x00\x00\x00\x00\x00"#++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\xfc\xff\xfa\xff\xf7\xff\x00\x00\xf6\xff\x00\x00\xfc\xff\xfb\xff\x00\x00\xf8\xff\x00\x00\xfe\xff\xf9\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x0c\x00\x0c\x00\x0d\x00\x0c\x00\x0d\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x01\x00\x02\x00\x03\x00\x04\x00\x03\x00\x04\x00\x1d\x00\x1d\x00\x23\x00\x1d\x00\x17\x00\x1d\x00\x23\x00\x02\x00\x03\x00\x04\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\x07\x00\x07\x00\x10\x00\x07\x00\x0d\x00\x07\x00\x08\x00\x02\x00\x09\x00\x04\x00\x05\x00\x02\x00\x03\x00\x04\x00\x05\x00\x0a\x00\x05\x00\x08\x00\x08\x00\xff\xff\x08\x00\x0e\x00\x08\x00\xfd\xff\x0e\x00\x04\x00\x05\x00\x0b\x00\x04\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyReduceArr = Happy_Data_Array.array (1, 9) [+ (1 , happyReduce_1),+ (2 , happyReduce_2),+ (3 , happyReduce_3),+ (4 , happyReduce_4),+ (5 , happyReduce_5),+ (6 , happyReduce_6),+ (7 , happyReduce_7),+ (8 , happyReduce_8),+ (9 , happyReduce_9)+ ]++happy_n_terms = 36 :: Int+happy_n_nonterms = 5 :: Int++happyReduce_1 = happySpecReduce_3 0# happyReduction_1+happyReduction_1 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_3 of { happy_var_3 -> + happyIn4+ (mkPhiTy happy_var_1 happy_var_3+ )}}++happyReduce_2 = happySpecReduce_1 0# happyReduction_2+happyReduction_2 happy_x_1+ = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn4+ (happy_var_1+ )}++happyReduce_3 = happySpecReduce_1 1# happyReduction_3+happyReduction_3 happy_x_1+ = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn5+ ([happy_var_1]+ )}++happyReduce_4 = happySpecReduce_2 2# happyReduction_4+happyReduction_4 happy_x_2+ happy_x_1+ = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn6+ (mkAppTy happy_var_1 happy_var_2+ )}}++happyReduce_5 = happySpecReduce_1 2# happyReduction_5+happyReduction_5 happy_x_1+ = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6+ (happy_var_1+ )}++happyReduce_6 = happySpecReduce_3 3# happyReduction_6+happyReduction_6 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn7+ (happy_var_2+ )}++happyReduce_7 = happyMonadReduce 2# 3# happyReduction_7+happyReduction_7 (happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest) tk+ = happyThen (( lookupName "()")+ ) (\r -> happyReturn (happyIn7 r))++happyReduce_8 = happySpecReduce_1 3# happyReduction_8+happyReduction_8 happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn7+ (happy_var_1+ )}++happyReduce_9 = happyMonadReduce 1# 4# happyReduction_9+happyReduction_9 (happy_x_1 `HappyStk`+ happyRest) tk+ = happyThen (case happyOutTok happy_x_1 of { (Tname happy_var_1) -> + ( lookupName happy_var_1)}+ ) (\r -> happyReturn (happyIn8 r))++happyNewToken action sts stk [] =+ happyDoAction 35# notHappyAtAll action sts stk []++happyNewToken action sts stk (tk:tks) =+ let cont i = happyDoAction i tk action sts stk tks in+ case tk of {+ Tforall -> cont 1#;+ Trec -> cont 2#;+ Tlet -> cont 3#;+ Tin -> cont 4#;+ Tcase -> cont 5#;+ Tof -> cont 6#;+ Tcast -> cont 7#;+ Tnote -> cont 8#;+ Texternal -> cont 9#;+ Tlocal -> cont 10#;+ Twild -> cont 11#;+ Toparen -> cont 12#;+ Tcparen -> cont 13#;+ Tobrace -> cont 14#;+ Tcbrace -> cont 15#;+ Thash -> cont 16#;+ Teq -> cont 17#;+ Tcolon -> cont 18#;+ Tcoloncolon -> cont 19#;+ Tcoloneqcolon -> cont 20#;+ Tstar -> cont 21#;+ Tarrow -> cont 22#;+ Tdoublearrow -> cont 23#;+ Tlambda -> cont 24#;+ Tat -> cont 25#;+ Tdot -> cont 26#;+ Tquestion -> cont 27#;+ Tsemicolon -> cont 28#;+ Tname happy_dollar_dollar -> cont 29#;+ Tcname happy_dollar_dollar -> cont 30#;+ Tinteger happy_dollar_dollar -> cont 31#;+ Trational happy_dollar_dollar -> cont 32#;+ Tstring happy_dollar_dollar -> cont 33#;+ Tchar happy_dollar_dollar -> cont 34#;+ _ -> happyError' (tk:tks)+ }++happyError_ 35# tk tks = happyError' tks+happyError_ _ tk tks = happyError' (tk:tks)++happyThen :: () => TypeParseM a -> (a -> TypeParseM b) -> TypeParseM b+happyThen = (>>=)+happyReturn :: () => a -> TypeParseM a+happyReturn = (return)+happyThen1 m k tks = (>>=) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> TypeParseM a+happyReturn1 = \a tks -> (return) a+happyError' :: () => [(Token)] -> TypeParseM a+happyError' = parseError++parser tks = happySomeParser where+ happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))++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+ either (const (addTyVar nm)) return et++catchFrees :: Type -> TypeParseM ([TyVar], Type)+catchFrees ty = do+ used <- gets tpUsed+ let frees = varSetElems $ freeVarsType ty+ quants = filter (`elem` used) frees+ modify $ \ st -> st { tpUsed = filter (`notElem` frees) (tpUsed st) }+ return (quants, ty)++data TPState = TPState { tpContext :: HermitC+ , tpUsed :: [TyVar]+ }++type TypeParseM a = StateT TPState HermitM a++getContext :: TypeParseM HermitC+getContext = gets tpContext++addTyVar :: String -> TypeParseM Type+addTyVar tvStr = do+ used <- gets tpUsed+ case [ tv | tv <- used, getOccString tv == tvStr ] of+ [] -> do tv <- lift $ newTyVarH tvStr liftedTypeKind+ modify $ \ st -> st { tpUsed = tv : tpUsed st }+ return $ mkTyVarTy tv+ [tv] -> return $ mkTyVarTy tv+ other -> fail "addTyVar: impossible case"++---------------------------------------------++-- | Parse a CoreString into a Type, where all type variables must be bound.+parseType :: CoreString -> HermitC -> HermitM Type+parseType cs c = do+ (ty, holes) <- parseTypeWithHoles cs c+ guardMsg (null holes) "type contains unbound type variables."+ return ty++-- | Parse a CoreString into a Type, any unbound variables are returned.+parseTypeWithHoles :: CoreString -> HermitC -> HermitM (Type, [TyVar])+parseTypeWithHoles (CoreString s) c =+ case lexer s of+ Left msg -> fail msg+ Right tokens -> do+ (ty,st) <- runStateT (parser tokens) (TPState c [])+ return (ty,tpUsed st)++---------------------------------------------++-- | Parse a 'CoreString' to a 'Type', using the current context.+parseTypeT :: CoreString -> TransformH a Type+parseTypeT = contextonlyT . parseType++-- | Parse a 'CoreString' to a 'Type', using the current context, returning unbound type variables.+parseTypeWithHolesT :: CoreString -> TransformH a (Type, [TyVar])+parseTypeWithHolesT = contextonlyT . parseTypeWithHoles++---------------------------------------------+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp +++{-# LINE 13 "templates/GenericTemplate.hs" #-}++++++-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.+#if __GLASGOW_HASKELL__ > 706+#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool)+#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool)+#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool)+#else+#define LT(n,m) (n Happy_GHC_Exts.<# m)+#define GTE(n,m) (n Happy_GHC_Exts.>=# m)+#define EQ(n,m) (n Happy_GHC_Exts.==# m)+#endif++{-# LINE 46 "templates/GenericTemplate.hs" #-}+++data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList+++++++{-# LINE 67 "templates/GenericTemplate.hs" #-}+++{-# LINE 77 "templates/GenericTemplate.hs" #-}+++++++++++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is 0#, it means we've just accepted a partial+-- parse (a %partial parser). We must ignore the saved token on the top of+-- the stack in this case.+happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =+ happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++++happyDoAction i tk st+ = {- nothing -}+ ++ case action of+ 0# -> {- nothing -}+ happyFail i tk st+ -1# -> {- nothing -}+ happyAccept i tk st+ n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}+ + (happyReduceArr Happy_Data_Array.! rule) i tk st+ where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))+ n -> {- nothing -}+ ++ happyShift new_state i tk st+ where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))+ where off = indexShortOffAddr happyActOffsets st+ off_i = (off Happy_GHC_Exts.+# i)+ check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#))+ then EQ(indexShortOffAddr happyCheck off_i, i)+ else False+ action+ | check = indexShortOffAddr happyTable off_i+ | otherwise = indexShortOffAddr happyDefActions st+++indexShortOffAddr (HappyA# arr) off =+ Happy_GHC_Exts.narrow16Int# i+ where+ i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)+ high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))+ low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))+ off' = off Happy_GHC_Exts.*# 2#++++++data HappyAddr = HappyA# Happy_GHC_Exts.Addr#+++++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)+++{-# LINE 170 "templates/GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =+ let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+-- trace "shifting the error token" $+ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)++happyShift new_state i tk st sts stk =+ happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_0 nt fn j tk st@((action)) sts stk+ = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')+ = let r = fn v1 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')+ = let r = fn v1 v2 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+ = let r = fn v1 v2 v3 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyReduce k nt fn j tk st sts stk+ = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of+ sts1@((HappyCons (st1@(action)) (_))) ->+ let r = fn stk in -- it doesn't hurt to always seq here...+ happyDoSeq r (happyGoto nt j tk st1 sts1 r)++happyMonadReduce k nt fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+ case happyDrop k (HappyCons (st) (sts)) of+ sts1@((HappyCons (st1@(action)) (_))) ->+ let drop_stk = happyDropStk k stk in+ happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))++happyMonad2Reduce k nt fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+ case happyDrop k (HappyCons (st) (sts)) of+ sts1@((HappyCons (st1@(action)) (_))) ->+ let drop_stk = happyDropStk k stk++ off = indexShortOffAddr happyGotoOffsets st1+ off_i = (off Happy_GHC_Exts.+# nt)+ new_state = indexShortOffAddr happyTable off_i++++ in+ happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))++happyDrop 0# l = l+happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t++happyDropStk 0# l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction+++happyGoto nt j tk st = + {- nothing -}+ happyDoAction j tk new_state+ where off = indexShortOffAddr happyGotoOffsets st+ off_i = (off Happy_GHC_Exts.+# nt)+ new_state = indexShortOffAddr happyTable off_i+++++-----------------------------------------------------------------------------+-- Error recovery (0# is the error token)++-- parse error if we are in recovery and we fail again+happyFail 0# tk old_st _ stk@(x `HappyStk` _) =+ let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+-- trace "failing" $ + happyError_ i tk++{- We don't need state discarding for our restricted implementation of+ "error". In fact, it can cause some bogus parses, so I've disabled it+ for now --SDM++-- discard a state+happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) =+-- trace ("discarding state, depth " ++ show (length stk)) $+ happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+-- save the old token and carry on.+happyFail i tk (action) sts stk =+-- trace "entering error recovery" $+ happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll :: a+notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions+++happyTcHack :: Happy_GHC_Exts.Int# -> a -> a+happyTcHack x y = y+{-# INLINE happyTcHack #-}+++-----------------------------------------------------------------------------+-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq+-- otherwise it emits+-- happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq a b = a `seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template. GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.+++{-# NOINLINE happyDoAction #-}+{-# NOINLINE happyTable #-}+{-# NOINLINE happyCheck #-}+{-# NOINLINE happyActOffsets #-}+{-# NOINLINE happyGotoOffsets #-}+{-# NOINLINE happyDefActions #-}++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.+
driver/Main.hs view
@@ -1,99 +1,8 @@-{-# LANGUAGE ViewPatterns #-}- module Main where import HERMIT.Driver import System.Environment-import System.Process-import System.Exit -import Data.List (isPrefixOf, partition)-import System.Directory (doesFileExist)--usage :: IO ()-usage = putStrLn $ unlines- [hermit_version- ,""- ,"usage: hermit File.hs SCRIPTNAME"- ," - OR -"- ," hermit File.hs [HERMIT_ARGS] [+module_name [MOD_ARGS]]* [-- [ghc-args]]"- ,""- ,"examples: hermit Foo.hs Foo.hss"- ," hermit Foo.hs -p6 +Main Foo.hss"- ," hermit Foo.hs +Main Foo.hss resume"- ," hermit Foo.hs +Main Foo.hss +Other.Module.Name Bar.hss"- ," hermit Foo.hs -- -ddump-simpl -ddump-to-file"- ,""- ,"A * may be used for the module name. * matches any module."- ,"If a module name is not supplied, * is assumed."- ,""- ,"HERMIT_ARGS"- ," -opt=MODULE : where MODULE is the module containing a HERMIT optimization plugin"- ," -vN : controls verbosity, where N is one of the following values:"- ," 0 : suppress HERMIT messages, pass -v0 to GHC"- ," 1 : suppress HERMIT messages"- ," 2 : pass -v0 to GHC"- ," 3 : (default) display all HERMIT and GHC messages"- ,""- ,"MOD_ARGS"- ," SCRIPTNAME : name of script file to run for this module"- ," resume : skip interactive mode and resume compilation after any scripts"- ]- main :: IO ()-main = getArgs >>= main1--main1 :: [String] -> IO ()-main1 [] = usage-main1 args@(file_nm:script_nm:rest) = do- e <- doesFileExist script_nm- if e && (not (any (isPrefixOf "+") rest)) - then main4 file_nm [] [("*", script_nm:rest)] [] - else main2 args-main1 other = main2 other--main2 (file_nm:rest) = case span (/= "--") rest of- (args,"--":ghc_args) -> main3 file_nm args ghc_args- (args,[]) -> main3 file_nm args []- _ -> error "hermit internal error"--main3 file_nm args ghc_args = main4 file_nm hermit_args (sepMods margs) ghc_args- where (hermit_args, margs) = span (not . isPrefixOf "+") args-- sepMods :: [String] -> [(String, [String])]- sepMods [] = []- sepMods (('+':mod_nm):rest) = (mod_nm, mod_opts) : sepMods next- where (mod_opts, next) = span (not . isPrefixOf "+") rest--main4 file_nm hermit_args [] ghc_args = main4 file_nm hermit_args [("*", [])] ghc_args-main4 file_nm hermit_args module_args ghc_args = do- putStrLn $ "[starting " ++ hermit_version ++ " on " ++ file_nm ++ "]"- let (pluginName, hermit_args') = getPlugin hermit_args- cmds = file_nm : ghcFlags ++- [ "-fplugin=" ++ pluginName ] ++- [ "-fplugin-opt=" ++ pluginName ++ ":" ++ opt | opt <- hermit_args' ] ++- [ "-fplugin-opt=" ++ pluginName ++ ":" ++ m_nm ++ ":" ++ opt- | (m_nm, m_opts) <- module_args- , opt <- "" : m_opts- ] ++ extraGHCArgs hermit_args' ++ ghc_args- putStrLn $ "% ghc " ++ unwords cmds- (_,_,_,r) <- createProcess $ proc "ghc" cmds- ex <- waitForProcess r- exitWith ex--getPlugin :: [String] -> (String, [String])-getPlugin = go "HERMIT" []- where go plug flags [] = (plug, flags)- go plug flags (f:fs) | "-opt=" `isPrefixOf` f = go (drop 5 f) flags fs- | otherwise = go plug (f:flags) fs---- | See if the given HERMIT args imply any additional GHC args-extraGHCArgs :: [String] -> [String]-extraGHCArgs (matchArgs (`elem` ["-v0","-v2"]) -> Just (_,r)) = "-v0" : extraGHCArgs r-extraGHCArgs _ = []--matchArgs :: (String -> Bool) -> [String] -> Maybe ([String], [String])-matchArgs p args = case partition p args of- ([],_) -> Nothing- (as,r) -> Just (as,r)+main = getArgs >>= hermitDriver
examples/concatVanishes/Flatten.hs view
@@ -1,7 +1,11 @@+{-# LANGUAGE CPP #-} module Main where import HList++#if __GLASGOW_HASKELL__ < 708 import Data.Function (fix)+#endif data Tree a = Node (Tree a) (Tree a) | Leaf a
examples/concatVanishes/QSort.hs view
@@ -1,8 +1,12 @@+{-# LANGUAGE CPP #-} module Main where import HList-import Data.Function (fix) import Data.List++#if __GLASGOW_HASKELL__ < 708+import Data.Function (fix)+#endif data Tree a = Node (Tree a) (Tree a) | Leaf a
examples/concatVanishes/Rev.hs view
@@ -1,7 +1,11 @@+{-# LANGUAGE CPP #-} module Main where import HList++#if __GLASGOW_HASKELL__ < 708 import Data.Function (fix)+#endif rev :: [a] -> [a] rev [] = []
examples/evaluation/Eval.hs view
@@ -1,7 +1,11 @@+{-# LANGUAGE CPP #-} module Main where import Prelude hiding (abs)++#if __GLASGOW_HASKELL__ < 708 import Data.Function (fix)+#endif data Expr = Val Int | Add Expr Expr | Throw | Catch Expr Expr
examples/factorial/Fac.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP #-} module Main where import Prelude hiding ((*),(-)) import GHC.Exts-import Data.Function(fix)++#if __GLASGOW_HASKELL__ < 708+import Data.Function (fix)+#endif ------------------------------------
examples/fib-stream/Fib.hs view
@@ -1,10 +1,13 @@+{-# LANGUAGE CPP #-} module Main where import Prelude hiding ((+),map,(!!)) import Nat import Stream -import Data.Function(fix)+#if __GLASGOW_HASKELL__ < 708+import Data.Function (fix)+#endif fib :: Nat -> Nat fib Zero = Zero
examples/fib-tuple/Fib.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE CPP #-} module Main where +#if __GLASGOW_HASKELL__ < 708 -- so we can fix-intro import Data.Function (fix)+#endif import Prelude hiding ((+))
examples/flatten/Flatten.hs view
@@ -1,7 +1,11 @@+{-# LANGUAGE CPP #-} module Main where import HList++#if __GLASGOW_HASKELL__ < 708 import Data.Function (fix)+#endif data Tree a = Node (Tree a) (Tree a) | Leaf a
examples/hanoi/Hanoi.hs view
@@ -1,10 +1,13 @@+{-# LANGUAGE CPP #-} module Main where -- import Criterion.Main import Control.Monad (forM_) +#if __GLASGOW_HASKELL__ < 708 import Data.Function (fix)+#endif data Nat = Z | S Nat
examples/last/Last.hs view
@@ -1,6 +1,10 @@+{-# LANGUAGE CPP #-} module Main where -import Data.Function(fix)+#if __GLASGOW_HASKELL__ < 708+import Data.Function (fix)+#endif+ import Prelude hiding (last) -------------------------------------------------
examples/qsort/QSort.hs view
@@ -1,7 +1,12 @@+{-# LANGUAGE CPP #-} module Main where import HList++#if __GLASGOW_HASKELL__ < 708 import Data.Function (fix)+#endif+ import Data.List data Tree a = Node (Tree a) (Tree a) | Leaf a
examples/reverse/Reverse.hs view
@@ -1,9 +1,12 @@+{-# LANGUAGE CPP #-} module Main where import HList -- import Seq +#if __GLASGOW_HASKELL__ < 708 import Data.Function (fix)+#endif rev :: [a] -> [a] rev [] = []
hermit.cabal view
@@ -1,5 +1,5 @@ Name: hermit-Version: 0.4.0.0+Version: 0.5.0.0 Synopsis: Haskell Equational Reasoning Model-to-Implementation Tunnel Description: HERMIT uses Haskell to express semi-formal models,@@ -15,8 +15,6 @@ . * log command prints linearly, even if command history is a tree. .- * RULES have issues with forall types.- . * A number of rewrites don't enforce preconditions. eg: cast elimination always works, even if the cast is necessary .@@ -30,12 +28,12 @@ . @ $ hermit Reverse.hs Reverse.hss resume- [starting HERMIT v0.4.0.0 on Reverse.hs]+ [starting HERMIT v0.5.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.4.0.0 ... linking ... done.+ Loading package hermit-0.5.0.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) Linking Reverse ... $ ./Reverse@@ -46,12 +44,12 @@ . @ $ hermit Reverse.hs- [starting HERMIT v0.4.0.0 on Reverse.hs]+ [starting HERMIT v0.5.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.4.0.0 ... linking ... done.+ Loading package hermit-0.5.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@@ -144,20 +142,26 @@ array, containers >= 0.5.0.0, data-default >= 0.5.0,+ directory >= 1.2.0.0, ghc >= 7.6, haskeline >= 0.7.0.3,- kure >= 2.14.0,+ kure >= 2.16.0, marked-pretty >= 0.1, mtl >= 2.1.2, operational >= 0.2.2.1, process >= 1.1.0.2, stm >= 2.4,- temporary >= 1.1.2.4,+ temporary >= 1.2.0.3, transformers if !os(windows) 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+ default-language: Haskell2010 Exposed-modules:@@ -205,8 +209,10 @@ HERMIT.Kure HERMIT.Kure.SumTypes HERMIT.Monad+ HERMIT.Name HERMIT.Parser HERMIT.ParserCore+ HERMIT.ParserType HERMIT.Plugin HERMIT.Plugin.Builder@@ -223,7 +229,9 @@ HERMIT.Shell.Dictionary HERMIT.Shell.Interpreter HERMIT.Shell.Externals+ HERMIT.Shell.KernelEffect HERMIT.Shell.ScriptToRewrite+ HERMIT.Shell.ShellEffect HERMIT.Shell.Proof HERMIT.Shell.Types @@ -238,9 +246,7 @@ Executable hermit Build-Depends: base >= 4 && < 5,- directory >= 1.2.0.0,- hermit,- process+ hermit default-language: Haskell2010 Main-Is: Main.hs
src/HERMIT/Context.hs view
@@ -7,8 +7,7 @@ , LocalPathH -- ** The Standard Context , HermitC- , initHermitC- , hermitC_modguts -- TODO: for now+ , topLevelHermitC -- ** Bindings , HermitBindingSite(..) , BindingDepth@@ -36,10 +35,10 @@ , lookupHermitBinding , lookupHermitBindingDepth , lookupHermitBindingSite- -- ** Accessing the Global Reader Environment from the context- , HasGlobalRdrEnv(..) -- ** Accessing GHC rewrite rules from the context , HasCoreRules(..)+ -- ** An empty Context+ , HasEmptyContext(..) ) where import Prelude hiding (lookup)@@ -71,9 +70,10 @@ | CASEALT -- ^ A variable bound in a case alternative. | CASEBINDER CoreExpr (AltCon,[Var]) -- ^ A case binder. We store both the scrutinised expression, and the case alternative 'AltCon' and variables. | FORALL -- ^ A universally quantified type variable.+ | TOPLEVEL CoreExpr -- ^ A special case. When we're focussed on ModGuts, we treat all top-level bindings as being in scope at depth 0. -data HermitBinding = HB { hbDepth :: BindingDepth - , hbSite :: HermitBindingSite +data HermitBinding = HB { hbDepth :: BindingDepth+ , hbSite :: HermitBindingSite , hbPath :: AbsolutePathH } @@ -88,6 +88,7 @@ CASEALT -> fail "variable is bound in a case alternative, not bound to an expression." CASEBINDER e _ -> return e FORALL -> fail "variable is a universally quantified type variable."+ TOPLEVEL e -> return e hermitBindingSummary :: HermitBinding -> String hermitBindingSummary b = show (hbDepth b) ++ "$" ++ case hbSite b of@@ -99,6 +100,7 @@ CASEALT -> "CASEALT" CASEBINDER {} -> "CASEBINDER" FORALL -> "FORALL"+ TOPLEVEL {} -> "TOPLEVEL" -- | Retrieve the expression in a 'HermitBinding', if there is one. hermitBindingExpr :: HermitBinding -> KureM CoreExpr@@ -207,21 +209,17 @@ -- | A class of contexts that store GHC rewrite rules. class HasCoreRules c where- hermitCoreRules :: c -> [CoreRule]+ hermitCoreRules :: c -> [CoreRule] instance HasCoreRules [CoreRule] where- hermitCoreRules :: [CoreRule] -> [CoreRule]- hermitCoreRules = id+ hermitCoreRules :: [CoreRule] -> [CoreRule]+ hermitCoreRules = id ------------------------------------------------------------------------ --- | A class of contexts that store the Global Reader Environment.-class HasGlobalRdrEnv c where- hermitGlobalRdrEnv :: c -> GlobalRdrEnv--instance HasGlobalRdrEnv GlobalRdrEnv where- hermitGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv- hermitGlobalRdrEnv = id+-- | A class of contexts that provide an empty context.+class HasEmptyContext c where+ setEmptyContext :: c -> c ------------------------------------------------------------------------ @@ -232,31 +230,34 @@ -- The bindings here are lazy by choice, so that we can avoid the cost -- of building the context if we never use it. data HermitC = HermitC- { hermitC_bindings :: Map Var HermitBinding -- ^ All (important) bindings in scope.- , hermitC_depth :: BindingDepth -- ^ The depth of the most recent bindings.- , hermitC_path :: AbsolutePathH -- ^ The 'AbsolutePath' to the current node from the root.- , hermitC_globalRdrEnv :: GlobalRdrEnv -- ^ The top-level lexical environment.- , hermitC_coreRules :: [CoreRule] -- ^ GHC rewrite RULES.- , hermitC_modguts :: ModGuts -- ^ Used to run the typechecker/desugarer- }+ { hermitC_bindings :: Map Var HermitBinding -- ^ All (local to this module) bindings in scope.+ , hermitC_depth :: BindingDepth -- ^ The depth of the most recent bindings.+ , hermitC_path :: AbsolutePathH -- ^ The 'AbsolutePath' to the current node from the root.+ , hermitC_specRules :: [CoreRule] -- ^ In-scope GHC RULES found in IdInfos.+ } ------------------------------------------------------------------------ --- | Create the initial HERMIT 'HermitC' by providing a 'ModGuts'.-initHermitC :: ModGuts -> HermitC-initHermitC modGuts = HermitC- { hermitC_bindings = empty- , hermitC_depth = 0- , hermitC_path = mempty- , hermitC_globalRdrEnv = mg_rdr_env modGuts- , hermitC_coreRules = mg_rules modGuts ++ other_rules- -- We need this to run the typechecker/desugarer- -- TODO: if this is undesirable, another way?- , hermitC_modguts = modGuts- }+-- | The |HermitC| empty context has an initial depth of 0, an empty path, and no bindings nor rules.+instance HasEmptyContext HermitC where+ setEmptyContext :: HermitC -> HermitC+ setEmptyContext c = c+ { hermitC_bindings = empty+ , hermitC_depth = 0+ , hermitC_path = mempty+ , hermitC_specRules = []+ } - where other_rules :: [CoreRule]- other_rules = mg_binds modGuts >>= bindToVarExprs >>= (idCoreRules . fst)+-- | A special HERMIT context intended for use only when focussed on ModGuts.+-- All top-level bindings are considered to be in scope at depth 0.+topLevelHermitC :: ModGuts -> HermitC+topLevelHermitC mg = let ies = concatMap bindToVarExprs (mg_binds mg)+ in HermitC+ { hermitC_bindings = fromList [ (i , HB 0 (TOPLEVEL e) mempty) | (i,e) <- ies ]+ , hermitC_depth = 0+ , hermitC_path = mempty+ , hermitC_specRules = concatMap (idCoreRules . fst) ies+ } ------------------------------------------------------------------------ @@ -274,11 +275,13 @@ instance AddBindings HermitC where addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> HermitC -> HermitC- addHermitBindings vbs c = let nextDepth = succ (hermitC_depth c)- vhbs = [ (v, HB nextDepth b p) | (v,b,p) <- vbs ]- in c { hermitC_bindings = fromList vhbs `union` hermitC_bindings c- , hermitC_depth = nextDepth- }+ addHermitBindings vbs c =+ let nextDepth = succ (hermitC_depth c)+ vhbs = [ (v, HB nextDepth b p) | (v,b,p) <- vbs ]+ in c { hermitC_bindings = fromList vhbs `union` hermitC_bindings c+ , hermitC_depth = nextDepth+ , hermitC_specRules = concat [ idCoreRules i | (i,_,_) <- vbs, isId i ] ++ hermitC_specRules c+ } ------------------------------------------------------------------------ @@ -297,12 +300,6 @@ instance HasCoreRules HermitC where hermitCoreRules :: HermitC -> [CoreRule]- hermitCoreRules = hermitC_coreRules----------------------------------------------------------------------------instance HasGlobalRdrEnv HermitC where- hermitGlobalRdrEnv :: HermitC -> GlobalRdrEnv- hermitGlobalRdrEnv = hermitC_globalRdrEnv+ hermitCoreRules = hermitC_specRules ------------------------------------------------------------------------
src/HERMIT/Core.hs view
@@ -113,7 +113,7 @@ bindsToProg = foldr ProgCons ProgNil {-# INLINE bindsToProg #-} --- | Extract the list of identifier/expression pairs from a binding group.+-- | Extract the list of variable/expression pairs from a binding group. bindToVarExprs :: CoreBind -> [(Var,CoreExpr)] bindToVarExprs (NonRec v e) = [(v,e)] bindToVarExprs (Rec bds) = bds
src/HERMIT/Dictionary/AlphaConversion.hs view
@@ -19,17 +19,23 @@ , alphaProgR -- ** Shadow Detection and Unshadowing , unshadowR+ , unshadowExprR+ , unshadowAltR+ , unshadowProgR , visibleVarsT- , freshNameGenT+ , cloneVarAvoidingT+-- , freshNameGenAvoidingT , freshNameGenAvoiding+ , detectShadowsM , replaceVarR ) where import Control.Applicative import Control.Arrow-import Control.Monad (liftM, liftM2)+import Control.Monad (liftM2) import Data.Char (isDigit)+import Data.Function (on) import Data.List (intersect) import Data.Maybe (fromMaybe, listToMaybe) @@ -39,6 +45,7 @@ import HERMIT.Kure import HERMIT.External import HERMIT.GHC+import HERMIT.Utilities(dupsBy) import HERMIT.Dictionary.GHC hiding (externals) import HERMIT.Dictionary.Common@@ -94,15 +101,18 @@ -- 2. Any bound variables in context. -- | Collect all visible variables (in the expression or the context).-visibleVarsT :: (BoundVars c, Monad m) => Translate c m CoreTC VarSet+visibleVarsT :: (BoundVars c, Monad m) => Transform c m CoreTC VarSet visibleVarsT = liftM2 unionVarSet boundVarsT (arr freeVarsCoreTC) --- | If a name is provided replace the string with that,--- otherwise modify the string making sure to /not/ clash with any visible variables.-freshNameGenT :: (BoundVars c, Monad m) => Maybe String -> Translate c m CoreTC (String -> String)-freshNameGenT mn = freshNameGenAvoiding mn `liftM` visibleVarsT+-- | 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 v mn vs =+ do vvs <- visibleVarsT+ let nameModifier = freshNameGenAvoiding mn (extendVarSetList vvs vs)+ constT (cloneVarH nameModifier v) --- | Use the optional argument if given, otherwise generate a new name avoiding clashes with the list of variables.+-- | Use the optional argument if given, otherwise generate a new name avoiding clashes with the set of variables. freshNameGenAvoiding :: Maybe String -> VarSet -> (String -> String) freshNameGenAvoiding mn vs str = maybe (inventNames vs str) ((\(c:cs) -> reverse (c:(takeWhile (/='.') cs))) . reverse) mn -- The 'Just' case above gives the unqualified portion of the name (properly handling the compose operator '.')@@ -124,38 +134,51 @@ _ -> 0 --- | Remove all variables from the first set that shadow a variable in the second set.+-- | 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 --- | Lifted version of 'shadowedBy'.--- Additionally, it fails if no shadows are found.-shadowedByT :: MonadCatch m => Translate c m a VarSet -> Translate c m a VarSet -> Translate c m a VarSet-shadowedByT t1 t2 = setFailMsg "No shadows detected." $ (liftM2 shadowedBy t1 t2) >>> acceptR (not . isEmptyVarSet)+-- | Shadows are any duplicates in the list, or any occurrences of the list elements in the set.+detectShadowsM :: Monad m => [Var] -> VarSet -> m VarSet+detectShadowsM bs fvs = let ss = shadowedBy (mkVarSet bs) fvs `extendVarSetList` dupVars bs+ in do guardMsg (not $ isEmptyVarSet ss) "No shadows detected."+ return ss -- | Rename local variables with manifestly unique names (x, x0, x1, ...). -- Does not rename top-level definitions.-unshadowR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core+unshadowR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb)+ => Rewrite c HermitM Core unshadowR = setFailMsg "No shadows to eliminate." $- anytdR (promoteExprR unshadowExpr <+ promoteAltR unshadowAlt <+ promoteProgR unshadowProg)+ anytdR (promoteExprR unshadowExprR <+ promoteAltR unshadowAltR <+ promoteProgR unshadowProgR) - where- unshadowExpr :: Rewrite c HermitM CoreExpr- unshadowExpr = do vs <- shadowedByT (mkVarSet <$> (letVarsT <+ (return <$> (caseBinderIdT <+ lamVarT))))- (unionVarSet <$> boundVarsT <*> arr freeVarsExpr)- alphaLamR Nothing <+ alphaLetVarsR (varSetElems vs) <+ alphaCaseBinderR Nothing+unshadowExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb)+ => Rewrite c HermitM CoreExpr+unshadowExprR = do+ bs <- letVarsT <+ (return <$> (caseBinderIdT <+ lamVarT))+ fvs <- unionVarSet <$> boundVarsT <*> arr freeVarsExpr+ ss <- detectShadowsM bs fvs+ alphaLamR Nothing <+ alphaLetVarsR (varSetElems ss) <+ alphaCaseBinderR Nothing - unshadowAlt :: Rewrite c HermitM CoreAlt- unshadowAlt = do vs <- shadowedByT (arr (mkVarSet . altVars))- (unionVarSet <$> boundVarsT <*> arr freeVarsAlt)- alphaAltVarsR (varSetElems vs)+unshadowAltR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb)+ => Rewrite c HermitM CoreAlt+unshadowAltR = do+ bs <- arr altVars+ fvs <- unionVarSet <$> boundVarsT <*> arr freeVarsAlt+ ss <- detectShadowsM bs fvs+ alphaAltVarsR (varSetElems ss) - unshadowProg :: Rewrite c HermitM CoreProg- unshadowProg = do is <- shadowedByT (mkVarSet <$> progConsIdsT)- (unionVarSet <$> boundVarsT <*> arr freeVarsProg)- alphaProgConsIdsR (varSetElems is)+unshadowProgR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb)+ => Rewrite c HermitM CoreProg+unshadowProgR = do+ bs <- progConsIdsT+ fvs <- unionVarSet <$> boundVarsT <*> arr freeVarsProg+ ss <- detectShadowsM bs fvs+ alphaProgConsIdsR (varSetElems ss) +dupVars :: [Var] -> [Var]+dupVars = dupsBy ((==) `on` uqName)+ ----------------------------------------------------------------------- -- Maybe this should be defined elsewhere.@@ -182,28 +205,27 @@ -- | 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 mn = setFailMsg (wrongFormForAlpha "Lam v e") $- do (v, nameModifier) <- lamT idR (extractT $ freshNameGenT mn) (,)- v' <- constT (cloneVarH nameModifier v)+ do v <- lamVarT+ v' <- extractT (cloneVarAvoidingT v mn [v]) lamAnyR (arr $ replaceVar v 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 mn = setFailMsg (wrongFormForAlpha "Case e v ty alts") $- do Case _ v _ _ <- idR- nameModifier <- extractT (freshNameGenT mn)- v' <- constT (cloneVarH nameModifier v)- caseAnyR idR (return v') idR (\ _ -> replaceVarR v v')+alphaCaseBinderR mn = setFailMsg (wrongFormForAlpha "Case e i ty alts") $+ do i <- caseBinderIdT+ i' <- extractT (cloneVarAvoidingT i mn [i])+ caseAnyR idR (return i') idR (\ _ -> replaceVarR i i') ----------------------------------------------------------------------- -- | 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 mn v = do- nameModifier <- freshNameGenAvoiding mn <$> liftM2 unionVarSet boundVarsT (arr freeVarsAlt)- v' <- constT (cloneVarH nameModifier v) (con, vs, rhs) <- idR+ v' <- extractT (cloneVarAvoidingT v mn vs)+ -- This is a bit of a hack. We include all the binders *after* v in the call to substAltR, -- then put the binders before v, and v', back on the front. The use of substAltR this way, -- handles the case where v is a type binder which substitutes into the types of bs'.@@ -246,8 +268,8 @@ -- | 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 mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $- do (v, nameModifier) <- letNonRecT idR successT (extractT $ freshNameGenT mn) (\ v () nameMod -> (v, nameMod))- v' <- constT (cloneVarH nameModifier v)+ 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.@@ -263,11 +285,10 @@ 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 mn v = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $- do usedVars <- unionVarSet <$> boundVarsT- <*> letRecT (\ _ -> defT idR (arr freeVarsExpr) (flip extendVarSet)) (arr freeVarsExpr) (\ bndfvs vs -> unionVarSets (vs:bndfvs))- v' <- constT (cloneVarH (freshNameGenAvoiding mn usedVars) v)- letRecDefAnyR (\ _ -> (arr (replaceVar v v'), replaceVarR v v')) (replaceVarR v v')+ 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') -- | Rename the identifiers bound in a Let with the given list of suggested names.@@ -291,9 +312,9 @@ -- | 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 mn = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $- do (i, nameModifier) <- consNonRecT idR successT (extractT $ freshNameGenT mn) (\ i () nameMod -> (i, nameMod))+ do i <- progConsNonRecIdT guardMsg (not $ isExportedId i) ("Identifier " ++ var2String i ++ " is exported, and thus cannot be alpha-renamed.")- i' <- constT (cloneVarH nameModifier i)+ 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.@@ -309,9 +330,8 @@ -- | 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 mn i = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $- do usedVars <- unionVarSet <$> boundVarsT- <*> consRecT (\ _ -> defT idR (arr freeVarsExpr) (flip extendVarSet)) (arr freeVarsProg) (\ bndfvs vs -> unionVarSets (vs:bndfvs))- i' <- constT (cloneVarH (freshNameGenAvoiding mn usedVars) i)+ do is <- progConsRecIdsT+ i' <- extractT (cloneVarAvoidingT i mn is) consRecDefAnyR (\ _ -> (arr (replaceVar i i'), replaceVarR i i')) (replaceVarR i i') @@ -348,6 +368,8 @@ -- TODO: Alpha rewrites need better error messages. Currently the use of (<+) leads to incorrect error reporting. -- Though really, we first need to improve KURE to have a version of (<+) that maintains the existing error message in the case of non-matching constructors henceforth.++-- TODO 2: Also, we should be able to rename inside types and coercions. -----------------------------------------------------------------------
src/HERMIT/Dictionary/Common.hs view
@@ -32,7 +32,11 @@ , boundVarsT , findBoundVarT , findIdT- , findId+#if __GLASGOW_HASKELL__ > 706+ , findVarT+ , findTyConT+ , findTypeT+#endif , varBindingDepthT , varIsOccurrenceOfT , exprIsOccurrenceOfT@@ -48,17 +52,19 @@ import Data.Monoid import Control.Arrow-import Control.Monad+import Control.Monad.IO.Class -import HERMIT.Kure-import HERMIT.Core import HERMIT.Context+import HERMIT.Core import HERMIT.GHC+import HERMIT.Kure+import HERMIT.Monad+import HERMIT.Name ------------------------------------------------------------------------------ -- | Apply a transformation to a value in the current context.-applyInContextT :: Translate c m a b -> a -> Translate c m x b+applyInContextT :: Transform c m a b -> a -> Transform c m x b applyInContextT t a = contextonlyT $ \ c -> apply t c a -- Note: this is the same as: return a >>> t@@ -66,13 +72,13 @@ ------------------------------------------------------------------------------ -- | Lift GHC's collectArgs-callT :: Monad m => Translate c m CoreExpr (CoreExpr, [CoreExpr])+callT :: Monad m => Transform c m CoreExpr (CoreExpr, [CoreExpr]) callT = contextfreeT $ \ e -> case e of Var {} -> return (e, []) App {} -> return (collectArgs e) _ -> fail "not an application or variable occurence." -callPredT :: Monad m => (Id -> [CoreExpr] -> Bool) -> Translate c m CoreExpr (CoreExpr, [CoreExpr])+callPredT :: Monad m => (Id -> [CoreExpr] -> Bool) -> Transform c m CoreExpr (CoreExpr, [CoreExpr]) callPredT p = do call@(Var i, args) <- callT guardMsg (p i args) "predicate failed."@@ -80,22 +86,22 @@ -- | 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 -> Translate c m CoreExpr (CoreExpr, [CoreExpr])+callNameT :: MonadCatch m => String -> Transform c m CoreExpr (CoreExpr, [CoreExpr]) callNameT nm = setFailMsg ("callNameT failed: not a call to '" ++ nm ++ ".") $ callPredT (const . cmpString2Var nm) -- | Succeeds if we are looking at a fully saturated function call.-callSaturatedT :: Monad m => Translate c m CoreExpr (CoreExpr, [CoreExpr])+callSaturatedT :: Monad m => Transform c m CoreExpr (CoreExpr, [CoreExpr]) callSaturatedT = callPredT (\ i args -> idArity i == length args) -- TODO: probably better to calculate arity based on Id's type, as -- idArity is conservatively set to zero by default. -- | Succeeds if we are looking at an application of given function-callNameG :: MonadCatch m => String -> Translate c m CoreExpr ()+callNameG :: MonadCatch m => String -> Transform c m CoreExpr () callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >>= \_ -> constT (return ()) -- | Succeeds if we are looking at an application of a data constructor.-callDataConT :: MonadCatch m => Translate c m CoreExpr (DataCon, [Type], [CoreExpr])+callDataConT :: 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) ])@@ -107,7 +113,7 @@ #endif -- | Succeeds if we are looking at an application of a named data constructor.-callDataConNameT :: MonadCatch m => String -> Translate c m CoreExpr (DataCon, [Type], [CoreExpr])+callDataConNameT :: MonadCatch m => String -> Transform c m CoreExpr (DataCon, [Type], [CoreExpr]) callDataConNameT nm = do res@(dc,_,_) <- callDataConT guardMsg (cmpString2Name nm (dataConName dc)) "wrong datacon."@@ -115,86 +121,86 @@ -- 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, MonadCatch m) => String -> Rewrite c m CoreExpr -> Rewrite c m Core+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, MonadCatch m) => String -> Translate c m CoreExpr b -> Translate c m Core [b]+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.-progConsIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreProg [Id]+progConsIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Transform c m CoreProg [Id] progConsIdsT = progConsT (arr bindVars) mempty (\ vs () -> vs) -- | List the identifiers bound by a recursive top-level binding group at the head of the program.-progConsRecIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg [Id]+progConsRecIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m CoreProg [Id] progConsRecIdsT = progConsT recIdsT mempty (\ vs () -> vs) -- | Return the identifier bound by a non-recursive top-level binding at the head of the program.-progConsNonRecIdT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg Id+progConsNonRecIdT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m CoreProg Id progConsNonRecIdT = progConsT nonRecVarT mempty (\ v () -> v) -- | Return the variable bound by a non-recursive let expression.-nonRecVarT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreBind Var+nonRecVarT :: (ExtendPath c Crumb, Monad m) => Transform c m CoreBind Var nonRecVarT = nonRecT idR mempty (\ v () -> v) -- | List all identifiers bound in a recursive binding group.-recIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind [Id]+recIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m CoreBind [Id] recIdsT = recT (\ _ -> arr defId) id -- | Return the variable bound by a lambda expression.-lamVarT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var+lamVarT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m CoreExpr Var lamVarT = lamT idR mempty (\ v () -> v) -- | List the variables bound by a let expression.-letVarsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreExpr [Var]+letVarsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Transform c m CoreExpr [Var] letVarsT = letT (arr bindVars) mempty (\ vs () -> vs) -- | List the identifiers bound by a recursive let expression.-letRecIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Id]+letRecIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m CoreExpr [Id] letRecIdsT = letT recIdsT mempty (\ vs () -> vs) -- | Return the variable bound by a non-recursive let expression.-letNonRecVarT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var+letNonRecVarT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m CoreExpr Var letNonRecVarT = letT nonRecVarT mempty (\ v () -> v) -- | List all variables bound by a case expression (in the alternatives and the case binder).-caseVarsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Var]+caseVarsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m CoreExpr [Var] caseVarsT = caseT mempty idR mempty (\ _ -> arr altVars) (\ () v () vss -> v : nub (concat vss)) -- | Return the case binder.-caseBinderIdT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Id+caseBinderIdT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m CoreExpr Id caseBinderIdT = caseT mempty idR mempty (\ _ -> idR) (\ () i () _ -> i) -- | List the variables bound by all alternatives in a case expression.-caseAltVarsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [[Var]]+caseAltVarsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m CoreExpr [[Var]] caseAltVarsT = caseT mempty mempty mempty (\ _ -> arr altVars) (\ () () () vss -> vss) ------------------------------------------------------------------------------ -- | Find the depth of a variable's binding.-varBindingDepthT :: (ReadBindings c, Monad m) => Var -> Translate c m g BindingDepth+varBindingDepthT :: (ReadBindings c, Monad m) => Var -> Transform c m g BindingDepth varBindingDepthT v = contextT >>= lookupHermitBindingDepth v -- | Determine if the current variable matches the given variable, and is bound at the specified depth (helpful to detect shadowing).-varIsOccurrenceOfT :: (ExtendPath c Crumb, ReadBindings c, Monad m) => Var -> BindingDepth -> Translate c m Var Bool+varIsOccurrenceOfT :: (ExtendPath c Crumb, ReadBindings c, Monad m) => Var -> BindingDepth -> Transform c m Var Bool varIsOccurrenceOfT v d = readerT $ \ v' -> if v == v' then varBindingDepthT v >>^ (== d) else return False -- | Determine if the current expression is an occurrence of the given variable, bound at the specified depth (helpful to detect shadowing).-exprIsOccurrenceOfT :: (ExtendPath c Crumb, ReadBindings c, Monad m) => Var -> BindingDepth -> Translate c m CoreExpr Bool+exprIsOccurrenceOfT :: (ExtendPath c Crumb, ReadBindings c, Monad m) => Var -> BindingDepth -> Transform c m CoreExpr Bool exprIsOccurrenceOfT v d = varT $ varIsOccurrenceOfT v d -- | Lifted version of 'boundVars'.-boundVarsT :: (BoundVars c, Monad m) => Translate c m a VarSet+boundVarsT :: (BoundVars c, Monad m) => Transform c m a VarSet boundVarsT = contextonlyT (return . boundVars) -- | Find the unique variable bound in the context that matches the given name, failing if it is not unique.-findBoundVarT :: (BoundVars c, MonadCatch m) => String -> Translate c m a Var+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@@ -202,48 +208,25 @@ [v] -> return v _ : _ : _ -> fail "multiple matching variables in scope." --- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.-findIdT :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m, MonadCatch m) => String -> Translate c m a Id-findIdT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $- contextonlyT (findId nm)--findId :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m) => String -> c -> m Id-findId nm c = case {- filter (isValName . idName) $ -} varSetElems (findBoundVars nm c) of- [] -> findIdMG nm c- [v] -> return v- _ : _ : _ -> fail "multiple matching variables in scope."--findIdMG :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m) => String -> c -> m Id-findIdMG nm c =- case filter isValName $ findNamesFromString (hermitGlobalRdrEnv c) nm of- [] -> findIdBuiltIn nm- [n] | isVarName n -> lookupId n - | isDataConName n -> liftM dataConWrapId $ lookupDataCon n- ns -> do dynFlags <- getDynFlags- fail $ "multiple matches found:\n" ++ intercalate ", " (map (showPpr dynFlags) ns)--findIdBuiltIn :: forall m. Monad m => String -> m Id-findIdBuiltIn = go - where go ":" = dataConId consDataCon- go "[]" = dataConId nilDataCon-- go "True" = return trueDataConId- go "False" = return falseDataConId-- go "<" = return ltDataConId- go "==" = return eqDataConId- go ">" = return gtDataConId+-------------------------------------------------------------------------------------------------- - go "I#" = dataConId intDataCon+-- | 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) - 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."+#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) - dataConId :: DataCon -> m Id- dataConId = return . dataConWorkId+-- | 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) +-- | 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 -- TODO: "inScope" was defined elsewhere, but I've moved it here. Should it be combined with the above functions? @@ -256,9 +239,9 @@ DFunUnfolding {} -> True _ -> False) -withVarsInScope :: forall c m b. (ReadPath c Crumb, ExtendPath c Crumb, AddBindings c, MonadCatch m) - => [Var] -> Translate c m CoreExpr b -> Translate c m CoreExpr b-withVarsInScope vs t = arr (mkCoreLams vs) >>> extractT (pathT (replicate (length vs) Lam_Body) (promoteExprT t :: Translate c m Core b))+-- | 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 ------------------------------------------------------------------------------
src/HERMIT/Dictionary/Composite.hs view
@@ -57,11 +57,11 @@ -- | Unfold the current expression if it is one of the basic combinators: ('$'), ('.'), 'id', 'flip', 'const', 'fst' or 'snd'. -- This is intended to be used as a component of simplification traversals such as 'simplifyR' or 'bashR'.-unfoldBasicCombinatorR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+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 -simplifyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core+simplifyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM Core simplifyR = setFailMsg "Simplify failed: nothing to simplify." $ innermostR ( promoteBindR recToNonrecR <+ promoteExprR ( unfoldBasicCombinatorR@@ -73,17 +73,17 @@ ------------------------------------------------------------------------------------------------------ -bashR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core+bashR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM Core bashR = bashExtendedWithR [] -bashExtendedWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core+bashExtendedWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core bashExtendedWithR rs = bashUsingR (rs ++ map fst bashComponents) -smashR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core+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) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core+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) @@ -110,12 +110,12 @@ -- bashCoreR :: Rewrite c m Core -- bashCoreR = repeatR (innermostR (catchesT rs) >>> occurAnalyseR) -bashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => [Rewrite c m Core] -> Rewrite c m Core+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." $ repeatR (occurAnalyseR >>> onetdR (catchesT rs)) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR -smashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => [Rewrite c m Core] -> [Rewrite c m Core] -> Rewrite c m Core+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@@ -141,7 +141,7 @@ ) -- TODO: Think about a good order for bash.-bashComponents :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [(Rewrite c HermitM Core, String)]+bashComponents :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [(Rewrite c HermitM Core, String)] bashComponents = [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr") -- ?? (promoteExprR betaReduceR, "beta-reduce") -- O(1)@@ -178,7 +178,7 @@ -- | As bash, but with "let-nonrec-subst" instead of "let-nonrec-subst-safe".-smashComponents1 :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [(Rewrite c HermitM Core, String)]+smashComponents1 :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [(Rewrite c HermitM Core, String)] smashComponents1 = [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr") -- ?? (promoteExprR betaReduceR, "beta-reduce") -- O(1)@@ -207,7 +207,7 @@ -- , (promoteExprR dezombifyR, "dezombify") -- O(1) -- performed at the end ] -smashComponents2 :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [(Rewrite c HermitM Core, String)]+smashComponents2 :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [(Rewrite c HermitM Core, String)] smashComponents2 = [ (promoteExprR caseElimMergeAltsR, "case-elim-merge-alts") -- do this last, lest it prevent other simplifications
src/HERMIT/Dictionary/FixPoint.hs view
@@ -17,6 +17,7 @@ import Control.Applicative import Control.Arrow+import Control.Monad.IO.Class import Data.Monoid (mempty) @@ -126,7 +127,7 @@ guardMsg (eqType tyB tyB') "Type mismatch: this shouldn't have happened, report this as a bug." rollingRuleResult tyA f g - rollingRuleResult :: Type -> CoreExpr -> CoreExpr -> TranslateH z CoreExpr+ rollingRuleResult :: 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)))) @@ -181,7 +182,7 @@ -------------------------------------------------------------------------------------------------- -- | Check that the expression has the form "fix t (f :: t -> t)", returning "t" and "f".-isFixExprT :: TranslateH CoreExpr (Type,CoreExpr)+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@@ -191,7 +192,7 @@ -------------------------------------------------------------------------------------------------- -- | f ==> fix f-mkFixT :: (BoundVars c, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => CoreExpr -> Translate c m z CoreExpr+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]@@ -200,7 +201,7 @@ fixLocation = "Data.Function.fix" -- TODO: will crash if 'fix' is not used (or explicitly imported) in the source file.-findFixId :: (BoundVars c, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Translate c m a Id+findFixId :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id findFixId = findIdT fixLocation --------------------------------------------------------------------------------------------------
src/HERMIT/Dictionary/Fold.hs view
@@ -7,6 +7,8 @@ , stashFoldAnyR -- * Unlifted fold interface , fold+ , unifyTypes+ , tyMatchesToCoreExpr ) where@@ -55,7 +57,7 @@ stashFoldR :: ReadBindings c => Label -> Rewrite c HermitM CoreExpr stashFoldR label = prefixFailMsg "Fold failed: " $- translate $ \ c e -> do+ 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.)" maybe (fail "no match.")@@ -66,7 +68,7 @@ stashFoldAnyR = setFailMsg "Fold failed: no definitions could be folded." $ catchesM =<< map stashFoldR <$> (Map.keys <$> constT getStash) -foldR :: (HasGlobalRdrEnv c, ReadBindings c) => String -> Rewrite c HermitM CoreExpr+foldR :: ReadBindings c => String -> Rewrite c HermitM CoreExpr foldR nm = prefixFailMsg "Fold failed: " $ do v <- findIdT nm foldVarR v Nothing@@ -94,18 +96,26 @@ go bs i (Lam b e) = go (b:bs) (i-1) e go _ _ _ = Nothing --- return Nothing if not equal, so sequence will fail below-checkEqual :: Maybe CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr-checkEqual m1 m2 = ifM (exprAlphaEq <$> m1 <*> m2) m1 Nothing+unifyHoles :: Ord k+ => [k] -- keys we care about (TODO: figure out what else is getting in there)+ -> (a -> a -> Bool) -- notion of equality+ -> [(k,a)] -- list of key/values+ -> Maybe [(k,a)] -- list of unified key/values, or failure+unifyHoles vs eq kvs = do+ -- return Nothing if not equal, so sequence will fail below+ let checkEqual m1 m2 = ifM (eq <$> m1 <*> m2) m1 Nothing+ m = Map.fromListWith checkEqual [(k,Just v) | (k,v) <- kvs ] + es <- sequence [ join (Map.lookup v m) | v <- vs ]+ return $ zip vs es+ fold :: Id -> CoreExpr -> CoreExpr -> Maybe CoreExpr fold i lam exp = do (vs,body) <- collectNBinders (countBinders lam - countBinders exp) lam al <- foldMatch vs [] body exp - let m = Map.fromListWith checkEqual [(k,Just v) | (k,v) <- al ]+ es <- liftM (map snd) $ unifyHoles vs exprAlphaEq al - es <- sequence [ join (Map.lookup v m) | v <- vs ] return $ mkCoreApps (varToCoreExpr i) es -- Note: Var in the concrete instance is first@@ -191,6 +201,16 @@ foldMatch _ _ _ _ = Nothing ------------------------------------------------------------------------++-- | Given list of TyVars which can match any type (the holes),+-- a pattern, and a concrete type, return mapping from hole to type+-- for successful unification.+unifyTypes :: [TyVar] -> Type -> Type -> Maybe [(TyVar, Type)]+unifyTypes holes pat ty = do+ al <- foldMatchType holes [] pat ty+ -- unlike folding itself, we don't care that every hole is assigned+ let found = [ v | (v,_) <- al, v `elem` holes ]+ unifyHoles found typeAlphaEq al foldMatchType :: [TyVar] -- ^ vars that can unify with anything -> [(TyVar,TyVar)] -- ^ alpha equivalences, wherever there is binding
src/HERMIT/Dictionary/Function.hs view
@@ -34,15 +34,15 @@ ------------------------------------------------------------------------------------------------------ -- | Traditional Static Argument Transformation-staticArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Rewrite c HermitM CoreDef+staticArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c) => Rewrite c HermitM CoreDef staticArgR = staticArgPredR (return . map fst) -- | Static Argument Transformation that only considers type arguments to be static.-staticArgTypesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Rewrite c HermitM CoreDef+staticArgTypesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c) => Rewrite c HermitM CoreDef staticArgTypesR = staticArgPredR (return . map fst . filter (isTyVar . snd)) -- | Static Argument Transformations which requires that arguments in the given position are static.-staticArgPosR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => [Int] -> Rewrite c HermitM CoreDef+staticArgPosR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c) => [Int] -> Rewrite c HermitM CoreDef staticArgPosR is' = staticArgPredR $ \ss' -> let is = nub is' ss = map fst ss' in if is == (is `intersect` ss)@@ -50,7 +50,7 @@ else fail $ "args " ++ commas (filter (`notElem` ss) is) ++ " are not static." -- | Generalized Static Argument Transformation, which allows static arguments to be filtered.-staticArgPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c)+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 decide = prefixFailMsg "static-arg failed: " $ do
src/HERMIT/Dictionary/GHC.hs view
@@ -49,13 +49,13 @@ [ "Zap the occurrence information in the current identifer if it is a zombie."] .+ Shallow , external "occurrence-analysis" (occurrenceAnalysisR :: RewriteH Core) [ "Perform dependency analysis on all sub-expressions; simplifying and updating identifer info."] .+ Deep- , external "lint-expr" (promoteExprT lintExprT :: TranslateH Core String)+ , external "lint-expr" (promoteExprT lintExprT :: TransformH CoreTC String) [ "Runs GHC's Core Lint, which typechecks the current expression." , "Note: this can miss several things that a whole-module core lint will find." , "For instance, running this on the RHS of a binding, the type of the RHS will" , "not be checked against the type of the binding. Running on the whole let expression" , "will catch that however."] .+ Deep .+ Debug .+ Query- , external "lint-module" (promoteModGutsT lintModuleT :: TranslateH Core String)+ , external "lint-module" (promoteModGutsT lintModuleT :: TransformH CoreTC String) [ "Runs GHC's Core Lint, which typechecks the current module."] .+ Deep .+ Debug .+ Query ] @@ -121,7 +121,7 @@ -- | Run the Core Lint typechecker. -- Fails on errors, with error messages. -- Succeeds returning warnings.-lintModuleT :: TranslateH ModGuts String+lintModuleT :: TransformH ModGuts String lintModuleT = do dynFlags <- dynFlagsT bnds <- arr mg_binds@@ -139,8 +139,8 @@ -- For instance, running this on the RHS of a binding, the type of the RHS will -- not be checked against the type of the binding. Running on the whole let expression -- will catch that however.-lintExprT :: (BoundVars c, Monad m, HasDynFlags m) => Translate c m CoreExpr String-lintExprT = translate $ \ c e -> do+lintExprT :: (BoundVars c, Monad m, HasDynFlags m) => Transform c m CoreExpr String+lintExprT = transform $ \ c e -> do dflags <- getDynFlags maybe (return "Core Lint Passed") (fail . showSDoc dflags) #if __GLASGOW_HASKELL__ > 706@@ -152,7 +152,7 @@ ------------------------------------------- -- | Lifted version of 'getDynFlags'.-dynFlagsT :: HasDynFlags m => Translate c m a DynFlags+dynFlagsT :: HasDynFlags m => Transform c m a DynFlags dynFlagsT = constT getDynFlags -------------------------------------------@@ -167,7 +167,7 @@ dezombifyR = varR (acceptR isDeadBinder >>^ zapVarOccInfo) -- | Apply 'occurAnalyseExprR' to all sub-expressions.-occurAnalyseR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core+occurAnalyseR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core occurAnalyseR = let r = promoteExprR (arr occurAnalyseExpr) go = r <+ anyR go in tryR go -- always succeed@@ -177,14 +177,14 @@ occurAnalyseExprChangedR = changedByR exprSyntaxEq (arr occurAnalyseExpr) -- | Occurrence analyse all sub-expressions, failing if the result is syntactically equal to the initial expression.-occurAnalyseChangedR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core+occurAnalyseChangedR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core occurAnalyseChangedR = changedByR coreSyntaxEq occurAnalyseR -- | Run GHC's occurrence analyser, and also eliminate any zombies.-occurAnalyseAndDezombifyR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core+occurAnalyseAndDezombifyR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core occurAnalyseAndDezombifyR = allbuR (tryR $ promoteExprR dezombifyR) >>> occurAnalyseR -occurrenceAnalysisR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core+occurrenceAnalysisR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core occurrenceAnalysisR = occurAnalyseAndDezombifyR {- Does not work (no export)
src/HERMIT/Dictionary/Induction.hs view
@@ -30,7 +30,8 @@ ------------------------------------------------------------------------------ -inductionCaseSplit :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasGlobalRdrEnv c) => [Var] -> Id -> CoreExpr -> CoreExpr -> Translate c HermitM x [(Maybe DataCon,[Var],CoreExpr,CoreExpr)]+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 il <- constT $ newIdH "dummyL" (exprKindOrType lhsE)@@ -63,7 +64,7 @@ -- -- | A general induction principle. TODO: Is this valid for infinite data types? Probably not. -- inductionOnT :: forall c. (AddBindings c, ReadBindings c, ReadPath c Crumb, ExtendPath c Crumb, Walker c Core)--- => (Id -> Bool) -> (DataCon -> [BiRewrite c HermitM CoreExpr] -> CoreExprEqualityProof c HermitM) -> Translate c HermitM CoreExprEquality ()+-- => (Id -> Bool) -> (DataCon -> [BiRewrite c HermitM CoreExpr] -> CoreExprEqualityProof c HermitM) -> Transform c HermitM CoreExprEquality () -- inductionOnT idPred genCaseAltProofs = prefixFailMsg "Induction failed: " $ -- do eq@(CoreExprEquality bs lhs rhs) <- idR @@ -72,7 +73,7 @@ -- cases <- inductionCaseSplit bs i lhs rhs -- -- TODO: will this work if vs contains TyVars or CoVars? Maybe we need to sort the Vars in order: TyVars; CoVars; Ids.--- let verifyInductiveCaseT :: (DataCon,[Var],CoreExpr,CoreExpr) -> Translate c HermitM x ()+-- let verifyInductiveCaseT :: (DataCon,[Var],CoreExpr,CoreExpr) -> Transform c HermitM x () -- verifyInductiveCaseT (con,vs,lhsE,rhsE) = -- let vs_matching_i_type = filter (typeAlphaEq (varType i) . varType) vs -- eqs = [ discardUniVars (instantiateCoreExprEq [(i,Var i')] eq) | i' <- vs_matching_i_type ]@@ -89,7 +90,7 @@ -- => (Id -> Bool) -- Id to case split on -- -> CoreExprEqualityProof c HermitM -- proof for [] case -- -> (BiRewrite c HermitM CoreExpr -> CoreExprEqualityProof c HermitM) -- proof for (:) case, given smaller proof--- -> Translate c HermitM CoreExprEquality ()+-- -> Transform c HermitM CoreExprEquality () -- listInductionOnT idPred nilCaseProof consCaseProof = inductionOnT idPred $ \ con brs -> -- if | con == nilDataCon -> case brs of -- [] -> nilCaseProof
src/HERMIT/Dictionary/Inline.hs view
@@ -27,6 +27,8 @@ import Control.Applicative import Control.Monad +import Data.List (intercalate)+ import HERMIT.Context import HERMIT.Core import HERMIT.External@@ -60,48 +62,52 @@ 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) => String -> Rewrite c HermitM CoreExpr+inlineNameR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => String -> Rewrite c HermitM 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) => [String] -> Rewrite c HermitM CoreExpr+inlineNamesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [String] -> Rewrite c HermitM 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) => (Id -> Bool) -> Rewrite c HermitM CoreExpr+inlineMatchingPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => (Id -> Bool) -> Rewrite c HermitM CoreExpr inlineMatchingPredR idPred = configurableInlineR AllBinders (arr $ idPred) -- | Inline the current variable.-inlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+inlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr inlineR = configurableInlineR AllBinders (return True) -- | Inline the current identifier if it is a case binder, using the scrutinee rather than the case-alternative pattern.-inlineCaseScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+inlineCaseScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr inlineCaseScrutineeR = configurableInlineR (CaseBinderOnly Scrutinee) (return True) -- | Inline the current identifier if is a case binder, using the case-alternative pattern rather than the scrutinee.-inlineCaseAlternativeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+inlineCaseAlternativeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr inlineCaseAlternativeR = configurableInlineR (CaseBinderOnly Alternative) (return True) -- | The implementation of inline, an important transformation. -- This *only* works if the current expression has the form @Var v@ (it does not traverse the expression). -- It can trivially be prompted to more general cases using traversal strategies.-configurableInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c)+configurableInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => InlineConfig- -> (Translate c HermitM Id Bool) -- ^ Only inline identifiers that satisfy this predicate.+ -> (Transform c HermitM Id Bool) -- ^ Only inline identifiers that satisfy this predicate. -> Rewrite c HermitM CoreExpr configurableInlineR config p = prefixFailMsg "Inline failed: " $ do b <- varT p guardMsg b "identifier does not satisfy predicate." (e,uncaptured) <- varT (getUnfoldingT config)+ return e >>> ensureBoundT -- fails if not all bound setFailMsg "values in inlined expression have been rebound."- (return e >>> accepterR ensureBoundT >>> accepterR (ensureDepthT uncaptured))+ (return e >>> accepterR (ensureDepthT uncaptured)) -- | Check that all free variables in an expression are bound.-ensureBoundT :: (Monad m, ReadBindings c) => Translate c m CoreExpr Bool-ensureBoundT = translate $ \ c -> return . all (inScope c) . varSetElems . localFreeVarsExpr+-- 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) -- NOTE: When inlining, we have to take care to avoid variable capture. -- Our approach is to track the binding depth of the inlined identifier.@@ -122,18 +128,18 @@ -- | Ensure all the free variables in an expression were bound above a given depth. -- Assumes minimum depth is 0.-ensureDepthT :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m) => (BindingDepth -> Bool) -> Translate c m CoreExpr Bool+ensureDepthT :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c, MonadCatch m) => (BindingDepth -> Bool) -> Transform c m CoreExpr Bool ensureDepthT uncaptured = do frees <- arr localFreeVarsExpr- let collectDepthsT :: Translate c m Core [BindingDepth]+ let collectDepthsT :: Transform c m Core [BindingDepth] collectDepthsT = collectT $ promoteExprT $ varT (acceptR (`elemVarSet` frees) >>> readerT varBindingDepthT) 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 => InlineConfig- -> Translate c HermitM Id (CoreExpr, BindingDepth -> Bool)-getUnfoldingT config = translate $ \ c i ->+ -> Transform c HermitM 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@@ -168,6 +174,10 @@ MUTUALREC e -> do requireAllBinders config return (e, (<= depth+1)) + TOPLEVEL e -> do requireAllBinders config+ return (e, (<= depth)) -- Depth should always be 0 for top-level bindings.+ -- Any inlined variables should only refer to top-level bindings or global things, else they've been captured.+ _ -> fail "variable is not bound to an expression." where requireAllBinders :: Monad m => InlineConfig -> m ()@@ -190,7 +200,7 @@ alt2Exp tys (DataAlt dc, vs) = return $ mkCoreConApps dc (map Type tys ++ map (varToCoreExpr . zapVarOccInfo) vs) -- | Get list of possible inline targets. Used by shell for completion.-inlineTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Translate c HermitM Core [String]+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) -- | Build a CoreExpr for a DFunUnfolding@@ -210,7 +220,7 @@ -} dFunExpr :: Unfolding -> HermitM CoreExpr -- TODO: is this correct?-dFunExpr dunf@(DFunUnfolding {}) = return $ trace "dFunExpr" $ mkCoreConApps (df_con dunf) (df_args dunf)+dFunExpr dunf@(DFunUnfolding {}) = return $ mkCoreConApps (df_con dunf) (df_args dunf) dFunExpr _ = fail "dFunExpr: not a DFunUnfolding" #else dFunExpr :: DataCon -> [DFunArg CoreExpr] -> Type -> HermitM CoreExpr
src/HERMIT/Dictionary/Kure.hs view
@@ -23,13 +23,13 @@ externals = map (.+ KURE) [ external "id" (idR :: RewriteH Core) [ "Perform an identity rewrite."] .+ Shallow- , external "success" (successT :: TranslateH Core ())+ , external "success" (successT :: TransformH Core ()) [ "An always succeeding translation." ] , external "fail" (fail :: String -> RewriteH Core) [ "A failing rewrite."] , external "<+" ((<+) :: RewriteH Core -> RewriteH Core -> RewriteH Core) [ "Perform the first rewrite, and then, if it fails, perform the second rewrite." ]- , external "<+" ((<+) :: TranslateH Core () -> TranslateH Core () -> TranslateH Core ())+ , external "<+" ((<+) :: TransformH Core () -> TransformH Core () -> TransformH Core ()) [ "Perform the first check, and then, if it fails, perform the second check." ] , external ">>>" ((>>>) :: RewriteH Core -> RewriteH Core -> RewriteH Core) [ "Compose rewrites, requiring both to succeed." ]@@ -71,17 +71,17 @@ [ "Attempt to apply a rewrite in a top-down manner, prunning at successful rewrites." ] .+ Deep , external "innermost" (innermostR :: RewriteH Core -> RewriteH Core) [ "A fixed-point traveral, starting with the innermost term." ] .+ Deep .+ Loop- , external "focus" (hfocusR :: TranslateH Core LocalPathH -> RewriteH Core -> RewriteH Core)+ , external "focus" (hfocusR :: TransformH CoreTC LocalPathH -> RewriteH CoreTC -> RewriteH CoreTC) [ "Apply a rewrite to a focal point."] .+ Navigation .+ Deep- , external "focus" (hfocusT :: TranslateH Core LocalPathH -> TranslateH Core String -> TranslateH Core String)+ , external "focus" (hfocusT :: TransformH CoreTC LocalPathH -> TransformH CoreTC String -> TransformH CoreTC String) [ "Apply a query at a focal point."] .+ Navigation .+ Deep- , external "focus" (hfocusR . return :: LocalPathH -> RewriteH Core -> RewriteH Core)+ , external "focus" (hfocusR . return :: LocalPathH -> RewriteH CoreTC -> RewriteH CoreTC) [ "Apply a rewrite to a focal point."] .+ Navigation .+ Deep- , external "focus" (hfocusT . return :: LocalPathH -> TranslateH Core String -> TranslateH Core String)+ , external "focus" (hfocusT . return :: LocalPathH -> TransformH CoreTC String -> TransformH CoreTC String) [ "Apply a query at a focal point."] .+ Navigation .+ Deep- , external "when" ((>>) :: TranslateH Core () -> RewriteH Core -> RewriteH Core)+ , external "when" ((>>) :: TransformH Core () -> RewriteH Core -> RewriteH Core) [ "Apply a rewrite only if the check succeeds." ] .+ Predicate- , external "not" (notM :: TranslateH Core () -> TranslateH Core ())+ , external "not" (notM :: TransformH Core () -> TransformH Core ()) [ "Cause a failing check to succeed, a succeeding check to fail." ] .+ Predicate , external "invert" (invertBiT :: BiRewriteH Core -> BiRewriteH Core) [ "Reverse a bidirectional rewrite." ]@@ -89,21 +89,25 @@ [ "Apply a bidirectional rewrite forewards." ] , external "backward" (backwardT :: BiRewriteH Core -> RewriteH Core) [ "Apply a bidirectional rewrite backwards." ]- , external "test" (testQuery :: RewriteH Core -> TranslateH Core String)+ , external "test" (testQuery :: RewriteH Core -> TransformH Core String) [ "Determine if a rewrite could be successfully applied." ]- , external "any-call" (anyCallR :: RewriteH Core -> RewriteH Core)+ , external "any-call" (anyCallR :: RewriteH Core -> RewriteH Core) [ "any-call (.. unfold command ..) applies an unfold command to all applications." , "Preference is given to applications with more arguments." ] .+ Deep+ , external "promote" (promoteR :: RewriteH Core -> RewriteH CoreTC)+ [ "Promote a RewriteCore to a RewriteCoreTC" ]+ , external "extract" (extractR :: RewriteH CoreTC -> RewriteH Core)+ [ "Extract a RewriteCore from a RewriteCoreTC" ] ] ------------------------------------------------------------------------------------ -hfocusR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m Core LocalPathH -> Rewrite c m Core -> Rewrite c m Core+hfocusR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m CoreTC LocalPathH -> Rewrite c m CoreTC -> Rewrite c m CoreTC hfocusR tp r = do lp <- tp localPathR lp r {-# INLINE hfocusR #-} -hfocusT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m Core LocalPathH -> Translate c m Core String -> Translate c m Core String+hfocusT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m CoreTC LocalPathH -> Transform c m CoreTC String -> Transform c m CoreTC String hfocusT tp t = do lp <- tp localPathT lp t {-# INLINE hfocusT #-}@@ -111,7 +115,7 @@ ------------------------------------------------------------------------------------ -- | Test if a rewrite would succeed, producing a string describing the result.-testQuery :: MonadCatch m => Rewrite c m g -> Translate c m g String+testQuery :: MonadCatch m => Rewrite c m g -> Transform c m g String testQuery r = f `liftM` testM r where f :: Bool -> String@@ -122,7 +126,7 @@ ------------------------------------------------------------------------------------ -- | Top-down traversal tuned to matching function calls.-anyCallR :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m)+anyCallR :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Rewrite c m Core -> Rewrite c m Core anyCallR rr = prefixFailMsg "any-call failed: " $ readerT $ \ e -> case e of
src/HERMIT/Dictionary/Local.hs view
@@ -181,7 +181,7 @@ ------------------------------------------------------------------------------ -- | Flatten all the top-level binding groups in the module to a single recursive binding group.-flattenModuleR :: (ExtendPath c Crumb, Monad m) => Rewrite c m ModGuts+flattenModuleR :: (ExtendPath c Crumb, HasEmptyContext c, Monad m) => Rewrite c m ModGuts flattenModuleR = modGutsR flattenProgramR -- | Flatten all the top-level binding groups in a program to a program containing a single recursive binding group.@@ -190,7 +190,7 @@ return (bindsToProg [bnd]) -- | Flatten all the top-level binding groups in a program to a single recursive binding group.-flattenProgramT :: Monad m => Translate c m CoreProg CoreBind+flattenProgramT :: Monad m => Transform c m CoreProg CoreBind flattenProgramT = do bds <- arr (concatMap bindToVarExprs . progToBinds) guardMsg (nodups $ map fst bds) "Top-level bindings contain multiple occurrences of a name." return (Rec bds)@@ -215,7 +215,7 @@ -- | Push a function through a Case or Let expression. -- Unsafe if the function is not strict.-pushR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasGlobalRdrEnv c)+pushR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Maybe (Rewrite c HermitM CoreExpr) -- ^ a proof that the function (after being applied to its type arguments) is strict -> (Id -> Bool) -- ^ a predicate to identify the function -> Rewrite c HermitM CoreExpr
src/HERMIT/Dictionary/Local/Case.hs view
@@ -16,6 +16,7 @@ , caseReduceDataconR , caseReduceLiteralR , caseReduceIdR+ , caseReduceUnfoldR , caseSplitR , caseSplitInlineR , caseInlineScrutineeR@@ -50,6 +51,7 @@ import HERMIT.Dictionary.Fold (foldVarR) import HERMIT.Dictionary.GHC (substCoreExpr) import HERMIT.Dictionary.Undefined (verifyStrictT)+import HERMIT.Dictionary.Unfold (unfoldR) -- NOTE: these are hard to test in small examples, as GHC does them for us, so use with caution ------------------------------------------------------------------------------@@ -95,6 +97,8 @@ , "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 , 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@@ -165,7 +169,7 @@ -- | @f (case s of alt1 -> e1; alt2 -> e2)@ ==> @case s of alt1 -> f e1; alt2 -> f e2@ -- Only safe if @f@ is strict.-caseFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, HasGlobalRdrEnv c)+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 mf mstrict = prefixFailMsg "Case floating from App argument failed: " $@@ -286,9 +290,14 @@ -- | 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) => Bool -> Rewrite c HermitM CoreExpr+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.+-- 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 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.@@ -385,7 +394,7 @@ return $ Case (Var i) w (coreAltsType alts) alts -- auxillary function for use by caseSplit and caseSeq-matchingFreeIdT :: Monad m => (Id -> Bool) -> Translate c m CoreExpr Id+matchingFreeIdT :: Monad m => (Id -> Bool) -> Transform c m CoreExpr Id matchingFreeIdT idPred = do fvs <- arr freeVarsExpr case varSetElems (filterVarSet (\ v -> idPred v && isId v) fvs) of@@ -397,12 +406,12 @@ -- for each occurance of the named variable. -- -- > caseSplitInline idPred = caseSplit idPred >>> caseInlineAlternativeR-caseSplitInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => (Id -> Bool) -> Rewrite c HermitM CoreExpr+caseSplitInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => (Id -> Bool) -> Rewrite c HermitM CoreExpr caseSplitInlineR idPred = caseSplitR idPred >>> caseInlineAlternativeR ------------------------------------------------------------------------------ -caseInlineBinderR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => CaseBinderInlineOption -> Rewrite c HermitM CoreExpr+caseInlineBinderR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => CaseBinderInlineOption -> Rewrite c HermitM CoreExpr caseInlineBinderR opt = do w <- caseBinderIdT caseAllR idR idR idR $ \ _ -> setFailMsg "no inlinable occurrences." $@@ -410,12 +419,12 @@ extractR $ anybuR (promoteExprR (configurableInlineR (CaseBinderOnly opt) (varIsOccurrenceOfT w depth)) :: Rewrite c HermitM 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) => Rewrite c HermitM CoreExpr+caseInlineScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM 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) => Rewrite c HermitM CoreExpr+caseInlineAlternativeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr caseInlineAlternativeR = prefixFailMsg "case-inline-alternative failed: " $ caseInlineBinderR Alternative @@ -435,31 +444,31 @@ 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) => Rewrite c HermitM CoreExpr+caseFoldBinderR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM 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) -- | 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) => Rewrite c HermitM CoreExpr+caseMergeAltsWithBinderR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM 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) => Rewrite c HermitM CoreExpr+caseElimInlineScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr caseElimInlineScrutineeR = alphaCaseBinderR Nothing >>> tryR caseInlineScrutineeR >>> caseElimR -- | Eliminate a case, merging the case alternatives into a single default alternative and inlining the case binder as the scrutinee (if possible).-caseElimMergeAltsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+caseElimMergeAltsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM 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) => Rewrite c HermitM CoreExpr+caseElimSeqR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr caseElimSeqR = prefixFailMsg "case-elim-seq failed: " $ withPatFailMsg "not a seq case." $ do Case s w _ [(DEFAULT,[],rhs)] <- idR
src/HERMIT/Dictionary/Local/Let.hs view
@@ -147,7 +147,7 @@ letSubstR = letAllR (tryR recToNonrecR) idR >>> letNonRecSubstR -- | As 'letNonRecSubstSafeR', but attempting to convert a singleton recursive binding to a non-recursive binding first.-letSubstSafeR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, ReadBindings c, MonadCatch m) => Rewrite c m CoreExpr+letSubstSafeR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, ReadBindings c, HasEmptyContext c, MonadCatch m) => Rewrite c m CoreExpr letSubstSafeR = letAllR (tryR recToNonrecR) idR >>> letNonRecSubstSafeR -- | @Let (NonRec v e) body@ ==> @body[e/v]@@@ -159,17 +159,17 @@ -- | 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, MonadCatch m) => Rewrite c m CoreExpr+letNonRecSubstSafeR :: forall c m. (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, ReadBindings c, HasEmptyContext c, MonadCatch m) => Rewrite c m CoreExpr letNonRecSubstSafeR = do Let (NonRec v _) _ <- idR when (isId v) $ guardMsgM (safeSubstT v) "safety criteria not met." letNonRecSubstR where- safeSubstT :: Id -> Translate c m CoreExpr Bool+ safeSubstT :: Id -> Transform c m CoreExpr Bool safeSubstT i = letNonRecT mempty safeBindT (safeOccursT i) (\ () -> (||)) -- what about other Expr constructors, e.g Cast?- safeBindT :: Translate c m CoreExpr Bool+ safeBindT :: Transform c m CoreExpr Bool safeBindT = do c <- contextT arr $ \ e ->@@ -183,20 +183,20 @@ (bds,_) -> length bds > length args _ -> False - safeOccursT :: Id -> Translate c m CoreExpr Bool+ safeOccursT :: Id -> Transform c m CoreExpr Bool safeOccursT i = do depth <- varBindingDepthT i- let occursHereT :: Translate c m Core ()+ let occursHereT :: Transform c m Core () occursHereT = promoteExprT (exprIsOccurrenceOfT i depth >>> guardT) -- lamOccurrenceT can only fail if the expression is not a Lam -- return either 2 (occurrence) or 0 (no occurrence)- lamOccurrenceT :: Translate c m CoreExpr (Sum Int)+ lamOccurrenceT :: Transform c m CoreExpr (Sum Int) lamOccurrenceT = lamT mempty (mtryM (Sum 2 <$ extractT (onetdT occursHereT))) mappend - occurrencesT :: Translate c m Core (Sum Int)+ occurrencesT :: Transform c m Core (Sum Int) occurrencesT = prunetdT (promoteExprT lamOccurrenceT <+ (Sum 1 <$ occursHereT)) extractT occurrencesT >>^ (getSum >>> (< 2))@@ -275,8 +275,7 @@ withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $ do Let (NonRec v ev) _ <- idR guardMsg (not $ isTyCoArg ev) "cannot case on a type or coercion."- nameModifier <- extractT (freshNameGenT Nothing)- caseBndr <- constT (cloneVarH nameModifier v)+ caseBndr <- extractT (cloneVarAvoidingT v Nothing [v]) letT mempty (replaceVarR v caseBndr) $ \ () e' -> Case ev caseBndr (varType v) [(DEFAULT, [], e')] -------------------------------------------------------------------------------------------@@ -499,7 +498,7 @@ -- | Introduce a local definition for a (possibly imported) identifier. -- Rewrites occurences of the identifier to point to this new local definiton.-letIntroUnfoldingR :: (BoundVars c, HasGlobalRdrEnv c, ReadBindings c) => String -> Rewrite c HermitM CoreExpr+letIntroUnfoldingR :: (BoundVars c, ReadBindings c) => String -> Rewrite c HermitM CoreExpr letIntroUnfoldingR nm = do i <- findIdT nm (rhs,_) <- getUnfoldingT AllBinders <<< return i
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, FlexibleInstances, InstanceSigs #-} module HERMIT.Dictionary.Navigation ( -- * Navigation@@ -36,36 +36,36 @@ -- | 'External's involving navigating to named entities. externals :: [External] externals = crumbExternals ++ map (.+ Navigation)- [ external "rhs-of" (rhsOfT . cmpString2Var :: String -> TranslateH Core LocalPathH)+ [ 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 -> TranslateH CoreTC LocalPathH)+ , 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 -> TranslateH CoreTC LocalPathH)+ , 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 -> TranslateH CoreTC LocalPathH)+ , external "occurrence-of" (occurrenceOfT . cmpString2Var :: String -> TransformH CoreTC LocalPathH) [ "Find the path to the first occurrence of the named variable." ]- , external "consider" (considerConstruct :: String -> TranslateH Core LocalPathH)+ , external "consider" (considerConstruct :: String -> TransformH Core LocalPathH) [ "consider <c> focuses on the first construct <c>.", recognizedConsiderables]- , external "arg" (promoteExprT . nthArgPath :: Int -> TranslateH Core LocalPathH)+ , 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 :: TranslateH Core LocalPathH)+ , external "lams-body" (promoteExprT lamsBodyT :: TransformH Core LocalPathH) [ "Descend into the body after a sequence of lambdas." ]- , external "lets-body" (promoteExprT letsBodyT :: TranslateH Core LocalPathH)+ , 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 :: TranslateH Core LocalPathH)+ , external "prog-end" (promoteModGutsT gutsProgEndT <+ promoteProgT progEndT :: TransformH Core LocalPathH) [ "Descend to the end of a program." ] - , external "parent-of" (parentOfT :: TranslateH Core LocalPathH -> TranslateH Core LocalPathH)+ , external "parent-of" (parentOfT :: TransformH Core LocalPathH -> TransformH Core LocalPathH) [ "Focus on the parent of another focal point." ]- , external "parent-of" (parentOfT :: TranslateH CoreTC LocalPathH -> TranslateH CoreTC LocalPathH)+ , external "parent-of" (parentOfT :: TransformH CoreTC LocalPathH -> TransformH CoreTC LocalPathH) [ "Focus on the parent of another focal point." ] ] --------------------------------------------------------------------------------------- -- | Discard the last crumb of a non-empty 'LocalPathH'.-parentOfT :: MonadCatch m => Translate c m g LocalPathH -> Translate c m g LocalPathH+parentOfT :: MonadCatch m => Transform c m g LocalPathH -> Transform c m g LocalPathH parentOfT t = withPatFailMsg "Path points to origin, there is no parent." $ do SnocPath (_:p) <- t return (SnocPath p)@@ -73,7 +73,7 @@ ----------------------------------------------------------------------- -- | Find the path to the RHS of a binding.-rhsOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => (Var -> Bool) -> Translate c m Core LocalPathH+rhsOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m Core LocalPathH rhsOfT p = prefixFailMsg ("rhs-of failed: ") $ do lp <- onePathToT (arr $ bindingOf p . inject) case lastCrumb lp of@@ -85,17 +85,17 @@ Nothing -> defOrNonRecT successT lastCrumbT (\ () cr -> mempty @@ cr) -- | Find the path to the binding group of a variable.-bindingGroupOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => (Var -> Bool) -> Translate c m CoreTC LocalPathH+bindingGroupOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m CoreTC LocalPathH bindingGroupOfT p = prefixFailMsg ("binding-group-of failed: ") $ oneNonEmptyPathToT (promoteBindT $ arr $ bindingGroupOf p) -- | Find the path to the binding of a variable.-bindingOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => (Var -> Bool) -> Translate c m CoreTC LocalPathH+bindingOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m CoreTC LocalPathH bindingOfT p = prefixFailMsg ("binding-of failed: ") $ oneNonEmptyPathToT (arr $ bindingOf p) --- | Find the path to the first occurrence occurrence of a variable.-occurrenceOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => (Var -> Bool) -> Translate c m CoreTC LocalPathH+-- | Find the path to the first occurrence of a variable.+occurrenceOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m CoreTC LocalPathH occurrenceOfT p = prefixFailMsg ("occurrence-of failed: ") $ oneNonEmptyPathToT (arr $ occurrenceOf p) @@ -167,19 +167,19 @@ ----------------------------------------------------------------------- -- | Find all possible targets of 'occurrenceOfT'.-occurrenceOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet+occurrenceOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m CoreTC VarSet occurrenceOfTargetsT = allT $ crushbuT (arr varOccurrence >>> projectT >>^ unitVarSet) -- | Find all possible targets of 'bindingOfT'.-bindingOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet+bindingOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m CoreTC VarSet bindingOfTargetsT = allT $ crushbuT (arr binders) -- | Find all possible targets of 'bindingGroupOfT'.-bindingGroupOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet+bindingGroupOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m CoreTC VarSet bindingGroupOfTargetsT = allT $ crushbuT (promoteBindT $ arr (mkVarSet . bindVars)) -- | Find all possible targets of 'rhsOfT'.-rhsOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet+rhsOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m CoreTC VarSet rhsOfTargetsT = crushbuT (promoteBindT (arr binderBind) <+ promoteDefT (arr binderDef)) -----------------------------------------------------------------------@@ -207,14 +207,14 @@ , ("coerce",CoercionExpr) ] -considerConstruct :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => String -> Translate c m Core LocalPathH+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 ++ "\"? " + 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, MonadCatch m) => Considerable -> Translate c m Core LocalPathH+considerConstructT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Considerable -> Transform c m Core LocalPathH considerConstructT con = oneNonEmptyPathToT (arr $ underConsideration con) string2considerable :: String -> Maybe Considerable@@ -240,7 +240,7 @@ --------------------------------------------------------------------------------------- -- | Construct a path to the (n-1)th argument in a nested sequence of 'App's.-nthArgPath :: Monad m => Int -> Translate c m CoreExpr LocalPathH+nthArgPath :: Monad m => Int -> Transform c m CoreExpr LocalPathH nthArgPath n = contextfreeT $ \ e -> let funCrumbs = appCount e - 1 - n in if funCrumbs < 0 then fail ("Argument " ++ show n ++ " does not exist.")@@ -248,24 +248,29 @@ --------------------------------------------------------------------------------------- -exhaustRepeatCrumbT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Walker c CoreTC, MonadCatch m) => Crumb -> Translate c m CoreTC LocalPathH+instance HasEmptyContext c => HasEmptyContext (ExtendContext c (LocalPath Crumb)) where+ setEmptyContext :: ExtendContext c (LocalPath Crumb) -> ExtendContext c (LocalPath Crumb)+ setEmptyContext ec = ec { baseContext = setEmptyContext (baseContext ec)+ , extraContext = mempty }++exhaustRepeatCrumbT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c CoreTC, MonadCatch m) => Crumb -> Transform c m CoreTC LocalPathH exhaustRepeatCrumbT cr = let l = exhaustPathL (repeat cr) in withLocalPathT (focusT l exposeLocalPathT) -- | Construct a path to the body of a sequence of lambdas.-lamsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Walker c CoreTC, MonadCatch m) => Translate c m CoreExpr LocalPathH+lamsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c CoreTC, MonadCatch m) => Transform c m CoreExpr LocalPathH lamsBodyT = extractT (exhaustRepeatCrumbT Lam_Body) -- | Construct a path to the body of a sequence of let bindings.-letsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Walker c CoreTC, MonadCatch m) => Translate c m CoreExpr LocalPathH+letsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c CoreTC, MonadCatch m) => Transform c m CoreExpr LocalPathH letsBodyT = extractT (exhaustRepeatCrumbT Let_Body) -- | Construct a path to end of a program.-progEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Walker c CoreTC, MonadCatch m) => Translate c m CoreProg LocalPathH+progEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c CoreTC, MonadCatch m) => Transform c m CoreProg LocalPathH progEndT = extractT (exhaustRepeatCrumbT ProgCons_Tail) -- | Construct a path to teh end of a program, starting at the 'ModGuts'.-gutsProgEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Walker c CoreTC, MonadCatch m) => Translate c m ModGuts LocalPathH+gutsProgEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c CoreTC, MonadCatch m) => Transform c m ModGuts LocalPathH gutsProgEndT = modGutsT progEndT (\ _ p -> (mempty @@ ModGuts_Prog) <> p) ---------------------------------------------------------------------------------------
src/HERMIT/Dictionary/New.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} module HERMIT.Dictionary.New where import Control.Arrow@@ -8,20 +8,13 @@ import HERMIT.Kure import HERMIT.External import HERMIT.GHC-#if __GLASGOW_HASKELL__ > 706-import HERMIT.Monad-#endif import HERMIT.ParserCore -#if __GLASGOW_HASKELL__ > 706-import HERMIT.Dictionary.Composite hiding (externals)-import HERMIT.Dictionary.Debug hiding (externals)-#endif import HERMIT.Dictionary.Local.Let hiding (externals) externals :: [External] externals = map ((.+ Experiment) . (.+ TODO))- [ external "var" (promoteExprT . isVar :: String -> TranslateH Core ())+ [ external "var" (promoteExprT . isVar :: String -> TransformH Core ()) [ "var '<v> returns successfully for variable v, and fails otherwise." , "Useful in combination with \"when\", as in: when (var v) r" ] .+ Predicate@@ -38,10 +31,6 @@ -- [ "Introduce a new definition as a non-recursive let binding." -- , "let-nonrec-intro 'v [| e |]" -- , "body ==> let v = e in body" ] .+ Introduce .+ Shallow-#if __GLASGOW_HASKELL__ > 706- , external "replace-typeable-int-list" (promoteExprR (return (mkListTy intTy) >>> buildTypeableT) :: RewriteH Core)- [ "test building a dictionary" ]-#endif ] ------------------------------------------------------------------------------------------------------@@ -50,17 +39,17 @@ -- Probably better to have another predicate that operates on CoreTC, that way it can reach TyVars buried within types. -- But given the current setup (using Core for most things), changing "var" to operate on CoreTC would make it incompatible with other combinators. -- I'm not sure how to fix the current setup though.--- isVar :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => String -> Translate c m CoreExpr ()+-- isVar :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => String -> Transform c m CoreExpr () -- isVar nm = (varT matchName <+ typeT (tyVarT matchName) <+ coercionT (coVarCoT matchName)) -- >>= guardM -- where--- matchName :: Monad m => Translate c m Var Bool+-- matchName :: Monad m => Transform c m Var Bool -- matchName = arr (cmpString2Var nm) -- TODO: there might be a better module for this -- | Test if the current expression is an identifier matching the given name.-isVar :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => String -> Translate c m CoreExpr ()+isVar :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => String -> Transform c m CoreExpr () isVar nm = varT (arr $ cmpString2Var nm) >>= guardM ------------------------------------------------------------------------------------------------------@@ -88,11 +77,3 @@ --------------------------------------------------------------------------------------------------------#if __GLASGOW_HASKELL__ > 706-buildTypeableT :: TranslateH Type CoreExpr-buildTypeableT = do- (i, bnds) <- translate $ \ c -> liftCoreM . buildTypeable (hermitC_modguts c)- return (mkCoreLets bnds (varToCoreExpr i)) >>> tryR (extractR simplifyR) >>> observeR "buildTypeableT result"-#endif-
src/HERMIT/Dictionary/Query.hs view
@@ -31,21 +31,21 @@ -- | Externals that reflect GHC functions, or are derived from GHC functions. externals :: [External] externals =- [ external "info" (infoT :: TranslateH CoreTC String)+ [ external "info" (infoT :: TransformH CoreTC String) [ "Display information about the current node." ] .+ Query- , external "compare-bound-ids" (compareBoundIds :: String -> String -> TranslateH CoreTC ())+ , 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 :: TranslateH Core LocalPathH -> TranslateH Core LocalPathH -> TranslateH Core ())+ , 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 ] -------------------------------------------------------- -infoT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, BoundVars c, HasDynFlags m, MonadCatch m) => Translate c m CoreTC String+infoT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, BoundVars c, HasEmptyContext c, HasDynFlags m, MonadCatch m) => Transform c m CoreTC String infoT = do crumbs <- childrenT fvs <- arr freeVarsCoreTC- translate $ \ c coreTC ->+ transform $ \ c coreTC -> do dynFlags <- getDynFlags let node = "Node: " ++ coreTCNode coreTC con = "Constructor: " ++ coreTCConstructor coreTC@@ -55,21 +55,28 @@ [ "\n " ++ var2String k ++ " : " ++ hermitBindingSummary hbs | (k,hbs) <- Map.toList (hermitBindings c) ]--- showVarSet (boundVars c) freevars = [ "Free local identifiers: " ++ showVarSet (filterVarSet isLocalId fvs) , "Free global identifiers: " ++ showVarSet (filterVarSet isGlobalId fvs) , "Free type variables: " ++ showVarSet (filterVarSet isTyVar fvs) , "Free coercion variables: " ++ showVarSet (filterVarSet isCoVar fvs) ]+ typeId = case coreTC of Core (ExprCore e) -> let tyK = exprKindOrType e 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" , "Unique: " ++ show (getUnique i) , "Identifier arity: " ++ show (arityOf c i)- , "Identifier binding depth: " ++ runKureM show id (lookupHermitBindingDepth i c) ]+ , "Identifier binding depth: " ++ runKureM show id (lookupHermitBindingDepth i c)+ ] ++ if isId i then let inf = idInfo i+ in [ "Unfolding: " ++ showPpr dynFlags (unfoldingInfo inf)+ , "Occurrence Info: " ++ showPpr dynFlags (occInfo inf)+ , "Inline Pragmas: " ++ showPpr dynFlags (inlinePragInfo inf)+ ]+ else [] _ -> [] TyCo (TypeCore ty) -> ["Kind: " ++ showPpr dynFlags (typeKind ty)] TyCo (CoercionCore co) -> ["Kind: " ++ showPpr dynFlags (coercionKind co) ]@@ -156,7 +163,7 @@ -------------------------------------------------------- -- | Compare the core fragments at the end of the specified 'LocalPathH's.-compareCoreAtT :: (ExtendPath c Crumb, AddBindings c, ReadBindings c, ReadPath c Crumb, MonadCatch m) => Translate c m Core LocalPathH -> Translate c m Core LocalPathH -> Translate c m Core ()+compareCoreAtT :: (ExtendPath c Crumb, AddBindings c, ReadBindings c, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Transform c m Core LocalPathH -> Transform c m Core LocalPathH -> Transform c m Core () compareCoreAtT p1T p2T = do p1 <- p1T p2 <- p2T@@ -165,7 +172,7 @@ guardMsg (core1 `coreAlphaEq` core2) "core fragments are not alpha-equivalent." -- | Compare the definitions of two identifiers for alpha-equality.-compareBoundIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Id -> Id -> Translate c HermitM x ()+compareBoundIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Id -> Id -> Transform c HermitM x () compareBoundIdsT i1 i2 = do e1 <- fst ^<< getUnfoldingT AllBinders <<< return i1 e2 <- replaceVarR i2 i1 <<< fst ^<< getUnfoldingT AllBinders <<< return i2@@ -173,7 +180,7 @@ guardMsg (e1 `exprAlphaEq` e2) "bindings are not alpha-equivalent." -- | Compare the definitions of the two named identifiers for alpha-equality.-compareBoundIds :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasGlobalRdrEnv c) => String -> String -> Translate c HermitM x ()+compareBoundIds :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => String -> String -> Transform c HermitM x () compareBoundIds nm1 nm2 = do i1 <- findIdT nm1 i2 <- findIdT nm2 compareBoundIdsT i1 i2
src/HERMIT/Dictionary/Reasoning.hs view
@@ -1,30 +1,52 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, FlexibleInstances, InstanceSigs, ScopedTypeVariables #-}+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, InstanceSigs,+ ScopedTypeVariables, TupleSections, TypeFamilies #-} module HERMIT.Dictionary.Reasoning- ( -- * Equational Reasoning- externals- , CoreExprEquality(..)- , CoreExprEqualityProof- , flipCoreExprEquality- , eqLhsIntroR- , eqRhsIntroR- , birewrite- , verifyCoreExprEqualityT- , verifyEqualityLeftToRightT- , verifyEqualityCommonTargetT- , verifyIsomorphismT- , verifyRetractionT- , retractionBR- , instantiateCoreExprEq- , instantiateCoreExprEqVar- , discardUniVars- )-where+ ( -- * Equational Reasoning+ externals+ , CoreExprEquality(..)+ , RewriteCoreExprEqualityBox(..)+ , TransformCoreExprEqualityStringBox(..)+ , CoreExprEqualityProof+ , flipCoreExprEquality+ , eqLhsIntroR+ , eqRhsIntroR+ , birewrite+ , extensionalityR+ -- ** Lifting transformations over 'CoreExprEquality'+ , lhsT+ , rhsT+ , bothT+ , forallVarsT+ , lhsR+ , rhsR+ , bothR+ , ppCoreExprEqualityT+ , proveCoreExprEqualityT+ , verifyCoreExprEqualityT+ , verifyEqualityLeftToRightT+ , verifyEqualityCommonTargetT+ , verifyIsomorphismT+ , verifyRetractionT+ , retractionBR+ , alphaEqualityR+ , unshadowEqualityR+ , instantiateDictsR+ , instantiateEquality+ , instantiateEqualityVar+ , instantiateEqualityVarR+ , 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@@ -33,39 +55,87 @@ import HERMIT.Kure import HERMIT.Monad import HERMIT.ParserCore+#if __GLASGOW_HASKELL__ >= 708+import HERMIT.ParserType+#endif 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 HERMIT.PrettyPrinter.Common++import qualified Text.PrettyPrint.MarkedHughesPJ as PP+ ------------------------------------------------------------------------------ externals :: [External] externals =- [ external "retraction" ((\ f g r -> promoteExprBiR $ retraction (Just r) f g) :: CoreString -> CoreString -> RewriteH Core -> BiRewriteH Core)+ [ external "retraction" ((\ f g r -> promoteExprBiR $ retraction (Just r) f g) :: CoreString -> CoreString -> RewriteH Core -> BiRewriteH Core) [ "Given f :: X -> Y and g :: Y -> X, and a proof that f (g y) ==> y, then" , "f (g y) <==> y." ] .+ Shallow- , external "retraction-unsafe" ((\ f g -> promoteExprBiR $ retraction Nothing f g) :: CoreString -> CoreString -> BiRewriteH Core)+ , external "retraction-unsafe" ((\ f g -> promoteExprBiR $ retraction Nothing f g) :: CoreString -> CoreString -> BiRewriteH Core) [ "Given f :: X -> Y and g :: Y -> X, then" , "f (g y) <==> y." , "Note that the precondition (f (g y) == y) is expected to hold." ] .+ Shallow .+ PreCondition- ]+ , external "alpha-equality" ((\ nm newName -> alphaEqualityR (cmpString2Var nm) (const newName)))+ [ "Alpha-rename a universally quantified variable." ]+ , external "unshadow-equality" unshadowEqualityR+ [ "Unshadow 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) -- | Flip the LHS and RHS of a 'CoreExprEquality'. flipCoreExprEquality :: CoreExprEquality -> CoreExprEquality flipCoreExprEquality (CoreExprEquality xs lhs rhs) = CoreExprEquality xs rhs lhs +-- | f == g ==> forall x. f x == g x+extensionalityR :: Maybe String -> Rewrite c HermitM CoreExprEquality+extensionalityR mn = prefixFailMsg "extensionality failed: " $+ do CoreExprEquality 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+ v <- constT $ newVarH (fromMaybe "x" mn) argTy++ let x = varToCoreExpr v++ return $ CoreExprEquality (vs ++ [v])+ (mkCoreApp lhs x)+ (mkCoreApp rhs x)+ ------------------------------------------------------------------------------ -- | @e@ ==> @let v = lhs in e@@@ -82,9 +152,9 @@ -- -- 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) => CoreExprEquality -> BiRewrite c HermitM CoreExpr+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)- where foldUnfold lhs rhs = translate $ \ c e -> do+ 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 v <- newIdH "biTemp" (exprType lhsLam)@@ -95,6 +165,51 @@ c' = addHermitBindings [(v, NONREC rhsLam, mempty)] c apply 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 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 both sides of a 'CoreExprEquality'.+bothT :: (AddBindings c, Monad m, ReadPath c Crumb) => Transform c m CoreExpr b -> Transform c m CoreExprEquality (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 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+lhsR r = do+ CoreExprEquality vs lhs rhs <- idR+ lhs' <- withVarsInScope vs r <<< return lhs+ return $ CoreExprEquality 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+rhsR r = do+ CoreExprEquality vs lhs rhs <- idR+ rhs' <- withVarsInScope vs r <<< return rhs+ return $ CoreExprEquality 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+bothR r = lhsR r >+> rhsR r++------------------------------------------------------------------------------++ppCoreExprEqualityT :: PrettyPrinter -> TransformH CoreExprEquality DocH+ppCoreExprEqualityT pp = do+ let pos = pOptions pp+ d1 <- forallVarsT (liftPrettyH pos $ pForall pp)+ (d2,d3) <- bothT (liftPrettyH pos $ extractT $ pCoreTC pp)+ return $ PP.sep [d1,d2,syntaxColor (PP.text "="),d3]++------------------------------------------------------------------------------+ -- Idea: use Haskell's functions to fill the holes automagically -- -- plusId <- findIdT "+"@@ -102,7 +217,7 @@ -- mkEquality $ \ x -> ( mkCoreApps (Var plusId) [x,x] -- , mkCoreApps (Var timesId) [Lit 2, x]) ----- Problem: need to know type of 'x' to generate a variable.+-- TODO: need to know type of 'x' to generate a variable. class BuildEquality a where mkEquality :: a -> HermitM CoreExprEquality @@ -117,27 +232,36 @@ CoreExprEquality bnds lhs rhs <- mkEquality (f (varToCoreExpr x)) return $ CoreExprEquality (x:bnds) lhs rhs +------------------------------------------------------------------------------+ -- | Verify that a 'CoreExprEquality' holds, by applying a rewrite to each side, and checking that the results are equal.-verifyCoreExprEqualityT :: forall c m. (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, Walker c Core) => CoreExprEqualityProof c m -> Translate c m CoreExprEquality ()-verifyCoreExprEqualityT (lhsR,rhsR) =- do CoreExprEquality bs lhs rhs <- idR- verifyEqualityCommonTargetT lhs rhs (withVarsInScope bs lhsR, withVarsInScope bs rhsR)+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 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+ guardMsg (exprAlphaEq lhs rhs) "the two sides of the equality do not match."+ ------------------------------------------------------------------------------ +-- TODO: are these other functions used? If so, can they be rewritten in terms of lhsR and rhsR as above?+ -- | Given two expressions, and a rewrite from the former to the latter, verify that rewrite.-verifyEqualityLeftToRightT :: MonadCatch m => CoreExpr -> CoreExpr -> Rewrite c m CoreExpr -> Translate c m a ()+verifyEqualityLeftToRightT :: MonadCatch m => CoreExpr -> CoreExpr -> Rewrite c m CoreExpr -> Transform c m a () verifyEqualityLeftToRightT sourceExpr targetExpr r = prefixFailMsg "equality verification failed: " $ do resultExpr <- r <<< return sourceExpr 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 -> Translate c m a ()-verifyEqualityCommonTargetT lhs rhs (lhsR,rhsR) =+verifyEqualityCommonTargetT :: MonadCatch m => CoreExpr -> CoreExpr -> CoreExprEqualityProof c m -> Transform c m a ()+verifyEqualityCommonTargetT lhs rhs (l,r) = prefixFailMsg "equality verification failed: " $- do lhsResult <- lhsR <<< return lhs- rhsResult <- rhsR <<< return rhs+ do lhsResult <- l <<< return lhs+ rhsResult <- r <<< return rhs guardMsg (exprAlphaEq lhsResult rhsResult) "results of running proofs on both sides of equality do not match." ------------------------------------------------------------------------------@@ -145,7 +269,7 @@ -- Note: We use global Ids for verification to avoid out-of-scope errors. -- | Given f :: X -> Y and g :: Y -> X, verify that f (g y) ==> y and g (f x) ==> x.-verifyIsomorphismT :: CoreExpr -> CoreExpr -> Rewrite c HermitM CoreExpr -> Rewrite c HermitM CoreExpr -> Translate c HermitM a ()+verifyIsomorphismT :: CoreExpr -> CoreExpr -> Rewrite c HermitM CoreExpr -> Rewrite c HermitM CoreExpr -> Transform c HermitM a () verifyIsomorphismT f g fgR gfR = prefixFailMsg "Isomorphism verification failed: " $ do (tyX, tyY) <- funExprsWithInverseTypes f g x <- constT (newGlobalIdH "x" tyX)@@ -154,7 +278,7 @@ verifyEqualityLeftToRightT (App g (App f (Var x))) (Var x) gfR -- | Given f :: X -> Y and g :: Y -> X, verify that f (g y) ==> y.-verifyRetractionT :: CoreExpr -> CoreExpr -> Rewrite c HermitM CoreExpr -> Translate c HermitM a ()+verifyRetractionT :: CoreExpr -> CoreExpr -> Rewrite c HermitM CoreExpr -> Transform c HermitM a () verifyRetractionT f g r = prefixFailMsg "Retraction verification failed: " $ do (_tyX, tyY) <- funExprsWithInverseTypes f g y <- constT (newGlobalIdH "y" tyY)@@ -192,26 +316,129 @@ ------------------------------------------------------------------------------ +-- TODO: revisit this for binder re-ordering issue+instantiateDictsR :: RewriteH CoreExprEquality+#if __GLASGOW_HASKELL__ >= 708+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+ 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)+ new = varSetElems $ delVarSetList (localFreeVarsExpr dExpr) bs+ return (b,dExpr,new)+ let buildSubst :: Monad m => Var -> m (Var, CoreExpr, [Var])+ buildSubst b = case [ (b,e,[]) | (b',e,_) <- ds, eqType (varType b) (varType b') ] of+ [] -> fail "cannot find equivalent dictionary expression (impossible!)"+ [t] -> return t+ _ -> fail "multiple dictionary expressions found (impossible!)"+ lookup3 :: Var -> [(Var,CoreExpr,[Var])] -> (Var,CoreExpr,[Var])+ lookup3 v l = head [ t | t@(v',_,_) <- l, v == v' ]+ allDs <- forM dArgs $ \ b -> constT $ do+ if b `elem` uniqDs+ 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 p f = prefixFailMsg "Alpha-renaming binder in equality failed: " $ do+ CoreExprEquality 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+ i' <- constT $ cloneVarH f i++ let inS = delVarSetList (unionVarSets (map localFreeVarsExpr [lhs, rhs] ++ map freeVarsVar vs)) (i:i':vs)+ subst = extendSubst (mkEmptySubst (mkInScopeSet inS)) i (varToCoreExpr i')+ (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'++unshadowEqualityR :: RewriteH CoreExprEquality+unshadowEqualityR = prefixFailMsg "Unshadowing equality failed: " $ do+ c@(CoreExprEquality bs _ _) <- idR+ bvs <- boundVarsT+ let visible = unionVarSets [bvs , freeVarsEquality c]+ ss <- varSetElems <$> detectShadowsM bs visible+ guardMsg (not (null ss)) "no shadows to eliminate."+ 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) =+ delVarSetList (unionVarSets (map freeVarsExpr [lhs,rhs])) bs++------------------------------------------------------------------------------++instantiateEqualityVarR :: (Var -> Bool) -> CoreString -> RewriteH CoreExprEquality+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'. -- Note: assumes implicit ordering of variables, such that substitution happens to the right--- as it does in case alternatives.-instantiateCoreExprEqVar :: Var -> CoreExpr -> CoreExprEquality -> CoreExprEquality-instantiateCoreExprEqVar i e c@(CoreExprEquality bs lhs rhs)- | i `notElem` bs = c- | otherwise =- let (bs',_:vs) = break (==i) bs -- this is safe because we know i is in bs- inS = delVarSetList (unionVarSets (map localFreeVarsExpr [lhs, rhs, e] ++ map freeVarsVar vs)) (i:vs)+-- 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)+ | 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+ tyVars = filter isTyVar bs'+ failMsg = fail "type of provided expression differs from selected binder."++ -- unifyTypes will give back mappings from a TyVar to itself+ -- we don't want to do these instantiations, or else variables+ -- become unbound+ dropSelfSubst :: [(TyVar, Type)] -> [(TyVar,Type)]+ dropSelfSubst ps = [ (v,t) | (v,t) <- ps, case t of+ TyVarTy v' | v' == v -> False+ _ -> True ]+ tvs <- maybe failMsg (return . tyMatchesToCoreExpr . dropSelfSubst)+ $ unifyTypes tyVars (varType i) (exprKindOrType e)++ 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- in CoreExprEquality (bs'++vs') lhs' rhs'+ instantiateEquality (noAdds tvs) $ CoreExprEquality (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'. -- It is important that all type variables appear before any value-level variables in the first argument.-instantiateCoreExprEq :: [(Var,CoreExpr)] -> CoreExprEquality -> CoreExprEquality-instantiateCoreExprEq = flip (foldr (uncurry instantiateCoreExprEqVar))--- foldr is important here because it effectively does the substitutions in reverse order,+instantiateEquality :: MonadIO m => [(Var,CoreExpr,[Var])] -> CoreExprEquality -> m CoreExprEquality+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). ------------------------------------------------------------------------------
src/HERMIT/Dictionary/Rules.hs view
@@ -8,7 +8,8 @@ , rulesR , ruleToEqualityT , ruleNameToEqualityT- , getSingletonHermitRuleT+ , getHermitRuleT+ , getHermitRulesT -- , verifyCoreRuleT -- , verifyRuleT -- , ruleLhsIntroR@@ -35,7 +36,7 @@ import HERMIT.External import HERMIT.GHC -import HERMIT.Dictionary.Common (findIdT,inScope,callT)+import HERMIT.Dictionary.Common (inScope,callT) import HERMIT.Dictionary.GHC (dynFlagsT) -- import HERMIT.Dictionary.Induction import HERMIT.Dictionary.Kure (anyCallR)@@ -47,9 +48,9 @@ -- | Externals that reflect GHC functions, or are derived from GHC functions. externals :: [External] externals =- [ external "rules-help-list" (rulesHelpListT :: TranslateH CoreTC String)+ [ external "rules-help-list" (rulesHelpListT :: TransformH CoreTC String) [ "List all the rules in scope." ] .+ Query- , external "rule-help" (ruleHelpT :: RuleNameString -> TranslateH CoreTC String)+ , 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@@ -101,7 +102,7 @@ rulesToRewriteH rs = prefixFailMsg "RulesToRewrite failed: " $ withPatFailMsg "rule not matched." $ do (Var fn, args) <- callT- translate $ \ c e -> do+ transform $ \ c e -> do let in_scope = mkInScopeSet (mkVarEnv [ (v,v) | v <- varSetElems (localFreeVarsExpr e) ]) #if __GLASGOW_HASKELL__ > 706 dflags <- getDynFlags@@ -122,48 +123,41 @@ ruleR r = do theRules <- getHermitRulesT case lookup r theRules of- Nothing -> fail $ "failed to find rule: " ++ show r- Just rr -> rulesToRewriteH rr+ 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] rulesR :: (ReadBindings c, HasCoreRules c) => [RuleNameString] -> Rewrite c HermitM CoreExpr rulesR = orR . map ruleR -getHermitRulesT :: HasCoreRules c => Translate c HermitM a [(RuleNameString, [CoreRule])]+-- | Return all the RULES (including specialization RULES on binders) currently in scope.+getHermitRulesT :: HasCoreRules c => Transform c HermitM a [(RuleNameString, CoreRule)] getHermitRulesT = contextonlyT $ \ c -> do- rb <- liftCoreM getRuleBase- hscEnv <- liftCoreM getHscEnv- rb' <- liftM eps_rule_base $ liftIO $ runIOEnv () $ readMutVar (hsc_EPS hscEnv)- return [ ( unpackFS (ruleName r), [r] )- | r <- hermitCoreRules c ++ concat (nameEnvElts rb) ++ concat (nameEnvElts rb')+ 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') ] -getHermitRuleT :: HasCoreRules c => RuleNameString -> Translate c HermitM a [CoreRule]+getHermitRuleT :: HasCoreRules c => RuleNameString -> Transform c HermitM a CoreRule getHermitRuleT name = do rulesEnv <- getHermitRulesT case filter ((name ==) . fst) rulesEnv of- [] -> fail ("Rule \"" ++ name ++ "\" not found.")- [(_,rus)] -> return rus- _ -> fail ("Rule name \"" ++ name ++ "\" is ambiguous.")--getSingletonHermitRuleT :: HasCoreRules c => RuleNameString -> Translate c HermitM a CoreRule-getSingletonHermitRuleT name =- do rus <- getHermitRuleT name- case rus of- [] -> fail "No rules with that name."- [ru] -> return ru- _ -> fail "Multiple rules with that name."-+ [] -> fail ("Rule \"" ++ name ++ "\" not found.")+ [(_,r)] -> return r+ _ -> fail ("Rule name \"" ++ name ++ "\" is ambiguous.") -rulesHelpListT :: HasCoreRules c => Translate c HermitM a String+rulesHelpListT :: HasCoreRules c => Transform c HermitM a String rulesHelpListT = do rulesEnv <- getHermitRulesT- return (intercalate "\n" $ map fst rulesEnv)+ return (intercalate "\n" $ reverse $ map fst rulesEnv) -ruleHelpT :: HasCoreRules c => RuleNameString -> Translate c HermitM a String-ruleHelpT name = showSDoc <$> dynFlagsT <*> (pprRulesForUser <$> getHermitRuleT name)+ruleHelpT :: HasCoreRules c => RuleNameString -> Transform c HermitM a String+ruleHelpT name = showSDoc <$> dynFlagsT <*> ((pprRulesForUser . (:[])) <$> getHermitRuleT name) -- Too much information.--- rulesHelpT :: HasCoreRules c => Translate c HermitM a String+-- rulesHelpT :: HasCoreRules c => Transform c HermitM a String -- rulesHelpT = do -- rulesEnv <- getHermitRulesT -- dynFlags <- dynFlagsT@@ -194,14 +188,14 @@ _ -> fail $ "found multiple bindings for " ++ nm -- | Returns the universally quantified binders, the LHS, and the RHS.-ruleToEqualityT :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m, MonadCatch m) => Translate c m CoreRule CoreExprEquality+ruleToEqualityT :: (BoundVars c, HasDynFlags m, HasModGuts m, MonadThings m, MonadCatch m) => Transform c m CoreRule CoreExprEquality ruleToEqualityT = withPatFailMsg "HERMIT cannot handle built-in rules yet." $ do r@Rule{} <- idR -- other possibility is "BuiltinRule"- f <- findIdT (getOccString $ ru_fn r) -- TODO: refactor name lookup functions (like findIdT) to avoid intermediate String here+ f <- lookupId $ ru_fn r return $ CoreExprEquality (ru_bndrs r) (mkCoreApps (Var f) (ru_args r)) (ru_rhs r) -ruleNameToEqualityT :: (BoundVars c, HasGlobalRdrEnv c, HasCoreRules c) => RuleNameString -> Translate c HermitM a CoreExprEquality-ruleNameToEqualityT name = getSingletonHermitRuleT name >>> ruleToEqualityT+ruleNameToEqualityT :: (BoundVars c, HasCoreRules c) => RuleNameString -> Transform c HermitM a CoreExprEquality+ruleNameToEqualityT name = getHermitRuleT name >>> ruleToEqualityT ------------------------------------------------------------------------ @@ -239,18 +233,18 @@ -- | Get all the specialization rules on a binding. -- These are created by SpecConstr and other GHC passes.-idSpecRules :: TranslateH Id [CoreRule]+idSpecRules :: TransformH Id [CoreRule] idSpecRules = do guardMsgM (arr isId) "idSpecRules called on TyVar." -- idInfo panics on TyVars contextfreeT $ \ i -> let SpecInfo rs _ = specInfo (idInfo i) in return rs -- | Promote 'idSpecRules' to CoreBind.-bindSpecRules :: TranslateH CoreBind [CoreRule]+bindSpecRules :: TransformH CoreBind [CoreRule] bindSpecRules = recT (\_ -> defT idSpecRules successT const) concat <+ nonRecT idSpecRules successT const -- | Find all specialization rules in a Core fragment.-specRules :: TranslateH Core [CoreRule]+specRules :: TransformH Core [CoreRule] specRules = crushtdT $ promoteBindT bindSpecRules ------------------------------------------------------------------------
src/HERMIT/Dictionary/Undefined.hs view
@@ -22,13 +22,15 @@ where import Control.Monad ((>=>))+import Control.Monad.IO.Class import Data.Monoid import HERMIT.Context import HERMIT.Core-import HERMIT.Kure-import HERMIT.GHC hiding ((<>)) import HERMIT.External+import HERMIT.GHC hiding ((<>))+import HERMIT.Kure+import HERMIT.Monad import HERMIT.Dictionary.Common import HERMIT.Dictionary.GHC (substR)@@ -47,7 +49,7 @@ , external "error-to-undefined" (promoteExprR errorToUndefinedR :: RewriteH Core) [ "error ty string ==> undefined ty" ] .+ Shallow .+ Context- , external "is-undefined-val" (promoteExprT isUndefinedValT :: TranslateH Core ())+ , external "is-undefined-val" (promoteExprT isUndefinedValT :: TransformH Core ()) [ "Succeed if the current expression is an undefined value." ] .+ Shallow .+ Context .+ Predicate , external "undefined-expr" (promoteExprR undefinedExprR :: RewriteH Core)@@ -81,11 +83,11 @@ undefinedLocation = "GHC.Err.undefined" -- TODO: will crash if 'undefined' is not used (or explicitly imported) in the source file.-findUndefinedIdT :: (BoundVars c, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Translate c m a Id+findUndefinedIdT :: (BoundVars c, MonadCatch m, HasModGuts 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, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Translate c m CoreExpr ()+isUndefinedValT :: (BoundVars c, MonadCatch m, HasModGuts 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@@ -98,11 +100,11 @@ errorLocation = "GHC.Err.error" -- TODO: will crash if 'error' is not used (or explicitly imported) in the source file.-findErrorIdT :: (BoundVars c, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Translate c m a Id+findErrorIdT :: (BoundVars c, MonadCatch m, HasModGuts 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, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Translate c m CoreExpr ()+isErrorValT :: (BoundVars c, MonadCatch m, HasModGuts 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@@ -112,13 +114,13 @@ ------------------------------------------------------------------------ -- | error ty string ==> undefined ty-errorToUndefinedR :: (BoundVars c, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+errorToUndefinedR :: (BoundVars c, MonadCatch m, HasModGuts 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, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Type -> Translate c m a CoreExpr+mkUndefinedValT :: (BoundVars c, MonadCatch m, HasModGuts 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)@@ -126,67 +128,67 @@ ------------------------------------------------------------------------------------------------------ -- | Set the current expression to 'undefined'.-replaceCurrentExprWithUndefinedR :: (BoundVars c, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+replaceCurrentExprWithUndefinedR :: (BoundVars c, MonadCatch m, HasModGuts 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, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Id -> Rewrite c m Core+replaceIdWithUndefinedR :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Id -> Rewrite c m Core replaceIdWithUndefinedR i = mkUndefinedValT (idType i) >>= substR i -replaceIdWithUndefined :: (BoundVars c, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => String -> Rewrite c m Core+replaceIdWithUndefined :: (BoundVars c, MonadCatch m, HasModGuts m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => String -> 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, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+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 = setFailMsg "undefined-expr failed." (undefinedAppR <+ undefinedLamR <+ undefinedLetR <+ undefinedCastR <+ undefinedTickR <+ undefinedCaseR) ------------------------------------------------------------------------------------------------------ -- | @(undefined ty1) e@ ==> @undefined ty2@-undefinedAppR :: (BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+undefinedAppR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasModGuts 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, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+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 = 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, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+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 = prefixFailMsg "undefined-let failed: " $ do letT successT isUndefinedValT (<>) replaceCurrentExprWithUndefinedR -- | Cast (undefined ty1) co ==> undefined ty2-undefinedCastR :: (BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+undefinedCastR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasModGuts 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, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+undefinedTickR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasModGuts 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, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+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 = setFailMsg "undefined-case failed" (undefinedCaseScrutineeR <+ undefinedCaseAltsR) -- | case (undefined ty) of alts ==> undefined ty-undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasModGuts 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, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr+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 = prefixFailMsg "undefined-case-alts failed: " $ do caseAltT successT successT successT (const (successT,const successT,isUndefinedValT)) (\ _ _ _ _ -> ()) replaceCurrentExprWithUndefinedR@@ -194,7 +196,7 @@ ------------------------------------------------------------------------ -- | Verify that the given rewrite is a proof that the given expression is a strict function.-verifyStrictT :: (BoundVars c, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => CoreExpr -> Rewrite c m CoreExpr -> Translate c m a ()+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 f r = prefixFailMsg "strictness verification failed: " $ do (argTy, resTy) <- constT (funExprArgResTypes f) undefArg <- mkUndefinedValT argTy
src/HERMIT/Dictionary/Unfold.hs view
@@ -19,7 +19,7 @@ import Data.List (intercalate) import qualified Data.Map as Map -import HERMIT.PrettyPrinter.Common (DocH, PrettyH, TranslateDocH(..), PrettyC)+import HERMIT.PrettyPrinter.Common (DocH, PrettyH, TransformDocH(..), PrettyC) import HERMIT.Dictionary.Common import HERMIT.Dictionary.Inline (inlineR)@@ -56,7 +56,7 @@ [ "Unfold a definition only if the function is fully applied." ] .+ Deep .+ Context , external "specialize" (promoteExprR specializeR :: RewriteH Core) [ "Specialize an application to its type and coercion arguments." ] .+ Deep .+ Context- , external "show-remembered" (TranslateDocH showStashT :: TranslateDocH CoreTC)+ , external "show-remembered" (TransformDocH showStashT :: TransformDocH CoreTC) [ "Display all remembered definitions." ] ] @@ -85,26 +85,26 @@ -- | A more powerful 'inline'. Matches two cases: -- Var ==> inlines -- App ==> inlines the head of the function call for the app tree-unfoldR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+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 go = appAllR go idR <+ inlineR -- this order gives better error messages -unfoldPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => (Id -> [CoreExpr] -> Bool) -> Rewrite c HermitM CoreExpr+unfoldPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => (Id -> [CoreExpr] -> Bool) -> Rewrite c HermitM CoreExpr unfoldPredR p = callPredT p >> unfoldR -unfoldNameR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => String -> Rewrite c HermitM CoreExpr+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) -unfoldNamesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [String] -> Rewrite c HermitM CoreExpr+unfoldNamesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => [String] -> Rewrite c HermitM CoreExpr unfoldNamesR [] = fail "unfold-names failed: no names given." unfoldNamesR nms = setFailMsg "unfold-names failed." $ orR (map unfoldNameR nms) -unfoldSaturatedR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+unfoldSaturatedR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr unfoldSaturatedR = callSaturatedT >> unfoldR -specializeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr+specializeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c) => Rewrite c HermitM CoreExpr specializeR = unfoldPredR (const $ all isTyCoArg) -- NOTE: Using a Rewrite because of the way the Kernel is set up.@@ -120,7 +120,7 @@ -- | Stash a binding with a name for later use. -- Allows us to look at past definitions.--- rememberR :: String -> Translate c m Core ()+-- rememberR :: String -> Transform c m Core () -- rememberR label = contextfreeT $ \ core -> -- case core of -- DefCore def -> saveDef label def@@ -141,7 +141,7 @@ else fail $ "free variables " ++ intercalate "," (map (showPpr dflags) (filter (not . inScope c) fvars)) ++ " in stashed definition are no longer in scope." else fail $ "stashed definition applies to " ++ var2String i ++ " not " ++ var2String v -showStashT :: Injection CoreDef a => PrettyC -> PrettyH a -> Translate c HermitM a DocH+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
src/HERMIT/Dictionary/Unsafe.hs view
@@ -31,7 +31,7 @@ unsafeReplaceR :: CoreString -> RewriteH CoreExpr unsafeReplaceR core =- translate $ \ c e -> do+ transform $ \ c e -> do e' <- parseCore core c guardMsg (eqType (exprKindOrType e) (exprKindOrType e')) "expression types differ." return e'
src/HERMIT/Dictionary/WorkerWrapper/Fix.hs view
@@ -402,7 +402,7 @@ -> CoreExpr -- ^ unwrap -> CoreExpr -- ^ f -> WWAssumption- -> TranslateH x ()+ -> TransformH x () verifyWWAss wrap unwrap f (WWAssumption tag ass) = case tag of A -> verifyAssA wrap unwrap ass@@ -412,7 +412,7 @@ verifyAssA :: CoreExpr -- ^ wrap -> CoreExpr -- ^ unwrap -> RewriteH CoreExpr -- ^ WW Assumption A- -> TranslateH x ()+ -> TransformH x () verifyAssA wrap unwrap assA = prefixFailMsg ("verification of worker/wrapper Assumption A failed: ") $ do _ <- wrapUnwrapTypes wrap unwrap -- this check is redundant, but will produce a better error message@@ -422,7 +422,7 @@ -> CoreExpr -- ^ unwrap -> CoreExpr -- ^ f -> RewriteH CoreExpr -- ^ WW Assumption B- -> TranslateH x ()+ -> TransformH x () verifyAssB wrap unwrap f assB = prefixFailMsg ("verification of worker/wrapper assumption B failed: ") $ do (tyA,_) <- wrapUnwrapTypes wrap unwrap@@ -435,7 +435,7 @@ -> CoreExpr -- ^ unwrap -> CoreExpr -- ^ f -> RewriteH CoreExpr -- ^ WW Assumption C- -> TranslateH a ()+ -> TransformH a () verifyAssC wrap unwrap f assC = prefixFailMsg ("verification of worker/wrapper assumption C failed: ") $ do (tyA,_) <- wrapUnwrapTypes wrap unwrap
src/HERMIT/Dictionary/WorkerWrapper/FixResult.hs view
@@ -438,7 +438,7 @@ -> CoreExpr -- ^ rep -> CoreExpr -- ^ f -> WWAssumption- -> TranslateH x ()+ -> TransformH x () verifyWWAss abs rep f (WWAssumption tag ass) = case tag of A -> verifyAssA abs rep ass@@ -448,7 +448,7 @@ verifyAssA :: CoreExpr -- ^ abs -> CoreExpr -- ^ rep -> RewriteH CoreExpr -- ^ WW Assumption A- -> TranslateH x ()+ -> TransformH x () verifyAssA abs rep assA = prefixFailMsg ("verification of worker/wrapper Assumption A failed: ") $ do _ <- absRepTypes abs rep -- this check is redundant, but will produce a better error message@@ -458,7 +458,7 @@ -> CoreExpr -- ^ rep -> CoreExpr -- ^ f -> RewriteH CoreExpr -- ^ WW Assumption B- -> TranslateH x ()+ -> TransformH x () verifyAssB abs rep f assB = prefixFailMsg ("verification of worker/wrapper assumption B failed: ") $ do (tyA,_) <- absRepTypes abs rep@@ -475,7 +475,7 @@ -> CoreExpr -- ^ rep -> CoreExpr -- ^ f -> RewriteH CoreExpr -- ^ WW Assumption C- -> TranslateH a ()+ -> TransformH a () verifyAssC abs rep f assC = prefixFailMsg ("verification of worker/wrapper assumption C failed: ") $ do (tyA,_) <- absRepTypes abs rep
src/HERMIT/Driver.hs view
@@ -1,11 +1,22 @@-module HERMIT.Driver where+{-# LANGUAGE ViewPatterns #-}+module HERMIT.Driver + ( hermitVersion+ , ghcFlags+ , hermitDriver+ , usage+ ) where +import Data.List (isPrefixOf, partition) import Data.Version import Paths_hermit as P -hermit_version :: String -hermit_version = "HERMIT v" ++ showVersion P.version+import System.Directory (doesFileExist)+import System.Process+import System.Exit +hermitVersion :: String +hermitVersion = "HERMIT v" ++ showVersion P.version+ ghcFlags :: [String] ghcFlags = [ "-fforce-recomp" , "-O2"@@ -14,3 +25,95 @@ , "-fexpose-all-unfoldings" -- , "-v0" ]++usage :: IO ()+usage = putStrLn $ unlines+ [hermitVersion+ ,""+ ,"usage: hermit File.hs SCRIPTNAME"+ ," - OR -"+ ," hermit File.hs [HERMIT_ARGS] [+module_name [MOD_ARGS]]* [-- [ghc-args]]"+ ,""+ ,"examples: hermit Foo.hs Foo.hss"+ ," hermit Foo.hs -p6 +Main Foo.hss"+ ," hermit Foo.hs +Main Foo.hss resume"+ ," hermit Foo.hs +Main Foo.hss +Other.Module.Name Bar.hss"+ ," hermit Foo.hs -- -ddump-simpl -ddump-to-file"+ ,""+ ,"A * may be used for the module name. * matches any module."+ ,"If a module name is not supplied, * is assumed."+ ,""+ ,"HERMIT_ARGS"+ ," -opt=MODULE : where MODULE is the module containing a HERMIT optimization plugin"+ ," -vN : controls verbosity, where N is one of the following values:"+ ," 0 : suppress HERMIT messages, pass -v0 to GHC"+ ," 1 : suppress HERMIT messages"+ ," 2 : pass -v0 to GHC"+ ," 3 : (default) display all HERMIT and GHC messages"+ ,""+ ,"MOD_ARGS"+ ," SCRIPTNAME : name of script file to run for this module"+ ," resume : skip interactive mode and resume compilation after any scripts"+ ]++-- | Entry point for HERMIT driver executable. +-- First String in list is expected to be target file name.+hermitDriver :: [String] -> IO ()+hermitDriver [] = usage+hermitDriver args@(file_nm:script_nm:rest) = do+ e <- doesFileExist script_nm+ if e && (not (any (isPrefixOf "+") rest))+ then main4 file_nm [] [("*", script_nm:rest)] []+ else main2 args+hermitDriver other = main2 other++main2 :: [String] -> IO ()+main2 [] = usage+main2 (file_nm:rest) = case span (/= "--") rest of+ (args,"--":ghc_args) -> main3 file_nm args ghc_args+ (args,[]) -> main3 file_nm args []+ _ -> error "hermit internal error"++main3 :: String -> [String] -> [String] -> IO ()+main3 file_nm args ghc_args = main4 file_nm hermit_args (sepMods margs) ghc_args+ where (hermit_args, margs) = span (not . isPrefixOf "+") args++ sepMods :: [String] -> [(String, [String])]+ sepMods [] = []+ sepMods (('+':mod_nm):rest) = (mod_nm, mod_opts) : sepMods next+ where (mod_opts, next) = span (not . isPrefixOf "+") rest+ sepMods _ = error "sepMods impossible case"++main4 :: String -> [String] -> [(String, [String])] -> [String] -> IO ()+main4 file_nm hermit_args [] ghc_args = main4 file_nm hermit_args [("*", [])] ghc_args+main4 file_nm hermit_args module_args ghc_args = do+ putStrLn $ "[starting " ++ hermitVersion ++ " on " ++ file_nm ++ "]"+ let (pluginName, hermit_args') = getPlugin hermit_args+ cmds = file_nm : ghcFlags +++ [ "-fplugin=" ++ pluginName ] +++ [ "-fplugin-opt=" ++ pluginName ++ ":" ++ opt | opt <- hermit_args' ] +++ [ "-fplugin-opt=" ++ pluginName ++ ":" ++ m_nm ++ ":" ++ opt+ | (m_nm, m_opts) <- module_args+ , opt <- "" : m_opts+ ] ++ extraGHCArgs hermit_args' ++ ghc_args+ putStrLn $ "% ghc " ++ unwords cmds+ (_,_,_,r) <- createProcess $ proc "ghc" cmds+ ex <- waitForProcess r+ exitWith ex++getPlugin :: [String] -> (String, [String])+getPlugin = go "HERMIT" []+ where go plug flags [] = (plug, reverse flags) -- flag ordering is important here+ go plug flags (f:fs) | "-opt=" `isPrefixOf` f = go (drop 5 f) flags fs+ | otherwise = go plug (f:flags) fs++-- | See if the given HERMIT args imply any additional GHC args+extraGHCArgs :: [String] -> [String]+extraGHCArgs (matchArgs (`elem` ["-v0","-v2"]) -> Just (_,r)) = "-v0" : extraGHCArgs r+extraGHCArgs _ = []++matchArgs :: (String -> Bool) -> [String] -> Maybe ([String], [String])+matchArgs p args = case partition p args of+ ([],_) -> Nothing+ (as,r) -> Just (as,r)+
src/HERMIT/External.hs view
@@ -34,12 +34,12 @@ , RewriteCoreBox(..) , RewriteCoreTCBox(..) , BiRewriteCoreBox(..)- , TranslateCoreStringBox(..)- , TranslateCoreTCStringBox(..)- , TranslateCoreCheckBox(..)- , TranslateCoreTCCheckBox(..)- , TranslateCorePathBox(..)- , TranslateCoreTCPathBox(..)+ , TransformCoreStringBox(..)+ , TransformCoreTCStringBox(..)+ , TransformCoreCheckBox(..)+ , TransformCoreTCCheckBox(..)+ , TransformCorePathBox(..)+ , TransformCoreTCPathBox(..) , CoreString(..) , CoreBox(..) , CrumbBox(..)@@ -90,6 +90,7 @@ | 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.@@ -138,6 +139,7 @@ , (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.")@@ -227,7 +229,7 @@ } -- | Get all the 'External's which match a given tag predicate--- and box a Translate of the appropriate type.+-- and box a Transform of the appropriate type. matchingExternals :: (Extern tr, Tag t) => t -> [External] -> [(External, tr)] matchingExternals tag exts = [ (e,tr) | e <- exts, tagMatch tag e , Just tr <- [fmap unbox $ fromDynamic $ externDyn e] ]@@ -357,44 +359,44 @@ ----------------------------------------------------------------- -data TranslateCoreTCStringBox = TranslateCoreTCStringBox (TranslateH CoreTC String) deriving Typeable+data TransformCoreTCStringBox = TransformCoreTCStringBox (TransformH CoreTC String) deriving Typeable -instance Extern (TranslateH CoreTC String) where- type Box (TranslateH CoreTC String) = TranslateCoreTCStringBox- box = TranslateCoreTCStringBox- unbox (TranslateCoreTCStringBox t) = t+instance Extern (TransformH CoreTC String) where+ type Box (TransformH CoreTC String) = TransformCoreTCStringBox+ box = TransformCoreTCStringBox+ unbox (TransformCoreTCStringBox t) = t ----------------------------------------------------------------- -data TranslateCoreStringBox = TranslateCoreStringBox (TranslateH Core String) deriving Typeable+data TransformCoreStringBox = TransformCoreStringBox (TransformH Core String) deriving Typeable -instance Extern (TranslateH Core String) where- type Box (TranslateH Core String) = TranslateCoreStringBox- box = TranslateCoreStringBox- unbox (TranslateCoreStringBox t) = t+instance Extern (TransformH Core String) where+ type Box (TransformH Core String) = TransformCoreStringBox+ box = TransformCoreStringBox+ unbox (TransformCoreStringBox t) = t ----------------------------------------------------------------- -data TranslateCoreTCCheckBox = TranslateCoreTCCheckBox (TranslateH CoreTC ()) deriving Typeable+data TransformCoreTCCheckBox = TransformCoreTCCheckBox (TransformH CoreTC ()) deriving Typeable -instance Extern (TranslateH CoreTC ()) where- type Box (TranslateH CoreTC ()) = TranslateCoreTCCheckBox- box = TranslateCoreTCCheckBox- unbox (TranslateCoreTCCheckBox t) = t+instance Extern (TransformH CoreTC ()) where+ type Box (TransformH CoreTC ()) = TransformCoreTCCheckBox+ box = TransformCoreTCCheckBox+ unbox (TransformCoreTCCheckBox t) = t ----------------------------------------------------------------- -data TranslateCoreCheckBox = TranslateCoreCheckBox (TranslateH Core ()) deriving Typeable+data TransformCoreCheckBox = TransformCoreCheckBox (TransformH Core ()) deriving Typeable -instance Extern (TranslateH Core ()) where- type Box (TranslateH Core ()) = TranslateCoreCheckBox- box = TranslateCoreCheckBox- unbox (TranslateCoreCheckBox t) = t+instance Extern (TransformH Core ()) where+ type Box (TransformH Core ()) = TransformCoreCheckBox+ box = TransformCoreCheckBox+ unbox (TransformCoreCheckBox t) = t ----------------------------------------------------------------- --- TODO: We now have CrumbBoc, PathBox and TranslateCorePathBox.--- Ints are interpreted as a TranslateCorePathBox.+-- TODO: We now have CrumbBoc, PathBox and TransformCorePathBox.+-- Ints are interpreted as a TransformCorePathBox. -- This all needs cleaning up. data CrumbBox = CrumbBox Crumb deriving Typeable@@ -415,21 +417,21 @@ ----------------------------------------------------------------- -data TranslateCorePathBox = TranslateCorePathBox (TranslateH Core LocalPathH) deriving Typeable+data TransformCorePathBox = TransformCorePathBox (TransformH Core LocalPathH) deriving Typeable -instance Extern (TranslateH Core LocalPathH) where- type Box (TranslateH Core LocalPathH) = TranslateCorePathBox- box = TranslateCorePathBox- unbox (TranslateCorePathBox t) = t+instance Extern (TransformH Core LocalPathH) where+ type Box (TransformH Core LocalPathH) = TransformCorePathBox+ box = TransformCorePathBox+ unbox (TransformCorePathBox t) = t ----------------------------------------------------------------- -data TranslateCoreTCPathBox = TranslateCoreTCPathBox (TranslateH CoreTC LocalPathH) deriving Typeable+data TransformCoreTCPathBox = TransformCoreTCPathBox (TransformH CoreTC LocalPathH) deriving Typeable -instance Extern (TranslateH CoreTC LocalPathH) where- type Box (TranslateH CoreTC LocalPathH) = TranslateCoreTCPathBox- box = TranslateCoreTCPathBox- unbox (TranslateCoreTCPathBox t) = t+instance Extern (TransformH CoreTC LocalPathH) where+ type Box (TransformH CoreTC LocalPathH) = TransformCoreTCPathBox+ box = TransformCoreTCPathBox+ unbox (TransformCoreTCPathBox t) = t -----------------------------------------------------------------
src/HERMIT/GHC.hs view
@@ -11,6 +11,8 @@ , zapVarOccInfo , var2String , thRdrNameGuesses+ , varNameNS+ , isQualified , cmpString2Name , cmpString2Var , fqName@@ -37,38 +39,50 @@ , Pair(..) , bndrRuleAndUnfoldingVars #if __GLASGOW_HASKELL__ <= 706- , exprType + , exprType , Control.Monad.IO.Class.liftIO #else , runDsMtoCoreM , runTcMtoCoreM , buildTypeable+ , buildDictionary , eqExprX+ , lookupRdrNameInModuleForPlugins #endif+ , mkPhiTy+ , mkSigmaTy+ , 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)+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) +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 Panic (GhcException(ProgramError), throwGhcException)+import TcType (mkPhiTy, mkSigmaTy) import TypeRep (Type(..),TyLit(..)) #if __GLASGOW_HASKELL__ <= 706@@ -92,8 +106,15 @@ -------------------------------------------------------------------------- +-- | Rename this namespace, as 'varName' is already a function in Var.+varNameNS :: NameSpace+varNameNS = OccName.varName++getHscEnvCoreM :: CoreM HscEnv+getHscEnvCoreM = CoreMonad.getHscEnv+ #if __GLASGOW_HASKELL__ <= 706--- Note: prior to 7.8, the Let case was buggy for type +-- 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@@ -263,10 +284,10 @@ #if __GLASGOW_HASKELL__ > 706 runTcMtoCoreM :: ModGuts -> TcM a -> CoreM a runTcMtoCoreM guts m = do- env <- getHscEnv+ 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 (mg_module guts) m+ (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@@ -275,15 +296,22 @@ runDsMtoCoreM :: ModGuts -> DsM a -> CoreM a runDsMtoCoreM guts = runTcMtoCoreM guts . initDsTc --- TODO: +-- TODO: this is mostly an example, move somewhere? buildTypeable :: ModGuts -> Type -> CoreM (Id, [CoreBind]) buildTypeable guts ty = do- (i, bs) <- runTcMtoCoreM guts $ 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- evar <- newWantedEvVar predTy- let nonC = mkNonCanonical $ CtWanted { ctev_pred = predTy, ctev_evar = evar, ctev_loc = loc }+ 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?@@ -356,4 +384,47 @@ locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool locallyBoundL rn_env v = inRnEnvL rn_env v locallyBoundR rn_env v = inRnEnvR rn_env v++-- | Finds the 'Name' corresponding to the given 'RdrName' in the context of the 'ModuleName'. Returns @Nothing@ if no+-- such 'Name' could be found. Any other condition results in an exception:+--+-- * 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+ -- 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+ Found _ mod -> do+ -- Find the exports of the module+ (_, mb_iface) <- initTcFromModGuts hsc_env guts HsSrcFile False $+ initIfaceTcRn $+ loadPluginInterface doc mod+ case mb_iface of+ Just iface -> do+ -- Try and find the required name in the exports+ let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name+ , is_qual = False, is_dloc = noSrcSpan }+ provenance = Imported [ImpSpec decl_spec ImpAll]+ env = mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface))+ case lookupGRE_RdrName rdr_name env of+ [gre] -> return (Just (gre_name gre))+ [] -> return Nothing+ _ -> panic "lookupRdrNameInModule"++ Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]+ err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err+ where+ dflags = hsc_dflags hsc_env+ doc = ptext (sLit "contains a name used in an invocation of lookupRdrNameInModule")++-- | Also copied from GHC because it is not exposed.+throwCmdLineErrorS :: DynFlags -> SDoc -> IO a+throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags++throwCmdLineError :: String -> IO a+throwCmdLineError = throwGhcExceptionIO . CmdLineError #endif
src/HERMIT/GHC/Typechecker.hs view
@@ -4,6 +4,7 @@ #if __GLASGOW_HASKELL__ > 706 initTcFromModGuts , mk_type_env+ , tcLookupGlobal #endif ) where @@ -16,7 +17,6 @@ import CoreSyn import ErrUtils import VarEnv-import Module import Name import NameEnv import NameSet@@ -25,6 +25,7 @@ import Outputable import Data.IORef ( newIORef, readIORef ) +import TcEnv ( tcLookupGlobal ) import TcType ( noUntouchables ) import FastString@@ -33,7 +34,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map -import Prelude hiding (mod)+import Prelude import VarSet (emptyVarSet) -- Note: the contents of this module should eventually be folded into GHC proper.@@ -44,11 +45,10 @@ -> ModGuts -> HscSource -> Bool -- True <=> retain renamed syntax trees- -> Module -> TcM r -> IO (Messages, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already)-initTcFromModGuts hsc_env guts hsc_src keep_rn_syntax mod do_this+initTcFromModGuts hsc_env guts hsc_src keep_rn_syntax do_this = do { let { type_env = mk_type_env guts } ; errs_var <- newIORef (emptyBag, emptyBag) ; tvs_var <- newIORef emptyVarSet ;@@ -82,7 +82,7 @@ tcg_th_state = th_state_var, -- queried during tcrnif- tcg_mod = mod,+ tcg_mod = mg_module guts, tcg_src = hsc_src, tcg_rdr_env = mg_rdr_env guts, tcg_default = Nothing,
src/HERMIT/Kernel.hs view
@@ -30,7 +30,7 @@ { 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 -> TranslateH ModGuts a -> HermitMEnv -> IO (KureM a) -- ^ Apply a 'TranslateH' to the 'AST' and return the resulting value.+ , 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'. }@@ -78,18 +78,18 @@ , abortK = sendDone $ \ _ -> throwGhcException (ProgramError "Exiting HERMIT and aborting GHC compilation.") - , applyK = \ name r hm_env -> sendReq $ \ st -> findWithErrMsg name st fail $ \ (defs, guts) -> runHM hm_env+ , 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 (initHermitC guts) guts)+ (apply r (topLevelHermitC guts) guts) - , queryK = \ name t hm_env -> sendReqRead $ \ st -> findWithErrMsg name st fail $ \ (defs, core) -> runHM hm_env+ , queryK = \ name t hm_env -> sendReqRead $ \ st -> findWithErrMsg name st fail $ \ (defs, guts) -> runHM (guts,hm_env) defs (\ _ -> return.return) (return . fail)- (apply t (initHermitC core) core)+ (apply t (topLevelHermitC guts) guts) , deleteK = \ name -> sendReqWrite (return . delete name)
src/HERMIT/Kernel/Scoped.hs view
@@ -52,7 +52,7 @@ pathStackToLens ps p = injectL >>> pathL (concat $ pathStack2Paths ps p) -- This function is used to check the validity of paths, so which sum type we use is important.-testPathStackT :: [LocalPathH] -> LocalPathH -> TranslateH ModGuts Bool+testPathStackT :: [LocalPathH] -> LocalPathH -> TransformH ModGuts Bool testPathStackT ps p = testLensT (pathStackToLens ps p :: LensH ModGuts CoreTC) ----------------------------------------------------------------------------@@ -64,7 +64,7 @@ , applyS :: (MonadIO m, MonadCatch m, Injection ModGuts g, Walker HermitC g) => RewriteH g -> HermitMEnv -> SAST -> m SAST , queryS :: (MonadIO m, MonadCatch m, Injection ModGuts g, Walker HermitC g)- => TranslateH g a -> HermitMEnv -> SAST -> m a+ => 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]
src/HERMIT/Kure.hs view
@@ -6,14 +6,14 @@ -- | All the required functionality of KURE is exported here, so other modules do not need to import KURE directly. module Language.KURE- , module Language.KURE.BiTranslate+ , module Language.KURE.BiTransform , module Language.KURE.Lens , module Language.KURE.ExtendableContext , module Language.KURE.Pathfinder -- * Sub-Modules , module HERMIT.Kure.SumTypes -- * Synonyms- , TranslateH+ , TransformH , RewriteH , BiRewriteH , LensH@@ -88,7 +88,7 @@ where import Language.KURE-import Language.KURE.BiTranslate+import Language.KURE.BiTransform import Language.KURE.Lens import Language.KURE.ExtendableContext import Language.KURE.Pathfinder@@ -105,7 +105,7 @@ --------------------------------------------------------------------- -type TranslateH a b = Translate HermitC HermitM a b+type TransformH a b = Transform HermitC HermitM a b type RewriteH a = Rewrite HermitC HermitM a type BiRewriteH a = BiRewrite HermitC HermitM a type LensH a b = Lens HermitC HermitM a b@@ -124,7 +124,7 @@ --------------------------------------------------------------------- -- | Walking over modules, programs, binding groups, definitions, expressions and case alternatives.-instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Walker c Core where+instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c) => Walker c Core where allR :: forall m. MonadCatch m => Rewrite c m Core -> Rewrite c m Core allR r = prefixFailMsg "allR failed: " $@@ -248,7 +248,7 @@ --------------------------------------------------------------------- -- | Walking over modules, programs, binding groups, definitions, expressions and case alternatives.-instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Walker c CoreTC where+instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c) => Walker c CoreTC where allR :: forall m. MonadCatch m => Rewrite c m CoreTC -> Rewrite c m CoreTC allR r = prefixFailMsg "allR failed: " $@@ -300,29 +300,33 @@ --------------------------------------------------------------------- --- | Translate a module.+-- Note that we deliberately set the context to empty when descending into a ModGuts.+-- This is to hide the top-level definitions that we include in the context when focusses on ModGuts.+-- This is slightly awkward, but pragmatically useful.++-- | 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, Monad m) => Translate c m CoreProg a -> (ModGuts -> a -> b) -> Translate c m ModGuts b-modGutsT t f = translate $ \ c guts -> f guts <$> apply t (c @@ ModGuts_Prog) (bindsToProg $ mg_binds guts)+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) {-# INLINE modGutsT #-} -- | Rewrite the 'CoreProg' child of a module.-modGutsR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreProg -> Rewrite c m ModGuts+modGutsR :: (ExtendPath c Crumb, HasEmptyContext c, Monad m) => Rewrite c m CoreProg -> Rewrite c m ModGuts modGutsR r = modGutsT r (\ guts p -> guts {mg_binds = progToBinds p}) {-# INLINE modGutsR #-} --------------------------------------------------------------------- --- | Translate an empty list.-progNilT :: Monad m => b -> Translate c m CoreProg b+-- | Transform an empty list.+progNilT :: Monad m => b -> Transform c m CoreProg b progNilT b = contextfreeT $ \case ProgNil -> return b ProgCons _ _ -> fail "not an empty program." {-# INLINE progNilT #-} --- | Translate a program of the form: ('CoreBind' @:@ 'CoreProg')-progConsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind a1 -> Translate c m CoreProg a2 -> (a1 -> a2 -> b) -> Translate c m CoreProg b-progConsT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a non-empty program." {-# INLINE progConsT #-}@@ -344,9 +348,9 @@ --------------------------------------------------------------------- --- | Translate a binding group of the form: @NonRec@ 'Var' 'CoreExpr'-nonRecT :: (ExtendPath c Crumb, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreBind b-nonRecT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a non-recursive binding group." {-# INLINE nonRecT #-}@@ -367,9 +371,9 @@ {-# INLINE nonRecOneR #-} --- | Translate a binding group of the form: @Rec@ ['CoreDef']-recT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a) -> ([a] -> b) -> Translate c m CoreBind b-recT t f = translate $ \ c -> \case+-- | Transform a binding group of the form: @Rec@ ['CoreDef']+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 | ((i,e),n) <- zip bds [0..]@@ -394,9 +398,9 @@ --------------------------------------------------------------------- --- | Translate a recursive definition of the form: @Def@ 'Id' 'CoreExpr'-defT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Id a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreDef b-defT t1 t2 f = translate $ \ c (Def i e) -> f <$> apply t1 (c @@ Def_Id) i <*> apply t2 (addDefBinding i c @@ Def_RHS) e+-- | 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 {-# INLINE defT #-} -- | Rewrite all children of a recursive definition of the form: @Def@ 'Id' 'CoreExpr'@@ -416,9 +420,9 @@ --------------------------------------------------------------------- --- | Translate a case alternative of the form: ('AltCon', ['Var'], 'CoreExpr')-altT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m AltCon a1 -> (Int -> Translate c m Var a2) -> Translate c m CoreExpr a3 -> (a1 -> [a2] -> a3 -> b) -> Translate c m CoreAlt b-altT t1 ts t2 f = translate $ \ c (con,vs,e) -> f <$> apply t1 (c @@ Alt_Con) con+-- | 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 {-# INLINE altT #-}@@ -440,9 +444,9 @@ --------------------------------------------------------------------- --- | Translate an expression of the form: @Var@ 'Id'-varT :: (ExtendPath c Crumb, Monad m) => Translate c m Id b -> Translate c m CoreExpr b-varT t = translate $ \ c -> \case+-- | 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 _ -> fail "not a variable." {-# INLINE varT #-}@@ -453,9 +457,9 @@ {-# INLINE varR #-} --- | Translate an expression of the form: @Lit@ 'Literal'-litT :: (ExtendPath c Crumb, Monad m) => Translate c m Literal b -> Translate c m CoreExpr b-litT t = translate $ \ c -> \case+-- | 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 _ -> fail "not a literal." {-# INLINE litT #-}@@ -466,9 +470,9 @@ {-# INLINE litR #-} --- | Translate an expression of the form: @App@ 'CoreExpr' 'CoreExpr'-appT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreExpr a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b-appT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not an application." {-# INLINE appT #-}@@ -489,9 +493,9 @@ {-# INLINE appOneR #-} --- | Translate an expression of the form: @Lam@ 'Var' 'CoreExpr'-lamT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b-lamT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a lambda." {-# INLINE lamT #-}@@ -512,9 +516,9 @@ {-# INLINE lamOneR #-} --- | Translate an expression of the form: @Let@ 'CoreBind' 'CoreExpr'-letT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b-letT t1 t2 f = translate $ \ c -> \case+-- | Transform an expression of the form: @Let@ 'CoreBind' 'CoreExpr'+letT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m CoreBind a1 -> Transform c m CoreExpr a2 -> (a1 -> a2 -> b) -> Transform c m CoreExpr b+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@@ -537,15 +541,15 @@ {-# INLINE letOneR #-} --- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt']+-- | Transform an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt'] caseT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m)- => Translate c m CoreExpr e- -> Translate c m Id w- -> Translate c m Type ty- -> (Int -> Translate c m CoreAlt alt)+ => Transform c m CoreExpr e+ -> Transform c m Id w+ -> Transform c m Type ty+ -> (Int -> Transform c m CoreAlt alt) -> (e -> w -> ty -> [alt] -> b)- -> Translate c m CoreExpr b-caseT te tw tty talts f = translate $ \ c -> \case+ -> 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@@ -586,9 +590,9 @@ {-# INLINE caseOneR #-} --- | Translate an expression of the form: @Cast@ 'CoreExpr' 'Coercion'-castT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreExpr a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b-castT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a cast." {-# INLINE castT #-}@@ -609,9 +613,9 @@ {-# INLINE castOneR #-} --- | Translate an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr'-tickT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreTickish a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b-tickT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a tick." {-# INLINE tickT #-}@@ -632,9 +636,9 @@ {-# INLINE tickOneR #-} --- | Translate an expression of the form: @Type@ 'Type'-typeT :: (ExtendPath c Crumb, Monad m) => Translate c m Type b -> Translate c m CoreExpr b-typeT t = translate $ \ c -> \case+-- | 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 _ -> fail "not a type." {-# INLINE typeT #-}@@ -645,9 +649,9 @@ {-# INLINE typeR #-} --- | Translate an expression of the form: @Coercion@ 'Coercion'-coercionT :: (ExtendPath c Crumb, Monad m) => Translate c m Coercion b -> Translate c m CoreExpr b-coercionT t = translate $ \ c -> \case+-- | 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 _ -> fail "not a coercion." {-# INLINE coercionT #-}@@ -661,8 +665,8 @@ -- Some composite congruence combinators to export. --- | Translate a definition of the form @NonRec 'Var' 'CoreExpr'@ or @Def 'Id' 'CoreExpr'@-defOrNonRecT :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m g b+-- | Transform a definition of the form @NonRec 'Var' 'CoreExpr'@ or @Def 'Id' 'CoreExpr'@+defOrNonRecT :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Transform c m Var a1 -> Transform c m CoreExpr a2 -> (a1 -> a2 -> b) -> Transform c m g b defOrNonRecT t1 t2 f = promoteBindT (nonRecT t1 t2 f) <+ promoteDefT (defT t1 t2 f) {-# INLINE defOrNonRecT #-}@@ -684,8 +688,8 @@ {-# INLINE defOrNonRecOneR #-} --- | Translate a binding group of the form: @Rec@ [('Id', 'CoreExpr')]-recDefT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> ([(a1,a2)] -> b) -> Translate c m CoreBind b+-- | Transform a binding group of the form: @Rec@ [('Id', 'CoreExpr')]+recDefT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Transform c m Id a1, Transform c m CoreExpr a2)) -> ([(a1,a2)] -> b) -> Transform c m CoreBind b recDefT ts = recT (\ n -> uncurry defT (ts n) (,)) {-# INLINE recDefT #-} @@ -705,8 +709,8 @@ {-# INLINE recDefOneR #-} --- | Translate a program of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'-consNonRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> Translate c m CoreProg a3 -> (a1 -> a2 -> a3 -> b) -> Translate c m CoreProg b+-- | Transform a program of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg'+consNonRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m Var a1 -> Transform c m CoreExpr a2 -> Transform c m CoreProg a3 -> (a1 -> a2 -> a3 -> b) -> Transform c m CoreProg b consNonRecT t1 t2 t3 f = progConsT (nonRecT t1 t2 (,)) t3 (uncurry f) {-# INLINE consNonRecT #-} @@ -726,8 +730,8 @@ {-# INLINE consNonRecOneR #-} --- | Translate an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'-consRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a1) -> Translate c m CoreProg a2 -> ([a1] -> a2 -> b) -> Translate c m CoreProg b+-- | Transform an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg'+consRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Transform c m CoreDef a1) -> Transform c m CoreProg a2 -> ([a1] -> a2 -> b) -> Transform c m CoreProg b consRecT ts t = progConsT (recT ts id) t {-# INLINE consRecT #-} @@ -747,8 +751,8 @@ {-# INLINE consRecOneR #-} --- | Translate an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'-consRecDefT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> Translate c m CoreProg a3 -> ([(a1,a2)] -> a3 -> b) -> Translate c m CoreProg b+-- | Transform an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg'+consRecDefT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Transform c m Id a1, Transform c m CoreExpr a2)) -> Transform c m CoreProg a3 -> ([(a1,a2)] -> a3 -> b) -> Transform c m CoreProg b consRecDefT ts t = consRecT (\ n -> uncurry defT (ts n) (,)) t {-# INLINE consRecDefT #-} @@ -768,8 +772,8 @@ {-# INLINE consRecDefOneR #-} --- | Translate an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'-letNonRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> Translate c m CoreExpr a3 -> (a1 -> a2 -> a3 -> b) -> Translate c m CoreExpr b+-- | Transform an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr'+letNonRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Transform c m Var a1 -> Transform c m CoreExpr a2 -> Transform c m CoreExpr a3 -> (a1 -> a2 -> a3 -> b) -> Transform c m CoreExpr b letNonRecT t1 t2 t3 f = letT (nonRecT t1 t2 (,)) t3 (uncurry f) {-# INLINE letNonRecT #-} @@ -789,8 +793,8 @@ {-# INLINE letNonRecOneR #-} --- | Translate an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'-letRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a1) -> Translate c m CoreExpr a2 -> ([a1] -> a2 -> b) -> Translate c m CoreExpr b+-- | Transform an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr'+letRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Transform c m CoreDef a1) -> Transform c m CoreExpr a2 -> ([a1] -> a2 -> b) -> Transform c m CoreExpr b letRecT ts t = letT (recT ts id) t {-# INLINE letRecT #-} @@ -810,8 +814,8 @@ {-# INLINE letRecOneR #-} --- | Translate an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'-letRecDefT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> Translate c m CoreExpr a3 -> ([(a1,a2)] -> a3 -> b) -> Translate c m CoreExpr b+-- | Transform an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr'+letRecDefT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Transform c m Id a1, Transform c m CoreExpr a2)) -> Transform c m CoreExpr a3 -> ([(a1,a2)] -> a3 -> b) -> Transform c m CoreExpr b letRecDefT ts t = letRecT (\ n -> uncurry defT (ts n) (,)) t {-# INLINE letRecDefT #-} @@ -831,13 +835,13 @@ {-# INLINE letRecDefOneR #-} --- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')]+-- | Transform an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')] caseAltT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m)- => Translate c m CoreExpr sc- -> Translate c m Id w- -> Translate c m Type ty- -> (Int -> (Translate c m AltCon con, (Int -> Translate c m Var v), Translate c m CoreExpr rhs)) -> (sc -> w -> ty -> [(con,[v],rhs)] -> b)- -> Translate c m CoreExpr b+ => Transform c m CoreExpr sc+ -> Transform c m Id w+ -> Transform c m Type ty+ -> (Int -> (Transform c m AltCon con, (Int -> Transform c m Var v), Transform c m CoreExpr rhs)) -> (sc -> w -> ty -> [(con,[v],rhs)] -> b)+ -> Transform c m CoreExpr b caseAltT tsc tw tty talts = caseT tsc tw tty (\ n -> let (tcon,tvs,te) = talts n in altT tcon tvs te (,,)) {-# INLINE caseAltT #-} @@ -875,11 +879,11 @@ -- Recursive composite congruence combinators. --- | Translate all top-level binding groups in a program.-progBindsT :: forall c m a b. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Translate c m CoreBind a) -> ([a] -> b) -> Translate c m CoreProg b+-- | Transform all top-level binding groups in a program.+progBindsT :: forall c m a b. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Transform c m CoreBind a) -> ([a] -> b) -> Transform c m CoreProg b progBindsT ts f = f <$> progBindsTaux 0 where- progBindsTaux :: Int -> Translate c m CoreProg [a]+ progBindsTaux :: Int -> Transform c m CoreProg [a] progBindsTaux n = progNilT [] <+ progConsT (ts n) (progBindsTaux (succ n)) (:) {-# INLINE progBindsT #-} @@ -903,9 +907,9 @@ -- Types --- | Translate a type of the form: @TyVarTy@ 'TyVar'-tyVarT :: (ExtendPath c Crumb, Monad m) => Translate c m TyVar b -> Translate c m Type b-tyVarT t = translate $ \ c -> \case+-- | 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 _ -> fail "not a type variable." {-# INLINE tyVarT #-}@@ -916,9 +920,9 @@ {-# INLINE tyVarR #-} --- | Translate a type of the form: @LitTy@ 'TyLit'-litTyT :: (ExtendPath c Crumb, Monad m) => Translate c m TyLit b -> Translate c m Type b-litTyT t = translate $ \ c -> \case+-- | 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 _ -> fail "not a type literal." {-# INLINE litTyT #-}@@ -929,9 +933,9 @@ {-# INLINE litTyR #-} --- | Translate a type of the form: @AppTy@ 'Type' 'Type'-appTyT :: (ExtendPath c Crumb, Monad m) => Translate c m Type a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Type b-appTyT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a type application." {-# INLINE appTyT #-}@@ -952,9 +956,9 @@ {-# INLINE appTyOneR #-} --- | Translate a type of the form: @FunTy@ 'Type' 'Type'-funTyT :: (ExtendPath c Crumb, Monad m) => Translate c m Type a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Type b-funTyT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a function type." {-# INLINE funTyT #-}@@ -975,9 +979,9 @@ {-# INLINE funTyOneR #-} --- | Translate a type of the form: @ForAllTy@ 'Var' 'Type'-forAllTyT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Type b-forAllTyT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a forall type." {-# INLINE forAllTyT #-}@@ -998,9 +1002,9 @@ {-# INLINE forAllTyOneR #-} --- | Translate a type of the form: @TyConApp@ 'TyCon' ['KindOrType']-tyConAppT :: (ExtendPath c Crumb, Monad m) => Translate c m TyCon a1 -> (Int -> Translate c m KindOrType a2) -> (a1 -> [a2] -> b) -> Translate c m Type b-tyConAppT t ts f = translate $ \ c -> \case+-- | 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..] ] _ -> fail "not a type-constructor application." {-# INLINE tyConAppT #-}@@ -1027,9 +1031,9 @@ -- TODO: review and bring all these up-to-date for Coercions w/ Roles in 7.8 #if __GLASGOW_HASKELL__ > 706--- | Translate a coercion of the form: @Refl@ 'Role' 'Type'-reflT :: (ExtendPath c Crumb, Monad m) => Translate c m Type a1 -> (Role -> a1 -> b) -> Translate c m Coercion b-reflT t f = translate $ \ c -> \case+-- | 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 _ -> fail "not a reflexive coercion." @@ -1037,9 +1041,9 @@ reflR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Type -> Rewrite c m Coercion reflR r = reflT r Refl #else--- | Translate a coercion of the form: @Refl@ 'Type'-reflT :: (ExtendPath c Crumb, Monad m) => Translate c m Type b -> Translate c m Coercion b-reflT t = translate $ \ c -> \case+-- | 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." @@ -1051,15 +1055,15 @@ {-# INLINE reflR #-} #if __GLASGOW_HASKELL__ > 706--- | Translate a coercion of the form: @TyConAppCo@ 'Role' 'TyCon' ['Coercion']-tyConAppCoT :: (ExtendPath c Crumb, Monad m) => Translate c m TyCon a1 -> (Int -> Translate c m Coercion a2) -> (Role -> a1 -> [a2] -> b) -> Translate c m Coercion b-tyConAppCoT t ts f = translate $ \ c -> \case+-- | 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..] ] _ -> fail "not a type-constructor coercion." #else--- | Translate a coercion of the form: @TyConAppCo@ 'TyCon' ['Coercion']-tyConAppCoT :: (ExtendPath c Crumb, Monad m) => Translate c m TyCon a1 -> (Int -> Translate c m Coercion a2) -> (a1 -> [a2] -> b) -> Translate c m Coercion b-tyConAppCoT t ts f = translate $ \ c -> \case+-- | 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@@ -1081,9 +1085,9 @@ {-# INLINE tyConAppCoOneR #-} --- | Translate a coercion of the form: @AppCo@ 'Coercion' 'Coercion'-appCoT :: (ExtendPath c Crumb, Monad m) => Translate c m Coercion a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b-appCoT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a coercion application." {-# INLINE appCoT #-}@@ -1104,9 +1108,9 @@ {-# INLINE appCoOneR #-} --- | Translate a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion'-forAllCoT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m TyVar a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b-forAllCoT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a forall coercion." {-# INLINE forAllCoT #-}@@ -1127,9 +1131,9 @@ {-# INLINE forAllCoOneR #-} --- | Translate a coercion of the form: @CoVarCo@ 'CoVar'-coVarCoT :: (ExtendPath c Crumb, Monad m) => Translate c m CoVar b -> Translate c m Coercion b-coVarCoT t = translate $ \ c -> \case+-- | 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 _ -> fail "not a coercion variable." {-# INLINE coVarCoT #-}@@ -1140,15 +1144,15 @@ {-# INLINE coVarCoR #-} #if __GLASGOW_HASKELL__ > 706--- | Translate a coercion of the form: @AxiomInstCo@ ('CoAxiom' 'Branched') 'BranchIndex' ['Coercion']-axiomInstCoT :: (ExtendPath c Crumb, Monad m) => Translate c m (CoAxiom Branched) a1 -> Translate c m BranchIndex a2 -> (Int -> Translate c m Coercion a3) -> (a1 -> a2 -> [a3] -> b) -> Translate c m Coercion b-axiomInstCoT t1 t2 ts f = translate $ \ c -> \case+-- | 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..] ] _ -> fail "not a coercion axiom instantiation." #else--- | Translate a coercion of the form: @AxiomInstCo@ 'CoAxiom' ['Coercion']-axiomInstCoT :: (ExtendPath c Crumb, Monad m) => Translate c m CoAxiom a1 -> (Int -> Translate c m Coercion a2) -> (a1 -> [a2] -> b) -> Translate c m Coercion b-axiomInstCoT t ts f = translate $ \ c -> \case+-- | 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@@ -1189,9 +1193,9 @@ #if __GLASGOW_HASKELL__ > 706 #else--- | Translate a coercion of the form: @UnsafeCo@ 'Type' 'Type'-unsafeCoT :: (ExtendPath c Crumb, Monad m) => Translate c m Type a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b-unsafeCoT t1 t2 f = translate $ \ c -> \case+-- | 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 #-}@@ -1212,9 +1216,9 @@ {-# INLINE unsafeCoOneR #-} #endif --- | Translate a coercion of the form: @SymCo@ 'Coercion'-symCoT :: (ExtendPath c Crumb, Monad m) => Translate c m Coercion b -> Translate c m Coercion b-symCoT t = translate $ \ c -> \case+-- | 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 _ -> fail "not a symmetric coercion." {-# INLINE symCoT #-}@@ -1225,9 +1229,9 @@ {-# INLINE symCoR #-} --- | Translate a coercion of the form: @TransCo@ 'Coercion' 'Coercion'-transCoT :: (ExtendPath c Crumb, Monad m) => Translate c m Coercion a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b-transCoT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a transitive coercion." {-# INLINE transCoT #-}@@ -1248,9 +1252,9 @@ {-# INLINE transCoOneR #-} --- | Translate a coercion of the form: @NthCo@ 'Int' 'Coercion'-nthCoT :: (ExtendPath c Crumb, Monad m) => Translate c m Int a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b-nthCoT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not an Nth coercion." {-# INLINE nthCoT #-}@@ -1272,24 +1276,24 @@ #if __GLASGOW_HASKELL__ > 706--- | Translate a coercion of the form: @LRCo@ 'LeftOrRight' 'Coercion'-lrCoT :: (ExtendPath c Crumb, Monad m) => Translate c m LeftOrRight a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b-lrCoT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a left/right coercion." {-# INLINE lrCoT #-} --- | Translate all children of a coercion of the form: @LRCo@ 'LeftOrRight' 'Coercion'+-- | Transform all children of a coercion of the form: @LRCo@ 'LeftOrRight' 'Coercion' lrCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m LeftOrRight -> Rewrite c m Coercion -> Rewrite c m Coercion lrCoAllR r1 r2 = lrCoT r1 r2 LRCo {-# INLINE lrCoAllR #-} --- | Translate any children of a coercion of the form: @LRCo@ 'LeftOrRight' 'Coercion'+-- | Transform any children of a coercion of the form: @LRCo@ 'LeftOrRight' 'Coercion' lrCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m LeftOrRight -> Rewrite c m Coercion -> Rewrite c m Coercion lrCoAnyR r1 r2 = unwrapAnyR $ lrCoAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE lrCoAnyR #-} --- | Translate one child of a coercion of the form: @LRCo@ 'LeftOrRight' 'Coercion'+-- | Transform one child of a coercion of the form: @LRCo@ 'LeftOrRight' 'Coercion' 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 #-}@@ -1297,9 +1301,9 @@ #endif --- | Translate a coercion of the form: @InstCo@ 'Coercion' 'Type'-instCoT :: (ExtendPath c Crumb, Monad m) => Translate c m Coercion a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b-instCoT t1 t2 f = translate $ \ c -> \case+-- | 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 _ -> fail "not a coercion instantiation." {-# INLINE instCoT #-}@@ -1324,7 +1328,7 @@ -- | Earlier versions of HERMIT used 'Int' as the crumb type. -- This translation maps an 'Int' to the corresponding 'Crumb', for backwards compatibility purposes.-deprecatedIntToCrumbT :: Monad m => Int -> Translate c m Core Crumb+deprecatedIntToCrumbT :: Monad m => Int -> Transform c m Core Crumb deprecatedIntToCrumbT n = contextfreeT $ \case GutsCore _ | n == 0 -> return ModGuts_Prog AltCore _ | n == 0 -> return Alt_RHS@@ -1346,7 +1350,7 @@ {-# INLINE deprecatedIntToCrumbT #-} -- | Builds a path to the first child, based on the old numbering system.-deprecatedIntToPathT :: Monad m => Int -> Translate c m Core LocalPathH+deprecatedIntToPathT :: Monad m => Int -> Transform c m Core LocalPathH deprecatedIntToPathT = liftM (mempty @@) . deprecatedIntToCrumbT {-# INLINE deprecatedIntToPathT #-}
src/HERMIT/Kure/SumTypes.hs view
@@ -19,7 +19,7 @@ , freeVarsTyCo , freeVarsCoreTC -- * Promotion Combinators- -- ** Translate Promotions+ -- ** Transform Promotions , promoteModGutsT , promoteProgT , promoteBindT@@ -42,9 +42,9 @@ ) where -import Language.KURE.Translate+import Language.KURE.Transform import Language.KURE.Injection-import Language.KURE.BiTranslate+import Language.KURE.BiTransform import HERMIT.Core import HERMIT.GHC@@ -362,42 +362,42 @@ --------------------------------------------------------------------- -- | Promote a translate on 'ModGuts'.-promoteModGutsT :: (Monad m, Injection ModGuts g) => Translate c m ModGuts b -> Translate c m g b+promoteModGutsT :: (Monad m, Injection ModGuts g) => Transform c m ModGuts b -> Transform c m g b promoteModGutsT = promoteWithFailMsgT "This translate can only succeed at the module level." {-# INLINE promoteModGutsT #-} -- | Promote a translate on 'CoreProg'.-promoteProgT :: (Monad m, Injection CoreProg g) => Translate c m CoreProg b -> Translate c m g b+promoteProgT :: (Monad m, Injection CoreProg g) => Transform c m CoreProg b -> Transform c m g b promoteProgT = promoteWithFailMsgT "This translate can only succeed at program nodes (the top-level)." {-# INLINE promoteProgT #-} -- | Promote a translate on 'CoreBind'.-promoteBindT :: (Monad m, Injection CoreBind g) => Translate c m CoreBind b -> Translate c m g b+promoteBindT :: (Monad m, Injection CoreBind g) => Transform c m CoreBind b -> Transform c m g b promoteBindT = promoteWithFailMsgT "This translate can only succeed at binding group nodes." {-# INLINE promoteBindT #-} -- | Promote a translate on 'CoreDef'.-promoteDefT :: (Monad m, Injection CoreDef g) => Translate c m CoreDef b -> Translate c m g b+promoteDefT :: (Monad m, Injection CoreDef g) => Transform c m CoreDef b -> Transform c m g b promoteDefT = promoteWithFailMsgT "This translate can only succeed at recursive definition nodes." {-# INLINE promoteDefT #-} -- | Promote a translate on 'CoreAlt'.-promoteAltT :: (Monad m, Injection CoreAlt g) => Translate c m CoreAlt b -> Translate c m g b+promoteAltT :: (Monad m, Injection CoreAlt g) => Transform c m CoreAlt b -> Transform c m g b promoteAltT = promoteWithFailMsgT "This translate can only succeed at case alternative nodes." {-# INLINE promoteAltT #-} -- | Promote a translate on 'CoreExpr'.-promoteExprT :: (Monad m, Injection CoreExpr g) => Translate c m CoreExpr b -> Translate c m g b+promoteExprT :: (Monad m, Injection CoreExpr g) => Transform c m CoreExpr b -> Transform c m g b promoteExprT = promoteWithFailMsgT "This translate can only succeed at expression nodes." {-# INLINE promoteExprT #-} -- | Promote a translate on 'Type'.-promoteTypeT :: (Monad m, Injection Type g) => Translate c m Type b -> Translate c m g b+promoteTypeT :: (Monad m, Injection Type g) => Transform c m Type b -> Transform c m g b promoteTypeT = promoteWithFailMsgT "This translate can only succeed at type nodes." {-# INLINE promoteTypeT #-} -- | Promote a translate on 'Coercion'.-promoteCoercionT :: (Monad m, Injection Coercion g) => Translate c m Coercion b -> Translate c m g b+promoteCoercionT :: (Monad m, Injection Coercion g) => Transform c m Coercion b -> Transform c m g b promoteCoercionT = promoteWithFailMsgT "This translate can only succeed at coercion nodes." {-# INLINE promoteCoercionT #-}
src/HERMIT/Monad.hs view
@@ -10,6 +10,7 @@ , newIdH , newTyVarH , newCoVarH+ , newVarH , cloneVarH -- * Saving Definitions , Label@@ -17,6 +18,10 @@ , saveDef , lookupDef , getStash+ -- * Reader Information+ , HasHermitMEnv(..)+ , HasModGuts(..)+ , HasHscEnv(..) -- * Messages , HermitMEnv(..) , DebugMessage(..)@@ -40,6 +45,10 @@ import HERMIT.Kure.SumTypes import HERMIT.GHC +#if __GLASGOW_HASKELL__ > 706+import HERMIT.GHC.Typechecker+#endif+ ---------------------------------------------------------------------------- -- | A label for individual definitions.@@ -52,13 +61,13 @@ newtype HermitMEnv = HermitMEnv { hs_debugChan :: DebugMessage -> HermitM () } -- | The HERMIT monad is kept abstract.-newtype HermitM a = HermitM (HermitMEnv -> DefStash -> CoreM (KureM (DefStash, a)))+newtype HermitM a = HermitM ((ModGuts,HermitMEnv) -> DefStash -> CoreM (KureM (DefStash, a))) -runHermitM :: HermitM a -> HermitMEnv -> DefStash -> CoreM (KureM (DefStash, a))+runHermitM :: HermitM a -> (ModGuts,HermitMEnv) -> DefStash -> CoreM (KureM (DefStash, a)) runHermitM (HermitM f) = f -- | Eliminator for 'HermitM'.-runHM :: HermitMEnv -> DefStash -> (DefStash -> a -> CoreM b) -> (String -> CoreM b) -> HermitM a -> CoreM b+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 ----------------------------------------------------------------------------@@ -71,8 +80,31 @@ putStash :: DefStash -> HermitM () putStash s = HermitM (\ _ _ -> return $ return (s, ())) +class HasHermitMEnv m where+ -- | Get the HermitMEnv+ getHermitMEnv :: m HermitMEnv++instance HasHermitMEnv HermitM where+ getHermitMEnv = HermitM (\ rdr s -> return $ return (s, snd rdr))++class HasModGuts m where+ -- | Get the ModGuts (Note: this is a snapshot of the ModGuts from before the current transformation.)+ getModGuts :: m ModGuts++instance HasModGuts HermitM where+ getModGuts = HermitM (\ rdr s -> return $ return (s, fst rdr))++class HasHscEnv m where+ getHscEnv :: m HscEnv++instance HasHscEnv CoreM where+ getHscEnv = getHscEnvCoreM++instance HasHscEnv HermitM where+ getHscEnv = liftCoreM getHscEnv+ sendDebugMessage :: DebugMessage -> HermitM ()-sendDebugMessage msg = do env <- HermitM $ \ ch s -> return $ return (s, ch)+sendDebugMessage msg = do env <- getHermitMEnv hs_debugChan env msg -- | Save a definition for future use.@@ -126,8 +158,27 @@ getUniqueSupplyM = liftCoreM getUniqueSupplyM instance MonadThings HermitM where- lookupThing :: Name -> HermitM TyThing- lookupThing = liftCoreM . lookupThing+ lookupThing :: Name -> HermitM TyThing+ -- We do not simply do:+ --+ -- lookupThing = liftCoreM . lookupThing+ --+ -- because we can do better. HermitM has access+ -- to the ModGuts, so we can find TyThings defined+ -- in the current module, not just imported ones.+ -- Usually we look in the context first, which has+ -- *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 + -- 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 instance HasDynFlags HermitM where getDynFlags :: HermitM DynFlags@@ -153,6 +204,13 @@ -- | 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++-- 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 -- | Make a new variable of the same type, with a modified textual name. cloneVarH :: (String -> String) -> Var -> HermitM Var
+ src/HERMIT/Name.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ <= 706+{-# LANGUAGE ScopedTypeVariables #-}+#endif+module HERMIT.Name + ( HermitName+ , fromRdrName+ , toRdrName+ , toRdrNames+ , hnModuleName+ , hnUnqualified+ , parseName+ -- * Namespaces+ , Named(..)+ , varToNamed+ , allNameSpaces+ , dataConNS+ , tyConClassNS+ , tyVarNS+ , varNS+ -- * 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 HERMIT.Context+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. +-- Invariant: One constructor for each NameSpace.+data Named = NamedId Id+ | NamedDataCon DataCon+ | NamedTyCon TyCon+ | NamedTyVar Var++instance Show Named where+ show (NamedId _) = "NamedId"+ show (NamedDataCon _) = "NamedDataCon"+ show (NamedTyCon _) = "NamedTyCon"+ show (NamedTyVar _) = "NamedTyVar"++varToNamed :: Var -> Named+varToNamed v | isVarOcc onm = NamedId v+ | isTvOcc onm = NamedTyVar v+ | otherwise = error "varToNamed: impossible Var namespace"+ where onm = getOccName v++----------------------- Namespaces -----------------------+-- Simplify what GHC offers a bit, as it has more options+-- that are just duplicates of each other.++tyConClassNS :: NameSpace+tyConClassNS = tcClsName++dataConNS :: NameSpace+dataConNS = dataName++tyVarNS :: NameSpace+tyVarNS = tvName++varNS :: NameSpace+varNS = varNameNS++allNameSpaces :: [NameSpace]+allNameSpaces = [varNS, dataConNS, tyConClassNS, tyVarNS]++----------------------------------------------------------++mkQualified :: String -> String -> HermitName+mkQualified mnm nm = HermitName (Just $ mkModuleName mnm) nm+-- mkOccName+-- mkRdrQual++mkUnqualified :: String -> HermitName+mkUnqualified = HermitName Nothing+-- mkRdrUnqual++fromRdrName :: RdrName -> HermitName+fromRdrName nm = case isQual_maybe nm of+ Nothing -> HermitName Nothing (occNameString $ rdrNameOcc nm)+ Just (mnm, onm) -> HermitName (Just mnm) (occNameString onm)++-- | Make a RdrName for the given NameSpace and HermitName+toRdrName :: NameSpace -> HermitName -> RdrName+toRdrName ns (HermitName mnm nm) = maybe (mkRdrUnqual onm) (flip mkRdrQual onm) mnm+ where onm = mkOccName ns nm++-- | Make a RdrName for each given NameSpace.+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++--------------------------------------------------------------------------------------------------++-- | 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. +-- TODO: add function for this, or modify GHC's 'TyThing'?+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+ | isTyVarName nm -> fail "lookupThing cannot be used with TyVars."+ | otherwise -> fail "MonadThings instance for Transform: impossible namespace."+ [] -> lookupThing nm++--------------------------------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ > 706+findId :: (BoundVars c, HasHscEnv m, HasModGuts m, MonadCatch m, MonadIO m, MonadThings m) + => String -> c -> m Id+findId nm c = do+ nmd <- findInNameSpaces [varNS, dataConNS] nm c+ case nmd of+ NamedId i -> return i+ 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 nm c = do+ nmd <- findInNameSpaces [varNS, tyVarNS, dataConNS] nm c+ case nmd of+ NamedId i -> return i+ NamedTyVar v -> return v+ 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 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 nm c = do+ nmd <- findInNameSpaces [tyVarNS, tyConClassNS] nm c+ case nmd of+ NamedTyVar v -> return $ mkTyVarTy v+ NamedTyCon tc -> return $ mkTyConTy tc+ other -> fail $ "findType: impossible Named returned: " ++ show other++--------------------------------------------------------------------------------------------------++findInNameSpaces :: (BoundVars c, HasHscEnv m, HasModGuts m, MonadCatch m, MonadIO m, MonadThings m) + => [NameSpace] -> String -> 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+ _ : _ : _ -> fail "multiple matching variables in scope."+ [v] -> return $ varToNamed v+ [] -> findInNSModGuts ns (parseName nm)++-- | Looks for Named in current GlobalRdrEnv. If not present, calls 'findInNSPackageDB'.+findInNSModGuts :: (HasHscEnv m, HasModGuts m, MonadIO m, MonadThings m) + => NameSpace -> HermitName -> m Named+findInNSModGuts ns nm = do+ rdrEnv <- liftM mg_rdr_env getModGuts+ case lookupGRE_RdrName (toRdrName ns nm) rdrEnv of+ [gre] -> nameToNamed $ gre_name gre+ [] -> findInNSPackageDB ns nm+ _ -> fail "findInNSModGuts: multiple names returned"++-- | Looks for Named in package database, or built-in packages.+findInNSPackageDB :: (HasHscEnv m, HasModGuts 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)+ Just n -> nameToNamed n++-- | Helper to call GHC's lookupRdrNameInModuleForPlugins+lookupName :: (HasModGuts 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+ 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+ [] -> 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+ [] -> fail "type name not in scope."+ [tc] -> return $ NamedTyCon tc+ tcs -> fail $ "multiple TyCons match: " ++ show (map getOccString tcs)+ | otherwise = fail "findNameBuiltIn: unusable NameSpace"++-- | We have a name, find the corresponding Named.+nameToNamed :: MonadThings m => Name -> m Named+nameToNamed n | isVarName n = liftM NamedId $ lookupId n+ | isDataConName n = liftM NamedDataCon $ lookupDataCon n+ | isTyConName n = liftM NamedTyCon $ lookupTyCon n+ | 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)++-- | 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"++findIdBuiltIn :: forall m. Monad m => String -> m Id+findIdBuiltIn = go+ where go ":" = dataConId consDataCon+ go "[]" = dataConId nilDataCon++ go "True" = return trueDataConId+ go "False" = return falseDataConId++ go "<" = return ltDataConId+ go "==" = return eqDataConId+ go ">" = return gtDataConId++ go "I#" = dataConId intDataCon++ go "()" = return unitDataConId+ -- TODO: add more as needed+ -- http://www.haskell.org/ghc/docs/latest/html/libraries/ghc/TysWiredIn.html+ go _ = fail "variable not in scope."++ dataConId :: DataCon -> m Id+ dataConId = return . dataConWorkId+#endif
src/HERMIT/ParserCore.y view
@@ -1,6 +1,16 @@ { {-# LANGUAGE CPP #-}- module HERMIT.ParserCore (parseCore, parseCoreExprT, parse2beforeBiR, parse3beforeBiR, parse4beforeBiR, parse5beforeBiR) where+module HERMIT.ParserCore+ ( parseCore+ , parseCoreExprT+ , parse2beforeBiR+ , parse3beforeBiR+ , parse4beforeBiR+ , parse5beforeBiR+ , Token(..)+ , parseError+ , lexer+ ) where import Control.Arrow import Control.Monad.Reader@@ -11,10 +21,9 @@ import HERMIT.GHC import HERMIT.Kure import HERMIT.Monad+import HERMIT.Name import HERMIT.Syntax (isCoreInfixIdChar, isCoreIdFirstChar, isCoreIdChar) -import HERMIT.Dictionary.Common- import Language.KURE.MonadCatch (prefixFailMsg) } @@ -67,7 +76,7 @@ | arg { $1 } arg : '(' expr ')' { $2 }- | '(' ')' {% lookupName "()" Var }+ | '(' ')' {% lookupName "()" } | var { $1 } | intlit { $1 } | strlit { $1 }@@ -76,7 +85,7 @@ strlit : STRING {% lift $ mkStringExpr $1 } -var : NAME {% lookupName $1 varToCoreExpr }+var : NAME {% lookupName $1 } { mkIntExpr' :: Integer -> CoreParseM CoreExpr@@ -88,11 +97,11 @@ mkIntExpr' i = return $ mkIntExpr i #endif -lookupName :: String -> (Id -> CoreExpr) -> CoreParseM CoreExpr-lookupName nm k = do+lookupName :: String -> CoreParseM CoreExpr+lookupName nm = do c <- ask v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId nm c- return (k v)+ return $ varToCoreExpr v type CoreParseM a = ReaderT HermitC HermitM a @@ -122,6 +131,7 @@ | Tcoloneqcolon | Tstar | Tarrow+ | Tdoublearrow | Tlambda -- | Tat | Tdot@@ -137,13 +147,14 @@ lexer :: String -> Either String [Token] lexer [] = Right []-lexer ('_' :cs) = fmap (Twild:) $ lexer cs-lexer ('(' :cs) = fmap (Toparen:) $ lexer cs-lexer (')' :cs) = fmap (Tcparen:) $ lexer cs-lexer (':':':':cs) = fmap (Tcoloncolon:) $ lexer cs--- lexer (':' :cs) = fmap (Tcolon:) $ lexer cs-lexer ('\\':cs) = fmap (Tlambda:) $ lexer cs-lexer ('-':'>':cs) = fmap (Tarrow:) $ lexer cs+lexer ('_' :cs) = fmap (Twild:) $ lexer cs+lexer ('(' :cs) = fmap (Toparen:) $ lexer cs+lexer (')' :cs) = fmap (Tcparen:) $ lexer cs+lexer (':':':':cs) = fmap (Tcoloncolon:) $ lexer cs+-- lexer (':' :cs) = fmap (Tcolon:) $ lexer cs+lexer ('\\':cs) = fmap (Tlambda:) $ lexer cs+lexer ('-':'>':cs) = fmap (Tarrow:) $ lexer cs+lexer ('=':'>':cs) = fmap (Tdoublearrow:) $ lexer cs lexer ('\"':cs) = let (str,rest) = span (/='\"') cs in case rest of ('\"':cs') -> fmap (Tstring str:) $ lexer cs'@@ -170,7 +181,7 @@ -- These should probably go somewhere else. -- | Parse a 'CoreString' to a 'CoreExpr', using the current context.-parseCoreExprT :: CoreString -> TranslateH a CoreExpr+parseCoreExprT :: CoreString -> TransformH a CoreExpr parseCoreExprT = contextonlyT . parseCore parse2beforeBiR :: (CoreExpr -> CoreExpr -> BiRewriteH a)
+ src/HERMIT/ParserType.y view
@@ -0,0 +1,157 @@+{+{-# LANGUAGE CPP #-}+module HERMIT.ParserType+#if __GLASGOW_HASKELL__ <= 706+ () where+#else+ ( parseType+ , parseTypeT+ , parseTypeWithHoles+ , parseTypeWithHolesT+ ) where+#endif++import Control.Arrow+import Control.Monad.State+import Data.Char (isSpace, isDigit)++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.Syntax (isCoreInfixIdChar, isCoreIdFirstChar, isCoreIdChar)++import Language.KURE.MonadCatch (prefixFailMsg)+}++%name parser+%tokentype { Token }+%error { parseError }+%monad { TypeParseM } { >>= } { return }++%token+ 'forall' { Tforall }+ '%rec' { Trec }+ '%let' { Tlet }+ '%in' { Tin }+ '%case' { Tcase }+ '%of' { Tof }+ '%cast' { Tcast }+ '%note' { Tnote }+ '%external' { Texternal }+ '%local' { Tlocal }+ '%_' { Twild }+ '(' { Toparen }+ ')' { Tcparen }+ '{' { Tobrace }+ '}' { Tcbrace }+ '#' { Thash}+ '=' { Teq }+ ':' { Tcolon }+ '::' { Tcoloncolon }+ ':=:' { Tcoloneqcolon }+ '*' { Tstar }+ '->' { Tarrow }+ '=>' { Tdoublearrow }+ '\\' { Tlambda}+ '@' { Tat }+ '.' { Tdot }+ '?' { Tquestion}+ ';' { Tsemicolon }+ NAME { Tname $$ }+ CNAME { Tcname $$ }+ INTEGER { Tinteger $$ }+ RATIONAL { Trational $$ }+ STRING { Tstring $$ }+ CHAR { Tchar $$ }++%%++-- | Top level type term.+type : tytheta '=>' tyapp { mkPhiTy $1 $3 } -- { uncurry mkSigmaTy $1 $3 }+ | tyapp { $1 }++tytheta : tyapp { [$1] } -- {% liftM (\(tvs,ty) -> (tvs,[ty])) $ catchFrees $1 }++tyapp : tyapp tyarg { mkAppTy $1 $2 }+ | tyarg { $1 }++tyarg : '(' tyapp ')' { $2 }+ | '(' ')' {% lookupName "()" }+ | tyvar { $1 }++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+ either (const (addTyVar nm)) return et++catchFrees :: Type -> TypeParseM ([TyVar], Type)+catchFrees ty = do+ used <- gets tpUsed+ let frees = varSetElems $ freeVarsType ty+ quants = filter (`elem` used) frees+ modify $ \ st -> st { tpUsed = filter (`notElem` frees) (tpUsed st) }+ return (quants, ty)++data TPState = TPState { tpContext :: HermitC+ , tpUsed :: [TyVar]+ }++type TypeParseM a = StateT TPState HermitM a++getContext :: TypeParseM HermitC+getContext = gets tpContext++addTyVar :: String -> TypeParseM Type+addTyVar tvStr = do+ used <- gets tpUsed+ case [ tv | tv <- used, getOccString tv == tvStr ] of+ [] -> do tv <- lift $ newTyVarH tvStr liftedTypeKind+ modify $ \ st -> st { tpUsed = tv : tpUsed st }+ return $ mkTyVarTy tv+ [tv] -> return $ mkTyVarTy tv+ other -> fail "addTyVar: impossible case"++---------------------------------------------++-- | Parse a CoreString into a Type, where all type variables must be bound.+parseType :: CoreString -> HermitC -> HermitM Type+parseType cs c = do+ (ty, holes) <- parseTypeWithHoles cs c+ guardMsg (null holes) "type contains unbound type variables."+ return ty++-- | Parse a CoreString into a Type, any unbound variables are returned.+parseTypeWithHoles :: CoreString -> HermitC -> HermitM (Type, [TyVar])+parseTypeWithHoles (CoreString s) c =+ case lexer s of+ Left msg -> fail msg+ Right tokens -> do+ (ty,st) <- runStateT (parser tokens) (TPState c [])+ return (ty,tpUsed st)++---------------------------------------------++-- | Parse a 'CoreString' to a 'Type', using the current context.+parseTypeT :: CoreString -> TransformH a Type+parseTypeT = contextonlyT . parseType++-- | Parse a 'CoreString' to a 'Type', using the current context, returning unbound type variables.+parseTypeWithHolesT :: CoreString -> TransformH a (Type, [TyVar])+parseTypeWithHolesT = contextonlyT . parseTypeWithHoles++---------------------------------------------++}
src/HERMIT/Plugin.hs view
@@ -35,7 +35,6 @@ import Control.Monad.Operational import Control.Monad.State hiding (guard) -import Data.Default import Data.Monoid import qualified Data.Map as M @@ -70,10 +69,8 @@ emptyTick <- liftIO $ atomically $ newTVar M.empty return $ PluginState { ps_cursor = initSAST- , ps_pretty = Clean.ppCoreTC- , ps_pretty_opts = def { po_width = 80 }+ , ps_pretty = Clean.pretty , ps_render = unicodeConsole- , ps_running_script = False , ps_tick = emptyTick , ps_corelint = False , ps_diffonly = False@@ -85,9 +82,9 @@ data HPMInst :: * -> * where Shell :: [External] -> [CommandLineOption] -> HPMInst () Guard :: (PhaseInfo -> Bool) -> HPM () -> HPMInst ()- Focus :: (Injection ModGuts g, Walker HermitC g) => TranslateH g LocalPathH -> HPM a -> HPMInst a+ 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) => TranslateH g a -> HPMInst a+ Query :: (Injection ModGuts g, Walker HermitC g) => TransformH g a -> HPMInst a newtype HPM a = HPM { unHPM :: ProgramT HPMInst PluginM a } deriving (Functor, Applicative, Monad, MonadIO)@@ -167,10 +164,10 @@ interactive :: [External] -> [CommandLineOption] -> HPM () interactive es os = HPM . singleton $ Shell (externals ++ es) os -run :: RewriteH CoreTC -> HPM ()+run :: (Injection GHC.ModGuts g, Walker HermitC g) => RewriteH g -> HPM () run = HPM . singleton . RR -query :: (Injection GHC.ModGuts g, Walker HermitC g) => TranslateH g a -> HPM a+query :: (Injection GHC.ModGuts g, Walker HermitC g) => TransformH g a -> HPM a query = HPM . singleton . Query ----------------------------- guards ------------------------------@@ -178,7 +175,7 @@ guard :: (PhaseInfo -> Bool) -> HPM () -> HPM () guard p = HPM . singleton . Guard p -at :: TranslateH CoreTC LocalPathH -> HPM a -> HPM a+at :: TransformH CoreTC LocalPathH -> HPM a -> HPM a at tp = HPM . singleton . Focus tp phase :: Int -> HPM () -> HPM ()@@ -217,8 +214,8 @@ modifyCLS :: (PluginState -> PluginState) -> HPM () modifyCLS = HPM . modify -setPretty :: PrettyH CoreTC -> HPM ()+setPretty :: PrettyPrinter -> HPM () setPretty pp = modifyCLS $ \s -> s { ps_pretty = pp } setPrettyOptions :: PrettyOptions -> HPM ()-setPrettyOptions po = modifyCLS $ \s -> s { ps_pretty_opts = po }+setPrettyOptions po = modifyCLS $ \s -> s { ps_pretty = (ps_pretty s) { pOptions = po } }
src/HERMIT/Plugin/Display.hs view
@@ -26,20 +26,16 @@ st <- get focusPath <- getFocusPath let skernel = ps_kernel st- ppOpts = (ps_pretty_opts st) { po_focus = Just focusPath }- -- Do not show focus while loading- ifM (gets ps_running_script)- (return ())- (iokm' "Rendering error: "- (liftIO . ps_render st stdout ppOpts . Right)- (toASTS skernel (ps_cursor st) >>= \ ast ->- queryK (kernelS skernel) ast (extractT $ pathT (fromMaybe focusPath window) $ liftPrettyH ppOpts $ ps_pretty st) (mkKernelEnv st))- )+ ppOpts = (pOptions $ ps_pretty st) { po_focus = Just focusPath }+ iokm' "Rendering error: "+ (liftIO . ps_render st stdout ppOpts . Right)+ (toASTS skernel (ps_cursor st) >>= \ ast ->+ queryK (kernelS skernel) ast (extractT $ pathT (fromMaybe focusPath window) $ liftPrettyH ppOpts $ pCoreTC $ ps_pretty st) (mkKernelEnv st)) ps_putStr :: (MonadIO m, MonadState PluginState m) => String -> m () ps_putStr str = do st <- get- liftIO $ ps_render st stdout (ps_pretty_opts st) (Left str)+ liftIO $ ps_render st stdout (pOptions $ ps_pretty st) (Left str) ps_putStrLn :: (MonadIO m, MonadState PluginState m) => String -> m () ps_putStrLn = ps_putStr . (++"\n")
src/HERMIT/Plugin/Renderer.hs view
@@ -1,18 +1,21 @@+{-# LANGUAGE FlexibleContexts #-} module HERMIT.Plugin.Renderer where +import Control.Arrow import Control.Monad.State -import Data.List (isPrefixOf)+import Data.List (isInfixOf, isPrefixOf, isSuffixOf) import Data.Monoid +import HERMIT.Dictionary (traceR) import HERMIT.Kure import HERMIT.Plugin.Types import HERMIT.PrettyPrinter.Common --- import HERMIT.Shell.Types- import System.Console.ANSI import System.IO+import System.IO.Temp+import System.Process changeRenderer :: String -> PluginM () changeRenderer renderer = modify $ \ st ->@@ -20,6 +23,10 @@ Nothing -> st -- TODO: should fail with message Just r -> st { ps_render = r } +shellRenderers :: [(String,Handle -> PrettyOptions -> Either String DocH -> IO ())]+shellRenderers = [ ("unicode-terminal", unicodeConsole) ]+ ++ [ (nm, \ h opts -> either (hPutStr h) (hPutStr h . fn opts)) | (nm,fn) <- coreRenders ]+ ------------------------------------------------------------------------------- newtype UnicodeTerminal = UnicodeTerminal (Handle -> Maybe PathH -> IO ())@@ -32,10 +39,6 @@ mempty = UnicodeTerminal $ \ _ _ -> return () mappend (UnicodeTerminal f1) (UnicodeTerminal f2) = UnicodeTerminal $ \ h p -> f1 h p >> f2 h p -shellRenderers :: [(String,Handle -> PrettyOptions -> Either String DocH -> IO ())]-shellRenderers = [ ("unicode-terminal", unicodeConsole) ]- ++ [ (nm, \ h opts -> either (hPutStr h) (hPutStr h . fn opts)) | (nm,fn) <- coreRenders ]- unicodeConsole :: Handle -> PrettyOptions -> Either String DocH -> IO () unicodeConsole h _ (Left str) = hPutStr h str unicodeConsole h opts (Right doc) = let UnicodeTerminal r = renderCode opts doc@@ -74,4 +77,44 @@ WarningColor -> [ SetSwapForegroundBackground True, SetColor Foreground Vivid Yellow ] -- TODO: enable rDoHighlight _ (PathAttr p:_) = UnicodeTerminal $ setHighlight $ snocPathToPath p rDoHighlight o (_:rest) = rDoHighlight o rest++----------------------------------------------------------------------------------------------++-- TODO: this should be in PrettyPrinter.Common, but is here because it relies on+-- unicodeConsole to get nice colored diffs. We can either switch to straight unicode+-- renderer and give up on color, or come up with a clever solution.+diffDocH :: (MonadCatch m, MonadIO m) => PrettyPrinter -> DocH -> DocH -> m String+diffDocH pp doc1 doc2 =+ liftAndCatchIO $+ withSystemTempFile "A.dump" $ \ fp1 h1 ->+ withSystemTempFile "B.dump" $ \ fp2 h2 ->+ withSystemTempFile "AB.diff" $ \ fp3 h3 -> do+ let opts = pOptions pp+ unicodeConsole h1 opts (Right doc1)+ hFlush h1+ unicodeConsole h2 opts (Right doc2)+ hFlush h2+ let cmd = unwords ["diff", "-b", "-U 5", fp1, fp2]+ p = (shell cmd) { std_out = UseHandle h3 , std_err = UseHandle h3 }+ (_,_,_,h) <- createProcess p+ _ <- waitForProcess h+ res <- readFile fp3+ -- strip out some of the diff lines+ return $ unlines [ l | l <- lines res, not (fp1 `isInfixOf` l || fp2 `isInfixOf` l)+ , not ("@@" `isPrefixOf` l && "@@" `isSuffixOf` l) ]++-- TODO: again this should be elsewhere, but is here because diffDocH is here.+diffR :: Injection a CoreTC => PrettyPrinter -> String -> RewriteH a -> RewriteH a+diffR pp msg rr = do+ let ppT = extractT $ liftPrettyH (pOptions pp) (pCoreTC pp)+ runDiff b a = do+ doc1 <- return b >>> ppT+ doc2 <- return a >>> ppT+ r <- diffDocH pp doc1 doc2+ return a >>> traceR (msg ++ " diff:\n" ++ r)++ -- Be careful to only run the rr once, in case it has side effects.+ (e,r) <- idR &&& attemptM rr+ either fail (runDiff e) r+
src/HERMIT/Plugin/Types.hs view
@@ -45,10 +45,8 @@ -- Session-local issues; things that are never saved. data PluginState = PluginState { ps_cursor :: SAST -- ^ the current AST- , ps_pretty :: PrettyH CoreTC -- ^ which pretty printer to use- , ps_pretty_opts :: PrettyOptions -- ^ the options for the pretty printer+ , ps_pretty :: PrettyPrinter -- ^ which pretty printer to use , ps_render :: Handle -> PrettyOptions -> Either String DocH -> IO () -- ^ the way of outputing to the screen- , ps_running_script :: Bool -- ^ if running a script , ps_tick :: TVar (M.Map String Int) -- ^ the list of ticked messages , ps_corelint :: Bool -- ^ if true, run Core Lint on module after each rewrite , ps_diffonly :: Bool -- ^ if true, show diffs rather than pp full code (TODO: move into pretty opts)@@ -80,7 +78,8 @@ mkKernelEnv :: PluginState -> HermitMEnv mkKernelEnv st =- let out str = liftIO $ ps_render st stdout (ps_pretty_opts st) (Left $ str ++ "\n")+ let pp = ps_pretty st+ out str = liftIO $ ps_render st stdout (pOptions pp) (Left $ str ++ "\n") in mkHermitMEnv $ \ msg -> case msg of DebugTick msg' -> do@@ -88,8 +87,8 @@ out $ "<" ++ show c ++ "> " ++ msg' DebugCore msg' cxt core -> do out $ "[" ++ msg' ++ "]"- doc :: DocH <- apply (ps_pretty st) (liftPrettyC (ps_pretty_opts st) cxt) (inject core)- liftIO $ ps_render st stdout (ps_pretty_opts st) (Right doc)+ doc :: DocH <- apply (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 ++))
src/HERMIT/PrettyPrinter/AST.hs view
@@ -3,7 +3,8 @@ -- | Output the raw Expr constructors. Helpful for writing pattern matching rewrites. module HERMIT.PrettyPrinter.AST ( -- * HERMIT's AST Pretty-Printer for GHC Core- ppCoreTC+ pretty+ , ppCoreTC , ppModGuts , ppCoreProg , ppCoreBind@@ -18,6 +19,7 @@ import Control.Arrow hiding ((<+>)) import Data.Char (isSpace)+import Data.Default import HERMIT.GHC hiding (($$), (<+>), (<>), ($+$), cat, nest, parens, text, empty, hsep) import HERMIT.Kure@@ -39,6 +41,12 @@ --------------------------------------------------------------------------- +pretty :: PrettyPrinter+pretty = PP { pForall = ppForallQuantification+ , pCoreTC = ppCoreTC+ , pOptions = def+ } + -- | Pretty print a fragment of GHC Core using HERMIT's \"AST\" pretty printer. -- This displays the tree of constructors using nested indentation. ppCoreTC :: PrettyH CoreTC@@ -132,7 +140,9 @@ ppForallQuantification :: PrettyH [Var] ppForallQuantification = do vs <- mapT ppVar- return $ keywordText "forall" <+> hsep vs <> keywordText "."+ if null vs+ then return empty+ else return $ keywordText "forall" <+> hsep vs <> keywordText "." keywordText :: String -> DocH keywordText = keywordColor . text
src/HERMIT/PrettyPrinter/Clean.hs view
@@ -2,7 +2,8 @@ module HERMIT.PrettyPrinter.Clean ( -- * HERMIT's Clean Pretty-Printer for GHC Core- ppCoreTC+ pretty+ , ppCoreTC , ppModGuts , ppCoreProg , ppCoreBind@@ -18,6 +19,7 @@ import Control.Applicative ((<$>)) import Data.Char (isSpace)+import Data.Default import Data.Monoid (mempty) import HERMIT.Context@@ -37,6 +39,12 @@ ------------------------------------------------------------------------------------------------ +pretty :: PrettyPrinter+pretty = PP { pForall = ppForallQuantification+ , pCoreTC = ppCoreTC+ , pOptions = def+ }+ data RetExpr = RetLam AbsolutePathH [DocH] AbsolutePathH DocH | RetLet AbsolutePathH [DocH] AbsolutePathH DocH@@ -333,10 +341,10 @@ ppCoreExpr :: PrettyH CoreExpr ppCoreExpr = ppCoreExprR >>^ normalExpr -ppCoreExprR :: Translate PrettyC HermitM CoreExpr RetExpr+ppCoreExprR :: Transform PrettyC HermitM CoreExpr RetExpr ppCoreExprR = absPathT >>= ppCoreExprPR where- ppCoreExprPR :: AbsolutePathH -> Translate PrettyC HermitM CoreExpr RetExpr+ ppCoreExprPR :: AbsolutePathH -> Transform PrettyC HermitM CoreExpr RetExpr ppCoreExprPR p = lamT ppBinderMode ppCoreExprR (retLam p) <+ letT ppCoreBind ppCoreExprR (retLet p)@@ -357,7 +365,7 @@ ppKindOrType :: PrettyH KindOrType ppKindOrType = ppKindOrTypeR >>^ normalExpr -ppTypeModeR :: Translate PrettyC HermitM KindOrType RetExpr+ppTypeModeR :: Transform PrettyC HermitM KindOrType RetExpr ppTypeModeR = do opts <- prettyC_options ^<< contextT case po_exprTypes opts of@@ -365,10 +373,10 @@ Abstract -> RetAtom <$> typeSymbol _ -> ppKindOrTypeR -ppKindOrTypeR :: Translate PrettyC HermitM KindOrType RetExpr+ppKindOrTypeR :: Transform PrettyC HermitM KindOrType RetExpr ppKindOrTypeR = absPathT >>= ppKindOrTypePR where- ppKindOrTypePR :: AbsolutePathH -> Translate PrettyC HermitM KindOrType RetExpr+ ppKindOrTypePR :: AbsolutePathH -> Transform PrettyC HermitM KindOrType RetExpr ppKindOrTypePR p = tyVarT (RetAtom <$> ppVarOcc) <+ litTyT (RetAtom <$> ppLitTy)@@ -395,14 +403,16 @@ ppForallQuantification :: PrettyH [Var] ppForallQuantification = do vs <- mapT ppBinderMode- return $ specialSymbol mempty ForallSymbol <+> hsep vs <> symbol mempty '.'+ if null vs+ then return empty+ else return $ specialSymbol mempty ForallSymbol <+> hsep vs <> symbol mempty '.' -------------------------------------------------------------------- ppCoercion :: PrettyH Coercion ppCoercion = ppCoercionR >>^ normalExpr -ppCoercionModeR :: Translate PrettyC HermitM Coercion RetExpr+ppCoercionModeR :: Transform PrettyC HermitM Coercion RetExpr ppCoercionModeR = do p <- absPathT opts <- prettyC_options ^<< contextT case po_coercions opts of@@ -411,10 +421,10 @@ Show -> ppCoercionR Kind -> ppCoKind >>^ (\ k -> RetExpr (coercionSymbol p <+> typeOfSymbol p <+> k)) -ppCoercionR :: Translate PrettyC HermitM Coercion RetExpr+ppCoercionR :: Transform PrettyC HermitM Coercion RetExpr ppCoercionR = absPathT >>= ppCoercionPR where- ppCoercionPR :: AbsolutePathH -> Translate PrettyC HermitM Coercion RetExpr+ ppCoercionPR :: AbsolutePathH -> Transform PrettyC HermitM Coercion RetExpr ppCoercionPR p = coVarCoT (RetAtom <$> ppVarOcc) <+ symCoT (ppCoercionR >>> parenExpr >>^ \ co -> RetExpr (coKeyword p "sym" <+> co))
src/HERMIT/PrettyPrinter/Common.hs view
@@ -10,6 +10,7 @@ , coercionColor , idColor , keywordColor+ , syntaxColor , markBindingSite , markColor , typeColor@@ -25,13 +26,14 @@ , RenderSpecial , Unicode(..) -- * Pretty Printer Traversals+ , PrettyPrinter(..) , PrettyH , liftPrettyH , PrettyC(..) , initPrettyC , liftPrettyC- , TranslateDocH(..)- , TranslateCoreTCDocHBox(..)+ , TransformDocH(..)+ , TransformCoreTCDocHBox(..) -- * Pretty Printer Options , PrettyOptions(..) , updateCoShowOption@@ -71,14 +73,14 @@ type DocH = MDoc HermitMark -- newtype wrapper for proper instance selection-newtype TranslateDocH a = TranslateDocH { unTranslateDocH :: PrettyC -> PrettyH a -> TranslateH a DocH }+newtype TransformDocH a = TransformDocH { unTransformDocH :: PrettyC -> PrettyH a -> TransformH a DocH } -data TranslateCoreTCDocHBox = TranslateCoreTCDocHBox (TranslateDocH CoreTC) deriving Typeable+data TransformCoreTCDocHBox = TransformCoreTCDocHBox (TransformDocH CoreTC) deriving Typeable -instance Extern (TranslateDocH CoreTC) where- type Box (TranslateDocH CoreTC) = TranslateCoreTCDocHBox- box = TranslateCoreTCDocHBox- unbox (TranslateCoreTCDocHBox i) = i+instance Extern (TransformDocH CoreTC) where+ type Box (TransformDocH CoreTC) = TransformCoreTCDocHBox+ box = TransformCoreTCDocHBox+ unbox (TransformCoreTCDocHBox i) = i -- These are the zero-width marks on the document data HermitMark@@ -88,7 +90,7 @@ -- These are the attributes data Attr = BndrAttr AbsolutePathH -- path to binding of a variable- | Color SyntaxForColor + | Color SyntaxForColor | PathAttr AbsolutePathH -- path to this spot | SpecialFont deriving (Eq, Show)@@ -121,13 +123,21 @@ keywordColor :: DocH -> DocH keywordColor = markColor KeywordColor +syntaxColor :: DocH -> DocH+syntaxColor = markColor SyntaxColor+ markColor :: SyntaxForColor -> DocH -> DocH markColor = attr . Color specialFont :: DocH -> DocH specialFont = attr SpecialFont -type PrettyH a = Translate PrettyC HermitM a DocH+data PrettyPrinter = PP { pForall :: PrettyH [Var]+ , pCoreTC :: PrettyH CoreTC+ , pOptions :: PrettyOptions+ }++type PrettyH a = Transform PrettyC HermitM a DocH -- TODO: change monads to something more restricted? -- | Context for PrettyH translations.@@ -162,9 +172,14 @@ boundVars :: PrettyC -> VarSet boundVars = mkVarSet . M.keys . prettyC_vars +instance HasEmptyContext PrettyC where+ setEmptyContext :: PrettyC -> PrettyC+ setEmptyContext c = c { prettyC_path = mempty+ , prettyC_vars = M.empty}+ ------------------------------------------------------------------------ -liftPrettyH :: (ReadBindings c, ReadPath c Crumb) => PrettyOptions -> PrettyH a -> Translate c HermitM a DocH+liftPrettyH :: (ReadBindings c, ReadPath c Crumb) => PrettyOptions -> PrettyH a -> Transform c HermitM a DocH liftPrettyH = liftContext . liftPrettyC liftPrettyC :: (ReadBindings c, ReadPath c Crumb) => PrettyOptions -> c -> PrettyC
src/HERMIT/PrettyPrinter/GHC.hs view
@@ -1,7 +1,8 @@ -- | Output the raw Expr constructors. Helpful for writing pattern matching rewrites. module HERMIT.PrettyPrinter.GHC ( -- * GHC's standard Pretty-Printer for GHC Core- ppCoreTC+ pretty+ , ppCoreTC , ppModGuts , ppCoreProg , ppCoreBind@@ -16,16 +17,23 @@ import Control.Arrow hiding ((<+>)) import Data.Char (isSpace)+import Data.Default import HERMIT.Kure import HERMIT.Core-import HERMIT.GHC hiding ((<+>), (<>), char, text, parens, hsep)+import HERMIT.GHC hiding ((<+>), (<>), char, text, parens, hsep, empty) import HERMIT.PrettyPrinter.Common import Text.PrettyPrint.MarkedHughesPJ as PP --------------------------------------------------------------------------- +pretty :: PrettyPrinter+pretty = PP { pForall = ppForallQuantification+ , pCoreTC = ppCoreTC+ , pOptions = def+ }+ -- | This pretty printer is just a reflection of GHC's standard pretty printer. ppCoreTC :: PrettyH CoreTC ppCoreTC =@@ -73,6 +81,8 @@ ppForallQuantification :: PrettyH [Var] ppForallQuantification = do vs <- mapT ppSDoc- return $ text "forall" <+> hsep vs <> text "."+ if null vs+ then return empty+ else return $ text "forall" <+> hsep vs <> text "." ---------------------------------------------------------------------------
src/HERMIT/Shell/Command.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE LambdaCase, ScopedTypeVariables, GADTs, FlexibleContexts #-}+{-# LANGUAGE LambdaCase, ScopedTypeVariables, GADTs, FlexibleContexts, TypeFamilies #-} module HERMIT.Shell.Command ( -- * The HERMIT Command-line Shell@@ -7,134 +7,45 @@ , diffDocH , diffR -- ** Exported for hermit-web- , performKernelEffect , performQuery- , performShellEffect , cl_kernel_env , getFocusPath , shellComplete , evalScript ) where -import Control.Applicative-import Control.Arrow hiding (loop) import Control.Concurrent-import Control.Exception.Base hiding (catch) import Control.Monad.State import Control.Monad.Error import Data.Char-import Data.Monoid-import Data.List (intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub, partition)-import qualified Data.Map as M+import Data.List (isPrefixOf, partition) import Data.Maybe -import HERMIT.Core-import HERMIT.Dictionary import HERMIT.External import qualified HERMIT.GHC as GHC-import HERMIT.Kernel (queryK, AST) import HERMIT.Kernel.Scoped hiding (abortS, resumeS) import HERMIT.Kure import HERMIT.Parser import HERMIT.Plugin.Display import HERMIT.Plugin.Renderer-import HERMIT.Plugin.Types -import HERMIT.PrettyPrinter.Common-import HERMIT.PrettyPrinter.Clean (ppCoreTC)--import HERMIT.Shell.Dictionary import HERMIT.Shell.Externals import HERMIT.Shell.Interpreter+import HERMIT.Shell.KernelEffect import HERMIT.Shell.Proof import HERMIT.Shell.ScriptToRewrite+import HERMIT.Shell.ShellEffect import HERMIT.Shell.Types import System.IO-import System.IO.Temp-import System.Process -- import System.Console.ANSI import System.Console.Haskeline hiding (catch, display) -------------------------------------------------------------------------------------catch :: IO a -> (String -> IO a) -> IO a-catch = catchJust (\ (err :: IOException) -> return (show err))--fixWindow :: MonadIO m => CLT m ()-fixWindow = do- st <- get- -- check to make sure new path is still inside window- focusPath <- pluginM getFocusPath- -- move the window in two cases:- -- 1. window path is not prefix of focus path- -- 2. window path is empty (since at the top level we only show type sigs)- {- when (not (isPrefixOf (cl_window st) focusPath) || null (cl_window st))- $ put $ st { cl_window = focusPath } -}- put $ st { cl_window = focusPath } -- TODO: temporary until we figure out a better highlight interface--showWindow :: MonadIO m => CLT m ()-showWindow = fixWindow >> gets cl_window >>= pluginM . display . Just- ------------------------------------------------------------------------------- -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 (TranslateH 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 (M.keys (cl_dict 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 [])--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--setRunningScript :: MonadIO m => Bool -> CLT m ()-setRunningScript b = modify $ \st -> st { cl_pstate = (cl_pstate st) { ps_running_script = b } }- banner :: String banner = unlines [ "===================== Welcome to HERMIT ======================"@@ -167,7 +78,7 @@ let (flags, filesToLoad) = partition (isPrefixOf "-") opts ws_complete = " ()" - modify $ \ st -> st { cl_dict = mkDict (shell_externals ++ exts) }+ modify $ \ st -> st { cl_externals = shell_externals ++ exts } clState <- get completionMVar <- liftIO $ newMVar clState@@ -186,7 +97,7 @@ Just ('-':'-':_) -> loop Just line -> if all isSpace line then loop- else (evalScript line `ourCatch` cl_putStrLn) >> loop+ else (evalScript line `catchFailHard` cl_putStrLn) >> loop -- Display the banner if any (`elem` ["-v0", "-v1"]) flags@@ -194,15 +105,15 @@ else cl_putStrLn banner -- Load and run any scripts- setRunningScript True- sequence_ [ performShellEffect $ case fileName of- "abort" -> Abort- "resume" -> Resume- _ -> loadAndRun fileName+ setRunningScript $ Just []+ sequence_ [ case fileName of+ "abort" -> performShellEffect Abort+ "resume" -> performShellEffect Resume+ _ -> performScriptEffect runExprH $ loadAndRun fileName | fileName <- reverse filesToLoad , not (null fileName)- ] `ourCatch` \ msg -> cl_putStrLn $ "Booting Failure: " ++ msg- setRunningScript False+ ] `catchFailHard` \ msg -> cl_putStrLn $ "Booting Failure: " ++ msg+ setRunningScript Nothing -- Start the CLI showWindow@@ -210,225 +121,31 @@ (r,s) <- get >>= liftIO . runInputTBehavior behavior settings . flip runCLT loop either throwError (\v -> put s >> return v) r -ourCatch :: MonadIO m => CLT m () -> (String -> CLT m ()) -> CLT m ()-ourCatch m failure = catchM m $ \ msg -> ifM (gets cl_failhard) (performQuery Display >> cl_putStrLn msg >> abort) (failure msg)--evalScript :: MonadIO m => String -> CLT m ()-evalScript = parseScriptCLT >=> runScript--parseScriptCLT :: Monad m => String -> CLT m Script-parseScriptCLT = either fail return . parseScript+-- | Like 'catchM', but checks the 'cl_failhard' setting and does so if needed.+catchFailHard :: MonadIO m => CLT m () -> (String -> CLT m ()) -> CLT m ()+catchFailHard m failure = catchM m $ \ msg -> ifM (gets cl_failhard) (performQuery Display (CmdName "display") >> cl_putStrLn msg >> abort) (failure msg) -runScript :: MonadIO m => Script -> CLT m ()-runScript = mapM_ runExprH+evalScript :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => String -> m ()+evalScript = parseScriptCLT >=> mapM_ runExprH -runExprH :: MonadIO m => ExprH -> CLT m ()+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+ QueryFun query -> performQuery query expr ProofCommand cmd -> performProofCommand cmd -ppWholeProgram :: MonadIO m => AST -> CLT m DocH-ppWholeProgram ast = do- st <- get- liftIO (queryK (kernelS $ cl_kernel st)- ast- (extractT $ pathT [ModGuts_Prog] $ liftPrettyH (cl_pretty_opts st) $ cl_pretty st)- (cl_kernel_env st)) >>= runKureM return fail- ------------------------------------------------------------------------------- -- TODO: This can be refactored. We always showWindow. Also, Perhaps return a modifier, not () -- UPDATE: Not true. We don't always showWindow. -- TODO: All of these should through an exception if they fail to execute the command as given. -performKernelEffect :: MonadIO m => KernelEffect -> ExprH -> CLT m ()-performKernelEffect (Apply rr) expr = do- st <- get-- let sk = cl_kernel st- kEnv = cl_kernel_env st- sast = cl_cursor st- ppOpts = cl_pretty_opts st-- sast' <- prefixFailMsg "Rewrite failed: " $ applyS sk rr kEnv sast-- let commit = put (newSAST expr sast' st) >> showResult- showResult = if cl_diffonly st then showDiff else showWindow- showDiff = do doc1 <- queryS sk (liftPrettyH ppOpts (cl_pretty st)) kEnv sast- doc2 <- queryS sk (liftPrettyH ppOpts (cl_pretty st)) kEnv sast'- diffDocH ppOpts doc1 doc2 >>= cl_putStr-- if cl_corelint st- then do ast' <- toASTS sk sast'- liftIO (queryK (kernelS sk) ast' lintModuleT kEnv)- >>= runKureM (\ warns -> putStrToConsole warns >> commit)- (\ errs -> liftIO (deleteS sk sast') >> fail errs)- else commit--performKernelEffect (Pathfinder 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)- ast <- prefixFailMsg "Path is invalid: " $ modPathS (cl_kernel st) (<> p) (cl_kernel_env st) (cl_cursor st)- put $ newSAST expr ast st- showWindow--performKernelEffect (Direction 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- st <- get- ast <- beginScopeS (cl_kernel st) (cl_cursor st)- put $ newSAST expr ast st- showWindow--performKernelEffect 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--performKernelEffect (CorrectnessCritera q) expr = do- st <- get- -- TODO: Again, we may want a quiet version of the kernel_env- modFailMsg (\ err -> unparseExprH expr ++ " [exception: " ++ err ++ "]")- $ queryS (cl_kernel st) q (cl_kernel_env st) (cl_cursor st)- putStrToConsole $ unparseExprH expr ++ " [correct]"- ------------------------------------------------------------------------------- -performQuery :: MonadIO m => QueryFun -> CLT m ()-performQuery (QueryString q) = do- st <- get- str <- prefixFailMsg "Query failed: " $ queryS (cl_kernel st) q (cl_kernel_env st) (cl_cursor st)- putStrToConsole str--performQuery (QueryDocH q) = do- st <- get- doc <- prefixFailMsg "Query failed: " $ queryS (cl_kernel st) (q (initPrettyC $ cl_pretty_opts st) $ cl_pretty st) (cl_kernel_env st) (cl_cursor st)- liftIO $ cl_render st stdout (cl_pretty_opts st) (Right doc)--performQuery (Inquiry f) = get >>= liftIO . f >>= putStrToConsole--performQuery (Diff s1 s2) = do- st <- get-- ast1 <- toASTS (cl_kernel st) s1- ast2 <- toASTS (cl_kernel st) s2- let getCmds sast | sast == s1 = []- | otherwise = case [ (f,c) | (f,c,to) <- vs_graph (cl_version st), to == sast ] of- [(sast',cmd)] -> unparseExprH cmd : getCmds sast'- _ -> ["error: history broken!"] -- should be impossible-- cl_putStrLn "Commands:"- cl_putStrLn "========="- cl_putStrLn $ unlines $ reverse $ getCmds s2-- doc1 <- ppWholeProgram ast1- doc2 <- ppWholeProgram ast2-- r <- diffDocH (cl_pretty_opts st) doc1 doc2-- cl_putStrLn "Diff:"- cl_putStrLn "====="- cl_putStr r---- Explicit calls to display should work no matter what the loading state is.-performQuery Display = do- running_script_st <- gets cl_running_script- setRunningScript False- showWindow- setRunningScript running_script_st-----------------------------------------------------------------------------------performShellEffect :: MonadIO m => ShellEffect -> CLT m ()-performShellEffect (SeqMeta ms) = mapM_ performShellEffect ms-performShellEffect Abort = abort-performShellEffect Resume = do- st <- get- sast' <- applyS (cl_kernel st) occurAnalyseAndDezombifyR (cl_kernel_env st) (cl_cursor st)- resume sast'--performShellEffect Continue = get >>= continue-performShellEffect (Dump fileName renderer width) = do- st <- get- case lookup renderer shellRenderers of- Just r -> do doc <- prefixFailMsg "Bad renderer option: " $- queryS (cl_kernel st) (liftPrettyH (cl_pretty_opts st) $ cl_pretty st) (cl_kernel_env st) (cl_cursor st)- liftIO $ do h <- openFile fileName WriteMode- r h ((cl_pretty_opts st) { po_width = width }) (Right doc)- hClose h- _ -> fail "dump: bad pretty-printer or renderer option"--performShellEffect (LoadFile scriptName fileName) =- do putStrToConsole $ "Loading \"" ++ fileName ++ "\"..."- res <- liftIO $ try (readFile fileName)- case res of- Left (err :: IOException) -> fail ("IO error: " ++ show err)- Right str -> do script <- parseScriptCLT str- modify $ \ st -> st {cl_scripts = (scriptName,script) : cl_scripts st}- putStrToConsole ("Script \"" ++ scriptName ++ "\" loaded successfully from \"" ++ fileName ++ "\".")--performShellEffect (SaveFile fileName) =- do version <- gets cl_version- putStrToConsole $ "[saving " ++ fileName ++ "]"- -- no checks to see if you are clobering; be careful- liftIO $ writeFile fileName $ showGraph (vs_graph version) (vs_tags version) (SAST 0)--performShellEffect (ScriptToRewrite rewriteName scriptName) =- do script <- lookupScript scriptName- addScriptToDict rewriteName script - putStrToConsole ("Rewrite \"" ++ rewriteName ++ "\" defined successfully.")--performShellEffect (DefineScript scriptName str) =- do script <- parseScriptCLT str- modify $ \ st -> st {cl_scripts = (scriptName,script) : cl_scripts st}- putStrToConsole ("Script \"" ++ scriptName ++ "\" defined successfully.")--performShellEffect (RunScript scriptName) =- do script <- lookupScript scriptName- running_script_st <- gets cl_running_script- setRunningScript True- runScript script `catchError` (\ err -> setRunningScript running_script_st >> throwError err)- setRunningScript running_script_st- putStrToConsole ("Script \"" ++ scriptName ++ "\" ran successfully.")- showWindow--performShellEffect (SaveScript fileName scriptName) =- do script <- lookupScript scriptName- putStrToConsole $ "Saving script \"" ++ scriptName ++ "\" to file \"" ++ fileName ++ "\"."- liftIO $ writeFile fileName $ unparseScript script- putStrToConsole $ "Save successful."--performShellEffect (CLSModify f) = do- st <- get- opt <- liftIO (fmap Right (f st) `catch` \ str -> return (Left str))- case opt of- Right st' -> put st' >> showWindow- Left err -> fail err--performShellEffect (PluginComp m) = pluginM m------------------------------------------------------------------------------------- TODO: merge with cl_putStr defn-putStrToConsole :: MonadIO m => String -> CLT m ()-putStrToConsole str = ifM (gets cl_running_script)- (return ())- (cl_putStrLn str)----------------------------------------------------------- getNavCmd :: IO (Maybe String) getNavCmd = do b_in <- hGetBuffering stdin@@ -468,42 +185,4 @@ , ("f", res "step") ] ++ [ (show n, res (show n)) | n <- [0..9] :: [Int] ]---------------------------------------------------------------------------------------------------- TODO: this should be in PrettyPrinter.Common, but is here because it relies on--- unicodeConsole to get nice colored diffs. We can either switch to straight unicode--- renderer and give up on color, or come up with a clever solution.-diffDocH :: (MonadCatch m, MonadIO m) => PrettyOptions -> DocH -> DocH -> m String-diffDocH opts doc1 doc2 =- liftAndCatchIO $- withSystemTempFile "A.dump" $ \ fp1 h1 ->- withSystemTempFile "B.dump" $ \ fp2 h2 ->- withSystemTempFile "AB.diff" $ \ fp3 h3 -> do- unicodeConsole h1 opts (Right doc1)- hFlush h1- unicodeConsole h2 opts (Right doc2)- hFlush h2- let cmd = unwords ["diff", "-b", "-U 5", fp1, fp2]- p = (shell cmd) { std_out = UseHandle h3 , std_err = UseHandle h3 }- (_,_,_,h) <- createProcess p- _ <- waitForProcess h- res <- readFile fp3- -- strip out some of the diff lines- return $ unlines [ l | l <- lines res, not (fp1 `isInfixOf` l || fp2 `isInfixOf` l)- , not ("@@" `isPrefixOf` l && "@@" `isSuffixOf` l) ]---- TODO: again this should be elsewhere, but is here because diffDocH is here.-diffR :: Injection a CoreTC => PrettyOptions -> String -> RewriteH a -> RewriteH a-diffR opts msg rr = do- let pp = extractT $ liftPrettyH opts ppCoreTC- runDiff b a = do- doc1 <- return b >>> pp- doc2 <- return a >>> pp- r <- diffDocH opts doc1 doc2- return a >>> traceR (msg ++ " diff:\n" ++ r)-- -- Be careful to only run the rr once, in case it has side effects.- (e,r) <- idR &&& attemptM rr- either fail (runDiff e) r
src/HERMIT/Shell/Dictionary.hs view
@@ -7,7 +7,6 @@ import Data.List import Data.Map (Map, fromList, toList) -import HERMIT.Kure import HERMIT.External import HERMIT.PrettyPrinter.Common@@ -37,12 +36,12 @@ -------------------------------------------------------------------------- -- | The pretty-printing dictionaries.-pp_dictionary :: Map String (PrettyH CoreTC)+pp_dictionary :: Map String PrettyPrinter pp_dictionary = fromList- [ ("clean", Clean.ppCoreTC)- , ("ast", AST.ppCoreTC)- , ("ghc", GHCPP.ppCoreTC)- ]+ [ ("clean", Clean.pretty)+ , ("ast", AST.pretty)+ , ("ghc", GHCPP.pretty)+ ] --------------------------------------------------------------------------
src/HERMIT/Shell/Externals.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} module HERMIT.Shell.Externals where @@ -7,6 +7,8 @@ import Data.Monoid import Data.List (intercalate) import qualified Data.Map as M+import Control.Monad (liftM)+import Data.Dynamic (fromDynamic) import HERMIT.Context import HERMIT.Kure@@ -18,15 +20,19 @@ import HERMIT.Shell.Dictionary import HERMIT.Shell.Interpreter+import HERMIT.Shell.KernelEffect import HERMIT.Shell.Proof as Proof+import HERMIT.Shell.ScriptToRewrite+import HERMIT.Shell.ShellEffect import HERMIT.Shell.Types ---------------------------------------------------------------------------------- --- | There are four types of commands.+-- | 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 Translate (read only).+ | 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.@@ -34,19 +40,20 @@ interpShellCommand = [ interp $ \ (RewriteCoreBox rr) -> KernelEffect (Apply rr) , interp $ \ (RewriteCoreTCBox rr) -> KernelEffect (Apply rr)- , interp $ \ (BiRewriteCoreBox br) -> KernelEffect (Apply $ forwardT br)- , interp $ \ (CrumbBox cr) -> KernelEffect (Pathfinder (return (mempty @@ cr) :: TranslateH CoreTC LocalPathH))- , interp $ \ (PathBox p) -> KernelEffect (Pathfinder (return p :: TranslateH CoreTC LocalPathH))- , interp $ \ (TranslateCorePathBox tt) -> KernelEffect (Pathfinder tt)- , interp $ \ (TranslateCoreTCPathBox tt) -> KernelEffect (Pathfinder tt)+ , 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 $ \ (TranslateCoreStringBox tt) -> QueryFun (QueryString tt)- , interp $ \ (TranslateCoreTCStringBox tt) -> QueryFun (QueryString tt)- , interp $ \ (TranslateCoreTCDocHBox tt) -> QueryFun (QueryDocH $ unTranslateDocH tt)- , interp $ \ (TranslateCoreCheckBox tt) -> KernelEffect (CorrectnessCritera tt)- , interp $ \ (TranslateCoreTCCheckBox tt) -> KernelEffect (CorrectnessCritera tt)+ , 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 ]@@ -72,7 +79,7 @@ [ "move to the previous child"] , external "up" (Direction U) [ "move to the parent node"]- , external "down" (deprecatedIntToPathT 0 :: TranslateH Core LocalPathH) -- TODO: short-term solution+ , external "down" (deprecatedIntToPathT 0 :: TransformH Core LocalPathH) -- TODO: short-term solution [ "move to the first child"] , external "navigate" (CLSModify $ \ st -> return $ st { cl_nav = True }) [ "switch to navigate mode" ]@@ -119,14 +126,14 @@ Nothing -> do putStrLn $ "List of Pretty Printers: " ++ intercalate ", " (M.keys pp_dictionary) return st- Just pp -> return $ setPretty st pp)+ Just pp -> return $ flip setPrettyOpts (cl_pretty_opts st) $ setPretty st pp) -- careful to preserve the current options [ "set the pretty printer" , "use 'set-pp ls' to list available pretty printers" ] , external "set-pp-renderer" (PluginComp . changeRenderer) [ "set the output renderer mode"] , external "set-pp-renderer" showRenderers [ "set the output renderer mode"]- , external "dump" Dump+ , external "dump" (Dump (\st -> liftPrettyH (cl_pretty_opts st) $ pCoreTC $ cl_pretty st)) [ "dump <filename> <renderer> <width>"] , external "set-pp-width" (\ w -> CLSModify $ \ st -> return $ setPrettyOpts st (updateWidthOption w (cl_pretty_opts st)))@@ -172,6 +179,10 @@ ,"Note that any names in the script will not be resolved until the script is *run*." ] , external "display-scripts" displayScripts ["Display all loaded scripts."]+ , external "stop-script" (CLSModify $ \st -> return $ st { cl_running_script = Nothing })+ [ "Stop running the current script." ]+ --, external "test-rewrites" (testRewrites :: [(ExternalName,RewriteH Core)] -> TransformH Core String) ["Test a given set of rewrites to see if they succeed"] .+ Experiment+ , external "possible-rewrites" (testAllT:: CommandLineState-> TransformH Core String) ["Test all given set of rewrites to see if they succeed"] .+ Experiment -- TODO: maybe add a "list-scripts" as well that just lists the names of loaded scripts? ] ++ Proof.externals @@ -213,7 +224,7 @@ [] -> fail "Cannot step forward (no more steps)." [(_,cmd,d) ] -> do putStrLn $ "step : " ++ unparseExprH cmd- return $ setCursor st d + return $ setCursor st d _ -> fail "Cannot step forward (multiple choices)" Back -> do let ns = [ edge | edge@(_,_,d) <- vs_graph (cl_version st), d == cl_cursor st ]@@ -260,17 +271,6 @@ ] -showGraph :: [(SAST,ExprH,SAST)] -> [(String,SAST)] -> SAST -> String-showGraph graph tags this@(SAST n) =- (if length paths > 1 then "tag " ++ show n ++ "\n" else "") ++- concat (intercalate- ["goto " ++ show n ++ "\n"]- [ [ unparseExprH b ++ "\n" ++ showGraph graph tags c ]- | (b,c) <- paths- ])- where- paths = [ (b,c) | (a,b,c) <- graph, a == this ]- ------------------------------------------------------------------------------- displayScripts :: QueryFun@@ -280,3 +280,28 @@ showScripts = concatMap (\ (name,script) -> name ++ ": " ++ unparseScript script ++ "\n\n") -------------------------------------------------------------------------------+testAllT :: CommandLineState -> TransformH Core String+testAllT st = do+ let es = cl_externals st+ mbs = map (\d -> (externName d, fromDynamic (externDyn d) :: Maybe RewriteCoreBox)) es+ namedRewrites = [(name ,unbox boxedR) | (name, Just boxedR) <- mbs]+ testRewrites False namedRewrites++testRewrites :: Bool-> [(ExternalName, RewriteH Core)] -> TransformH Core String+testRewrites debug rewrites = case debug of+ True -> let list = mapM (\ (n,r) -> liftM (f n) (testM r)) rewrites+ in liftM unlines list+ False -> let list = mapM (\ (n,r) -> liftM (g n) (testM r)) rewrites+ filtered = liftM (filter(\x -> snd x)) list+ res = liftM (map (\ (n,b) -> f n b )) filtered+ in liftM unlines res+{-testRewrites rewrites = let list = mapM (\ (n,r) -> liftM (g n) (testM r)) rewrites+ filtered = liftM (filter (\ x -> snd x)) list+ res = liftM (map (\ (n, b) -> f n b)) filtered+ in liftM unlines res+-}+ where+ f :: ExternalName -> Bool -> String+ f x True = x++" would succeed."+ f x False = x++" would fail."+ g x y = (x,y)
src/HERMIT/Shell/Interpreter.hs view
@@ -5,8 +5,10 @@ Interp , interp , interpExprH+-- , runExprH ) where +import Control.Monad.Error import Control.Monad.State import Data.Char@@ -15,34 +17,44 @@ import HERMIT.External import HERMIT.Parser-import HERMIT.Kure (deprecatedIntToPathT,pathToSnocPath)+import HERMIT.Kure +import HERMIT.Shell.Dictionary import HERMIT.Shell.Types --- | 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 a] -> ExprH -> m a-interpExprH interps e = do - dyns <- interpExpr e- runInterp e dyns interps--runInterp :: Monad m => ExprH -> [Dynamic] -> [Interp b] -> m b-runInterp e dyns interps = case [f a | Interp f <- interps, Just a <- map fromDynamic dyns] of- [] -> fail $ "Does not type-check: " ++ unparseExprH e ++ "\n"- b:_ -> return b---- | An 'Interp' @a@ is a /possible/ means of converting a 'Typeable' value to a value of type @a@.+-- | 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 -> b) -> Interp b+ Interp :: Typeable a => (a -> cmd) -> Interp cmd -- | The primitive way of building an 'Interp'.-interp :: Typeable a => (a -> b) -> Interp b+interp :: Typeable a => (a -> cmd) -> Interp cmd interp = Interp instance Functor Interp where fmap :: (a -> b) -> Interp a -> Interp b fmap f (Interp g) = Interp (f . g) +{-+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+-} +-- | 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++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+ interpExpr :: MonadState CommandLineState m => ExprH -> m [Dynamic] interpExpr = interpExpr' False @@ -63,7 +75,7 @@ return $ toBoxedList dyns StringListBox ++ toBoxedList dyns (PathBox . pathToSnocPath) -- ugly hack. The whole dynamic stuff could do with overhauling.- ++ toBoxedList dyns (TranslateCorePathBox . return . pathToSnocPath) + ++ toBoxedList dyns (TransformCorePathBox . return . pathToSnocPath) ++ toBoxedList dyns IntListBox ++ toBoxedList dyns RewriteCoreListBox @@ -73,10 +85,10 @@ return [ -- An Int is either a Path, or will be interpreted specially later. toDyn $ IntBox i -- TODO: Find a better long-term solution.- , toDyn $ TranslateCorePathBox (deprecatedIntToPathT i) + , toDyn $ TransformCorePathBox (deprecatedIntToPathT i) ] | otherwise = do- dict <- gets cl_dict+ dict <- gets (mkDict . cl_externals) case M.lookup str dict of Just dyns -> do dyns' <- mapM provideState dyns
+ src/HERMIT/Shell/KernelEffect.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, GADTs, TypeFamilies #-}++module HERMIT.Shell.KernelEffect + ( KernelEffect(..)+ , performKernelEffect+ ) where++import Control.Monad.State+import Control.Monad.Error++import Data.Monoid+import Data.Typeable++import HERMIT.Context+import HERMIT.Dictionary+import HERMIT.External+import qualified HERMIT.GHC as GHC+import HERMIT.Kernel (queryK)+import HERMIT.Kernel.Scoped hiding (abortS, resumeS)+import HERMIT.Kure+import HERMIT.Parser++import HERMIT.Plugin.Renderer++import HERMIT.PrettyPrinter.Common++import HERMIT.Shell.Types++-------------------------------------------------------------------------------++-- 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+ deriving Typeable++instance Extern KernelEffect where+ type Box KernelEffect = KernelEffect+ box i = i+ unbox i = i++-------------------------------------------------------------------------------++performKernelEffect :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) + => KernelEffect -> ExprH -> m ()++performKernelEffect (Apply rr) expr = do+ st <- get++ let sk = cl_kernel st+ kEnv = cl_kernel_env st+ sast = cl_cursor st+ ppOpts = cl_pretty_opts st+ pp = pCoreTC $ cl_pretty st++ sast' <- prefixFailMsg "Rewrite failed: " $ applyS sk rr kEnv sast++ let commit = put (newSAST expr sast' st) >> showResult+ showResult = if cl_diffonly st then showDiff else showWindow+ showDiff = do doc1 <- queryS sk (liftPrettyH ppOpts pp) kEnv sast+ doc2 <- queryS sk (liftPrettyH ppOpts pp) kEnv sast'+ diffDocH (cl_pretty st) doc1 doc2 >>= cl_putStr++ if cl_corelint st+ then do ast' <- toASTS sk sast'+ liftIO (queryK (kernelS sk) ast' lintModuleT kEnv)+ >>= runKureM (\ warns -> putStrToConsole warns >> commit)+ (\ errs -> liftIO (deleteS sk sast') >> fail errs)+ else commit++performKernelEffect (Pathfinder 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)+ ast <- prefixFailMsg "Path is invalid: " $ modPathS (cl_kernel st) (<> p) (cl_kernel_env st) (cl_cursor st)+ put $ newSAST expr ast st+ showWindow++performKernelEffect (Direction 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+ st <- get+ ast <- beginScopeS (cl_kernel st) (cl_cursor st)+ put $ newSAST expr ast st+ showWindow++performKernelEffect 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++-------------------------------------------------------------------------------
src/HERMIT/Shell/Proof.hs view
@@ -1,100 +1,133 @@-{-# LANGUAGE TypeFamilies, DeriveDataTypeable, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,+ ScopedTypeVariables, TypeFamilies, TypeSynonymInstances #-} -module HERMIT.Shell.Proof where+module HERMIT.Shell.Proof+ ( externals+ , ProofCommand(..)+ , performProofCommand+ , UserProofTechnique+ , userProofTechnique+ , ppLemmaT+ ) where -import Control.Arrow+import Control.Arrow hiding (loop, (<+>))+import Control.Concurrent import Control.Monad.Error import Control.Monad.State +import Data.Char (isSpace) import Data.Dynamic-import Data.List-import Data.Maybe (isNothing)+import Data.List (delete, isInfixOf) import HERMIT.Core import HERMIT.External-import HERMIT.GHC+import HERMIT.GHC hiding (settings, (<>), text, sep, (<+>), ($+$), nest) import HERMIT.Kernel.Scoped import HERMIT.Kure+import HERMIT.Parser import HERMIT.Utilities -import HERMIT.Dictionary.Common-import HERMIT.Dictionary.Debug+import HERMIT.Dictionary.GHC hiding (externals) import HERMIT.Dictionary.Induction-import HERMIT.Dictionary.Reasoning-import HERMIT.Dictionary.Rules+import HERMIT.Dictionary.Reasoning hiding (externals)+import HERMIT.Dictionary.Rules hiding (externals) import HERMIT.Plugin.Types import HERMIT.PrettyPrinter.Common-import qualified HERMIT.PrettyPrinter.Clean as Clean +import HERMIT.Shell.Interpreter+import HERMIT.Shell.KernelEffect import HERMIT.Shell.ScriptToRewrite+import HERMIT.Shell.ShellEffect import HERMIT.Shell.Types +import System.Console.Haskeline hiding (catch, display) import System.IO +import Text.PrettyPrint.MarkedHughesPJ as PP+ -------------------------------------------------------------------------------------------------------- +-- | Externals that get us into the prover shell, or otherwise deal with lemmas. externals :: [External]-externals =- [ external "script-to-proof" scriptToProof- [ "Convert a loaded script to an equality proof, by applying the script as a LHS to RHS rewrite." ]- , external "script-both-sides-to-proof" scriptBothSidesToProof- [ "Convert a pair of loaded scripts to a proof, by applying the first script to the LHS and the second script to the RHS." ]- , external "rewrite-to-proof" (rewriteToProof . extractR :: RewriteH Core -> ProofH)- [ "Convert a rewrite to an equality proof, by applying it to the LHS." ]- , external "rewrite-both-sides-to-proof" ((\ r1 r2 -> rewriteBothSidesToProof (extractR r1) (extractR r2)) :: RewriteH Core -> RewriteH Core -> ProofH)- [ "Convert a pair of rewrites to a proof, by applying the first rewrite to the LHS and the second rewrite to the RHS." ]- , external "lemma-to-proof" lemmaToProof- [ "Convert a (proven) lemma to an equality proof." ]- , external "inductive-proof" (inductiveProofExt :: String -> [String] -> [ScriptName] -> ProofH)- [ "inductive-proof <id-name> [<data-con-name>] [<script-name>]"- , "Build an equality proof by induction on the named identifier."- , "Takes a list of proofs (in the form of scripts converting the LHS to the RHS) for each data constructor case,"- , "in the same order as the given list of data constructor names."- , "For example: inductive-proof 'xs [ '[] , ': ] [ \"NilCaseScript\" , \"ConsCaseScript\" ]"- , "The induction hypotheses are available for use under the names ind-hyp-0, ind-hyp-1, etc..."- ]- , external "inductive-proof-both-sides" (inductiveProofBothSidesExt :: String -> [String] -> [ScriptName] -> [ScriptName] -> ProofH)- [ "inductive-proof-both-sides <id-name> [<data-con-name>] [<script-name>] [<script-name>]"- , "As inductive-proof, but takes scripts to apply to the RHS of each case as well as the LHS."- ]- , external "flip-proof" flipProof- [ "Flip the LHS and RHS of a proof."- , "Example usage: flip-proof (rewrite-to-proof r)"- ]- , external "rule-to-lemma" RuleToLemma+externals = map (.+ Proof)+ [ external "rule-to-lemma" RuleToLemma [ "Create a lemma from a GHC RULE." ]- , external "show-lemmas" ShowLemmas+ , 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 "verify-lemma" VerifyLemma- [ "Prove a lemma." ] , 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 <lemma-name> <filename> <renderer> <width>" ]+ , 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." ] ] -----------------------------------------------------------------------------------------------------------data ProofH = RewritingProof ScriptOrRewrite ScriptOrRewrite -- ^ Prove by rewriting both sides to a common intermediate expression.- | InductiveProof (Id -> Bool) [((Maybe DataCon -> Bool), ScriptOrRewrite, ScriptOrRewrite)] -- ^ Prove by induction. 'Nothing' is the 'undefined' case.- | UserProof (TranslateH CoreExprEquality ()) -- ^ A user-defined proof technique.- | ProofH (CoreExprEquality -> CLT IO ()) -- ^ User-defined proof with full access to shell monad stack.--type ScriptOrRewrite = Either ScriptName (RewriteH CoreExpr) -- The named script should be convertible to a Rewrite.+-- | Externals that are added to the dictionary only when in interactive proof mode.+proof_externals :: [External]+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."+ ]+ , external "dump" PCDump+ [ "dump <filename> <renderer> <width>" ]+ , external "end-proof" PCEnd+ [ "check for alpha-equality, marking the lemma as proven" ]+ , external "end-case" PCEnd+ [ "check for alpha-equality, marking the proof case as proven" ]+ ] -------------------------------------------------------------------------------------------------------- data ProofCommand = RuleToLemma RuleNameString- | VerifyLemma LemmaName ProofH- | ShowLemmas+ | InteractiveProof LemmaName+ | ModifyLemma LemmaName (String -> String) (RewriteH CoreExprEquality) (Bool -> Bool)+ | QueryLemma LemmaName (TransformH CoreExprEquality String)+ | ShowLemmas (Maybe LemmaName)+ | DumpLemma LemmaName String String Int deriving (Typeable) instance Extern ProofCommand where@@ -102,78 +135,17 @@ box i = i unbox i = i -data ProofBox = ProofBox ProofH deriving Typeable--instance Extern ProofH where- type Box ProofH = ProofBox- box = ProofBox- unbox (ProofBox p) = p- -------------------------------------------------------------------------------------------------------- --- | Verify an equality by applying a user-supplied predicate.--- If the predicate holds, HERMIT accepts the equality as proven.-userProofTechnique :: TranslateH CoreExprEquality () -> ProofH-userProofTechnique = UserProof------------------------------------------------------------------------------------------------------------scriptToProof :: ScriptName -> ProofH-scriptToProof s = RewritingProof (Left s) (Right idR)--scriptBothSidesToProof :: ScriptName -> ScriptName -> ProofH-scriptBothSidesToProof s1 s2 = RewritingProof (Left s1) (Left s2)--rewriteToProof :: RewriteH CoreExpr -> ProofH-rewriteToProof r = RewritingProof (Right r) (Right idR)--rewriteBothSidesToProof :: RewriteH CoreExpr -> RewriteH CoreExpr -> ProofH-rewriteBothSidesToProof r1 r2 = RewritingProof (Right r1) (Right r2)------------------------------------------------------------------------------------------------------------inductiveProof :: (Id -> Bool) -> [((Maybe DataCon -> Bool), ScriptName)] -> ProofH-inductiveProof p cases = InductiveProof p (map (\ (dp,s) -> (dp, Left s, Right idR)) cases)--inductiveProofBothSides :: (Id -> Bool) -> [((Maybe DataCon -> Bool), ScriptName, ScriptName)] -> ProofH-inductiveProofBothSides p cases = InductiveProof p (map (\ (dp,s1,s2) -> (dp, Left s1, Left s2)) cases)-------------------------------------------------------------------------------------------------------------- inductiveProofExt :: String -> [(String, ScriptName)] -> ProofH--- inductiveProofExt idn cases = inductiveProof (cmpString2Var idn) [ ((cmpString2Name dcn . dataConName), sn) | (dcn,sn) <- cases ]---- TODO: Upgrade the parser so that this can be a list of pairs.-inductiveProofExt :: String -> [String] -> [ScriptName] -> ProofH-inductiveProofExt idn dcns sns = inductiveProof (cmpString2Var idn) (zip (caseNamePreds dcns) sns)---- inductiveProofBothSidesExt :: String -> [(String, ScriptName, ScriptName)] -> ProofH--- inductiveProofBothSidesExt idn cases = inductiveProofBothSides (cmpString2Var idn) [ ((cmpString2Name dcn . dataConName), sln, srn) | (dcn,sln,srn) <- cases ]---- TODO: Upgrade the parser so that this can be a list of triples.-inductiveProofBothSidesExt :: String -> [String] -> [ScriptName] -> [ScriptName] -> ProofH-inductiveProofBothSidesExt idn dcns s1ns s2ns = inductiveProofBothSides (cmpString2Var idn) (zip3 (caseNamePreds dcns) s1ns s2ns)---- isNothing for the undefined case-caseNamePreds :: [String] -> [Maybe DataCon -> Bool]-caseNamePreds dcns = isNothing : [ maybe False (cmpString2Name dcn . dataConName) | dcn <- dcns ]------------------------------------------------------------------------------------------------------------flipProof :: ProofH -> ProofH-flipProof (RewritingProof sr1 sr2) = RewritingProof sr2 sr1-flipProof (InductiveProof pr cases) = InductiveProof pr [ (dp,s2,s1) | (dp,s1,s2) <- cases ]-flipProof (UserProof t) = UserProof (arr flipCoreExprEquality >>> t)-flipProof (ProofH p) = ProofH (p . flipCoreExprEquality)----------------------------------------------------------------------------------------------------------- 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@@ -182,9 +154,6 @@ ) birewrite -lemmaToProof :: CommandLineState -> LemmaName -> ProofH-lemmaToProof st nm = rewriteToProof (forwardT (lemma False st nm))- -------------------------------------------------------------------------------------------------------- lemmaNameToEqualityT :: Monad m => CommandLineState -> LemmaName -> m CoreExprEquality@@ -202,119 +171,265 @@ -------------------------------------------------------------------------------------------------------- -performProofCommand :: MonadIO m => ProofCommand -> CLT m ()+performProofCommand :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => ProofCommand -> m () performProofCommand (RuleToLemma nm) = do st <- gets cl_pstate- equality <- queryS (ps_kernel st) (ruleNameToEqualityT nm :: TranslateH Core CoreExprEquality) (mkKernelEnv st) (ps_cursor st)- modify $ \ s -> s { cl_lemmas = (nm,equality,False) : cl_lemmas s }+ equality <- queryS (ps_kernel st) (ruleNameToEqualityT nm :: TransformH Core CoreExprEquality) (mkKernelEnv st) (ps_cursor st)+ _ <- addLemmas [(nm,equality,False)]+ return () -performProofCommand (VerifyLemma nm proof) = do+performProofCommand (InteractiveProof nm) = get >>= flip getLemmaByName nm >>= interactiveProof True++performProofCommand (ModifyLemma nm nFn rr pFn) = do st <- get- (_,equality,_) <- getLemmaByName st nm- prove equality proof -- this is like a guard- markProven nm+ (_,eq,p) <- getLemmaByName st nm -performProofCommand ShowLemmas = gets cl_lemmas >>= \ ls -> forM_ (reverse ls) printLemma+ -- 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 () -printLemma :: MonadIO m => Lemma -> CLT m ()-printLemma (nm, CoreExprEquality bs lhs rhs, proven) = do- st <- gets cl_pstate- let k = ps_kernel st- env = mkKernelEnv st- sast = ps_cursor st- pos = ps_pretty_opts st- pp = ps_pretty st- pr :: [Var] -> CoreExpr -> TranslateH Core DocH- pr vs e = return e >>> withVarsInScope vs (extractT $ liftPrettyH pos pp)- cl_putStr nm- cl_putStrLn $ if proven then " (Proven)" else " (Not Proven)"- unless (null bs) $ do- forallDoc <- queryS k (return bs >>> extractT (liftPrettyH pos Clean.ppForallQuantification) :: TranslateH Core DocH) env sast -- TODO: rather than hardwiring the Clean PP here, we should store a pretty printer in the shell state, which should match the main PP, and be updated correspondingly.- liftIO $ ps_render st stdout pos (Right forallDoc)- lDoc <- queryS k (pr bs lhs) env sast- rDoc <- queryS k (pr bs rhs) env sast- liftIO $ ps_render st stdout pos (Right lDoc)- cl_putStrLn "=="- liftIO $ ps_render st stdout pos (Right rDoc)- cl_putStrLn ""+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++performProofCommand (DumpLemma nm fn r w) = dump (\ st -> getLemmaByName st nm >>> ppLemmaT (cl_pretty st)) fn r w++performProofCommand (ShowLemmas mnm) = do+ ls <- gets $ filter (maybe (const True) (\ nm (n,_,_) -> nm `isInfixOf` n) mnm) . cl_lemmas+ forM_ ls printLemma+ -------------------------------------------------------------------------------------------------------- --- | Prove a lemma using the given proof in the current kernel context.--- Required to fail if proof fails.-prove :: MonadIO m => CoreExprEquality -> ProofH -> CLT m ()-prove eq (RewritingProof lp rp) = do- (lrr, rrr) <- getRewrites (lp, rp)- st <- gets cl_pstate- queryS (ps_kernel st) (return eq >>> verifyCoreExprEqualityT (lrr, rrr) :: TranslateH Core ()) (mkKernelEnv st) (ps_cursor st)+printLemma :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => Lemma -> m ()+printLemma 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)+ liftIO $ cl_render st stdout (cl_pretty_opts st) (Right doc) --- InductiveProof (Id -> Bool) [((DataCon -> Bool), ScriptOrRewrite, ScriptOrRewrite)]--- inductionOnT :: forall c. (AddBindings c, ReadBindings c, ReadPath c Crumb, ExtendPath c Crumb, Walker c Core)--- => (Id -> Bool)--- -> (DataCon -> [BiRewrite c HermitM CoreExpr] -> CoreExprEqualityProof c HermitM)--- -> Translate c HermitM CoreExprEquality ()-prove eq@(CoreExprEquality bs lhs rhs) (InductiveProof idPred caseProofs) = do+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)")+ 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++interactiveProof :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => Bool -> Lemma -> m ()+interactiveProof topLevel lem = do+ origEs <- addProofExternals topLevel+ origSt <- get+ completionMVar <- liftIO $ newMVar origSt++ let ws_complete = " ()"++ -- Main proof input loop+ loop :: Lemma -> CLT (InputT IO) ()+ loop l = do+ mExpr <- 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> "+ 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++ -- Display a proof banner?++ -- Start the CLI+ let settings = setComplete (completeWordWithPrev Nothing ws_complete (shellComplete completionMVar)) 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"++addProofExternals :: MonadState CommandLineState m => Bool -> m [External]+addProofExternals topLevel = do st <- get- let ps = cl_pstate st+ let es = cl_externals st+ -- commands with same same in proof_externals will override those in normal externals+ newEs = proof_externals ++ filter ((`notElem` (map externName proof_externals)) . externName) es+ when topLevel $ modify $ \ s -> s { cl_externals = newEs }+ return es +evalProofScript :: MonadIO m => Lemma -> String -> CLT m Lemma+evalProofScript lem = parseScriptCLT >=> foldM runExprH lem++runExprH :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => Lemma -> ExprH -> m Lemma+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+ st <- get++ let sk = cl_kernel st+ kEnv = cl_kernel_env st+ 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."++performProofShellCommand :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => Lemma -> ProofShellCommand -> m Lemma+performProofShellCommand lem@(nm, eq, b) = go+ where go (PCRewrite rr) = do+ st <- get+ let sk = cl_kernel st+ kEnv = cl_kernel_env st+ 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)+ go (PCTransform t) = do+ st <- get+ let sk = cl_kernel st+ kEnv = cl_kernel_env st+ sast = cl_cursor st++ -- Why do a query? See above.+ res <- queryS sk (return eq >>> t :: TransformH Core String) kEnv sast+ cl_putStrLn res+ return lem+ go (PCInduction idPred) = performInduction lem idPred+ go (PCShell effect) = performShellEffect effect >> return lem+ go (PCScript effect) = do+ lemVar <- liftIO $ newMVar lem -- couldn't resist that name+ let lemHack e = liftIO (takeMVar lemVar) >>= flip runExprH e >>= \l -> liftIO (putMVar lemVar l)+ performScriptEffect lemHack effect+ liftIO $ takeMVar lemVar+ go (PCQuery query) = performQuery query (error "PCQuery ExprH") >> return lem+ go (PCProofCommand cmd) = performProofCommand cmd >> return lem+ go (PCUser prf) = let UserProofTechnique t = prf in -- may add more constructors later+ do+ 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+ return lem -- never reached+ go (PCDump fName r w) = dump (\ st -> return lem >>> ppLemmaT (cl_pretty st)) 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+ st <- get+ let sk = cl_kernel st+ kEnv = cl_kernel_env st+ sast = cl_cursor st+ i <- setFailMsg "specified identifier is not universally quantified in this equality lemma." $ soleElement (filter idPred bs)- cases <- queryS (ps_kernel ps) (inductionCaseSplit bs i lhs rhs :: TranslateH Core [(Maybe DataCon,[Var],CoreExpr,CoreExpr)]) (mkKernelEnv ps) (ps_cursor ps)+ -- Why do a query? We want to do our proof in the current context of the shell, whatever that is.+ cases <- queryS sk (inductionCaseSplit bs i lhs rhs :: TransformH Core [(Maybe DataCon,[Var],CoreExpr,CoreExpr)]) kEnv sast forM_ cases $ \ (mdc,vs,lhsE,rhsE) -> do - (lp,rp) <- getProofsForCase mdc caseProofs- let vs_matching_i_type = filter (typeAlphaEq (varType i) . varType) vs- -- Generate list of specialized induction hypotheses for the recursive cases.- eqs = [ discardUniVars $ instantiateCoreExprEqVar i (Var i') eq- | i' <- vs_matching_i_type ]- brs = map birewrite eqs- nms = [ "ind-hyp-" ++ show n | n :: Int <- [0..] ] - forM_ [ (nm, e, True) | (nm,e) <- zip nms eqs ] printLemma- catchError (do put $ addToDict (zip nms brs) st- (l,r) <- getRewrites (lp,rp)- prove (CoreExprEquality (delete i bs ++ vs) lhsE rhsE) (rewriteBothSidesToProof l r) -- recursion!- )- (\ err -> put st >> throwError err)- put st -- put original state (with original dictionary) back+ -- Generate list of specialized induction hypotheses for the recursive cases.+ eqs <- forM vs_matching_i_type $ \ i' ->+ liftM discardUniVars $ instantiateEqualityVar (==i) (Var i') [] eq -prove eq (UserProof t) =- do st <- gets cl_pstate- queryS (ps_kernel st) (return eq >>> t :: TranslateH Core ()) (mkKernelEnv st) (ps_cursor st)+ 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 ) -prove eq (ProofH p) = clm2clt (p eq)+ origLemmas <- addLemmas hypLemmas+ interactiveProof False caseLemma -- recursion!+ modify $ \ s -> s { cl_lemmas = origLemmas } -- put original lemmas back -getProofsForCase :: Monad m => Maybe DataCon -> [(Maybe DataCon -> Bool, ScriptOrRewrite, ScriptOrRewrite)] -> m (ScriptOrRewrite, ScriptOrRewrite)-getProofsForCase mdc cases =- let dcnm = maybe "undefined" getOccString mdc- in case [ (l,r) | (dcPred, l, r) <- cases, dcPred mdc ] of- [] -> fail $ "no case for " ++ dcnm- [p] -> return p- _ -> fail $ "more than one case for " ++ dcnm+ completeProof nm+ return lem -- this is never reached, but the type says we need it. -addToDict :: [(String, BiRewriteH CoreExpr)] -> CommandLineState -> CommandLineState-addToDict rs st = st { cl_dict = foldr (\ (nm,r) -> addToDictionary (external nm (promoteExprBiR (beforeBiR (observeR ("Applying " ++ nm ++ " to: ")) (const r)) :: BiRewriteH Core) [])) (cl_dict st) rs }+addLemmas :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m) => [Lemma] -> m [Lemma]+addLemmas lems = do+ ifM isRunningScript (return ()) $ forM_ lems printLemma+ st <- get+ put $ st { cl_lemmas = cl_lemmas st ++ lems }+ return $ cl_lemmas st -{-- let verifyInductiveCaseT :: (DataCon,[Var],CoreExpr,CoreExpr) -> Translate c HermitM x ()- verifyInductiveCaseT (con,vs,lhsE,rhsE) =- let vs_matching_i_type = filter (typeAlphaEq (varType i) . varType) vs- eqs = [ discardUniVars (instantiateCoreExprEq [(i,Var i')] eq) | i' <- vs_matching_i_type ]- brs = map birewrite eqs -- These eqs now have no universally quantified variables.- -- Thus they can only be used on variables in the induction hypothesis.- -- TODO: consider whether this is unneccassarily restrictive- caseEq = CoreExprEquality (delete i bs ++ vs) lhsE rhsE- in return caseEq >>> verifyCoreExprEqualityT (genCaseAltProofs con brs)+data ProofShellCommand+ = PCRewrite (RewriteH CoreExprEquality)+ | PCTransform (TransformH CoreExprEquality String)+ | PCInduction (Id -> Bool)+ | PCShell ShellEffect+ | PCScript ScriptEffect+ | PCQuery QueryFun+ | PCProofCommand ProofCommand+ | PCUser UserProofTechnique+ | PCDump String String Int+ | PCEnd+ | PCUnsupported String+ deriving Typeable - mapM_ verifyInductiveCaseT cases--}+-- keep abstract to avoid breaking things if we modify this later+newtype UserProofTechnique = UserProofTechnique (TransformH CoreExprEquality ()) -getRewrites :: MonadState CommandLineState m => (ScriptOrRewrite, ScriptOrRewrite) -> m (RewriteH CoreExpr, RewriteH CoreExpr)-getRewrites (l,r) = liftM2 (,) (getRewrite l) (getRewrite r)+userProofTechnique :: TransformH CoreExprEquality () -> UserProofTechnique+userProofTechnique = UserProofTechnique -getRewrite :: MonadState CommandLineState m => ScriptOrRewrite -> m (RewriteH CoreExpr)-getRewrite = either (lookupScript >=> liftM extractR . scriptToRewrite) return+instance Extern ProofShellCommand where+ type Box ProofShellCommand = ProofShellCommand+ box i = i+ unbox i = i -markProven :: MonadState CommandLineState m => LemmaName -> m ()-markProven nm = modify $ \ st -> st { cl_lemmas = [ (n,e, if n == nm then True else p) | (n,e,p) <- cl_lemmas st ] }+data UserProofTechniqueBox = UserProofTechniqueBox UserProofTechnique deriving Typeable++instance Extern UserProofTechnique where+ type Box UserProofTechnique = UserProofTechniqueBox+ box = UserProofTechniqueBox+ unbox (UserProofTechniqueBox t) = t++interpProof :: [Interp 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"+ ]+
src/HERMIT/Shell/ScriptToRewrite.hs view
@@ -1,37 +1,124 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, LambdaCase, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-} module HERMIT.Shell.ScriptToRewrite- ( -- * Converting Scripts to Rewrites- addScriptToDict- , lookupScript- , scriptToRewrite- )-where+ ( -- * Converting Scripts to Rewrites+ addScriptToDict+ , loadAndRun+ , lookupScript+ , parseScriptCLT+ , performScriptEffect+ , popScriptLine+ , runScript+ , scriptToRewrite+ , setRunningScript+ , ScriptEffect(..)+ ) where import Control.Arrow+import Control.Monad.Error import Control.Monad.State+import Control.Exception hiding (catch) import Data.Dynamic-import Data.Map hiding (lookup) import HERMIT.Context(LocalPathH)+import HERMIT.Kernel.Scoped import HERMIT.Kure import HERMIT.External-import HERMIT.Parser(Script, ExprH, unparseExprH)+import HERMIT.Parser(Script, ExprH, unparseExprH, parseScript, unparseScript) -import HERMIT.PrettyPrinter.Common(TranslateCoreTCDocHBox(..))+import HERMIT.PrettyPrinter.Common(TransformCoreTCDocHBox(..)) +import HERMIT.Shell.KernelEffect import HERMIT.Shell.Interpreter+import HERMIT.Shell.ShellEffect import HERMIT.Shell.Types ------------------------------------ +type RewriteName = String++data ScriptEffect+ = DefineScript ScriptName String+ | LoadFile ScriptName FilePath -- load a file on top of the current node+ | RunScript ScriptName+ | SaveFile FilePath+ | SaveScript FilePath ScriptName+ | ScriptToRewrite RewriteName ScriptName+ | SeqMeta [ScriptEffect]+ deriving Typeable++instance Extern ScriptEffect where+ type Box ScriptEffect = ScriptEffect+ box i = i+ unbox i = i++-- | A composite meta-command for running a loaded script immediately.+-- The script is given the same name as the filepath.+loadAndRun :: FilePath -> ScriptEffect+loadAndRun fp = SeqMeta [LoadFile fp fp, RunScript fp]++runScript :: MonadState CommandLineState m => (ExprH -> m ()) -> m ()+runScript run = go+ where go = popScriptLine >>= maybe (return ()) (\e -> run e >> go)++popScriptLine :: MonadState CommandLineState m => m (Maybe ExprH)+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 runner = go+ where go (SeqMeta ms) = mapM_ go ms+ go (LoadFile scriptName fileName) = do+ putStrToConsole $ "Loading \"" ++ fileName ++ "\"..."+ res <- liftIO $ try (readFile fileName)+ case res of+ Left (err :: IOException) -> fail ("IO error: " ++ show err)+ Right str -> do + script <- parseScriptCLT str+ modify $ \ st -> st {cl_scripts = (scriptName,script) : cl_scripts st}+ putStrToConsole ("Script \"" ++ scriptName ++ "\" loaded successfully from \"" ++ fileName ++ "\".")++ go (SaveFile fileName) = do+ version <- gets cl_version+ putStrToConsole $ "[saving " ++ fileName ++ "]"+ -- no checks to see if you are clobering; be careful+ liftIO $ writeFile fileName $ showGraph (vs_graph version) (vs_tags version) (SAST 0)++ go (ScriptToRewrite rewriteName scriptName) = do+ script <- lookupScript scriptName+ addScriptToDict rewriteName script+ putStrToConsole ("Rewrite \"" ++ rewriteName ++ "\" defined successfully.")++ go (DefineScript scriptName str) = do+ script <- parseScriptCLT str+ modify $ \ st -> st {cl_scripts = (scriptName,script) : cl_scripts st}+ putStrToConsole ("Script \"" ++ scriptName ++ "\" defined successfully.")++ go (RunScript scriptName) = do+ script <- lookupScript scriptName+ running_script_st <- gets cl_running_script+ setRunningScript $ Just script+ runScript runner `catchError` (\ err -> setRunningScript running_script_st >> throwError err)+ setRunningScript running_script_st+ putStrToConsole ("Script \"" ++ scriptName ++ "\" ran successfully.")+ showWindow++ go (SaveScript fileName scriptName) = do + script <- lookupScript scriptName+ putStrToConsole $ "Saving script \"" ++ scriptName ++ "\" to file \"" ++ fileName ++ "\"."+ liftIO $ writeFile fileName $ unparseScript script+ putStrToConsole $ "Save successful."+ lookupScript :: MonadState CommandLineState m => ScriptName -> m Script lookupScript scriptName = do scripts <- gets cl_scripts case lookup scriptName scripts of Nothing -> fail $ "No script of name " ++ scriptName ++ " is loaded." Just script -> return script +parseScriptCLT :: Monad m => String -> m Script+parseScriptCLT = either fail return . parseScript+ ------------------------------------ data UnscopedScriptR@@ -47,7 +134,7 @@ data PrimScriptR = ScriptRewriteHCore (RewriteH Core) | ScriptPath PathH- | ScriptTranslateHCorePath (TranslateH Core LocalPathH)+ | ScriptTransformHCorePath (TransformH Core LocalPathH) -- TODO: Hacky parsing, needs cleaning up@@ -81,20 +168,20 @@ interpScriptR = [ interp (\ (RewriteCoreBox r) -> ScriptPrimUn $ ScriptRewriteHCore r) , interp (\ (RewriteCoreTCBox _) -> ScriptUnsupported "rewrite that traverses types and coercions") -- TODO- , interp (\ (BiRewriteCoreBox br) -> ScriptPrimUn $ ScriptRewriteHCore $ forwardT br)+ , interp (\ (BiRewriteCoreBox br) -> ScriptPrimUn $ ScriptRewriteHCore $ whicheverR br) , interp (\ (CrumbBox cr) -> ScriptPrimUn $ ScriptPath [cr]) , interp (\ (PathBox p) -> ScriptPrimUn $ ScriptPath (snocPathToPath p))- , interp (\ (TranslateCorePathBox t) -> ScriptPrimUn $ ScriptTranslateHCorePath t)+ , interp (\ (TransformCorePathBox t) -> ScriptPrimUn $ ScriptTransformHCorePath t) , interp (\ (effect :: KernelEffect) -> case effect of BeginScope -> ScriptBeginScope EndScope -> ScriptEndScope _ -> ScriptUnsupported "Kernel effect" ) , interp (\ (_ :: ShellEffect) -> ScriptUnsupported "shell effect") , interp (\ (_ :: QueryFun) -> ScriptUnsupported "query")- , interp (\ (TranslateCoreStringBox _) -> ScriptUnsupported "query")- , interp (\ (TranslateCoreTCStringBox _) -> ScriptUnsupported "query")- , interp (\ (TranslateCoreTCDocHBox _) -> ScriptUnsupported "query")- , interp (\ (TranslateCoreCheckBox _) -> ScriptUnsupported "predicate")+ , interp (\ (TransformCoreStringBox _) -> ScriptUnsupported "query")+ , interp (\ (TransformCoreTCStringBox _) -> ScriptUnsupported "query")+ , interp (\ (TransformCoreTCDocHBox _) -> ScriptUnsupported "query")+ , interp (\ (TransformCoreCheckBox _) -> ScriptUnsupported "predicate") , interp (\ (StringBox _) -> ScriptUnsupported "message") ] @@ -103,13 +190,13 @@ scopedScriptsToRewrite :: [ScopedScriptR] -> RewriteH Core scopedScriptsToRewrite [] = idR scopedScriptsToRewrite (x : xs) = let rest = scopedScriptsToRewrite xs- failWith e = prefixFailMsg ("Error in script expression: " ++ unparseExprH e ++ "\n") + failWith e = prefixFailMsg ("Error in script expression: " ++ unparseExprH e ++ "\n") in case x of ScriptScope ys -> scopedScriptsToRewrite ys >>> rest ScriptPrimSc e pr -> case pr of ScriptRewriteHCore r -> failWith e r >>> rest ScriptPath p -> failWith e $ pathR p rest- ScriptTranslateHCorePath t -> do p <- failWith e t+ ScriptTransformHCorePath t -> do p <- failWith e t localPathR p rest -----------------------------------@@ -127,13 +214,9 @@ addScriptToDict nm scr = do r <- scriptToRewrite scr - let dyn = toDyn (box r)-- alteration :: Maybe [Dynamic] -> Maybe [Dynamic]- alteration Nothing = Just [dyn]- alteration (Just dyns) = Just (dyn:dyns)+ let ext = external nm r [ "User-loaded script." ] - modify $ \ st -> st { cl_dict = alter alteration nm (cl_dict st) }+ modify $ \ st -> st { cl_externals = ext : cl_externals st } -----------------------------------
+ src/HERMIT/Shell/ShellEffect.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE CPP, KindSignatures, GADTs, FlexibleContexts, TypeFamilies,+ DeriveDataTypeable, GeneralizedNewtypeDeriving, LambdaCase,+ MultiParamTypeClasses, ScopedTypeVariables #-}++module HERMIT.Shell.ShellEffect + ( ShellEffect(..)+ , performShellEffect+ , dump+ ) where++import Control.Monad.Error+import Control.Monad.State++import Data.Typeable++import HERMIT.Dictionary+import HERMIT.External+import HERMIT.Kure+import HERMIT.Kernel.Scoped+import HERMIT.PrettyPrinter.Common++import HERMIT.Plugin.Renderer+import HERMIT.Plugin.Types++import HERMIT.Shell.Types++import System.IO++----------------------------------------------------------------------------------++data ShellEffect+ = Abort -- ^ Abort GHC+ | 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 + | Resume+ deriving Typeable++instance Extern ShellEffect where+ type Box ShellEffect = ShellEffect+ box i = i+ unbox i = i++----------------------------------------------------------------------------------++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 Continue = get >>= continue+performShellEffect (Dump pp fileName renderer width) = dump pp fileName renderer width++performShellEffect (CLSModify f) = get >>= liftAndCatchIO . f >>= put >> showWindow++performShellEffect (PluginComp m) = pluginM m >> showWindow++dump :: (MonadCatch m, MonadIO m, MonadState CommandLineState m) => (CommandLineState -> TransformH CoreTC DocH) -> String -> String -> Int -> m ()+dump pp fileName renderer width = do+ st <- get+ case lookup renderer shellRenderers of+ Just r -> do doc <- prefixFailMsg "Bad renderer option: " $ queryS (cl_kernel st) (pp st) (cl_kernel_env st) (cl_cursor st)+ liftIO $ do h <- openFile fileName WriteMode+ r h ((cl_pretty_opts st) { po_width = width }) (Right doc)+ hClose h+ _ -> fail "dump: bad pretty-printer or renderer option"
src/HERMIT/Shell/Types.hs view
@@ -1,33 +1,44 @@-{-# LANGUAGE CPP, KindSignatures, GADTs, FlexibleContexts, TypeFamilies,- DeriveDataTypeable, GeneralizedNewtypeDeriving, LambdaCase,- ScopedTypeVariables #-}+{-# LANGUAGE 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 import Control.Monad.Error +import Data.Char (isSpace) import Data.Dynamic+import Data.List (intercalate, isPrefixOf, nub) import qualified Data.Map as M+import Data.Maybe (isJust) import Data.Monoid (mempty) import HERMIT.Context+import HERMIT.Core import HERMIT.Kure import HERMIT.External import qualified HERMIT.GHC as GHC+import HERMIT.Kernel (AST, queryK) import HERMIT.Kernel.Scoped import HERMIT.Monad import HERMIT.Parser import HERMIT.PrettyPrinter.Common import HERMIT.Plugin.Display+import HERMIT.Plugin.Renderer import HERMIT.Plugin.Types +import HERMIT.Dictionary.Inline+import HERMIT.Dictionary.Navigation import HERMIT.Dictionary.Reasoning (CoreExprEquality) -import System.IO (Handle)+import System.Console.Haskeline hiding (catch, display)+import System.IO (Handle, stdout) #ifndef mingw32_HOST_OS import Data.Maybe (fromMaybe)@@ -36,38 +47,29 @@ ---------------------------------------------------------------------------------- --- 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) => TranslateH g LocalPathH -> KernelEffect- Direction :: Direction -> KernelEffect- BeginScope :: KernelEffect- EndScope :: KernelEffect- Delete :: SAST -> KernelEffect- CorrectnessCritera :: (Injection GHC.ModGuts g, Walker HermitC g) => TranslateH g () -> KernelEffect- deriving Typeable--instance Extern KernelEffect where- type Box KernelEffect = KernelEffect- box i = i- unbox i = i+{-+-- | 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)- => TranslateH g String -> QueryFun- QueryDocH :: (PrettyC -> PrettyH CoreTC -> TranslateH CoreTC DocH) -> QueryFun+ => TransformH g String -> QueryFun+ QueryDocH :: (PrettyC -> PrettyH CoreTC -> TransformH CoreTC DocH) -> QueryFun Diff :: SAST -> SAST -> QueryFun Display :: QueryFun Inquiry :: (CommandLineState -> IO String) -> QueryFun+ CorrectnessCritera :: (Injection GHC.ModGuts g, Walker HermitC g) => TransformH g () -> QueryFun deriving Typeable message :: String -> QueryFun@@ -78,36 +80,66 @@ box i = i unbox i = i -----------------------------------------------------------------------------------+performQuery :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m)+ => QueryFun -> ExprH -> m () -type RewriteName = String+performQuery (QueryString q) _ = do+ st <- get+ str <- prefixFailMsg "Query failed: " $ queryS (cl_kernel st) q (cl_kernel_env st) (cl_cursor st)+ putStrToConsole str -data ShellEffect- = Abort -- ^ Abort GHC- | CLSModify (CommandLineState -> IO CommandLineState) -- ^ Modify shell state- | PluginComp (PluginM ())- | Continue -- ^ exit the shell, but don't abort/resume- | DefineScript ScriptName String- | Dump String String Int- | LoadFile ScriptName FilePath -- load a file on top of the current node- | RunScript ScriptName- | SaveFile FilePath- | SaveScript FilePath ScriptName- | ScriptToRewrite RewriteName ScriptName- | SeqMeta [ShellEffect]- | Resume- deriving Typeable+performQuery (QueryDocH q) _ = do+ st <- get+ doc <- prefixFailMsg "Query failed: " $ queryS (cl_kernel st) (q (initPrettyC $ cl_pretty_opts st) $ pCoreTC $ cl_pretty st) (cl_kernel_env st) (cl_cursor st)+ liftIO $ cl_render st stdout (cl_pretty_opts st) (Right doc) --- | A composite meta-command for running a loaded script immediately.--- The script is given the same name as the filepath.-loadAndRun :: FilePath -> ShellEffect-loadAndRun fp = SeqMeta [LoadFile fp fp, RunScript fp]+performQuery (Inquiry f) _ = get >>= liftIO . f >>= putStrToConsole -instance Extern ShellEffect where- type Box ShellEffect = ShellEffect- box i = i- unbox i = i+performQuery (Diff s1 s2) _ = do+ st <- get + ast1 <- toASTS (cl_kernel st) s1+ ast2 <- toASTS (cl_kernel st) s2+ let getCmds sast | sast == s1 = []+ | otherwise = case [ (f,c) | (f,c,to) <- vs_graph (cl_version st), to == sast ] of+ [(sast',cmd)] -> unparseExprH cmd : getCmds sast'+ _ -> ["error: history broken!"] -- should be impossible++ cl_putStrLn "Commands:"+ cl_putStrLn "========="+ cl_putStrLn $ unlines $ reverse $ getCmds s2++ doc1 <- ppWholeProgram ast1+ doc2 <- ppWholeProgram ast2++ r <- diffDocH (cl_pretty st) doc1 doc2++ cl_putStrLn "Diff:"+ cl_putStrLn "====="+ cl_putStr r++-- Explicit calls to display should work no matter what the loading state is.+performQuery Display _ = do+ running_script_st <- gets cl_running_script+ setRunningScript Nothing+ showWindow+ setRunningScript running_script_st++performQuery (CorrectnessCritera q) expr = do+ st <- get+ -- TODO: Again, we may want a quiet version of the kernel_env+ modFailMsg (\ err -> unparseExprH expr ++ " [exception: " ++ err ++ "]")+ $ queryS (cl_kernel st) q (cl_kernel_env st) (cl_cursor st)+ putStrToConsole $ unparseExprH expr ++ " [correct]"++ppWholeProgram :: (MonadIO m, MonadState CommandLineState m) => AST -> m DocH+ppWholeProgram ast = do+ st <- get+ liftIO (queryK (kernelS $ cl_kernel st)+ ast+ (extractT $ pathT [ModGuts_Prog] $ liftPrettyH (cl_pretty_opts st) $ pCoreTC $ cl_pretty st)+ (cl_kernel_env st)) >>= runKureM return fail+ ---------------------------------------------------------------------------------- data VersionCmd = Back -- back (up) the derivation tree@@ -126,13 +158,13 @@ instance Error CLException where strMsg = CLError -abort :: Monad m => CLT m ()+abort :: MonadError CLException m => m () abort = throwError CLAbort -resume :: Monad m => SAST -> CLT m ()+resume :: MonadError CLException m => SAST -> m () resume = throwError . CLResume -continue :: Monad m => CommandLineState -> CLT m ()+continue :: MonadError CLException m => CommandLineState -> m () continue = throwError . CLContinue rethrowCLE :: CLException -> PluginM a@@ -141,7 +173,7 @@ rethrowCLE (CLContinue s) = put (cl_pstate s) >> return (error "CLContinue cannot return a value") rethrowCLE (CLError msg) = throwError (PError msg) -rethrowPE :: Monad m => PException -> CLT m a+rethrowPE :: MonadError CLException m => PException -> m a rethrowPE PAbort = throwError CLAbort rethrowPE (PResume sast) = throwError (CLResume sast) rethrowPE (PError msg) = throwError (CLError msg)@@ -193,7 +225,7 @@ Right r' -> put (cl_pstate s') >> return r' -- | Lift a PluginM computation into the CLM monad.-pluginM :: MonadIO m => PluginM a -> CLT m a+pluginM :: (MonadError CLException m, MonadIO m, MonadState CommandLineState m) => PluginM a -> m a pluginM m = do s <- get (r,ps) <- liftIO $ runPluginT (cl_pstate s) m@@ -231,16 +263,17 @@ -- Session-local issues; things that are never saved (except the PluginState). data CommandLineState = CommandLineState- { cl_pstate :: PluginState -- ^ Access to the enclosing plugin state. This is propagated back- -- to the plugin after the CLT computation ends. We do it this way- -- because nested StateT is a pain.- , cl_height :: Int -- ^ console height, in lines+ { cl_pstate :: PluginState -- ^ Access to the enclosing plugin state. This is propagated back+ -- to the plugin after the CLT computation ends. We do it this way+ -- 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_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- , cl_dict :: Dictionary+ , cl_window :: PathH -- ^ path to beginning of window, always a prefix of focus path in kernel+ , cl_externals :: [External] -- ^ Currently visible externals+ , cl_running_script :: Maybe Script -- ^ Nothing = no script running, otherwise the remaining script commands -- this should be in a reader , cl_initSAST :: SAST } deriving (Typeable)@@ -276,40 +309,39 @@ cl_kernel_env :: CommandLineState -> HermitMEnv cl_kernel_env = mkKernelEnv . cl_pstate -cl_pretty :: CommandLineState -> PrettyH CoreTC+cl_pretty :: CommandLineState -> PrettyPrinter cl_pretty = ps_pretty . cl_pstate -setPretty :: CommandLineState -> PrettyH CoreTC -> CommandLineState+setPretty :: CommandLineState -> PrettyPrinter -> CommandLineState setPretty st pp = st { cl_pstate = (cl_pstate st) { ps_pretty = pp } } cl_pretty_opts :: CommandLineState -> PrettyOptions-cl_pretty_opts = ps_pretty_opts . cl_pstate+cl_pretty_opts = pOptions . cl_pretty setPrettyOpts :: CommandLineState -> PrettyOptions -> CommandLineState-setPrettyOpts st po = st { cl_pstate = (cl_pstate st) { ps_pretty_opts = po } }+setPrettyOpts st po = setPretty st $ (cl_pretty st) { pOptions = po } cl_render :: CommandLineState -> (Handle -> PrettyOptions -> Either String DocH -> IO ()) cl_render = ps_render . cl_pstate -cl_running_script :: CommandLineState -> Bool-cl_running_script = ps_running_script . cl_pstate- -- | 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 - return $ CommandLineState { cl_pstate = (ps { ps_pretty_opts = (ps_pretty_opts ps) { po_width = w } })- , cl_height = h- , cl_scripts = []- , cl_lemmas = []- , cl_nav = False- , cl_version = VersionStore { vs_graph = [] , vs_tags = [] }- , cl_window = mempty- , cl_dict = M.empty -- Note, empty dictionary.- , cl_initSAST = ps_cursor ps+ 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+ , cl_externals = [] -- Note, empty dictionary.+ , cl_running_script = Nothing+ , cl_initSAST = ps_cursor ps }+ return $ setPrettyOpts st $ (cl_pretty_opts st) { po_width = w } getTermDimensions :: IO (Int, Int) getTermDimensions = do@@ -342,8 +374,103 @@ writeTVar var (M.insert msg c m) return c -cl_putStr :: MonadIO m => String -> CLT m ()+cl_putStr :: (MonadError CLException m, MonadIO m, MonadState CommandLineState m) => String -> m () cl_putStr = pluginM . ps_putStr -cl_putStrLn :: MonadIO m => String -> CLT m ()+cl_putStrLn :: (MonadError CLException m, MonadIO m, MonadState CommandLineState m) => String -> m () cl_putStrLn = pluginM . ps_putStrLn++isRunningScript :: MonadState CommandLineState m => m Bool+isRunningScript = liftM isJust $ gets cl_running_script++setRunningScript :: MonadState CommandLineState m => Maybe Script -> m ()+setRunningScript ms = modify $ \st -> st { cl_running_script = ms }++-- TODO: rename?+putStrToConsole :: (MonadError CLException m, MonadIO m, MonadState CommandLineState 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 = do+ st <- get+ -- check to make sure new path is still inside window+ focusPath <- pluginM getFocusPath+ -- move the window in two cases:+ -- 1. window path is not prefix of focus path+ -- 2. window path is empty (since at the top level we only show type sigs)+ {- when (not (isPrefixOf (cl_window st) focusPath) || null (cl_window st))+ $ 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 = ifM isRunningScript (return ()) $ fixWindow >> gets cl_window >>= pluginM . display . Just++------------------------------------------------------------------------------++showGraph :: [(SAST,ExprH,SAST)] -> [(String,SAST)] -> SAST -> String+showGraph graph tags this@(SAST n) =+ (if length paths > 1 then "tag " ++ show n ++ "\n" else "") +++ concat (intercalate+ ["goto " ++ show n ++ "\n"]+ [ [ unparseExprH b ++ "\n" ++ showGraph graph tags c ]+ | (b,c) <- paths+ ])+ where + paths = [ (b,c) | (a,b,c) <- graph, a == this ]++------------------------------------------------------------------------------
src/HERMIT/Utilities.hs view
@@ -1,6 +1,8 @@ module HERMIT.Utilities ( -- * Utilities nodups+ , dups+ , dupsBy , soleElement , equivalentBy , equivalent@@ -15,6 +17,18 @@ nodups :: Eq a => [a] -> Bool nodups [] = True nodups (a:as) = (a `notElem` as) && nodups as++-- | Generalisation of 'dups' to an arbitrary equality predicate.+dupsBy :: (a -> a -> Bool) -> [a] -> [a]+dupsBy _ [] = []+dupsBy p (a:as) = let ds = dupsBy p as+ in if any (p a) as+ then a : ds+ else ds++-- | Discard the last occurrence of each element in the list. Thus the returned list contains only the duplicated elements.+dups :: Eq a => [a] -> [a]+dups = dupsBy (==) soleElement :: Monad m => [a] -> m a soleElement [] = fail "soleElement: list is empty."