hermit 1.0.0.0 → 1.0.1
raw patch · 78 files changed
+2667/−1445 lines, 78 filesdep +faildep +filepathdep +ghc-pathsdep −base-compatdep −terminfodep −transformers-compatdep ~basedep ~directorydep ~ghcnew-uploader
Dependencies added: fail, filepath, ghc-paths, semigroups, tasty, tasty-golden, terminal-size
Dependencies removed: base-compat, terminfo, transformers-compat
Dependency ranges changed: base, directory, ghc, mtl, transformers
Files
- dist/build/HERMIT/Parser.hs +71/−17
- dist/build/HERMIT/ParserCore.hs +71/−17
- dist/build/HERMIT/ParserType.hs +71/−17
- examples/concatVanishes/Flatten.hs +11/−0
- examples/concatVanishes/HList.hs +7/−7
- examples/concatVanishes/QSort.hs +8/−0
- examples/concatVanishes/Rev.hs +10/−0
- examples/flatten/Flatten.hs +11/−0
- examples/flatten/HList.hs +7/−7
- examples/hanoi/Hanoi.hss +5/−3
- examples/new_reverse/HList.hs +9/−9
- examples/new_reverse/Reverse.hec +3/−3
- examples/new_reverse/Reverse.hs +12/−0
- examples/qsort/HList.hs +11/−11
- examples/qsort/QSort.hs +13/−0
- examples/reverse/HList.hs +9/−9
- examples/reverse/Reverse.hs +10/−0
- hermit.cabal +138/−119
- src/HERMIT/Context.hs +2/−3
- src/HERMIT/Core.hs +85/−6
- src/HERMIT/Dictionary/AlphaConversion.hs +6/−6
- src/HERMIT/Dictionary/Common.hs +3/−6
- src/HERMIT/Dictionary/Composite.hs +7/−5
- src/HERMIT/Dictionary/FixPoint.hs +6/−8
- src/HERMIT/Dictionary/Fold.hs +114/−47
- src/HERMIT/Dictionary/Function.hs +14/−1
- src/HERMIT/Dictionary/GHC.hs +45/−20
- src/HERMIT/Dictionary/Induction.hs +4/−3
- src/HERMIT/Dictionary/Inline.hs +7/−1
- src/HERMIT/Dictionary/Kure.hs +6/−2
- src/HERMIT/Dictionary/Local.hs +8/−0
- src/HERMIT/Dictionary/Local/Case.hs +9/−10
- src/HERMIT/Dictionary/Local/Cast.hs +11/−5
- src/HERMIT/Dictionary/Local/Let.hs +12/−11
- src/HERMIT/Dictionary/Navigation.hs +40/−18
- src/HERMIT/Dictionary/Navigation/Crumbs.hs +23/−2
- src/HERMIT/Dictionary/New.hs +1/−2
- src/HERMIT/Dictionary/Query.hs +19/−5
- src/HERMIT/Dictionary/Reasoning.hs +102/−101
- src/HERMIT/Dictionary/Remembered.hs +3/−6
- src/HERMIT/Dictionary/Rules.hs +37/−27
- src/HERMIT/Dictionary/Undefined.hs +28/−21
- src/HERMIT/Dictionary/WorkerWrapper/Common.hs +9/−10
- src/HERMIT/Dictionary/WorkerWrapper/Fix.hs +5/−5
- src/HERMIT/Dictionary/WorkerWrapper/FixResult.hs +22/−9
- src/HERMIT/External.hs +21/−27
- src/HERMIT/GHC.hs +58/−20
- src/HERMIT/GHC/Typechecker.hs +31/−21
- src/HERMIT/Kernel.hs +2/−4
- src/HERMIT/Kure.hs +226/−45
- src/HERMIT/Kure/Universes.hs +5/−0
- src/HERMIT/Lemma.hs +77/−81
- src/HERMIT/Libraries/Int.hs +10/−4
- src/HERMIT/Libraries/WW.hs +90/−0
- src/HERMIT/Monad.hs +8/−4
- src/HERMIT/Name.hs +10/−19
- src/HERMIT/Plugin.hs +3/−9
- src/HERMIT/Plugin/Builder.hs +1/−10
- src/HERMIT/Plugin/Display.hs +17/−9
- src/HERMIT/Plugin/Renderer.hs +7/−6
- src/HERMIT/Plugin/Types.hs +10/−11
- src/HERMIT/PrettyPrinter/AST.hs +75/−22
- src/HERMIT/PrettyPrinter/Clean.hs +298/−251
- src/HERMIT/PrettyPrinter/Common.hs +52/−57
- src/HERMIT/PrettyPrinter/GHC.hs +4/−4
- src/HERMIT/PrettyPrinter/Glyphs.hs +106/−0
- src/HERMIT/Shell/Command.hs +66/−23
- src/HERMIT/Shell/Completion.hs +0/−3
- src/HERMIT/Shell/Externals.hs +14/−17
- src/HERMIT/Shell/Interpreter.hs +9/−5
- src/HERMIT/Shell/KernelEffect.hs +9/−8
- src/HERMIT/Shell/Proof.hs +8/−12
- src/HERMIT/Shell/ScriptToRewrite.hs +5/−11
- src/HERMIT/Shell/ShellEffect.hs +24/−14
- src/HERMIT/Shell/Types.hs +118/−84
- src/HERMIT/Win32/Console.hs +12/−0
- src/HERMIT/Win32/Console.hsc +0/−105
- tests/Main.hs +186/−0
dist/build/HERMIT/Parser.hs view
@@ -489,10 +489,76 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 11 "<command-line>" #-}+# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4+++++++++++++++++++++++++++++++++++++++++++{-# LINE 11 "<command-line>" #-}+{-# LINE 1 "/opt/ghc/7.10.3/lib/ghc-7.10.3/include/ghcversion.h" #-}++++++++++++++++++{-# LINE 11 "<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" #-} @@ -509,7 +575,6 @@ #define GTE(n,m) (n Happy_GHC_Exts.>=# m) #define EQ(n,m) (n Happy_GHC_Exts.==# m) #endif- {-# LINE 46 "templates/GenericTemplate.hs" #-} @@ -519,20 +584,11 @@ - {-# 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)@@ -560,20 +616,20 @@ 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@@ -606,7 +662,6 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) - {-# LINE 170 "templates/GenericTemplate.hs" #-} -----------------------------------------------------------------------------@@ -771,4 +826,3 @@ {-# NOINLINE happyFail #-} -- end of Happy Template.-
dist/build/HERMIT/ParserCore.hs view
@@ -391,10 +391,76 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 11 "<command-line>" #-}+# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4+++++++++++++++++++++++++++++++++++++++++++{-# LINE 11 "<command-line>" #-}+{-# LINE 1 "/opt/ghc/7.10.3/lib/ghc-7.10.3/include/ghcversion.h" #-}++++++++++++++++++{-# LINE 11 "<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" #-} @@ -411,7 +477,6 @@ #define GTE(n,m) (n Happy_GHC_Exts.>=# m) #define EQ(n,m) (n Happy_GHC_Exts.==# m) #endif- {-# LINE 46 "templates/GenericTemplate.hs" #-} @@ -421,20 +486,11 @@ - {-# 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)@@ -462,20 +518,20 @@ 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@@ -508,7 +564,6 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) - {-# LINE 170 "templates/GenericTemplate.hs" #-} -----------------------------------------------------------------------------@@ -673,4 +728,3 @@ {-# NOINLINE happyFail #-} -- end of Happy Template.-
dist/build/HERMIT/ParserType.hs view
@@ -300,10 +300,76 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 11 "<command-line>" #-}+# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4+++++++++++++++++++++++++++++++++++++++++++{-# LINE 11 "<command-line>" #-}+{-# LINE 1 "/opt/ghc/7.10.3/lib/ghc-7.10.3/include/ghcversion.h" #-}++++++++++++++++++{-# LINE 11 "<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" #-} @@ -320,7 +386,6 @@ #define GTE(n,m) (n Happy_GHC_Exts.>=# m) #define EQ(n,m) (n Happy_GHC_Exts.==# m) #endif- {-# LINE 46 "templates/GenericTemplate.hs" #-} @@ -330,20 +395,11 @@ - {-# 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)@@ -371,20 +427,20 @@ 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@@ -417,7 +473,6 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) - {-# LINE 170 "templates/GenericTemplate.hs" #-} -----------------------------------------------------------------------------@@ -582,4 +637,3 @@ {-# NOINLINE happyFail #-} -- end of Happy Template.-
examples/concatVanishes/Flatten.hs view
@@ -11,3 +11,14 @@ main :: IO () main = print (flatten (Node (Leaf 'h') (Leaf 'i')))+++-- Should be in the "List" module+{-# RULES "++ []" forall xs . xs ++ [] = xs #-}+{-# RULES "++ strict" (++) undefined = undefined #-}++-- The "Algebra" for repH+{-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}+{-# RULES "repH []" repH [] = id #-}+{-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}+
examples/concatVanishes/HList.hs view
@@ -14,11 +14,11 @@ absH :: H a -> [a] absH f = f [] --- Should be in the "List" module-{-# RULES "++ []" forall xs . xs ++ [] = xs #-}-{-# RULES "++ strict" (++) undefined = undefined #-}+-- -- Should be in the "List" module+-- {-# RULES "++ []" forall xs . xs ++ [] = xs #-}+-- {-# RULES "++ strict" (++) undefined = undefined #-} --- The "Algebra" for repH-{-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}-{-# RULES "repH []" repH [] = id #-}-{-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}+-- -- The "Algebra" for repH+-- {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}+-- {-# RULES "repH []" repH [] = id #-}+-- {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}
examples/concatVanishes/QSort.hs view
@@ -15,3 +15,11 @@ main :: IO () main = print (qsort [8,3,5,7,2,9,4,6,3,2]) +-- Should be in the "List" module+{-# RULES "++ []" forall xs . xs ++ [] = xs #-}+{-# RULES "++ strict" (++) undefined = undefined #-}++-- The "Algebra" for repH+{-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}+{-# RULES "repH []" repH [] = id #-}+{-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}
examples/concatVanishes/Rev.hs view
@@ -10,3 +10,13 @@ main :: IO () main = print $ rev [1..10] ++-- Should be in the "List" module+{-# RULES "++ []" forall xs . xs ++ [] = xs #-}+{-# RULES "++ strict" (++) undefined = undefined #-}++-- The "Algebra" for repH+{-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}+{-# RULES "repH []" repH [] = id #-}+{-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}+
examples/flatten/Flatten.hs view
@@ -11,3 +11,14 @@ main :: IO () main = print (flatten (Node (Leaf 'h') (Leaf 'i')))+++-- Should be in a "List" module+{-# RULES "++ []" forall xs . xs ++ [] = xs #-}+{-# RULES "++ strict" (++) undefined = undefined #-}++-- The "Algebra" for repH+{-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}+{-# RULES "repH []" repH [] = id #-}+{-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}+
examples/flatten/HList.hs view
@@ -14,11 +14,11 @@ absH :: H a -> [a] absH f = f [] --- Should be in a "List" module-{-# RULES "++ []" forall xs . xs ++ [] = xs #-}-{-# RULES "++ strict" (++) undefined = undefined #-}+-- -- Should be in a "List" module+-- {-# RULES "++ []" forall xs . xs ++ [] = xs #-}+-- {-# RULES "++ strict" (++) undefined = undefined #-} --- The "Algebra" for repH-{-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}-{-# RULES "repH []" repH [] = id #-}-{-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}+-- -- The "Algebra" for repH+-- {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}+-- {-# RULES "repH []" repH [] = id #-}+-- {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}
examples/hanoi/Hanoi.hss view
@@ -22,7 +22,8 @@ any-call (unfold 'f) simplify any-call (unfold-rule "[] ++")- any-call (unfold-rule "++ []")+-- any-call (unfold-rule "++ []")+ assume } { case-alt 1 ; any-call (unfold 'f) ; simplify @@ -49,7 +50,7 @@ try (reorder-lets ['u,'v,'w]) any-call (fold 'u) any-call (fold 'v)- any-call (fold 'w)+-- any-call (fold 'w) let-tuple 'uvw any-call (fold 'unwrap) any-call (fold-remembered origwork)@@ -57,4 +58,5 @@ } } }-innermost let-elim+--innermost let-elim+innermost let-subst
examples/new_reverse/HList.hs view
@@ -7,11 +7,11 @@ type H a = [a] -> [a] -{-# INLINABLE repH #-}+-- {-# INLINABLE repH #-} repH :: [a] -> H a repH xs = (xs ++) -{-# INLINABLE absH #-}+-- {-# INLINABLE absH #-} absH :: H a -> [a] absH f = f [] @@ -19,12 +19,12 @@ myAppend :: [a] -> [a] -> [a] myAppend [] ys = ys myAppend (x:xs) ys = x : myAppend xs ys-{-# RULES "appendFix" [~] (++) = myAppend #-}+-- {-# RULES "appendFix" [~] (++) = myAppend #-} --- Algebra for repH-{-# RULES "repH []" [~] repH [] = id #-}-{-# RULES "repH (:)" [~] forall x xs. repH (x:xs) = (x:) . repH xs #-}-{-# RULES "repH ++" [~] forall xs ys. repH (xs ++ ys) = repH xs . repH ys #-}+-- -- Algebra for repH+-- {-# RULES "repH []" [~] repH [] = id #-}+-- {-# RULES "repH (:)" [~] forall x xs. repH (x:xs) = (x:) . repH xs #-}+-- {-# RULES "repH ++" [~] forall xs ys. repH (xs ++ ys) = repH xs . repH ys #-} --- Needed because the fusion rule we generate isn't too useful yet.-{-# RULES "repH-absH-fusion" [~] forall h. repH (absH h) = h #-}+-- -- Needed because the fusion rule we generate isn't too useful yet.+-- {-# RULES "repH-absH-fusion" [~] forall h. repH (absH h) = h #-}
examples/new_reverse/Reverse.hec view
@@ -31,14 +31,14 @@ any-bu (unfold 'myAppend >>> undefined-expr) any-bu (unfold 'myAppend >>> case-reduce) simplify-lemma-forall-body ; consequent+foralls-body ; consequent one-td (lemma-forward ind-hyp-0) end-case rule-to-lemma "myAppend-assoc" prove-lemma "myAppend-assoc" induction 'xs-{ forall-body+{ foralls-body { conj-lhs any-bu ((unfold 'myAppend) >>> undefined-case) reflexivity@@ -49,7 +49,7 @@ reflexivity } { conj-rhs- forall-body ; consequent+ foralls-body ; consequent any-bu (unfold 'myAppend) smash rhs (one-td (fold 'myAppend))
examples/new_reverse/Reverse.hs view
@@ -21,3 +21,15 @@ -- useful auxilliary lemma for proving the w/w assumption {-# RULES "++ []" [~] forall xs. xs ++ [] = xs #-} {-# RULES "myAppend-assoc" [~] forall xs ys zs. myAppend (myAppend xs ys) zs = myAppend xs (myAppend ys zs) #-}+++{-# RULES "appendFix" [~] (++) = myAppend #-}++-- Algebra for repH+{-# RULES "repH []" [~] repH [] = id #-}+{-# RULES "repH (:)" [~] forall x xs. repH (x:xs) = (x:) . repH xs #-}+{-# RULES "repH ++" [~] forall xs ys. repH (xs ++ ys) = repH xs . repH ys #-}++-- Needed because the fusion rule we generate isn't too useful yet.+{-# RULES "repH-absH-fusion" [~] forall h. repH (absH h) = h #-}+
examples/qsort/HList.hs view
@@ -6,22 +6,22 @@ type H a = [a] -> [a] -{-# INLINE repH #-}+-- {-# INLINE repH #-} repH :: [a] -> H a repH xs = (xs ++) -{-# INLINE absH #-}+-- {-# INLINE absH #-} absH :: H a -> [a] absH f = f [] --- Should be in a "List" module-{-# RULES "++ []" forall xs . xs ++ [] = xs #-}-{-# RULES "++ strict" (++) undefined = undefined #-}+-- -- Should be in a "List" module+-- {-# RULES "++ []" forall xs . xs ++ [] = xs #-}+-- {-# RULES "++ strict" (++) undefined = undefined #-} --- The "Algebra" for repH-{-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}-{-# RULES "repH []" repH [] = id #-}-{-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}+-- -- The "Algebra" for repH+-- {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}+-- {-# RULES "repH []" repH [] = id #-}+-- {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} --- Needed because the fusion rule we generate isn't too useful yet.-{-# RULES "repH-absH-fusion" [~] forall h. repH (absH h) = h #-}+-- -- Needed because the fusion rule we generate isn't too useful yet.+-- {-# RULES "repH-absH-fusion" [~] forall h. repH (absH h) = h #-}
examples/qsort/QSort.hs view
@@ -23,3 +23,16 @@ main :: IO () main = print (qsort [8,3,5,7,2,9,4,6,3,2])++-- Should be in a "List" module+{-# RULES "++ []" forall xs . xs ++ [] = xs #-}+{-# RULES "++ strict" (++) undefined = undefined #-}++-- The "Algebra" for repH+{-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}+{-# RULES "repH []" repH [] = id #-}+{-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}++-- Needed because the fusion rule we generate isn't too useful yet.+{-# RULES "repH-absH-fusion" [~] forall h. repH (absH h) = h #-}+
examples/reverse/HList.hs view
@@ -6,19 +6,19 @@ type H a = [a] -> [a] -{-# INLINE repH #-}+-- {-# INLINE repH #-} repH :: [a] -> H a repH xs = (xs ++) -{-# INLINE absH #-}+-- {-# INLINE absH #-} absH :: H a -> [a] absH f = f [] --- Should be in a "List" module-{-# RULES "++ []" forall xs . xs ++ [] = xs #-}-{-# RULES "++ strict" (++) undefined = undefined #-}+-- -- Should be in a "List" module+-- {-# RULES "++ []" forall xs . xs ++ [] = xs #-}+-- {-# RULES "++ strict" (++) undefined = undefined #-} --- The "Algebra" for repH-{-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}-{-# RULES "repH []" repH [] = id #-}-{-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}+-- -- The "Algebra" for repH+-- {-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}+-- {-# RULES "repH []" repH [] = id #-}+-- {-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}
examples/reverse/Reverse.hs view
@@ -10,3 +10,13 @@ main :: IO () main = print $ rev "hello"+++-- Should be in a "List" module+{-# RULES "++ []" forall xs . xs ++ [] = xs #-}+{-# RULES "++ strict" (++) undefined = undefined #-}++-- The "Algebra" for repH+{-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-}+{-# RULES "repH []" repH [] = id #-}+{-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-}
hermit.cabal view
@@ -1,7 +1,7 @@-Name: hermit-Version: 1.0.0.0-Synopsis: Haskell Equational Reasoning Model-to-Implementation Tunnel-Description:+name: hermit+version: 1.0.1+synopsis: Haskell Equational Reasoning Model-to-Implementation Tunnel+description: HERMIT is a Haskell-specific toolkit designed to mechanize equational reasoning and program transformation during compilation in GHC. .@@ -78,14 +78,14 @@ $ @ -Category: Language, Formal Methods, Optimization, Transformation, Refactoring, Reflection-License: BSD3-License-file: LICENSE-Author: Andrew Farmer, Andy Gill, Ed Komp, Neil Sculthorpe-Maintainer: Andrew Farmer <afarmer@ittc.ku.edu>-Stability: beta+category: Language, Formal Methods, Optimization, Transformation, Refactoring, Reflection+license: BSD3+license-file: LICENSE+author: Andrew Farmer, Andy Gill, Ed Komp, Neil Sculthorpe+maintainer: Andrew Farmer <afarmer@ittc.ku.edu>+stability: beta build-type: Simple-Cabal-Version: >= 1.14+cabal-version: >= 1.14 extra-source-files: README.md@@ -129,134 +129,153 @@ examples/new_reverse/Reverse.hs examples/new_reverse/Reverse.hec -Library- ghc-options: -Wall- Build-Depends: base >= 4 && < 5,- ansi-terminal >= 0.5.5,- array,- base-compat >= 0.8.1,- containers >= 0.5.0.0,- data-default-class >= 0.0.1,- directory >= 1.2.0.0,- ghc == 7.8.* || == 7.10.*,- haskeline >= 0.7.0.3,- kure >= 2.16.8,- marked-pretty >= 0.1,- mtl >= 2.1.2,- process >= 1.1.0.2,- stm >= 2.4,- temporary >= 1.2.0.3,- transformers >= 0.2,- transformers-compat >= 0.4+library+ ghc-options: -Wall+ build-depends: base >= 4.8 && < 5,+ ansi-terminal >= 0.5.5,+ array,+ containers >= 0.5.0.0,+ data-default-class >= 0.0.1,+ directory >= 1.2.0.0,+ fail,+ -- ^ TODO: Remove when we require GHC >= 8+ ghc == 7.10.3,+ haskeline >= 0.7.0.3,+ kure >= 2.16.8 && < 3.0,+ marked-pretty >= 0.1,+ mtl >= 2.2,+ process >= 1.1.0.2,+ semigroups >= 0.18,+ -- ^ TODO: Remove when we require GHC >= 8+ stm >= 2.4,+ temporary >= 1.2.0.3,+ terminal-size >= 0.3.2,+ transformers >= 0.4 if os(windows)- build-depends: Win32- else- build-depends: terminfo >= 0.3.2.5+ build-depends: Win32 - build-tools: alex >= 3.1.3,- happy >= 1.19.3+ build-tools: alex >= 3.1.3,+ happy >= 1.19.3 default-language: Haskell2010 - Exposed-modules:- HERMIT+ exposed-modules: HERMIT - HERMIT.Context- HERMIT.Core- HERMIT.Dictionary- HERMIT.Driver+ HERMIT.Context+ HERMIT.Core+ HERMIT.Dictionary+ HERMIT.Driver - HERMIT.Dictionary.AlphaConversion- HERMIT.Dictionary.Common- HERMIT.Dictionary.Composite- HERMIT.Dictionary.Debug- HERMIT.Dictionary.FixPoint- HERMIT.Dictionary.Fold- HERMIT.Dictionary.Function- HERMIT.Dictionary.GHC- HERMIT.Dictionary.Induction- HERMIT.Dictionary.Inline- HERMIT.Dictionary.Kure- HERMIT.Dictionary.Local- HERMIT.Dictionary.Local.Bind- HERMIT.Dictionary.Local.Case- HERMIT.Dictionary.Local.Cast- HERMIT.Dictionary.Local.Let- HERMIT.Dictionary.Navigation- HERMIT.Dictionary.Navigation.Crumbs- HERMIT.Dictionary.New- HERMIT.Dictionary.Query- HERMIT.Dictionary.Reasoning- HERMIT.Dictionary.Remembered- HERMIT.Dictionary.Rules- HERMIT.Dictionary.Undefined- HERMIT.Dictionary.Unfold- HERMIT.Dictionary.Unsafe- HERMIT.Dictionary.WorkerWrapper.Common- HERMIT.Dictionary.WorkerWrapper.Fix- HERMIT.Dictionary.WorkerWrapper.FixResult+ HERMIT.Dictionary.AlphaConversion+ HERMIT.Dictionary.Common+ HERMIT.Dictionary.Composite+ HERMIT.Dictionary.Debug+ HERMIT.Dictionary.FixPoint+ HERMIT.Dictionary.Fold+ HERMIT.Dictionary.Function+ HERMIT.Dictionary.GHC+ HERMIT.Dictionary.Induction+ HERMIT.Dictionary.Inline+ HERMIT.Dictionary.Kure+ HERMIT.Dictionary.Local+ HERMIT.Dictionary.Local.Bind+ HERMIT.Dictionary.Local.Case+ HERMIT.Dictionary.Local.Cast+ HERMIT.Dictionary.Local.Let+ HERMIT.Dictionary.Navigation+ HERMIT.Dictionary.Navigation.Crumbs+ HERMIT.Dictionary.New+ HERMIT.Dictionary.Query+ HERMIT.Dictionary.Reasoning+ HERMIT.Dictionary.Remembered+ HERMIT.Dictionary.Rules+ HERMIT.Dictionary.Undefined+ HERMIT.Dictionary.Unfold+ HERMIT.Dictionary.Unsafe+ HERMIT.Dictionary.WorkerWrapper.Common+ HERMIT.Dictionary.WorkerWrapper.Fix+ HERMIT.Dictionary.WorkerWrapper.FixResult - HERMIT.External- HERMIT.GHC- HERMIT.GHC.Typechecker- HERMIT.Kernel- HERMIT.Kure- HERMIT.Kure.Universes- HERMIT.Lemma- HERMIT.Monad- HERMIT.Name- HERMIT.Parser- HERMIT.ParserCore- HERMIT.ParserType+ HERMIT.External+ HERMIT.GHC+ HERMIT.GHC.Typechecker+ HERMIT.Kernel+ HERMIT.Kure+ HERMIT.Kure.Universes+ HERMIT.Lemma+ HERMIT.Monad+ HERMIT.Name+ HERMIT.Parser+ HERMIT.ParserCore+ HERMIT.ParserType - HERMIT.Plugin- HERMIT.Plugin.Builder- HERMIT.Plugin.Display- HERMIT.Plugin.Renderer- HERMIT.Plugin.Types+ HERMIT.Plugin+ HERMIT.Plugin.Builder+ HERMIT.Plugin.Display+ HERMIT.Plugin.Renderer+ HERMIT.Plugin.Types - HERMIT.PrettyPrinter.AST- HERMIT.PrettyPrinter.Clean- HERMIT.PrettyPrinter.Common- HERMIT.PrettyPrinter.GHC+ HERMIT.PrettyPrinter.AST+ HERMIT.PrettyPrinter.Clean+ HERMIT.PrettyPrinter.Common+ HERMIT.PrettyPrinter.GHC+ HERMIT.PrettyPrinter.Glyphs - HERMIT.Shell.Command- HERMIT.Shell.Completion- HERMIT.Shell.Dictionary- HERMIT.Shell.Interpreter- HERMIT.Shell.Externals- HERMIT.Shell.KernelEffect- HERMIT.Shell.ScriptToRewrite- HERMIT.Shell.ShellEffect- HERMIT.Shell.Proof- HERMIT.Shell.Types+ HERMIT.Shell.Command+ HERMIT.Shell.Completion+ HERMIT.Shell.Dictionary+ HERMIT.Shell.Interpreter+ HERMIT.Shell.Externals+ HERMIT.Shell.KernelEffect+ HERMIT.Shell.ScriptToRewrite+ HERMIT.Shell.ShellEffect+ HERMIT.Shell.Proof+ HERMIT.Shell.Types - HERMIT.Utilities+ HERMIT.Utilities - HERMIT.Libraries.Int+ HERMIT.Libraries.Int+ HERMIT.Libraries.WW - Other-modules:- HERMIT.Syntax+ other-modules: HERMIT.Syntax - Paths_hermit+ Paths_hermit if os(windows)- Other-modules:- HERMIT.Win32.Console- HERMIT.Win32.IO+ other-modules: HERMIT.Win32.Console+ HERMIT.Win32.IO - Hs-Source-Dirs: src+ hs-source-dirs: src -Executable hermit- Build-Depends: base >= 4 && < 5,- hermit+executable hermit+ build-depends: base >= 4.7 && < 5,+ hermit - default-language: Haskell2010- Main-Is: Main.hs- Hs-Source-Dirs: driver- Ghc-Options: -Wall+ default-language: Haskell2010+ main-is: Main.hs+ hs-source-dirs: driver+ ghc-options: -Wall ++test-suite hermit-tests+ type: exitcode-stdio-1.0+ build-depends: base >= 4.8 && < 5,+ directory >= 1.2,+ filepath,+ ghc,+ ghc-paths,+ hermit,+ process >= 1.1.0.2,+ tasty >= 0.8,+ tasty-golden >= 2.3,+ temporary >= 1.2.0.3++ default-language: Haskell2010+ main-is: Main.hs+ hs-source-dirs: tests+ ghc-options: -Wall+ source-repository head- type: git- location: git://github.com/ku-fpg/hermit.git+ type: git+ location: https://github.com/ku-fpg/hermit
src/HERMIT/Context.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module HERMIT.Context@@ -50,9 +49,9 @@ , HasEmptyContext(..) ) where -import Prelude.Compat hiding (lookup)+import Prelude hiding (lookup) -import Control.Monad (liftM)+import Control.Monad import Data.Map hiding (map, foldr, filter)
src/HERMIT/Core.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} module HERMIT.Core@@ -81,14 +82,16 @@ import Control.Monad ((>=>)) +import Data.List (intercalate)++import GHC.Generics+ import Language.KURE.Combinators.Monad import Language.KURE.MonadCatch import HERMIT.GHC import HERMIT.Utilities -import Data.List (intercalate)- ----------------------------------------------------------------------- -- | Unlike everything else, there is no synonym for 'Tickish' 'Id' provided by GHC, so we define one.@@ -181,22 +184,37 @@ typeSyntaxEq (TyVarTy v1) (TyVarTy v2) = v1 == v2 typeSyntaxEq (LitTy l1) (LitTy l2) = l1 == l2 typeSyntaxEq (AppTy t1 ty1) (AppTy t2 ty2) = typeSyntaxEq t1 t2 && typeSyntaxEq ty1 ty2+#if __GLASGOW_HASKELL__ > 710+typeSyntaxEq (ForAllTy b1 ty1) (ForAllTy b2 ty2) = tyBinderSyntaxEq b1 b2 && typeSyntaxEq ty1 ty2+#else typeSyntaxEq (FunTy t1 ty1) (FunTy t2 ty2) = typeSyntaxEq t1 t2 && typeSyntaxEq ty1 ty2 typeSyntaxEq (ForAllTy v1 ty1) (ForAllTy v2 ty2) = v1 == v2 && typeSyntaxEq ty1 ty2+#endif typeSyntaxEq (TyConApp c1 ts1) (TyConApp c2 ts2) = c1 == c2 && all2 typeSyntaxEq ts1 ts2 typeSyntaxEq _ _ = False +#if __GLASGOW_HASKELL__ > 710+tyBinderSyntaxEq :: TyBinder -> TyBinder -> Bool+tyBinderSyntaxEq (Named v1 f1) (Named v2 f2) = v1 == v2 && f1 == f2+tyBinderSyntaxEq (Anon t1) (Anon t2) = typeSyntaxEq t1 t2+tyBinderSyntaxEq _ _ = False+#endif+ -- | Syntactic Equality of 'Coercion's. coercionSyntaxEq :: Coercion -> Coercion -> Bool coercionSyntaxEq (Refl role1 ty1) (Refl role2 ty2) = role1 == role2 && typeSyntaxEq ty1 ty2 coercionSyntaxEq (TyConAppCo role1 tc1 cos1) (TyConAppCo role2 tc2 cos2) = role1 == role2 && tc1 == tc2 && all2 coercionSyntaxEq cos1 cos2 coercionSyntaxEq (AppCo co11 co12) (AppCo co21 co22) = coercionSyntaxEq co11 co21 && coercionSyntaxEq co12 co22+#if __GLASGOW_HASKELL__ > 710+coercionSyntaxEq (ForAllCo v1 c1k c1) (ForAllCo v2 c2k c2) = v1 == v2 && coercionSyntaxEq c1k c2k && coercionSyntaxEq c1 c2+#else coercionSyntaxEq (ForAllCo v1 co1) (ForAllCo v2 co2) = v1 == v2 && coercionSyntaxEq co1 co2+#endif coercionSyntaxEq (CoVarCo v1) (CoVarCo v2) = v1 == v2 coercionSyntaxEq (AxiomInstCo con1 ind1 cos1) (AxiomInstCo con2 ind2 cos2) = con1 == con2 && ind1 == ind2 && all2 coercionSyntaxEq cos1 cos2 coercionSyntaxEq (LRCo lr1 co1) (LRCo lr2 co2) = lr1 == lr2 && coercionSyntaxEq co1 co2-#if __GLASGOW_HASKELL__ < 710-coercionSyntaxEq (UnivCo role1 ty11 ty12) (UnivCo role2 ty21 ty22) = role1 == role2 && typeSyntaxEq ty11 ty21 && typeSyntaxEq ty12 ty22+#if __GLASGOW_HASKELL__ > 710+coercionSyntaxEq (UnivCo p1 role1 ty11 ty12) (UnivCo p2 role2 ty21 ty22) = ucpSyntaxEq p1 p2 && role1 == role2 && typeSyntaxEq ty11 ty21 && typeSyntaxEq ty12 ty22 #else coercionSyntaxEq (UnivCo fs1 role1 ty11 ty12) (UnivCo fs2 role2 ty21 ty22) = fs1 == fs2 && role1 == role2 && typeSyntaxEq ty11 ty21 && typeSyntaxEq ty12 ty22 #endif@@ -204,9 +222,24 @@ coercionSyntaxEq (SymCo co1) (SymCo co2) = coercionSyntaxEq co1 co2 coercionSyntaxEq (TransCo co11 co12) (TransCo co21 co22) = coercionSyntaxEq co11 co21 && coercionSyntaxEq co12 co22 coercionSyntaxEq (NthCo n1 co1) (NthCo n2 co2) = n1 == n2 && coercionSyntaxEq co1 co2+#if __GLASGOW_HASKELL__ > 710+coercionSyntaxEq (InstCo c11 c12) (InstCo c21 c22) = coercionSyntaxEq c11 c21 && coercionSyntaxEq c12 c22+#else coercionSyntaxEq (InstCo co1 ty1) (InstCo co2 ty2) = coercionSyntaxEq co1 co2 && typeSyntaxEq ty1 ty2+#endif coercionSyntaxEq _ _ = False +#if __GLASGOW_HASKELL__ > 710+ucpSyntaxEq :: UnivCoProvenance -> UnivCoProvenance -> Bool+ucpSyntaxEq UnsafeCoerceProv UnsafeCoerceProv = True+ucpSyntaxEq (PhantomProv c1) (PhantomProv c2) = coercionSyntaxEq c1 c2+ucpSyntaxEq (PluginProv s1) (PluginProv s2) = s1 == s2+ucpSyntaxEq (ProofIrrelProv c1) (ProofIrrelProv c2) = coercionSyntaxEq c1 c2+ucpSyntaxEq (HoleProv _) _ = error "ucpSyntaxEq: impossible HoleProv"+ucpSyntaxEq _ (HoleProv _) = error "ucpSyntaxEq: impossible HoleProv"+ucpSyntaxEq _ _ = False+#endif+ ----------------------------------------------------------------------- -- Alpha Equality@@ -255,7 +288,12 @@ -- | Alpha equality of coercions. coercionAlphaEq :: Coercion -> Coercion -> Bool+#if __GLASGOW_HASKELL__ > 710+coercionAlphaEq c1 c2 = eqCoercionX env c1 c2+ where env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfCo c1 `unionVarSet` tyCoVarsOfCo c2))+#else coercionAlphaEq = coreEqCoercion+#endif ----------------------------------------------------------------------- @@ -326,7 +364,11 @@ -- | Find all free variables on a binder. Equivalent to idFreeVars, but safe to call on type bindings. freeVarsVar :: Var -> VarSet+#if __GLASGOW_HASKELL__ > 710+freeVarsVar v = varTypeTyCoVars v `unionVarSet` bndrRuleAndUnfoldingVars v+#else freeVarsVar v = varTypeTyVars v `unionVarSet` bndrRuleAndUnfoldingVars v+#endif -- | Find all free variables in a recursive definition, which excludes the bound variable. freeVarsDef :: CoreDef -> VarSet@@ -348,7 +390,11 @@ -- | Find all free variables in a type. freeVarsType :: Type -> TyVarSet+#if __GLASGOW_HASKELL__ > 710+freeVarsType = tyCoVarsOfType+#else freeVarsType = tyVarsOfType+#endif -- | Find all free variables in a coercion. freeVarsCoercion :: Coercion -> VarSet@@ -458,26 +504,41 @@ | TyConApp_TyCon | TyConApp_Arg Int | FunTy_Dom | FunTy_CoDom | ForAllTy_Var | ForAllTy_Body+#if __GLASGOW_HASKELL__ > 710+ | CastTy_Ty | CastTy_Co+ | CoercionTy_Co+#endif -- Coercion | Refl_Type | TyConAppCo_TyCon | TyConAppCo_Arg Int | AppCo_Fun | AppCo_Arg- | ForAllCo_TyVar | ForAllCo_Body+ | ForAllCo_TyVar+#if __GLASGOW_HASKELL__ > 710+ | ForAllCo_KindCo | ForAllCo_Co+#else+ | ForAllCo_Body+#endif | CoVarCo_CoVar | AxiomInstCo_Axiom | AxiomInstCo_Index | AxiomInstCo_Arg Int | UnsafeCo_Left | UnsafeCo_Right | SymCo_Co+ | SubCo_Co | TransCo_Left | TransCo_Right | NthCo_Int | NthCo_Co+#if __GLASGOW_HASKELL__ > 710+ | InstCo_Left | InstCo_Right+#else | InstCo_Co | InstCo_Type+#endif | LRCo_LR | LRCo_Co+ | UnivCo_Dom | UnivCo_Ran -- Quantified | Forall_Body | Conj_Lhs | Conj_Rhs | Disj_Lhs | Disj_Rhs | Impl_Lhs | Impl_Rhs | Eq_Lhs | Eq_Rhs- deriving (Eq,Read,Show)+ deriving (Eq, Generic, Read, Show) showCrumbs :: [Crumb] -> String showCrumbs crs = "[" ++ intercalate ", " (map showCrumb crs) ++ "]"@@ -512,22 +573,40 @@ FunTy_Dom -> "fun-dom" FunTy_CoDom -> "fun-cod" ForAllTy_Body -> "forall-body"+#if __GLASGOW_HASKELL__ > 710+ CastTy_Ty -> "castTy-ty"+ CastTy_Co -> "castTy-co"+ CoercionTy_Co -> "coercionTy-co"+#endif -- Coercions Refl_Type -> "refl-type" TyConAppCo_Arg n -> "coCon-arg " ++ show n AppCo_Fun -> "appCo-fun" AppCo_Arg -> "appCo-arg"+#if __GLASGOW_HASKELL__ > 710+ ForAllCo_KindCo -> "coForall-kindco"+ ForAllCo_Co -> "coForall-co"+#else ForAllCo_Body -> "coForall-body"+#endif AxiomInstCo_Arg n -> "axiom-inst " ++ show n UnsafeCo_Left -> "unsafe-left" UnsafeCo_Right -> "unsafe-right" SymCo_Co -> "sym-co"+ SubCo_Co -> "sub-co" TransCo_Left -> "trans-left" TransCo_Right -> "trans-right" NthCo_Co -> "nth-co"+#if __GLASGOW_HASKELL__ > 710+ InstCo_Left -> "inst-left"+ InstCo_Right -> "inst-right"+#else InstCo_Co -> "inst-co" InstCo_Type -> "inst-type"+#endif LRCo_Co -> "lr-co"+ UnivCo_Dom -> "univ-dom"+ UnivCo_Ran -> "univ-ran" -- Quantified Forall_Body -> "forall-body" Conj_Lhs -> "conj-lhs"
src/HERMIT/Dictionary/AlphaConversion.hs view
@@ -161,7 +161,7 @@ ss <- detectShadowsM bs fvs alphaLamR Nothing <+ alphaLetVarsR (varSetElems ss) <+ alphaCaseBinderR Nothing -unshadowAltR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m)+unshadowAltR :: (BoundVars c, MonadCatch m, MonadUnique m) => Rewrite c m CoreAlt unshadowAltR = do bs <- arr altVars@@ -235,7 +235,7 @@ ----------------------------------------------------------------------- -- | 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, MonadCatch m, MonadUnique m)+alphaAltVarR :: (BoundVars c, MonadCatch m, MonadUnique m) => Maybe String -> Var -> Rewrite c m CoreAlt alphaAltVarR mn v = do (con, vs, rhs) <- idR@@ -253,26 +253,26 @@ -- | Rename the specified variables in a case alternative, using the suggested names where provided. -- Suggested names *must* be provided in left-to-right order matching the order of the alt binders.-alphaAltVarsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+alphaAltVarsWithR :: (BoundVars c, MonadCatch m, MonadUnique m) => [(Maybe String,Var)] -> Rewrite c m CoreAlt alphaAltVarsWithR = andR . map (uncurry alphaAltVarR) . reverse -- note: right-to-left so type subst aren't undone -- | Rename the variables bound in a case alternative with the given list of suggested names.-alphaAltWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+alphaAltWithR :: (BoundVars c, MonadCatch m, MonadUnique m) => [String] -> Rewrite c m CoreAlt alphaAltWithR ns = do vs <- arr altVars alphaAltVarsWithR $ zip (map Just ns) vs -- | Rename the specified variables in a case alternative.-alphaAltVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+alphaAltVarsR :: (BoundVars c, MonadCatch m, MonadUnique m) => [Var] -> Rewrite c m CoreAlt alphaAltVarsR vs = do bs <- arr altVars alphaAltVarsWithR (zip (repeat Nothing) (bs `intersect` vs)) -- | Rename all identifiers bound in a case alternative.-alphaAltR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)+alphaAltR :: (BoundVars c, MonadCatch m, MonadUnique m) => Rewrite c m CoreAlt alphaAltR = arr altVars >>= alphaAltVarsR
src/HERMIT/Dictionary/Common.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Note: this module should NOT export externals. It is for common@@ -58,8 +57,6 @@ import HERMIT.Monad import HERMIT.Name -import Prelude.Compat- ------------------------------------------------------------------------------ -- | apply a transformation to a value in the current context.@@ -75,7 +72,7 @@ callT = contextfreeT $ \ e -> case e of Var {} -> return (e, []) App {} -> return (collectArgs e)- _ -> fail "not an application or variable occurence."+ _ -> fail "not an application or variable occurrence." -- | Succeeds if we are looking at an application matching the given predicate. callPredT :: Monad m => (Id -> [CoreExpr] -> Bool) -> Transform c m CoreExpr (CoreExpr, [CoreExpr])@@ -102,7 +99,7 @@ callNameG :: MonadCatch m => HermitName -> Transform c m CoreExpr () callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >> return () --- | Succeeds if we are looking at an application of a data constructor.+-- | Succeeds if we are looking at a saturated application of a data constructor. callDataConT :: MonadCatch m => Transform c m CoreExpr (DataCon, [Type], [CoreExpr]) callDataConT = prefixFailMsg "callDataConT failed:" $ do mb <- contextfreeT $ \ e -> let in_scope = mkInScopeSet (mkVarEnv [ (v,v) | v <- varSetElems (localFreeVarsExpr e) ])@@ -173,7 +170,7 @@ 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 -> Transform c m Var Bool+varIsOccurrenceOfT :: (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
src/HERMIT/Dictionary/Composite.hs view
@@ -4,10 +4,12 @@ ( externals , unfoldBasicCombinatorR , simplifyR+ , bashHelp , bashUsingR , bashR , bashExtendedWithR , bashDebugR+ , smashHelp , smashR , smashUsingR , smashExtendedWithR@@ -122,7 +124,7 @@ bashUsingR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadPath c Crumb, MonadCatch m) => [Rewrite c m LCore] -> Rewrite c m LCore bashUsingR rs = setFailMsg "bash failed: nothing to do." $- repeatR (occurAnalyseR >>> onetdR (catchesT rs)) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR+ repeatR (occurAnalyseR >>> onetdR (catchesM rs)) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR {- Occurrence Analysis updates meta-data, as well as performing some basic simplifications.@@ -182,12 +184,12 @@ -- Unlike bash, smash is not concerned with whether it duplicates work, -- and is intended for use during proving tasks. smashR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb- , HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+ , HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) => Rewrite c m LCore smashR = smashExtendedWithR [] smashExtendedWithR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb- , HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+ , HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) => [Rewrite c m LCore] -> Rewrite c m LCore smashExtendedWithR rs = smashUsingR (rs ++ map fst smashComponents1) (map fst smashComponents2) @@ -195,7 +197,7 @@ smashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, LemmaContext c, MonadCatch m) => [Rewrite c m LCore] -> [Rewrite c m LCore] -> Rewrite c m LCore smashUsingR rs1 rs2 = setFailMsg "smash failed: nothing to do." $- repeatR (occurAnalyseR >>> (onetdR (catchesT rs1) <+ onetdR (catchesT rs2))) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR+ repeatR (occurAnalyseR >>> (onetdR (catchesM rs1) <+ onetdR (catchesM rs2))) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR smashHelp :: [String]@@ -206,7 +208,7 @@ -- | As bash, but with "let-nonrec-subst" instead of "let-nonrec-subst-safe". smashComponents1 :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb- , HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+ , HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) => [(Rewrite c m LCore, String)] smashComponents1 = [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr") -- ??
src/HERMIT/Dictionary/FixPoint.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} module HERMIT.Dictionary.FixPoint@@ -14,6 +13,7 @@ , fixFusionRuleBR -- ** Utilities , isFixExprT+ , fixFusionRule ) where import Control.Arrow@@ -25,7 +25,7 @@ import HERMIT.Context import HERMIT.Core import HERMIT.Monad-import HERMIT.Kure hiding ((<$>))+import HERMIT.Kure import HERMIT.External import HERMIT.GHC import HERMIT.Name@@ -39,8 +39,6 @@ import HERMIT.Dictionary.Undefined import HERMIT.Dictionary.Unfold -import Prelude.Compat- -------------------------------------------------------------------------------------------------- -- | Externals for manipulating fixed points.@@ -86,12 +84,12 @@ -------------------------------------------------------------------------------------------------- -fixIntroR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+fixIntroR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb , HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) => Rewrite c m Core fixIntroR = promoteR fixIntroRecR <+ promoteR fixIntroNonRecR -fixIntroNonRecR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+fixIntroNonRecR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb , HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) => Rewrite c m CoreBind fixIntroNonRecR = prefixFailMsg "fix introduction failed: " $ do@@ -100,7 +98,7 @@ return $ NonRec f rhs' -- | @f = e@ ==\> @f = fix (\\ f -> e)@-fixIntroRecR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+fixIntroRecR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb , HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) => Rewrite c m CoreDef fixIntroRecR = prefixFailMsg "fix introduction failed: " $ do@@ -111,7 +109,7 @@ -- | Helper for fixIntroNonRecR and fixIntroRecR. Argument is function name. -- Meant to be applied to RHS of function. polyFixT :: forall c m.- ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+ ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb , HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) => Id -> Rewrite c m CoreExpr polyFixT f = do
src/HERMIT/Dictionary/Fold.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -21,7 +20,6 @@ , toEqualities , flipEquality , freeVarsEquality- , ppEqualityT ) where import Control.Arrow@@ -32,13 +30,12 @@ import qualified Data.Map as M import Data.Maybe (catMaybes, fromMaybe, maybeToList) import qualified Data.IntMap.Lazy as I-import Data.Typeable import HERMIT.Core import HERMIT.Context import HERMIT.External import HERMIT.GHC-import HERMIT.Kure hiding ((<$>))+import HERMIT.Kure import HERMIT.Lemma import HERMIT.Monad import HERMIT.Name@@ -47,10 +44,7 @@ import HERMIT.Dictionary.Common (varBindingDepthT,findIdT) import HERMIT.Dictionary.Inline hiding (externals) -import HERMIT.PrettyPrinter.Common-import qualified Text.PrettyPrint.MarkedHughesPJ as PP--import Prelude.Compat hiding (exp)+import Prelude hiding (exp) ------------------------------------------------------------------------ @@ -72,14 +66,14 @@ ------------------------------------------------------------------------ -foldR :: (ReadBindings c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m)+foldR :: (ReadBindings c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m) => HermitName -> Rewrite c m CoreExpr foldR nm = prefixFailMsg "Fold failed: " $ findIdT nm >>= foldVarR Nothing -foldVarR :: (ReadBindings c, MonadCatch m, MonadUnique m) => Maybe BindingDepth -> Var -> Rewrite c m CoreExpr+foldVarR :: (ReadBindings c, MonadCatch m) => Maybe BindingDepth -> Var -> Rewrite c m CoreExpr foldVarR = foldVarConfigR AllBinders -foldVarConfigR :: (ReadBindings c, MonadCatch m, MonadUnique m)+foldVarConfigR :: (ReadBindings c, MonadCatch m) => InlineConfig -> Maybe BindingDepth -> Var -> Rewrite c m CoreExpr foldVarConfigR config md v = do case md of@@ -215,13 +209,19 @@ ------------------------------------------------------------------------ data TyMap a = TyMEmpty- | TyM { tmHole :: TyMap (M.Map Var a)- , tmVar :: VMap a- , tmApp :: TyMap (TyMap a)- , tmFun :: TyMap (TyMap a)- , tmTcApp :: NameEnv (ListMap TyMap a)- , tmForall :: TyMap (BMap a)- , tmTyLit :: TyLitMap a+ | TyM { tmHole :: TyMap (M.Map Var a)+ , tmVar :: VMap a+ , tmApp :: TyMap (TyMap a)+#if __GLASGOW_HASKELL__ > 710+ , tmCastTy :: TyMap (TyMap a) -- See Note [Coercions]+ , tmCoercionTy :: TyMap a+ , tmForall :: TyMap (TyBinderMap a)+#else+ , tmFun :: TyMap (TyMap a)+ , tmForall :: TyMap (BMap a)+#endif+ , tmTcApp :: NameEnv (ListMap TyMap a)+ , tmTyLit :: TyLitMap a } instance Fold TyMap where@@ -231,16 +231,29 @@ fEmpty = TyMEmpty fAlter :: AlphaEnv -> [Var] -> Key TyMap -> A a -> TyMap a -> TyMap a- fAlter env vs ty f TyMEmpty = fAlter env vs ty f (TyM fEmpty fEmpty fEmpty fEmpty emptyNameEnv fEmpty fEmpty)+ fAlter env vs ty f TyMEmpty =+#if __GLASGOW_HASKELL__ > 710+ fAlter env vs ty f (TyM fEmpty fEmpty fEmpty fEmpty fEmpty fEmpty emptyNameEnv fEmpty)+#else+ fAlter env vs ty f (TyM fEmpty fEmpty fEmpty fEmpty fEmpty emptyNameEnv fEmpty)+#endif fAlter env vs ty f m@TyM{} = go ty where go (TyVarTy v) | v `elem` vs = m { tmHole = fAlter env vs (varType v) (Just . M.alter f v . fromMaybe M.empty) (tmHole m) } | otherwise = m { tmVar = fAlter env vs v f (tmVar m) } go (AppTy t1 t2) = m { tmApp = fAlter env vs t1 (toA (fAlter env vs t2 f)) (tmApp m) }+#if __GLASGOW_HASKELL__ > 710+ go (CastTy t co) = m { tmCastTy = fAlter env vs t (toA (fAlter env vs (coercionType co) f)) (tmCastTy m) }+ go (CoercionTy co) = m { tmCoercionTy = fAlter env vs (coercionType co) f (tmCoercionTy m) }+ go (ForAllTy tb t) = let bs = tyBinderVars tb+ env' = foldr extendAlphaEnv env bs+ in m { tmForall = fAlter env' (vs \\ bs) t (toA (fAlter env vs tb f)) (tmForall m) }+#else go (FunTy t1 t2) = m { tmFun = fAlter env vs t1 (toA (fAlter env vs t2 f)) (tmFun m) }- go (TyConApp tc tys) = m { tmTcApp = alterNameEnv (toA (fAlter env vs tys f)) (tmTcApp m) (getName tc) } go (ForAllTy tv t) = m { tmForall = fAlter (extendAlphaEnv tv env) (delete tv vs) t (toA (fAlter env vs (varType tv) f)) (tmForall m) }+#endif+ go (TyConApp tc tys) = m { tmTcApp = alterNameEnv (toA (fAlter env vs tys f)) (tmTcApp m) (getName tc) } go (LitTy l) = m { tmTyLit = fAlter env vs l f (tmTyLit m) } fFold :: VarEnv CoreExpr -> AlphaEnv -> Key TyMap -> TyMap a -> [(VarEnv CoreExpr, a)]@@ -254,17 +267,82 @@ go (AppTy t1 t2) = do (hs', m') <- fFold hs env t1 (tmApp m) fFold hs' env t2 m'+#if __GLASGOW_HASKELL__ > 710+ go (CastTy t co) = do+ (hs', m') <- fFold hs env t (tmCastTy m)+ fFold hs' env (coercionType co) m'+ go (CoercionTy co) = fFold hs env (coercionType co) m+ go (ForAllTy tb t) = do+ (hs', m') <- fFold hs (foldr extendAlphaEnv env (tyBinderVars tb)) t (tmForall m)+ fFold hs' env tb m'+#else go (FunTy t1 t2) = do (hs', m') <- fFold hs env t1 (tmFun m) fFold hs' env t2 m'- go (TyConApp tc tys) = maybeToList (lookupNameEnv (tmTcApp m) (getName tc)) >>= fFold hs env tys go (ForAllTy tv t) = do (hs', m') <- fFold hs (extendAlphaEnv tv env) t (tmForall m) fFold hs' env (varType tv) m'+#endif+ go (TyConApp tc tys) = maybeToList (lookupNameEnv (tmTcApp m) (getName tc)) >>= fFold hs env tys go (LitTy l) = fFold hs env l (tmTyLit m) ------------------------------------------------------------------------ +#if __GLASGOW_HASKELL__ > 710+tyBinderVars :: TyBinder -> [TyVar]+tyBinderVars (Named tv _) = [tv]+tyBinderVars (Anon _ty) = []++data TyBinderMap a =+ TBM { tbmNamed :: BMap (VisMap a)+ , tbmAnon :: TyMap a+ }++instance Fold TyBinderMap where+ type Key TyBinderMap = TyBinder++ fEmpty :: TyBinderMap a+ fEmpty = TBM fEmpty fEmpty++ fAlter :: AlphaEnv -> [Var] -> Key TyBinderMap -> A a -> TyBinderMap a -> TyBinderMap a+ fAlter env vs tb f m@TBM{} = go tb+ where go (Named tv v) = m { tbmNamed = fAlter env vs (varType tv) (toA (fAlter env vs v f)) (tbmNamed m) }+ go (Anon ty) = m { tbmAnon = fAlter env vs ty f (tbmAnon m) }++ fFold :: VarEnv CoreExpr -> AlphaEnv -> Key TyBinderMap -> TyBinderMap a -> [(VarEnv CoreExpr, a)]+ fFold hs env tb m@TBM{} = go tb+ where go (Named tv v) = do+ (hs', m') <- fFold hs env (varType tv) (tbmNamed m)+ fFold hs' env v m'+ go (Anon ty) = fFold hs env ty (tbmAnon m)++data VisMap a =+ VisMap { vmVisible :: Maybe a+ , vmSpecified :: Maybe a+ , vmInvisible :: Maybe a+ }++instance Fold VisMap where+ type Key VisMap = VisibilityFlag++ fEmpty :: VisMap a+ fEmpty = VisMap Nothing Nothing Nothing++ fAlter :: AlphaEnv -> [Var] -> Key VisMap -> A a -> VisMap a -> VisMap a+ fAlter _ _ v f m@VisMap{} = go v+ where go Visible = m { vmVisible = f (vmVisible m) }+ go Specified = m { vmSpecified = f (vmSpecified m) }+ go Invisible = m { vmInvisible = f (vmInvisible m) }++ fFold :: VarEnv CoreExpr -> AlphaEnv -> Key VisMap -> VisMap a -> [(VarEnv CoreExpr, a)]+ fFold hs _ v m@VisMap{} = go v+ where go Visible = (hs,) <$> maybeToList (vmVisible m)+ go Specified = (hs,) <$> maybeToList (vmSpecified m)+ go Invisible = (hs,) <$> maybeToList (vmInvisible m)+#endif++------------------------------------------------------------------------+ data TyLitMap a = TLM { tlmNumber :: M.Map Integer a , tlmString :: M.Map FastString a }@@ -418,9 +496,7 @@ proves :: Clause -> Clause -> Bool proves cl1 cl2 = maybe False (const True) $ soleElement (findFold (discardUniVars cl2) m) where m = insertFold emptyAlphaEnv hs pat () CLMEmpty- (hs,pat) = hsOf cl1- hsOf (Forall bs cl) = (bs,cl)- hsOf cl = ([],cl)+ (hs,pat) = collectQs cl1 -- | Determine if the right Clause is a substitution -- instance of the left Clause (which is a pattern@@ -489,7 +565,7 @@ ---------------------------------------------------------------------------- data CLMap a = CLMEmpty- | CLM { clmForall :: CLMap (ListMap BMap a)+ | CLM { clmForall :: CLMap (BMap a) , clmConj :: CLMap (CLMap a) , clmDisj :: CLMap (CLMap a) , clmImpl :: CLMap (CLMap a) -- note we do not care about the name@@ -509,8 +585,8 @@ fAlter :: AlphaEnv -> [Var] -> Key CLMap -> A a -> CLMap a -> CLMap a fAlter env vs cl f CLMEmpty = fAlter env vs cl f emptyCLMapWrapper fAlter env vs cl f m@(CLM{}) = go cl- where go (Forall bs cl') = m { clmForall = fAlter (foldr extendAlphaEnv env bs) (vs \\ bs) cl'- (toA (fAlter env vs (map varType bs) f)) (clmForall m) }+ where go (Forall b cl') = m { clmForall = fAlter (extendAlphaEnv b env) (delete b vs) cl'+ (toA (fAlter env vs (varType b) f)) (clmForall m) } go (Conj q1 q2) = m { clmConj = fAlter env vs q1 (toA (fAlter env vs q2 f)) (clmConj m) } go (Disj q1 q2) = m { clmDisj = fAlter env vs q1 (toA (fAlter env vs q2 f)) (clmDisj m) } go (Impl _ q1 q2) = m { clmImpl = fAlter env vs q1 (toA (fAlter env vs q2 f)) (clmImpl m) }@@ -520,9 +596,9 @@ fFold :: VarEnv CoreExpr -> AlphaEnv -> Key CLMap -> CLMap a -> [(VarEnv CoreExpr, a)] fFold _ _ _ CLMEmpty = [] fFold hs env cl m@CLM{} = go cl- where go (Forall bs cl') = do- (hs', m') <- fFold hs (foldr extendAlphaEnv env bs) cl' (clmForall m)- fFold hs' env (map varType bs) m'+ where go (Forall b cl') = do+ (hs', m') <- fFold hs (extendAlphaEnv b env) cl' (clmForall m)+ fFold hs' env (varType b) m' go (Conj q1 q2) = do (hs', m') <- fFold hs env q1 (clmConj m) fFold hs' env q2 m'@@ -550,25 +626,16 @@ -- mkEquality [] (baz y z) (\x. foo x x) === forall x. baz y z x = foo x x -- mkEquality [] (\x. foo x) (\y. bar y) === forall x. foo x = bar x mkEquality :: [CoreBndr] -> CoreExpr -> CoreExpr -> Equality-mkEquality vs lhs rhs = case mkClause vs lhs rhs of- Forall vs' (Equiv lhs' rhs') -> Equality vs' lhs' rhs'- Equiv lhs' rhs' -> Equality [] lhs' rhs'+mkEquality vs lhs rhs = Equality vs' lhs' rhs'+ where (vs', Equiv lhs' rhs') = collectQs $ mkClause vs lhs rhs toEqualities :: Clause -> [Equality] toEqualities = go []- where go qs (Forall vs cl) = go (qs++vs) cl- go qs (Equiv e1 e2) = [mkEquality qs e1 e2]+ where go qs (Forall b cl) = go (b:qs) cl+ go qs (Equiv e1 e2) = [mkEquality (reverse qs) e1 e2] go qs (Conj q1 q2) = go qs q1 ++ go qs q2 go _ _ = [] -ppEqualityT :: PrettyPrinter -> PrettyH Equality-ppEqualityT pp = do- Equality bs lhs rhs <- idR- dfa <- return bs >>> pForall pp- d1 <- return lhs >>> extractT (pCoreTC pp)- d2 <- return rhs >>> extractT (pCoreTC pp)- return $ PP.sep [dfa,d1,PP.text "=",d2]- ------------------------------------------------------------------------------ -- | Flip the LHS and RHS of a 'Equality'.@@ -609,7 +676,7 @@ ------------------------------------------------------------------------------ -data RewriteEqualityBox = RewriteEqualityBox (RewriteH Equality) deriving Typeable+data RewriteEqualityBox = RewriteEqualityBox (RewriteH Equality) instance Extern (RewriteH Equality) where type Box (RewriteH Equality) = RewriteEqualityBox@@ -618,7 +685,7 @@ ----------------------------------------------------------------- -data TransformEqualityStringBox = TransformEqualityStringBox (TransformH Equality String) deriving Typeable+data TransformEqualityStringBox = TransformEqualityStringBox (TransformH Equality String) instance Extern (TransformH Equality String) where type Box (TransformH Equality String) = TransformEqualityStringBox@@ -627,7 +694,7 @@ ----------------------------------------------------------------- -data TransformEqualityUnitBox = TransformEqualityUnitBox (TransformH Equality ()) deriving Typeable+data TransformEqualityUnitBox = TransformEqualityUnitBox (TransformH Equality ()) instance Extern (TransformH Equality ()) where type Box (TransformH Equality ()) = TransformEqualityUnitBox
src/HERMIT/Dictionary/Function.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -105,7 +106,11 @@ let (chosenBinds, dynBinds) = partition ((`elem` chosen) . fst) allBinds (ps, dbnds) = unzip dynBinds unboundTys = concat [ [ (i,i') | (i',b') <- dynBinds, i' < i , b' `elem` fvs ]+#if __GLASGOW_HASKELL__ > 710+ | (i,b) <- chosenBinds, let fvs = varSetElems (varTypeTyCoVars b) ]+#else | (i,b) <- chosenBinds, let fvs = varSetElems (varTypeTyVars b) ]+#endif guardMsg (null unboundTys) $ "type variables in args " ++ commas (nub $ map fst unboundTys) ++ " would become unbound unless args "@@ -113,7 +118,7 @@ wkr <- newIdH (unqualifiedName f ++ "'") (exprType (mkCoreLams dbnds body)) - let replaceCall :: Monad m => Rewrite c m CoreExpr+ let replaceCall :: Rewrite c m CoreExpr replaceCall = do (_,exprs) <- callPredT (const . (== f)) return $ mkApps (Var wkr) [ e | (p,e) <- zip [0..] exprs, (p::Int) `elem` ps ]@@ -162,7 +167,11 @@ let vs = [ v | v <- vsF ++ vsX, isNothing $ lookupTyVar sub v ] -- things we should stick back on as foralls -- TODO: make sure vsX don't capture anything in f' -- and vsF' doesn't capture anything in x'+#if __GLASGOW_HASKELL__ > 710+ return $ mkCoreLams vs $ mkCoreApp (text "buildAppM") f' x'+#else return $ mkCoreLams vs $ mkCoreApp f' x'+#endif -- | Given expression for f, build fix f. buildFixT :: (BoundVars c, LiftCoreM m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)@@ -178,7 +187,11 @@ => Type -> Transform c m x CoreExpr buildIdT ty = do idId <- findIdT $ fromString "Data.Function.id"+#if __GLASGOW_HASKELL__ > 710+ return $ mkCoreApp (text "buildIdT") (varToCoreExpr idId) (Type ty)+#else return $ mkCoreApp (varToCoreExpr idId) (Type ty)+#endif ------------------------------------------------------------------------------
src/HERMIT/Dictionary/GHC.hs view
@@ -25,23 +25,28 @@ , occurAnalyseChangedR , occurAnalyseExprChangedR , occurAnalyseAndDezombifyR+ , occurrenceAnalysisR+ , deShadowProgR , dezombifyR , buildDictionary , buildDictionaryT-#if __GLASGOW_HASKELL__ < 710 , buildTypeable-#endif ) where import qualified Bag import qualified CoreLint+#if __GLASGOW_HASKELL__ > 710 +import TcRnMonad (getCtLocM)+import TcRnTypes (cc_ev)+#else+import TcRnMonad (getCtLoc)+#endif import Control.Arrow import Control.Monad import Control.Monad.IO.Class import Data.Char (isSpace)-import Data.Either (partitionEithers) import Data.List (mapAccumL, nub) import qualified Data.Map as M import Data.String@@ -55,6 +60,10 @@ import HERMIT.Monad import HERMIT.Name +import HERMIT.PrettyPrinter.Common+import HERMIT.PrettyPrinter.Glyphs+import qualified HERMIT.PrettyPrinter.Clean as Clean+ ------------------------------------------------------------------------ -- | Externals that reflect GHC functions, or are derived from GHC functions.@@ -132,12 +141,12 @@ lintModuleT = do dynFlags <- dynFlagsT bnds <- arr mg_binds-#if __GLASGOW_HASKELL__ < 710- let (warns, errs) = CoreLint.lintCoreBindings [] bnds -- [] are vars to treat as in scope, used by GHCi-#else+#if __GLASGOW_HASKELL__ <= 710 -- [] are vars to treat as in scope, used by GHCi -- 'CoreDesugar' so we check for global ids, but not INLINE loop breakers, see notes in GHC's CoreLint module. let (warns, errs) = CoreLint.lintCoreBindings CoreDesugar [] bnds+#else+ let (warns, errs) = CoreLint.lintCoreBindings dynFlags CoreDesugar [] bnds #endif dumpSDocs endMsg = Bag.foldBag (\ d r -> d ++ ('\n':r)) (showSDoc dynFlags) endMsg if Bag.isEmptyBag errs@@ -154,7 +163,11 @@ case e of Type _ -> fail "cannot core lint types." _ -> maybe (return "Core Lint Passed") (fail . showSDoc dflags)+#if __GLASGOW_HASKELL__ <= 710 (CoreLint.lintExpr (varSetElems $ boundVars c) e)+#else+ (CoreLint.lintExpr dflags (varSetElems $ boundVars c) e)+#endif ------------------------------------------- @@ -198,38 +211,43 @@ occurAnalyseChangedR = changedByR lcoreSyntaxEq occurAnalyseR -- | Run GHC's occurrence analyser, and also eliminate any zombies.-occurAnalyseAndDezombifyR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m, Walker c u, Injection CoreExpr u) => Rewrite c m u+occurAnalyseAndDezombifyR :: (ExtendPath c Crumb, MonadCatch m, Walker c u, Injection CoreExpr u) => Rewrite c m u occurAnalyseAndDezombifyR = allbuR (tryR $ promoteExprR dezombifyR) >>> occurAnalyseR -occurrenceAnalysisR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m, Walker c LCore) => Rewrite c m LCore+occurrenceAnalysisR :: (ExtendPath c Crumb, MonadCatch m, Walker c LCore) => Rewrite c m LCore occurrenceAnalysisR = occurAnalyseAndDezombifyR ---------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ < 710 -- TODO: this is mostly an example, move somewhere? buildTypeable :: (HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadIO m) => Type -> m (Id, [CoreBind]) buildTypeable ty = do evar <- runTcM $ do cls <- tcLookupClass typeableClassName let predTy = mkClassPred cls [typeKind ty, ty] -- recall that Typeable is now poly-kinded- newWantedEvVar predTy+ newEvVar predTy buildDictionary evar-#endif -- | Build a dictionary for the given buildDictionary :: (HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadIO m) => Id -> m (Id, [CoreBind]) buildDictionary evar = do (i, bs) <- runTcM $ do+#if __GLASGOW_HASKELL__ > 710 + loc <- getCtLocM (GivenOrigin UnkSkol) Nothing+#else loc <- getCtLoc $ GivenOrigin UnkSkol+#endif let predTy = varType evar- nonC = mkNonCanonical $ CtWanted { ctev_pred = predTy, ctev_evar = evar, ctev_loc = loc }-#if __GLASGOW_HASKELL__ < 710- wCs = mkFlatWC [nonC]+#if __GLASGOW_HASKELL__ > 710 + nonC = mkNonCanonical $ CtWanted { ctev_pred = predTy, ctev_dest = EvVarDest evar, ctev_loc = loc }+ wCs = mkSimpleWC [cc_ev nonC]+ -- TODO: Make sure solveWanteds is the right function to call.+ (_wCs', bnds) <- second evBindMapBinds <$> runTcS (solveWanteds wCs) #else+ nonC = mkNonCanonical $ CtWanted { ctev_pred = predTy, ctev_evar = evar, ctev_loc = loc } wCs = mkSimpleWC [nonC]-#endif (_wCs', bnds) <- solveWantedsTcM wCs+#endif -- reportAllUnsolved _wCs' -- this is causing a panic with dictionary instantiation -- revist and fix! return (evar, bnds)@@ -278,15 +296,22 @@ (\ l -> return [(lnm,l)]) (M.lookup lnm ls)) mblnm- r <- forM nls $ \ nl@(n, l) -> do+ nls' <- flip filterM nls $ \ (n, l) -> do er <- attemptM $ applyT lintClauseT c $ lemmaC l case er of- Left msg -> return $ Left $ "Not adding lemma " ++ show n ++ " because lint failed.\n" ++ msg- Right _ -> return $ Right nl- let (fs,nls') = partitionEithers r+ Left msg -> do+ let pp = Clean.pretty { pOptions = (pOptions Clean.pretty) { po_exprTypes = Detailed } }+ d <- applyT (liftPrettyH (pOptions pp) $ pLCoreTC pp) c $ inject $ lemmaC l+ let Glyphs gs = renderCode (pOptions pp) d+ liftIO $ do+ putStr "\n" >> sequence_ [ withStyle s t | Glyph t s <- gs ] >> putStr "\n"+ putStrLn $ "Not adding lemma " ++ show n ++ " because lint failed.\n" ++ msg+ return False+ Right _ -> return True+ guardMsg (not (null nls')) "no lemmas to load." m <- getLemmas putLemmas $ (M.fromList nls') `M.union` m- return $ unlines (fs ++ ["Successfully loaded library " ++ show nm])+ return $ "Successfully loaded library " ++ show nm loadLemmaLibrary :: HscEnv -> HermitName -> IO LemmaLibrary loadLemmaLibrary hscEnv hnm = do
src/HERMIT/Dictionary/Induction.hs view
@@ -10,6 +10,7 @@ ) where +import Control.Arrow import Control.Monad import Data.String @@ -37,10 +38,11 @@ ------------------------------------------------------------------------------ +-- TODO: revisit design here to make one level caseSplitOnR :: Bool -> (Id -> Bool) -> RewriteH Clause-caseSplitOnR induction idPred = do+caseSplitOnR induction idPred = withPatFailMsg "induction can only be performed on universally quantified terms." $ do let p b = idPred b && isId b- Forall bs cl <- idR+ (bs, cl) <- arr collectQs guardMsg (any p bs) "specified identifier is not universally quantified in this lemma. (Induction cannot be performed on type quantifiers.)" let (as,b:bs') = break p bs -- safe because above guard guardMsg (not (any p bs')) "multiple matching quantifiers."@@ -70,4 +72,3 @@ qs <- go cases return $ mkForall newBs $ foldr1 Conj qs-
src/HERMIT/Dictionary/Inline.hs view
@@ -166,7 +166,13 @@ case unfoldingInfo (idInfo i) of CoreUnfolding { uf_tmpl = uft } -> single (uft, uncaptured) dunf@(DFunUnfolding {}) -> single . (,uncaptured) =<< dFunExpr dunf- _ -> fail $ "cannot find unfolding in Env or IdInfo."+ _ -> case idDetails i of+ ClassOpId cls -> do+ let selectors = zip [ idName s | s <- classAllSelIds cls] [0..]+ msg = getOccString i ++ " is not a method of " ++ getOccString cls ++ "."+ idx <- maybe (fail msg) return $ lookup (idName i) selectors+ single (mkDictSelRhs cls idx, uncaptured)+ _ -> fail "cannot find unfolding in Env or IdInfo." Just b -> let depth = hbDepth b in case hbSite b of CASEBINDER s alt -> let tys = tyConAppArgs (idType i)
src/HERMIT/Dictionary/Kure.hs view
@@ -5,6 +5,10 @@ externals , anyCallR , betweenR+ , anyCallR_LCore+ , testQuery+ , hfocusR+ , hfocusT ) where import Control.Arrow@@ -124,13 +128,13 @@ ------------------------------------------------------------------------------------ -hfocusR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, Walker c u, MonadCatch m)+hfocusR :: (ReadPath c Crumb, Walker c u, MonadCatch m) => Transform c m u LocalPathH -> Rewrite c m u -> Rewrite c m u hfocusR tp r = do lp <- tp localPathR lp r {-# INLINE hfocusR #-} -hfocusT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, Walker c u, MonadCatch m)+hfocusT :: (ReadPath c Crumb, Walker c u, MonadCatch m) => Transform c m u LocalPathH -> Transform c m u b -> Transform c m u b hfocusT tp t = do lp <- tp localPathT lp t
src/HERMIT/Dictionary/Local.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} module HERMIT.Dictionary.Local ( -- * Local Structural Manipulations@@ -13,6 +16,7 @@ , module HERMIT.Dictionary.Local.Let -- ** Miscellaneous , abstractR+ , push , pushR , betaReduceR , betaExpandR@@ -158,7 +162,11 @@ v' <- constT (cloneVarH id v) -- currently uses the same visible name (via "id"). -- We could do something else here, e.g. add a prime suffix. e <- arr (substCoreExpr v (varToCoreExpr v'))+#if __GLASGOW_HASKELL__ > 710+ return $ mkCoreApp (text "abstractR") (Lam v' e) (varToCoreExpr v)+#else return $ mkCoreApp (Lam v' e) (varToCoreExpr v)+#endif ------------------------------------------------------------------------------------------------------
src/HERMIT/Dictionary/Local/Case.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -9,6 +8,7 @@ ( -- * Rewrites on Case Expressions externals , caseFloatAppR+ , caseFloatArg , caseFloatArgR , caseFloatArgLemmaR , caseFloatCaseR@@ -18,6 +18,7 @@ , caseFloatInR , caseFloatInAppR , caseFloatInArgsR+ , caseFoldBinderR , caseReduceR , caseReduceDataconR , caseReduceLiteralR@@ -38,7 +39,7 @@ ) where import Control.Arrow-import Control.Monad ((>=>), forM, liftM)+import Control.Monad import Control.Monad.IO.Class import Data.List (intersect, transpose)@@ -61,8 +62,6 @@ import HERMIT.Dictionary.Undefined (verifyStrictT, buildStrictnessLemmaT) import HERMIT.Dictionary.Unfold (unfoldR) -import Prelude.Compat hiding ((<$>))- ------------------------------------------------------------------------------ -- | Externals relating to Case expressions.@@ -390,7 +389,7 @@ caseSplitR s = prefixFailMsg "case-split failed: " $ do c <- contextT guardMsg (all (inScope c) $ varSetElems $ freeVarsExpr s) "variables in desired scrutinee are unbound."- w <- constT $ newVarH "w" (exprType s)+ w <- constT $ newIdH "w" (exprType s) let f = compileFold [Equality [] s (varToCoreExpr w)] e' <- tryR $ withVarsInScope [w] $ extractR (anytdR (promoteR $ runFoldR f) :: Rewrite c m Core) constT $ do@@ -448,7 +447,7 @@ ------------------------------------------------------------------------------ caseInlineBinderR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c- , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+ , ReadBindings c, HasEmptyContext c, MonadCatch m ) => CaseBinderInlineOption -> Rewrite c m CoreExpr caseInlineBinderR opt = do w <- caseBinderIdT@@ -458,14 +457,14 @@ -- | Inline the case binder as the case scrutinee everywhere in the case alternatives. caseInlineScrutineeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c- , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+ , ReadBindings c, HasEmptyContext c, MonadCatch m ) => Rewrite c m CoreExpr caseInlineScrutineeR = prefixFailMsg "case-inline-scrutinee failed: " $ caseInlineBinderR Scrutinee -- | Inline the case binder as the case-alternative pattern everywhere in the case alternatives. caseInlineAlternativeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c- , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+ , ReadBindings c, HasEmptyContext c, MonadCatch m ) => Rewrite c m CoreExpr caseInlineAlternativeR = prefixFailMsg "case-inline-alternative failed: " $ caseInlineBinderR Alternative@@ -487,7 +486,7 @@ -- | In the case alternatives, fold any occurrences of the case alt patterns to the case binder. caseFoldBinderR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c- , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+ , ReadBindings c, HasEmptyContext c, MonadCatch m ) => Rewrite c m CoreExpr caseFoldBinderR = prefixFailMsg "case-fold-binder failed: " $ -- ensure the case binder is not dead, or else fold will fail@@ -498,7 +497,7 @@ -- | A cleverer version of 'mergeCaseAlts' that first attempts to abstract out any occurrences of the alternative pattern using the case binder. caseMergeAltsWithBinderR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c- , ReadBindings c, HasEmptyContext c, MonadCatch m, MonadUnique m )+ , ReadBindings c, HasEmptyContext c, MonadCatch m ) => Rewrite c m CoreExpr caseMergeAltsWithBinderR = prefixFailMsg "merge-case-alts-with-binder failed: " $
src/HERMIT/Dictionary/Local/Cast.hs view
@@ -1,23 +1,23 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} module HERMIT.Dictionary.Local.Cast ( -- * Rewrites on Case Expressions externals+ , castElimR , castElimReflR , castElimSymR , castFloatAppR , castFloatLamR , castElimSymPlusR -- TODO: revisit+ , castElimUnsafeR ) where -import qualified Coercion (substCo, extendTvSubst)- import Control.Arrow import Control.Monad import HERMIT.Core-import HERMIT.Context import HERMIT.External import HERMIT.GHC import HERMIT.Kure@@ -76,9 +76,13 @@ TyConAppCo _r t [c1, c2] -> do True <- return (isFunTyCon t) return $ Cast (App e1 (Cast e2 (SymCo c1))) c2+#if __GLASGOW_HASKELL__ > 710+ ForAllCo{} -> fail "castFloatAppR: ForAllCo TODO"+#else ForAllCo t c2 -> do Type x' <- return e2- return (Cast (App e1 e2) (Coercion.substCo (Coercion.extendTvSubst emptyCvSubst t x') c2))+ return (Cast (App e1 e2) (substCo (extendTvSubst emptySubst t x') c2))+#endif _ -> fail "castFloatApp" -- (\ x::a -> cast e (b -> c)) :: a -> c@@ -91,15 +95,17 @@ aTy = varType b return (Cast (Lam b e) (mkFunCo r (mkReflCo r aTy) co)) +#if __GLASGOW_HASKELL__ <= 710 -- | Attempts to tease a coercion apart into a type constructor and the application -- of a number of coercion arguments to that constructor splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) splitTyConAppCo_maybe (Refl ro ty) = (fmap . second . map) (Refl ro) (splitTyConApp_maybe ty) splitTyConAppCo_maybe (TyConAppCo _r tc cs) = Just (tc, cs) splitTyConAppCo_maybe _ = Nothing+#endif -- TODO: revisit-castElimSymPlusR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreExpr+castElimSymPlusR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreExpr castElimSymPlusR = castT idR idR (flip go) >>> joinT where go :: Monad m => Coercion -> CoreExpr -> m CoreExpr
src/HERMIT/Dictionary/Local/Let.hs view
@@ -1,7 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} module HERMIT.Dictionary.Local.Let@@ -46,7 +46,7 @@ ) where import Control.Arrow-import Control.Monad (ap, liftM, when)+import Control.Monad import Control.Monad.IO.Class import Data.List (intersect, partition)@@ -68,8 +68,6 @@ import HERMIT.Dictionary.Local.Bind hiding (externals) -import Prelude.Compat hiding ((<$))- ------------------------------------------------------------------------------ -- | Externals relating to 'Let' expressions.@@ -239,12 +237,9 @@ extractT occurrencesT >>^ (getSum >>> (< 2)) -(<$) :: Monad m => a -> m b -> m a-a <$ mb = mb >> return a- ------------------------------------------------------------------------------------------- -letElimR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr+letElimR :: MonadCatch m => Rewrite c m CoreExpr letElimR = prefixFailMsg "Let elimination failed: " $ withPatFailMsg (wrongExprForm "Let binds expr") $ do Let bg _ <- idR@@ -474,7 +469,11 @@ let bs = bindVars bnds captured = bs `intersect` (w : concatMap altVars alts) guardMsg (null captured) "let bindings would capture case pattern bindings."+#if __GLASGOW_HASKELL__ > 710+ let unbound = mkVarSet bs `intersectVarSet` (tyCoVarsOfType ty `unionVarSet` freeVarsVar w)+#else let unbound = mkVarSet bs `intersectVarSet` (tyVarsOfType ty `unionVarSet` freeVarsVar w)+#endif guardMsg (isEmptyVarSet unbound) "type variables in case signature would become unbound." return (Case (Let bnds s) w ty alts) >>> caseAllR idR idR idR (\_ -> altAllR idR (\_ -> idR) (arr (Let bnds) >>> alphaLetR)) @@ -574,7 +573,9 @@ -- | @body@ ==> @let v = e in body@ letNonRecIntroR :: (MonadCatch m, MonadUnique m) => String -> CoreExpr -> Rewrite c m CoreExpr letNonRecIntroR nm e = prefixFailMsg "Let-introduction failed: " $- contextfreeT $ \ body -> do v <- newVarH nm $ exprKindOrType e+ contextfreeT $ \ body -> do v <- case e of+ Type _ -> newTyVarH nm $ exprKindOrType e+ _ -> newIdH nm $ exprKindOrType e return $ Let (NonRec v e) body @@ -595,8 +596,8 @@ _ -> fail "can only introduce non-recursive bindings at Program or Expression nodes." -- | Introduce a local definition for a (possibly imported) identifier.--- Rewrites occurences of the identifier to point to this new local definiton.-letIntroUnfoldingR :: ( BoundVars c, ReadBindings c, HasDynFlags m, HasHermitMEnv m, LiftCoreM m+-- Rewrites occurrences of the identifier to point to this new local definiton.+letIntroUnfoldingR :: ( ReadBindings c, HasHermitMEnv m, LiftCoreM m , MonadCatch m, MonadIO m, MonadThings m, MonadUnique m ) => HermitName -> Rewrite c m CoreExpr letIntroUnfoldingR nm = do
@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-}@@ -24,14 +25,21 @@ , considerConstructT , nthArgPath , string2considerable+ , lamsBodyT+ , letsBodyT+ , gutsProgEndT+ , progEndT+ , applicationOfT+ , recognizedConsiderables ) where import Control.Arrow import Control.Monad -import Data.Dynamic (Typeable) import Data.Monoid +import GHC.Generics+ import HERMIT.Core import HERMIT.Context import HERMIT.External@@ -62,6 +70,8 @@ [ "consider <c> focuses on the first construct <c>.", recognizedConsiderables ] , external "arg" (promoteExprT . nthArgPath :: Int -> TransformH LCore LocalPathH) [ "arg n focuses on the (n-1)th argument of a nested application." ]+ , external "foralls-body" (promoteClauseT forallsBodyT :: TransformH LCore LocalPathH)+ [ "Descend into the body after a sequence of foralls." ] , external "lams-body" (promoteExprT lamsBodyT :: TransformH LCore LocalPathH) [ "Descend into the body after a sequence of lambdas." ] , external "lets-body" (promoteExprT letsBodyT :: TransformH LCore LocalPathH)@@ -129,11 +139,11 @@ bindingOf p = any p . varSetElems . binders binders :: LCoreTC -> VarSet-binders (LTCCore (LClause (Forall bs _))) = mkVarSet bs-binders (LTCCore (LClause _)) = emptyVarSet-binders (LTCCore (LCore core)) = bindersCore core-binders (LTCTyCo (TypeCore ty)) = binderType ty-binders (LTCTyCo (CoercionCore co)) = binderCoercion co+binders (LTCCore (LClause (Forall b _))) = unitVarSet b+binders (LTCCore (LClause _)) = emptyVarSet+binders (LTCCore (LCore core)) = bindersCore core+binders (LTCTyCo (TypeCore ty)) = bindersType ty+binders (LTCTyCo (CoercionCore co)) = binderCoercion co bindersCore :: Core -> VarSet bindersCore (BindCore bnd) = binderBind bnd@@ -154,13 +164,21 @@ binderExpr (Case _ w _ _) = unitVarSet w binderExpr _ = emptyVarSet -binderType :: Type -> VarSet-binderType (ForAllTy v _) = unitVarSet v-binderType _ = emptyVarSet+bindersType :: Type -> VarSet+#if __GLASGOW_HASKELL__ > 710+bindersType (ForAllTy (Named v _) _) = unitVarSet v+#else+bindersType (ForAllTy v _) = unitVarSet v+#endif+bindersType _ = emptyVarSet binderCoercion :: Coercion -> VarSet-binderCoercion (ForAllCo v _) = unitVarSet v-binderCoercion _ = emptyVarSet+#if __GLASGOW_HASKELL__ > 710+binderCoercion (ForAllCo v _ _) = unitVarSet v+#else+binderCoercion (ForAllCo v _) = unitVarSet v+#endif+binderCoercion _ = emptyVarSet ----------------------------------------------------------------------- @@ -207,7 +225,7 @@ -- | Language constructs that can be zoomed to. data Considerable = Binding | Definition | CaseAlt | Variable | Literal | Application | Lambda | LetExpr | CaseOf | Casty | Ticky | TypeExpr | CoercionExpr- deriving Typeable+ deriving Generic instance Extern Considerable where type Box Considerable = Considerable@@ -280,22 +298,26 @@ setEmptyContext ec = ec { baseContext = setEmptyContext (baseContext ec) , extraContext = mempty } -exhaustRepeatCrumbT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, Walker c LCoreTC, MonadCatch m) => Crumb -> Transform c m LCoreTC LocalPathH+exhaustRepeatCrumbT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, MonadCatch m) => Crumb -> Transform c m LCoreTC LocalPathH exhaustRepeatCrumbT cr = let l = exhaustPathL (repeat cr) in withLocalPathT (focusT l exposeLocalPathT) +-- | Construct a path to the body of a sequence of foralls.+forallsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, MonadCatch m) => Transform c m Clause LocalPathH+forallsBodyT = extractT (exhaustRepeatCrumbT Forall_Body)+ -- | Construct a path to the body of a sequence of lambdas.-lamsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, Walker c LCoreTC, MonadCatch m) => Transform c m CoreExpr LocalPathH+lamsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, 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, HasEmptyContext c, LemmaContext c, Walker c LCoreTC, MonadCatch m) => Transform c m CoreExpr LocalPathH+letsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, 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, HasEmptyContext c, LemmaContext c, Walker c LCoreTC, MonadCatch m) => Transform c m CoreProg LocalPathH+progEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, MonadCatch m) => Transform c m CoreProg LocalPathH progEndT = extractT (exhaustRepeatCrumbT ProgCons_Tail) -- | Construct a path to the end of a program, starting at the 'ModGuts'.-gutsProgEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, Walker c LCoreTC, MonadCatch m) => Transform c m ModGuts LocalPathH+gutsProgEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, MonadCatch m) => Transform c m ModGuts LocalPathH gutsProgEndT = modGutsT progEndT (\ _ p -> (mempty @@ ModGuts_Prog) <> p)
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module HERMIT.Dictionary.Navigation.Crumbs ( -- * Navigating Using Crumbs crumbExternals@@ -61,7 +62,7 @@ [ "Descend into the domain of a function type." ] , external "fun-cod" FunTy_CoDom [ "Descend into the codomain of a function type." ]- , external "forall-body" ForAllTy_Body+ , external "forall-ty-body" ForAllTy_Body [ "Descend into the body of a forall type." ] , external "refl-type" Refl_Type [ "Descend into the (n-1)th argument of a type constructor coercion." ]@@ -71,8 +72,15 @@ [ "Descend into the coercion function in a coercion application." ] , external "appCo-arg" AppCo_Arg [ "Descend into the coercion argument in a coercion application." ]+#if __GLASGOW_HASKELL__ > 710+ , external "coForall-kindco" ForAllCo_KindCo+ [ "Descend into the kind coercion of a forall coercion." ]+ , external "coForall-co" ForAllCo_Co+ [ "Descend into the body of a forall coercion." ]+#else , external "coForall-body" ForAllCo_Body [ "Descend into the body of a forall coercion." ]+#endif , external "axiom-inst" AxiomInstCo_Arg [ "Descend into the (n-1)th argument of a coercion axiom instantiation." ] , external "unsafe-left" UnsafeCo_Left@@ -81,20 +89,33 @@ [ "Descend into the right-hand type of an unsafe coercion." ] , external "sym-co" SymCo_Co [ "Descend into the coercion within a symmetric coercion." ]+ , external "sub-co" SubCo_Co+ [ "Descend into the coercion within a sub coercion." ] , external "trans-left" TransCo_Left [ "Descend into the left-hand type of a transitive coercion." ] , external "trans-right" TransCo_Right [ "Descend into the right-hand type of a transitive coercion." ] , external "nth-co" NthCo_Co [ "Descend into the coercion within an nth projection coercion." ]+#if __GLASGOW_HASKELL__ > 710+ , external "inst-left" InstCo_Left+ [ "Descend into the left coercion of a coercion instantiation." ]+ , external "inst-right" InstCo_Right+ [ "Descend into the right coercion of a coercion instantiation." ]+#else , external "inst-co" InstCo_Co [ "Descend into the coercion within a coercion instantiation." ] , external "inst-type" InstCo_Type [ "Descend into the type within a coercion instantiation." ]+#endif , external "lr-co" LRCo_Co [ "Descend into the coercion within a left/right projection coercion." ]+ , external "univ-dom" UnivCo_Dom+ [ "Descend into the domain type within a universal coercion." ]+ , external "univ-ran" UnivCo_Ran+ [ "Descend into the range type within a universal coercion." ] , external "forall-body" Forall_Body- [ "Descend into the clause of a quantified clause." ]+ [ "Descend into the body of a quantified clause." ] , external "conj-lhs" Conj_Lhs [ "Descend into left-hand side of a conjunction." ] , external "conj-rhs" Conj_Rhs
src/HERMIT/Dictionary/New.hs view
@@ -3,7 +3,6 @@ import Control.Arrow -import HERMIT.Context import HERMIT.Core import HERMIT.Kure import HERMIT.External@@ -49,7 +48,7 @@ -- 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 -> Transform c m CoreExpr ()+isVar :: (ExtendPath c Crumb, MonadCatch m) => String -> Transform c m CoreExpr () isVar nm = varT (arr $ cmpString2Var nm) >>= guardM ------------------------------------------------------------------------------------------------------
src/HERMIT/Dictionary/Query.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} @@ -7,6 +8,7 @@ , infoT , compareCoreAtT , compareBoundIdsT+ , compareBoundIds ) where import Control.Arrow@@ -43,7 +45,7 @@ -------------------------------------------------------- -- TODO: update this to cope with lemmas-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 :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c, HasDynFlags m, MonadCatch m) => Transform c m CoreTC String infoT = do crumbs <- childrenT fvs <- arr freeVarsCoreTC@@ -68,7 +70,11 @@ modName i = case nameModule_maybe (getName i) of Nothing -> "no module name." Just m -> moduleNameString (moduleName m)+#if __GLASGOW_HASKELL__ > 710+ in ["Type/Kind: " ++ showPpr dynFlags tyK] +++#else in [(if isKind tyK then "Kind: " else "Type: ") ++ showPpr dynFlags tyK] +++#endif case e of Var i -> [ "" , "OccName: " ++ getOccString i@@ -140,7 +146,12 @@ TyVarTy{} -> "TyVarTy" AppTy{} -> "AppTy" TyConApp{} -> "TyConApp"+#if __GLASGOW_HASKELL__ > 710+ CastTy{} -> "CastTy"+ CoercionTy{} -> "CoercionTy"+#else FunTy{} -> "FunTy"+#endif ForAllTy{} -> "ForAllTy" LitTy{} -> "LitTy" @@ -160,11 +171,15 @@ LRCo{} -> "LRCo" SubCo{} -> "SubCo" UnivCo{} -> "UnivCo"+#if __GLASGOW_HASKELL__ > 710+ KindCo{} -> "KindCo"+ CoherenceCo{} -> "CoherenceCo"+#endif -------------------------------------------------------- -- | Compare the core fragments at the end of the specified 'LocalPathH's.-compareCoreAtT :: (ExtendPath c Crumb, AddBindings c, ReadBindings c, ReadPath c Crumb, HasEmptyContext c, LemmaContext c, MonadCatch m) => Transform c m LCoreTC LocalPathH -> Transform c m LCoreTC LocalPathH -> Transform c m LCoreTC ()+compareCoreAtT :: (ExtendPath c Crumb, AddBindings c, ReadPath c Crumb, HasEmptyContext c, LemmaContext c, MonadCatch m) => Transform c m LCoreTC LocalPathH -> Transform c m LCoreTC LocalPathH -> Transform c m LCoreTC () compareCoreAtT p1T p2T = do p1 <- p1T p2 <- p2T@@ -174,7 +189,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 -> Transform c HermitM x ()+compareBoundIdsT :: 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@@ -182,8 +197,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)- => HermitName -> HermitName -> Transform c HermitM x ()+compareBoundIds :: ReadBindings c => HermitName -> HermitName -> Transform c HermitM x () compareBoundIds nm1 nm2 = do i1 <- findIdT nm1 i2 <- findIdT nm2 compareBoundIdsT i1 i2
src/HERMIT/Dictionary/Reasoning.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -29,8 +28,15 @@ , showLemmaT , showLemmasT , ppLemmaT- , ppClauseT- , ppLCoreTCT+ , retraction+ , mergeQuantifiersR+ , conjunctLemmasT+ , disjunctLemmasT+ , implyLemmasT+ , lemmaConsequentBiR+ , lemmaLhsIntroR+ , lemmaRhsIntroR+ , splitAntecedentR -- ** Lifting transformations over 'Clause' , lhsT , rhsT@@ -51,8 +57,9 @@ , retractionBR , unshadowClauseR , instantiateDictsR- , instantiateClauseVarR , abstractClauseR+ , csInQBodyT+ , instantiateClauseVarR -- * Constructing Composite Lemmas , ($$) , ($$$)@@ -66,7 +73,7 @@ ) where import Control.Arrow hiding ((<+>))-import Control.Monad ((>=>), forM, liftM)+import Control.Monad import Data.Either (partitionEithers) import Data.List (isInfixOf, nubBy)@@ -84,7 +91,6 @@ import HERMIT.Name import HERMIT.ParserCore import HERMIT.ParserType-import HERMIT.PrettyPrinter.Common import HERMIT.Utilities import HERMIT.Dictionary.Common@@ -93,7 +99,7 @@ import HERMIT.Dictionary.GHC hiding (externals) import HERMIT.Dictionary.Local.Let (nonRecIntroR) -import Prelude.Compat hiding ((<$>), (<*>))+import HERMIT.PrettyPrinter.Common import qualified Text.PrettyPrint.MarkedHughesPJ as PP @@ -124,9 +130,9 @@ , external "float-right" (\n1 -> promoteR (mergeQuantifiersR (const False) (cmpHN2Var n1)) :: RewriteH LCore) [ "Float quantifier out of right-hand side." ] , external "conjunct" (\n1 n2 n3 -> conjunctLemmasT n1 n2 n3 :: TransformH LCore ())- [ "conjunt new-name lhs-name rhs-name" ]+ [ "conjunct new-name lhs-name rhs-name" ] , external "disjunct" (\n1 n2 n3 -> disjunctLemmasT n1 n2 n3 :: TransformH LCore ())- [ "disjunt new-name lhs-name rhs-name" ]+ [ "disjunct new-name lhs-name rhs-name" ] , external "imply" (\n1 n2 n3 -> implyLemmasT n1 n2 n3 :: TransformH LCore ()) [ "imply new-name antecedent-name consequent-name" ] , external "lemma-birewrite" (promoteExprBiR . lemmaBiR Obligation :: LemmaName -> BiRewriteH LCore)@@ -186,7 +192,7 @@ [ "Apply a rewrite to both sides of an equality, succeeding if either succeed." ] , external "both" ((\t -> do (r,s) <- promoteClauseT (bothT t); return (unlines [r,s])) :: TransformH LCore String -> TransformH LCore String) [ "Apply a transformation to both sides of a quantified clause." ]- , external "reflexivity" (promoteClauseR (forallR idR reflexivityR <+ reflexivityR) :: RewriteH LCore)+ , external "reflexivity" (promoteClauseR (reflexivityR <+ forallR idR reflexivityR) :: RewriteH LCore) [ "Rewrite alpha-equivalence to true." ] , external "simplify-lemma" (simplifyClauseR :: RewriteH LCore) [ "Reduce a proof by applying reflexivity and logical operator identities." ]@@ -203,40 +209,45 @@ type EqualityProof c m = (Rewrite c m CoreExpr, Rewrite c m CoreExpr) -- | f == g ==> forall x. f x == g x-extensionalityR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb) => Maybe String -> Rewrite c HermitM Clause-extensionalityR mn = prefixFailMsg "extensionality failed: " $- do (vs,(lhs,rhs)) <- forallT idR (equivT idR idR (,)) (,) <+ equivT idR idR (\l r -> ([],(l,r)))+extensionalityR :: Maybe String -> Rewrite c HermitM Clause+extensionalityR mn = prefixFailMsg "extensionality failed: " $ do+ (vs, Equiv lhs rhs) <- arr collectQs - 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."+ 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+ -- TODO: use the fresh-name-generator in AlphaConversion to avoid shadowing.+ (_,argTy,_) <- splitFunTypeM tyL+ v <- constT $ newIdH (fromMaybe "x" mn) argTy - let x = varToCoreExpr v+ let x = varToCoreExpr v - return $ Forall (vs ++ [v]) $ Equiv (mkCoreApp lhs x) (mkCoreApp rhs x)+#if __GLASGOW_HASKELL__ > 710+ return $ mkForall vs $ Forall v $ Equiv (mkCoreApp (text "extensionalityR-lhs") lhs x)+ (mkCoreApp (text "extensionalityR-rhs") rhs x)+#else+ return $ mkForall vs $ Forall v $ Equiv (mkCoreApp lhs x) (mkCoreApp rhs x)+#endif ------------------------------------------------------------------------------ -- | @e@ ==> @let v = lhs in e@ eqLhsIntroR :: Clause -> Rewrite c HermitM Core-eqLhsIntroR (Forall bs (Equiv lhs _)) = nonRecIntroR "lhs" (mkCoreLams bs lhs)-eqLhsIntroR _ = fail "compound lemmas not supported."+eqLhsIntroR cl | (bs, Equiv lhs _) <- collectQs cl+ = nonRecIntroR "lhs" (mkCoreLams bs lhs)+eqLhsIntroR _ = fail "compound lemmas not supported." -- | @e@ ==> @let v = rhs in e@ eqRhsIntroR :: Clause -> Rewrite c HermitM Core-eqRhsIntroR (Forall bs (Equiv _ rhs)) = nonRecIntroR "rhs" (mkCoreLams bs rhs)-eqRhsIntroR _ = fail "compound lemmas not supported."+eqRhsIntroR cl | (bs, Equiv _ rhs) <- collectQs cl+ = nonRecIntroR "rhs" (mkCoreLams bs rhs)+eqRhsIntroR _ = fail "compound lemmas not supported." ------------------------------------------------------------------------------ -- | Create a 'BiRewrite' from a 'Clause'.-birewrite :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c- , ReadPath c Crumb, MonadCatch m, MonadUnique m )- => Clause -> BiRewrite c m CoreExpr+birewrite :: (ReadBindings c, MonadCatch m) => Clause -> BiRewrite c m CoreExpr birewrite cl = bidirectional (foldUnfold "left" id) (foldUnfold "right" flipEquality) where foldUnfold side f = transform $ \ c -> maybeM ("expression did not match "++side++"-hand side")@@ -250,14 +261,16 @@ -- | Lift a transformation over 'LCoreTC' into a transformation over the left-hand side of a 'Clause'. lhsT :: (AddBindings c, HasEmptyContext c, LemmaContext c, ReadPath c Crumb, ExtendPath c Crumb, MonadCatch m) => Transform c m LCore a -> Transform c m Clause a-lhsT t = extractT $ catchesT [ f (childT cr t) | cr <- [Conj_Lhs, Disj_Lhs, Impl_Lhs, Eq_Lhs]- , f <- [childT Forall_Body, id] ]+lhsT t = extractT+ $ catchesM+ $ childT Forall_Body (promoteT $ lhsT t) : [ childT cr t | cr <- [Conj_Lhs, Disj_Lhs, Impl_Lhs, Eq_Lhs] ] -- | Lift a transformation over 'LCoreTC' into a transformation over the right-hand side of a 'Clause'. rhsT :: (AddBindings c, HasEmptyContext c, LemmaContext c, ReadPath c Crumb, ExtendPath c Crumb, MonadCatch m) => Transform c m LCore a -> Transform c m Clause a-rhsT t = extractT $ catchesT [ f (childT cr t) | cr <- [Conj_Rhs, Disj_Rhs, Impl_Rhs, Eq_Rhs]- , f <- [childT Forall_Body, id] ]+rhsT t = extractT+ $ catchesM+ $ childT Forall_Body (promoteT $ rhsT t) : [ childT cr t | cr <- [Conj_Rhs, Disj_Rhs, Impl_Rhs, Eq_Rhs] ] -- | Lift a transformation over 'LCoreTC' into a transformation over both sides of a 'Clause'. bothT :: (AddBindings c, HasEmptyContext c, LemmaContext c, ReadPath c Crumb, ExtendPath c Crumb, MonadCatch m)@@ -267,14 +280,16 @@ -- | Lift a rewrite over 'LCoreTC' into a rewrite over the left-hand side of a 'Clause'. lhsR :: (AddBindings c, HasEmptyContext c, LemmaContext c, ReadPath c Crumb, ExtendPath c Crumb, MonadCatch m) => Rewrite c m LCore -> Rewrite c m Clause-lhsR r = extractR $ catchesT [ f (childR cr r) | cr <- [Conj_Lhs, Disj_Lhs, Impl_Lhs, Eq_Lhs]- , f <- [childR Forall_Body, id] ]+lhsR r = extractR+ $ catchesM+ $ childR Forall_Body (promoteR $ lhsR r) : [ childR cr r | cr <- [Conj_Lhs, Disj_Lhs, Impl_Lhs, Eq_Lhs] ] -- | Lift a rewrite over 'LCoreTC' into a rewrite over the right-hand side of a 'Clause'. rhsR :: (AddBindings c, HasEmptyContext c, LemmaContext c, ReadPath c Crumb, ExtendPath c Crumb, MonadCatch m) => Rewrite c m LCore -> Rewrite c m Clause-rhsR r = extractR $ catchesT [ f (childR cr r) | cr <- [Conj_Rhs, Disj_Rhs, Impl_Rhs, Eq_Rhs]- , f <- [childR Forall_Body, id] ]+rhsR r = extractR+ $ catchesM+ $ childR Forall_Body (promoteR $ rhsR r) : [ childR cr r | cr <- [Conj_Rhs, Disj_Rhs, Impl_Rhs, Eq_Rhs] ] -- | Lift a rewrite over 'LCoreTC' into a rewrite over both sides of a 'Clause'. bothR :: (AddBindings c, HasEmptyContext c, LemmaContext c, ReadPath c Crumb, ExtendPath c Crumb, MonadCatch m)@@ -296,27 +311,13 @@ ppLemmaT :: PrettyPrinter -> LemmaName -> PrettyH Lemma ppLemmaT pp nm = do Lemma q p _u <- idR- qDoc <- return q >>> ppClauseT pp+ qDoc <- return q >>> extractT (pLCoreTC pp) let hDoc = PP.text (show nm) PP.<+> PP.text ("(" ++ show p ++ ")") return $ hDoc PP.$+$ PP.nest 2 qDoc -ppLCoreTCT :: PrettyPrinter -> PrettyH LCoreTC-ppLCoreTCT pp = promoteT (ppClauseT pp) <+ promoteT (pCoreTC pp)--ppClauseT :: PrettyPrinter -> PrettyH Clause-ppClauseT pp = do- p <- absPathT- let parenify = ppClauseT pp >>^ \ d -> syntaxColor (PP.text "(") PP.<> d PP.<> syntaxColor (PP.text ")")- (forallT (pForall pp) (ppClauseT pp) (\ d1 d2 -> PP.sep [d1,d2])- <+ conjT parenify parenify (\ d1 d2 -> PP.sep [d1,syntaxColor (specialSymbol p ConjSymbol),d2])- <+ disjT parenify parenify (\ d1 d2 -> PP.sep [d1,syntaxColor (specialSymbol p DisjSymbol),d2])- <+ implT parenify parenify (\ _nm d1 d2 -> PP.sep [d1,syntaxColor (specialSymbol p ImplSymbol),d2])- <+ equivT (extractT $ pCoreTC pp) (extractT $ pCoreTC pp) (\ d1 d2 -> PP.sep [d1,specialSymbol p EquivSymbol,d2])- <+ return (syntaxColor $ PP.text "true"))- ------------------------------------------------------------------------------ -verifyClauseT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, MonadCatch m) => Transform c m Clause ()+verifyClauseT :: MonadCatch m => Transform c m Clause () verifyClauseT = setFailMsg "verification failed: clause must be true (perhaps try reflexivity first)" $ do CTrue <- idR return ()@@ -329,7 +330,7 @@ markLemmaUsedT nm used return CTrue -verifyOrCreateT :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, LemmaContext c, ReadBindings c, ReadPath c Crumb+verifyOrCreateT :: ( HasCoreRules c, LemmaContext c, ReadBindings c, ReadPath c Crumb , HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m ) => Used -> LemmaName -> Clause -> Transform c m a () verifyOrCreateT u nm cl = do@@ -338,8 +339,8 @@ then return cl >>> lemmaR u nm >>> verifyClauseT else contextonlyT $ \ c -> sendKEnvMessage $ AddObligation (toHermitC c) nm $ Lemma cl NotProven u -reflexivityR :: Monad m => Rewrite c m Clause-reflexivityR = do+reflexivityR :: MonadCatch m => Rewrite c m Clause+reflexivityR = withPatFailMsg "reflexivity may only be applied to equivalence lemmas" $ do Equiv lhs rhs <- idR guardMsg (exprAlphaEq lhs rhs) "the two sides are not alpha-equivalent." return CTrue@@ -475,10 +476,10 @@ ------------------------------------------------------------------------------ --- TODO: revisit this for binder re-ordering issue+-- TODO: revisit this and rewrite to act only on current quantifer? (more KURE-like) instantiateDictsR :: RewriteH Clause instantiateDictsR = prefixFailMsg "Dictionary instantiation failed: " $ do- bs <- forallT idR successT const+ (bs,_) <- arr collectQs 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."@@ -529,13 +530,15 @@ mergeQuantifiers :: MonadCatch m => (Var -> Bool) -> (Var -> Bool) -> Clause -> m Clause mergeQuantifiers pl pr cl = prefixFailMsg "merge-quantifiers failed: " $ do- (con,lq@(Forall bsl cll),rq@(Forall bsr clr)) <- case cl of+ (con,lq,rq) <- case cl of Conj q1 q2 -> return (Conj,q1,q2) Disj q1 q2 -> return (Disj,q1,q2) Impl nm q1 q2 -> return (Impl nm,q1,q2) _ -> fail "no quantifiers on either side." - let (lBefore,lbs) = break pl bsl+ let (bsl, cll) = collectQs lq+ (bsr, clr) = collectQs rq+ (lBefore,lbs) = break pl bsl (rBefore,rbs) = break pr bsr check b q l r = guardMsg (not (b `elemVarSet` freeVarsClause q)) $ "specified "++l++" binder would capture in "++r++"-hand clause."@@ -575,7 +578,16 @@ unshadowClause c = go emptySubst (mapUniqSet fs (freeVarsClause c)) c where fs = occNameFS . getOccName - go subst seen (Forall bs cl) = go1 subst seen bs [] cl+ go subst seen (Forall b cl)+ | fsb `elementOfUniqSet` seen = do+ b'' <- cloneVarFSH (inventNames seen) b'+ cl' <- go (extendSubst subst' b' (varToCoreExpr b'')) (addOneToUniqSet seen (fs b'')) cl+ return $ addBinder b'' cl'+ | otherwise = do+ cl' <- go subst' (addOneToUniqSet seen fsb) cl+ return $ addBinder b' cl'+ where fsb = fs b'+ (subst', b') = substBndr subst b go subst seen (Conj q1 q2) = do q1' <- go subst seen q1 q2' <- go subst seen q2@@ -594,18 +606,6 @@ in return $ Equiv e1' e2' go _ _ CTrue = return CTrue - go1 subst seen [] bs' cl = do- cl' <- go subst seen cl- return $ mkForall (reverse bs') cl'- go1 subst seen (b:bs) bs' cl- | fsb `elementOfUniqSet` seen = do- b'' <- cloneVarFSH (inventNames seen) b'- go1 (extendSubst subst' b' (varToCoreExpr b'')) (addOneToUniqSet seen (fs b'')) bs (b'':bs') cl- | otherwise = go1 subst' (addOneToUniqSet seen fsb) bs (b':bs') cl- where fsb = fs b'- (subst', b') = substBndr subst b-- inventNames :: UniqSet FastString -> FastString -> FastString inventNames s nm = head [ nm' | i :: Int <- [0..] , let nm' = nm `appendFS` (mkFastString (show i))@@ -613,28 +613,33 @@ ------------------------------------------------------------------------------ +-- TODO: revisit design of this, it's ugly instantiateClauseVarR :: (Var -> Bool) -> CoreString -> RewriteH Clause-instantiateClauseVarR p cs = prefixFailMsg "instantiation failed: " $ do- bs <- forallT idR successT const- e <- case filter p bs of- [] -> fail "no universally quantified variables match predicate."- (b:_) | isId b -> let (before,_) = break (==b) bs- in withVarsInScope before $ parseCoreExprT cs- | otherwise -> let (before,_) = break (==b) bs- in liftM (Type . fst) $ withVarsInScope before $ parseTypeWithHolesT cs+instantiateClauseVarR p cs = setFailMsg "instantiation failed: no quantifier matches"+ $ extractR (onetdR (promoteClauseR $ instantiateForallVarR p cs) :: RewriteH LCore)++instantiateForallVarR :: (Var -> Bool) -> CoreString -> RewriteH Clause+instantiateForallVarR p cs = prefixFailMsg "instantiation failed: " $ do+ Forall b _ <- idR+ guardMsg (p b) "universally quantified variable does not match predicate."+ e <- if isId b+ then parseCoreExprT cs+ else liftM (Type . fst) $ parseTypeWithHolesT cs transform (\ c -> instClause (boundVars c) p e) >>> (lintClauseT >> idR) -- lint for sanity ------------------------------------------------------------------------------ -- | Replace all occurrences of the given expression with a new quantified variable. abstractClauseR :: forall c m.- ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb- , LemmaContext c, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadUnique m )+ ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+ , LemmaContext c, LiftCoreM m, MonadCatch m, MonadUnique m ) => String -> Transform c m Clause CoreExpr -> Rewrite c m Clause abstractClauseR nm tr = prefixFailMsg "abstraction failed: " $ do e <- tr cl <- idR- b <- constT $ newVarH nm (exprKindOrType e)+ b <- constT $ case e of+ Type _ -> newTyVarH nm (exprKindOrType e)+ _ -> newIdH nm (exprKindOrType e) let f = compileFold [Equality [] e (varToCoreExpr b)] -- we don't use mkEquality on purpose, so we can abstract lambdas liftM dropBinders $ return (mkForall [b] cl) >>> extractR (anytdR $ promoteExprR $ runFoldR f :: Rewrite c m LCoreTC)@@ -652,18 +657,15 @@ ------------------------------------------------------------------------------ -lemmaBiR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb- , HasLemmas m, MonadCatch m, MonadUnique m)+lemmaBiR :: (LemmaContext c, ReadBindings c, HasLemmas m, MonadCatch m) => Used -> LemmaName -> BiRewrite c m CoreExpr lemmaBiR u nm = afterBiR (beforeBiR (getLemmaByNameT nm) (birewrite . lemmaC)) (markLemmaUsedT nm u >> idR) -lemmaConsequentR :: forall c m. ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c- , ReadPath c Crumb, HasLemmas m, MonadCatch m, MonadUnique m)+lemmaConsequentR :: forall c m. (LemmaContext c, ReadBindings c, HasLemmas m, MonadCatch m) => Used -> LemmaName -> Rewrite c m Clause lemmaConsequentR u nm = prefixFailMsg "lemma-consequent failed:" $ withPatFailMsg "lemma is not an implication." $ do- (hs,ante,pat) <- (getLemmaByNameT nm >>^ lemmaC) >>= \case Forall bs (Impl _ ante con) -> return (bs,ante,con)- Impl _ ante con -> return ([],ante,con)+ (hs, Impl _ ante pat) <- getLemmaByNameT nm >>^ (collectQs . lemmaC) cl' <- transform $ \ c cl -> do m <- maybeM ("consequent did not match.") $ lemmaMatch hs pat cl subs <- maybeM ("some quantifiers not instantiated.") $@@ -675,16 +677,16 @@ markLemmaUsedT nm u return cl' -lemmaConsequentBiR :: forall c m. ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, LemmaContext c+lemmaConsequentBiR :: forall c m. ( HasCoreRules c, LemmaContext c , ReadBindings c, ReadPath c Crumb, HasHermitMEnv m, HasLemmas m, LiftCoreM m- , MonadCatch m, MonadUnique m)+ , MonadCatch m) => Used -> LemmaName -> BiRewrite c m CoreExpr lemmaConsequentBiR u nm = afterBiR (beforeBiR (getLemmaByNameT nm) (go [] . lemmaC)) (markLemmaUsedT nm u >> idR) where go :: [CoreBndr] -> Clause -> BiRewrite c m CoreExpr- go bbs (Forall bs cl) = go (bbs++bs) cl- go bbs (Impl anteNm ante con) = do- let con' = mkForall bbs con- bs = forallQs con'+ go bs (Forall b cl) = go (b:bs) cl+ go bs (Impl anteNm ante con) = do+ let con' = mkForall (reverse bs) con+ (bs',_) = collectQs con' eqs = toEqualities con' foldUnfold side f = do (cl,e) <- transform $ \ c e -> do@@ -693,11 +695,10 @@ let matches = [ case lookupVarEnv hs b of Nothing -> Left b Just arg -> Right (b,arg)- | b <- bs ]+ | b <- bs' ] (unmatched, subs) = partitionEithers matches acl = substClauses subs ante- cl = mkForall unmatched acl- return (cl,e')+ return (mkForall unmatched acl, e') verifyOrCreateT u anteNm cl return e bidirectional (foldUnfold "left" id) (foldUnfold "right" flipEquality)@@ -730,7 +731,7 @@ markLemmaProvenT :: (LemmaContext c, HasLemmas m, MonadCatch m) => LemmaName -> Proven -> Transform c m a () markLemmaProvenT nm p = ifM (lemmaExistsT nm) (modifyLemmaT nm id idR (const p) id) (return ()) -lemmaExistsT :: (LemmaContext c, HasLemmas m, MonadCatch m) => LemmaName -> Transform c m a Bool+lemmaExistsT :: (HasLemmas m, MonadCatch m) => LemmaName -> Transform c m a Bool lemmaExistsT nm = constT $ Map.member nm <$> getLemmas ------------------------------------------------------------------------------@@ -760,7 +761,7 @@ (==>) :: (LemmaName, Clause) -> Clause -> Clause (==>) = uncurry Impl -infixr 5 /\+infixr 5 /\ -- this comment is required to avoid a CPP issue with backslash (/\) :: Clause -> Clause -> Clause (/\) = Conj
src/HERMIT/Dictionary/Remembered.hs view
@@ -62,20 +62,17 @@ insertLemmaT (prefixRemembered nm) $ Lemma (mkClause [] (varToCoreExpr v) e) Proven NotUsed -- | Unfold a remembered definition (like unfoldR, but looks in stash instead of context).-unfoldRememberedR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb- , HasLemmas m, MonadCatch m, MonadUnique m)+unfoldRememberedR :: (LemmaContext c, ReadBindings c, HasLemmas m, MonadCatch m) => Used -> LemmaName -> Rewrite c m CoreExpr unfoldRememberedR u = prefixFailMsg "Unfolding remembered definition failed: " . forwardT . lemmaBiR u . prefixRemembered -- | Fold a remembered definition (like foldR, but looks in stash instead of context).-foldRememberedR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb- , HasLemmas m, MonadCatch m, MonadUnique m)+foldRememberedR :: (LemmaContext c, ReadBindings c, HasLemmas m, MonadCatch m) => Used -> LemmaName -> Rewrite c m CoreExpr foldRememberedR u = prefixFailMsg "Folding remembered definition failed: " . backwardT . lemmaBiR u . prefixRemembered -- | Fold any of the remembered definitions.-foldAnyRememberedR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb- , HasLemmas m, MonadCatch m, MonadUnique m)+foldAnyRememberedR :: (LemmaContext c, ReadBindings c, HasLemmas m, MonadCatch m) => Rewrite c m CoreExpr foldAnyRememberedR = setFailMsg "Fold failed: no definitions could be folded." $ compileRememberedT >>= runFoldR
src/HERMIT/Dictionary/Rules.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}@@ -18,6 +17,10 @@ , ruleNameToClauseT , getHermitRuleT , getHermitRulesT+ , rulesHelpListT+ , ruleHelpT+ , lemmaHelpT+ , ruleToLemmaT -- ** Specialisation , specConstrR , specialiseR@@ -29,7 +32,6 @@ import Control.Arrow import Control.Monad -import Data.Dynamic (Typeable) import Data.Function (on) import Data.List (deleteFirstsBy,intercalate) import Data.String (IsString(..))@@ -47,6 +49,7 @@ import HERMIT.Dictionary.Reasoning hiding (externals) import HERMIT.PrettyPrinter.Common+import HERMIT.PrettyPrinter.Glyphs import IOEnv hiding (liftIO) @@ -57,7 +60,7 @@ externals = [ external "show-rules" (rulesHelpListT :: TransformH LCoreTC String) [ "List all the rules in scope." ] .+ Query- , external "show-rule" (ruleHelpT :: PrettyPrinter -> RuleName -> TransformH LCoreTC DocH)+ , external "show-rule" (ruleHelpT :: PrettyPrinter -> RuleName -> TransformH LCoreTC Glyphs) [ "Display details on the named rule." ] .+ Query , external "fold-rule" (promoteExprR . foldRuleR Obligation :: RuleName -> RewriteH LCore) [ "Apply a named GHC rule right-to-left." ] .+ Shallow@@ -71,7 +74,7 @@ [ "Apply named GHC rules left-to-right, succeed if any of the rules succeed" ] .+ Shallow , external "unfold-rules-unsafe" (promoteExprR . unfoldRulesR UnsafeUsed :: [RuleName] -> RewriteH LCore) [ "Apply named GHC rules left-to-right, succeed if any of the rules succeed" ] .+ Shallow .+ Unsafe- , external "rule-to-lemma" ((\pp nm -> ruleToLemmaT nm >> liftPrettyH (pOptions pp) (showLemmaT (fromString (show nm)) pp)) :: PrettyPrinter -> RuleName -> TransformH LCore DocH)+ , external "rule-to-lemma" (lemmaHelpT :: PrettyPrinter -> RuleName -> TransformH LCore Glyphs) [ "Create a lemma from a GHC RULE." ] , external "spec-constr" (promoteModGutsR specConstrR :: RewriteH LCore) [ "Run GHC's SpecConstr pass, which performs call pattern specialization."] .+ Deep@@ -81,7 +84,7 @@ ------------------------------------------------------------------------ -newtype RuleName = RuleName String deriving (Eq, Typeable)+newtype RuleName = RuleName String deriving Eq instance Extern RuleName where type Box RuleName = RuleName@@ -91,7 +94,7 @@ instance IsString RuleName where fromString = RuleName instance Show RuleName where show (RuleName s) = s -newtype RuleNameListBox = RuleNameListBox [RuleName] deriving Typeable+newtype RuleNameListBox = RuleNameListBox [RuleName] instance Extern [RuleName] where type Box [RuleName] = RuleNameListBox@@ -99,34 +102,34 @@ unbox (RuleNameListBox l) = l -- | Lookup a rule by name, attempt to apply it left-to-right. If successful, record it as an unproven lemma.-foldRuleR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, LemmaContext c, ReadBindings c- , ReadPath c Crumb, HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m- , MonadIO m, MonadThings m, MonadUnique m )+foldRuleR :: ( HasCoreRules c, LemmaContext c, ReadBindings c+ , ReadPath c Crumb, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m+ , MonadIO m, MonadThings m ) => Used -> RuleName -> Rewrite c m CoreExpr foldRuleR u nm = do q <- ruleNameToClauseT nm backwardT (birewrite q) >>> (verifyOrCreateT u (fromString (show nm)) q >> idR) -- | Lookup a set of rules by name, attempt to apply them left-to-right. Record an unproven lemma for the one that succeeds.-foldRulesR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, LemmaContext c, ReadBindings c- , ReadPath c Crumb, HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m- , MonadIO m, MonadThings m, MonadUnique m )+foldRulesR :: ( HasCoreRules c, LemmaContext c, ReadBindings c+ , ReadPath c Crumb, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m+ , MonadIO m, MonadThings m ) => Used -> [RuleName] -> Rewrite c m CoreExpr foldRulesR u = orR . map (foldRuleR u) -- | Lookup a rule by name, attempt to apply it left-to-right. If successful, record it as an unproven lemma.-unfoldRuleR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, LemmaContext c, ReadBindings c- , ReadPath c Crumb, HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m- , MonadIO m, MonadThings m, MonadUnique m )+unfoldRuleR :: ( HasCoreRules c, LemmaContext c, ReadBindings c+ , ReadPath c Crumb, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m+ , MonadIO m, MonadThings m ) => Used -> RuleName -> Rewrite c m CoreExpr unfoldRuleR u nm = do q <- ruleNameToClauseT nm forwardT (birewrite q) >>> (verifyOrCreateT u (fromString (show nm)) q >> idR) -- | Lookup a set of rules by name, attempt to apply them left-to-right. Record an unproven lemma for the one that succeeds.-unfoldRulesR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, LemmaContext c, ReadBindings c- , ReadPath c Crumb, HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m- , MonadIO m, MonadThings m, MonadUnique m )+unfoldRulesR :: ( HasCoreRules c, LemmaContext c, ReadBindings c+ , ReadPath c Crumb, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m+ , MonadIO m, MonadThings m ) => Used -> [RuleName] -> Rewrite c m CoreExpr unfoldRulesR u = orR . map (unfoldRuleR u) @@ -172,17 +175,25 @@ return (intercalate "\n" $ reverse $ map (show.fst) rulesEnv) -- | Print a named CoreRule using the quantified printer.-ruleHelpT :: (HasCoreRules c, LemmaContext c, ReadBindings c, ReadPath c Crumb) => PrettyPrinter -> RuleName -> Transform c HermitM a DocH-ruleHelpT pp nm = ruleNameToClauseT nm >>> liftPrettyH (pOptions pp) (ppClauseT pp)+ruleHelpT :: (HasCoreRules c, LemmaContext c, ReadBindings c, ReadPath c Crumb)+ => PrettyPrinter -> RuleName -> Transform c HermitM a Glyphs+ruleHelpT pp nm =+ do doc <- ruleNameToClauseT nm >>> liftPrettyH (pOptions pp) (extractT $ pLCoreTC pp)+ return $! renderCode (pOptions pp) doc +lemmaHelpT :: PrettyPrinter -> RuleName -> TransformH LCore Glyphs+lemmaHelpT pp nm =+ do doc <- ruleToLemmaT nm >> liftPrettyH (pOptions pp) (showLemmaT (fromString (show nm)) pp)+ return $! renderCode (pOptions pp) doc+ -- | Build an Clause from a named GHC rewrite rule.-ruleNameToClauseT :: ( BoundVars c, HasCoreRules c, HasDynFlags m, HasHermitMEnv m- , LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m )+ruleNameToClauseT :: ( BoundVars c, HasCoreRules c, HasHermitMEnv m+ , LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m ) => RuleName -> Transform c m a Clause ruleNameToClauseT name = getHermitRuleT name >>> ruleToClauseT -- | Transform GHC's CoreRule into an Clause.-ruleToClauseT :: (BoundVars c, HasHermitMEnv m, MonadThings m, MonadCatch m)+ruleToClauseT :: (BoundVars c, MonadThings m, MonadCatch m) => Transform c m CoreRule Clause ruleToClauseT = withPatFailMsg "HERMIT cannot handle built-in rules yet." $ do r@Rule{} <- idR -- other possibility is "BuiltinRule"@@ -190,7 +201,7 @@ let lhs = mkCoreApps (varToCoreExpr f) (ru_args r) return $ mkClause (ru_bndrs r) lhs (ru_rhs r) -ruleToLemmaT :: ( BoundVars c, HasCoreRules c, HasDynFlags m, HasHermitMEnv m, HasLemmas m+ruleToLemmaT :: ( BoundVars c, HasCoreRules c, HasHermitMEnv m, HasLemmas m , LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m) => RuleName -> Transform c m a () ruleToLemmaT nm = do@@ -236,7 +247,7 @@ 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+ contextfreeT (return . idCoreRules) -- | Promote 'idSpecRules' to CoreBind. bindSpecRules :: TransformH CoreBind [CoreRule]@@ -250,8 +261,7 @@ -- | Turn a list of rules into a rewrite which succeeds on the first successful rule. -- Note: this should only be used for built-in and compiler-generated rules which we assume -- are correct, because it does not record a lemma obligation for the rules used.-rulesToRewrite :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb- , HasDynFlags m, HasHermitMEnv m, MonadCatch m, MonadThings m, MonadUnique m )+rulesToRewrite :: (ReadBindings c, MonadCatch m, MonadThings m) => [CoreRule] -> Rewrite c m CoreExpr rulesToRewrite rs = catchesM [ (return r >>> ruleToClauseT) >>= forwardT . birewrite | r <- rs ]
src/HERMIT/Dictionary/Undefined.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+ module HERMIT.Dictionary.Undefined ( -- * Working with Undefined Values -- | Note that many of these operations require 'GHC.Err.undefined' to be explicitly imported if it is not used in the source file.@@ -10,6 +12,7 @@ , isUndefinedValT , replaceCurrentExprWithUndefinedR , replaceIdWithUndefinedR+ , replaceIdWithUndefined , errorToUndefinedR , undefinedExprR , undefinedAppR@@ -90,7 +93,7 @@ findUndefinedIdT = findIdT undefinedLocation -- | Check if the current expression is an undefined value.-isUndefinedValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Transform c m CoreExpr ()+isUndefinedValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, LiftCoreM 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@@ -102,11 +105,11 @@ errorLocation :: HermitName errorLocation = fromString "GHC.Err.error" -findErrorIdT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Transform c m a Id+findErrorIdT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Transform c m a Id findErrorIdT = findIdT errorLocation -- | Check if the current expression is an undefined value.-isErrorValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Transform c m CoreExpr ()+isErrorValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, LiftCoreM 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@@ -116,13 +119,13 @@ ------------------------------------------------------------------------ -- | error ty string ==> undefined ty-errorToUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+errorToUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr errorToUndefinedR = prefixFailMsg "error-to-undefined failed: " (isErrorValT >> replaceCurrentExprWithUndefinedR) ------------------------------------------------------------------------ -- | Make an undefined value of the given type.-mkUndefinedValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Type -> Transform c m a CoreExpr+mkUndefinedValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Type -> Transform c m a CoreExpr mkUndefinedValT ty = do un <- findUndefinedIdT return $ App (varToCoreExpr un) (Type ty)@@ -130,67 +133,67 @@ ------------------------------------------------------------------------------------------------------ -- | Set the current expression to 'undefined'.-replaceCurrentExprWithUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+replaceCurrentExprWithUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr replaceCurrentExprWithUndefinedR = contextfreeT exprTypeM >>= mkUndefinedValT -- | Replace all occurrences of the specified identifier with 'undefined'.-replaceIdWithUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Id -> Rewrite c m Core+replaceIdWithUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Id -> Rewrite c m Core replaceIdWithUndefinedR i = mkUndefinedValT (idType i) >>= substR i -replaceIdWithUndefined :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => HermitName -> Rewrite c m Core+replaceIdWithUndefined :: (BoundVars c, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => HermitName -> Rewrite c m Core replaceIdWithUndefined = findIdT >=> replaceIdWithUndefinedR ------------------------------------------------------------------------------------------------------ -- | undefinedExprR = undefinedAppR <+ undefinedLamR <+ undefinedLetR <+ undefinedCastR <+ undefinedTickR <+ undefinedCaseR-undefinedExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedExprR = setFailMsg "undefined-expr failed." (undefinedAppR <+ undefinedLamR <+ undefinedLetR <+ undefinedCastR <+ undefinedTickR <+ undefinedCaseR) ------------------------------------------------------------------------------------------------------ -- | @(undefined ty1) e@ ==> @undefined ty2@-undefinedAppR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedAppR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedAppR = prefixFailMsg "undefined-app failed: " $ do appT isUndefinedValT successT (<>) replaceCurrentExprWithUndefinedR -- | @(\ v -> undefined ty1)@ ==> @undefined ty2@ (where v is not a 'TyVar')-undefinedLamR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedLamR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedLamR = prefixFailMsg "undefined-lam failed: " $ do lamT successT isUndefinedValT (<>) replaceCurrentExprWithUndefinedR -- | let bds in (undefined ty) ==> undefined ty-undefinedLetR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedLetR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedLetR = prefixFailMsg "undefined-let failed: " $ do letT successT isUndefinedValT (<>) replaceCurrentExprWithUndefinedR -- | Cast (undefined ty1) co ==> undefined ty2-undefinedCastR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedCastR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedCastR = prefixFailMsg "undefined-cast failed: " $ do castT isUndefinedValT successT (<>) replaceCurrentExprWithUndefinedR -- | Tick tick (undefined ty1) ==> undefined ty1-undefinedTickR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedTickR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedTickR = prefixFailMsg "undefined-tick failed: " $ do tickT successT isUndefinedValT (<>) replaceCurrentExprWithUndefinedR -- | undefinedCaseR = undefinedCaseScrutineeR <+ undefinedCaseAltsR-undefinedCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseR = setFailMsg "undefined-case failed" (undefinedCaseScrutineeR <+ undefinedCaseAltsR) -- | case (undefined ty) of alts ==> undefined ty-undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseScrutineeR = prefixFailMsg "undefined-case failed: " $ do caseT isUndefinedValT successT successT (const successT) (\ _ _ _ _ -> ()) replaceCurrentExprWithUndefinedR -- | case e of {pat_1 -> undefined ty ; pat_2 -> undefined ty ; ... ; pat_n -> undefined ty} ==> undefined ty-undefinedCaseAltsR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseAltsR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, LiftCoreM 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@@ -198,7 +201,7 @@ ------------------------------------------------------------------------ -- | Verify that the given rewrite is a proof that the given expression is a strict function.-verifyStrictT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, LiftCoreM m, MonadIO m, MonadThings m) => CoreExpr -> Rewrite c m CoreExpr -> Transform c m a ()+verifyStrictT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, LiftCoreM 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 (funExprArgResTypesM f) undefArg <- mkUndefinedValT argTy@@ -207,18 +210,22 @@ verifyEqualityLeftToRightT lhs rhs r -- | Apply the given expression to undefined, at the proper type.-applyToUndefinedT :: (BoundVars c, HasDynFlags m, LiftCoreM m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+applyToUndefinedT :: (BoundVars c, LiftCoreM m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m) => CoreExpr -> Transform c m x CoreExpr applyToUndefinedT f = do let (tvs, body) = collectTyBinders f (_,dom,_) <- splitFunTypeM (exprType body) undef <- mkUndefinedValT dom+#if __GLASGOW_HASKELL__ > 710+ return $ mkCoreLams tvs $ mkCoreApp (text "applyToUndefinedT") body undef+#else return $ mkCoreLams tvs $ mkCoreApp body undef+#endif -- | Add a lemma for the strictness of a function. -- Note: assumes added lemma has been used-buildStrictnessLemmaT :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, LemmaContext c, ReadBindings c- , ReadPath c Crumb, HasDynFlags m, LiftCoreM m, HasHermitMEnv m, HasLemmas m+buildStrictnessLemmaT :: ( HasCoreRules c, LemmaContext c, ReadBindings c+ , ReadPath c Crumb, LiftCoreM m, HasHermitMEnv m, HasLemmas m , MonadCatch m, MonadIO m, MonadThings m) => Used -> LemmaName -> CoreExpr -> Transform c m x () buildStrictnessLemmaT u nm f = do
src/HERMIT/Dictionary/WorkerWrapper/Common.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -14,10 +13,10 @@ , workLabel ) where +import Control.Arrow import Control.Monad.IO.Class import Data.String (fromString)-import Data.Typeable import HERMIT.Context import HERMIT.Core@@ -74,7 +73,7 @@ -------------------------------------------------------------------------------------------------- -data WWAssumptionTag = A | B | C deriving (Eq,Ord,Show,Read,Typeable)+data WWAssumptionTag = A | B | C deriving (Eq,Ord,Show,Read) instance Extern WWAssumptionTag where type Box WWAssumptionTag = WWAssumptionTag@@ -104,7 +103,7 @@ let (_,compBody) = collectTyBinders comp (tvs, xTy, _) <- splitFunTypeM (exprType comp) idE <- buildIdT xTy- return $ Forall tvs (Equiv compBody idE)+ return $ mkForall tvs (Equiv compBody idE) -- Given abs, rep, and f expressions, build "abs . rep . f = f" assumptionBClauseT :: ( BoundVars c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m)@@ -114,16 +113,16 @@ comp <- buildCompositionT absE repAfterF let (tvs,lhs) = collectTyBinders comp rhs <- appArgM 5 lhs >>= appArgM 5 -- get f with proper tvs applied- return $ Forall tvs (Equiv lhs rhs)+ return $ mkForall tvs (Equiv lhs rhs) -- Given abs, rep, and f expressions, build "fix (abs . rep . f) = fix f" assumptionCClauseT :: (BoundVars c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m) => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Clause assumptionCClauseT absE repE fE = prefixFailMsg "Building assumption C failed: " $ do- Forall vs (Equiv lhs rhs) <- assumptionBClauseT absE repE fE+ (vs, Equiv lhs rhs) <- collectQs ^<< assumptionBClauseT absE repE fE lhs' <- buildFixT lhs rhs' <- buildFixT rhs- return $ Forall vs (Equiv lhs' rhs')+ return $ mkForall vs (Equiv lhs' rhs') -- Given abs, rep, and 'fix g' expressions, build "rep (abs (fix g)) = fix g" wwFusionClauseT :: MonadCatch m => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Clause@@ -134,11 +133,11 @@ rhs <- case lhs of (App _ (App _ rhs)) -> return rhs _ -> fail "lhs malformed"- return $ Forall tvs (Equiv lhs rhs)+ return $ mkForall tvs (Equiv lhs rhs) -- Perform the worker/wrapper split using condition 1-beta, introducing -- an unproven lemma for assumption C, and an appropriate w/w fusion lemma.-split1BetaR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, LemmaContext c, ReadBindings c, ReadPath c Crumb+split1BetaR :: ( HasCoreRules c, LemmaContext c, ReadBindings c, ReadPath c Crumb , HasHermitMEnv m, LiftCoreM m, HasLemmas m, MonadCatch m, MonadIO m, MonadThings m , MonadUnique m ) => Used -> LemmaName -> CoreExpr -> CoreExpr -> Rewrite c m CoreExpr@@ -163,7 +162,7 @@ return $ mkCoreLets [NonRec gId g, NonRec workId workRhs] newRhs -split2BetaR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, LemmaContext c, ReadBindings c, ReadPath c Crumb+split2BetaR :: ( HasCoreRules c, LemmaContext c, ReadBindings c, ReadPath c Crumb , HasHermitMEnv m, LiftCoreM m, HasLemmas m, MonadCatch m, MonadIO m, MonadThings m , MonadUnique m ) => Used -> LemmaName -> CoreExpr -> CoreExpr -> Rewrite c m CoreExpr
src/HERMIT/Dictionary/WorkerWrapper/Fix.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-}- module HERMIT.Dictionary.WorkerWrapper.Fix ( -- * The Worker/Wrapper Transformation -- | Note that many of these operations require 'Data.Function.fix' to be in scope.@@ -12,6 +10,10 @@ , wwAssA , wwAssB , wwAssC+ , wwAssAimpliesAssB+ , wwAssBimpliesAssC+ , wwAssAimpliesAssC+ , wwSplit ) where import Control.Arrow@@ -21,7 +23,7 @@ import HERMIT.Core import HERMIT.External import HERMIT.GHC-import HERMIT.Kure hiding ((<$>))+import HERMIT.Kure import HERMIT.Lemma import HERMIT.Monad import HERMIT.Name@@ -38,8 +40,6 @@ import HERMIT.Dictionary.Unfold import HERMIT.Dictionary.WorkerWrapper.Common--import Prelude.Compat --------------------------------------------------------------------------------------------------
src/HERMIT/Dictionary/WorkerWrapper/FixResult.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} module HERMIT.Dictionary.WorkerWrapper.FixResult@@ -13,9 +13,18 @@ , wwResultAssA , wwResultAssB , wwResultAssC+ , wwA+ , wwB+ , wwC+ , wwResultAssAimpliesAssB+ , wwResultAssBimpliesAssC+ , wwResultAssAimpliesAssC+ , wwFusion+ -- ** Exported for hermit-shell:+ , wwResultSplit ) where -import Prelude.Compat hiding (abs)+import Prelude hiding (abs) import Control.Arrow @@ -24,7 +33,7 @@ import HERMIT.Core import HERMIT.External import HERMIT.GHC-import HERMIT.Kure hiding ((<$>))+import HERMIT.Kure import HERMIT.Lemma import HERMIT.Monad import HERMIT.Name@@ -62,7 +71,7 @@ "fix (X->A) f ==> \\ x1 -> abs (fix (X->B) (\\ h x2 -> rep (f (\\ x3 -> abs (h x3)) x2)) x1", "Note: the pre-condition \"fix (X -> A) (\\ h x -> abs (rep (f h x))) == fix (X->A) f\" is expected to hold." ] .+ Introduce .+ Context .+ PreCondition- , external "ww-result-split" ((\ abs rep assC -> promoteDefR $ wwSplit (mkWWAssC assC) abs rep)+ , external "ww-result-split" ((\ abs rep assC -> promoteDefR $ wwResultSplit (mkWWAssC assC) abs rep) :: CoreString -> CoreString -> RewriteH LCore -> RewriteH LCore) [ "Worker/Wrapper Split (Result Variant)", "For any \"prog :: X -> A\", and given \"abs :: B -> A\" and \"rep :: A -> B\" as arguments,",@@ -71,7 +80,7 @@ " in let work = \\ x1 -> rep (f (\\ x2 -> abs (work x2)) x1)", " in \\ x0 -> abs (work x0)" ] .+ Introduce .+ Context- , external "ww-result-split-unsafe" ((\ abs rep -> promoteDefR $ wwSplit Nothing abs rep)+ , external "ww-result-split-unsafe" ((\ abs rep -> promoteDefR $ wwResultSplit Nothing abs rep) :: CoreString -> CoreString -> RewriteH LCore) [ "Unsafe Worker/Wrapper Split (Result Variant)", "For any \"prog :: X -> A\", and given \"abs :: B -> A\" and \"rep :: A -> B\" as arguments, then",@@ -177,7 +186,11 @@ wwL tyA tyB = prefixFailMsg "worker/wrapper factorisation failed: " $ do (tyXA,f) <- isFixExprT (_,tyX,tA) <- constT (splitFunTypeM tyXA)+#if __GLASGOW_HASKELL__ > 710+ let tyXB = ForAllTy (Anon tyX) tyB+#else let tyXB = FunTy tyX tyB+#endif h <- constT (newIdH "h" tyXB) guardMsg (eqType tyA tA) ("abs/rep types do not match fix body type.") x0 <- constT (newIdH "x0" tyX)@@ -308,13 +321,13 @@ ) -- | \\ abs rep -> (@prog = expr@ ==> @prog = let f = \\ prog -> expr in let work = \\ x1 -> rep (f (\\ x2 -> abs (work x2)) x1) in \\ x0 -> abs (work x0))@-wwSplit :: Maybe WWAssumption -> CoreString -> CoreString -> RewriteH CoreDef-wwSplit mAss absS repS = (parseCoreExprT absS &&& parseCoreExprT repS) >>= uncurry (wwResultSplitR mAss)+wwResultSplit :: Maybe WWAssumption -> CoreString -> CoreString -> RewriteH CoreDef+wwResultSplit mAss absS repS = (parseCoreExprT absS &&& parseCoreExprT repS) >>= uncurry (wwResultSplitR mAss) --- | As 'wwSplit' but performs the static-argument transformation for @n@ static arguments first, and optionally provides some of those arguments (specified by index) to all calls of abs and rep.+-- | As 'wwResultSplit' but performs the static-argument transformation for @n@ static arguments first, and optionally provides some of those arguments (specified by index) to all calls of abs and rep. -- This is useful if, for example, the expression, and abs and rep, all have a @forall@ type. wwResultSplitStaticArg :: Int -> [Int] -> Maybe WWAssumption -> CoreString -> CoreString -> RewriteH CoreDef-wwResultSplitStaticArg 0 _ = wwSplit+wwResultSplitStaticArg 0 _ = wwResultSplit wwResultSplitStaticArg n is = \ mAss absS repS -> prefixFailMsg "worker/wrapper split (static argument variant) failed: " $ do guardMsg (all (< n) is) "arguments for abs and rep must be chosen from the statically transformed arguments."
src/HERMIT/External.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -267,11 +265,7 @@ in (a:as, r') splitFunTyMaybe :: TypeRep -> Maybe (TypeRep, TypeRep)-#if __GLASGOW_HASKELL__ < 710-splitFunTyMaybe (TypeRep _ tc [a,r]) | tc == funTc = Just (a,r)-#else splitFunTyMaybe (TypeRep _ tc _krs [a,r]) | tc == funTc = Just (a,r)-#endif splitFunTyMaybe _ = Nothing -----------------------------------------------------------------@@ -298,7 +292,7 @@ ----------------------------------------------------------------- -data TagBox = TagBox TagE deriving Typeable+data TagBox = TagBox TagE instance Extern TagE where type Box TagE = TagBox@@ -307,7 +301,7 @@ ----------------------------------------------------------------- -data IntBox = IntBox Int deriving Typeable+data IntBox = IntBox Int instance Extern Int where type Box Int = IntBox@@ -317,7 +311,7 @@ ----------------------------------------------------------------- -- TODO: Considering unifying CrumbBox and PathBox under TransformLCoreTCPathBox.-data CrumbBox = CrumbBox Crumb deriving Typeable+data CrumbBox = CrumbBox Crumb instance Extern Crumb where type Box Crumb = CrumbBox@@ -326,7 +320,7 @@ ----------------------------------------------------------------- -data PathBox = PathBox LocalPathH deriving Typeable+data PathBox = PathBox LocalPathH instance Extern LocalPathH where type Box LocalPathH = PathBox@@ -335,7 +329,7 @@ ----------------------------------------------------------------- -newtype CoreString = CoreString { unCoreString :: String } deriving Typeable+newtype CoreString = CoreString { unCoreString :: String } instance Extern CoreString where type Box CoreString = CoreString@@ -344,7 +338,7 @@ ----------------------------------------------------------------- -data StringBox = StringBox String deriving Typeable+data StringBox = StringBox String instance Extern String where type Box String = StringBox@@ -353,7 +347,7 @@ ----------------------------------------------------------------- -data StringListBox = StringListBox [String] deriving Typeable+data StringListBox = StringListBox [String] instance Extern [String] where type Box [String] = StringListBox@@ -362,7 +356,7 @@ ----------------------------------------------------------------- -data IntListBox = IntListBox [Int] deriving Typeable+data IntListBox = IntListBox [Int] instance Extern [Int] where type Box [Int] = IntListBox@@ -378,7 +372,7 @@ ----------------------------------------------------------------- -data RewriteLCoreBox = RewriteLCoreBox (RewriteH LCore) deriving Typeable+data RewriteLCoreBox = RewriteLCoreBox (RewriteH LCore) instance Extern (RewriteH LCore) where type Box (RewriteH LCore) = RewriteLCoreBox@@ -387,7 +381,7 @@ ----------------------------------------------------------------- -data TransformLCoreStringBox = TransformLCoreStringBox (TransformH LCore String) deriving Typeable+data TransformLCoreStringBox = TransformLCoreStringBox (TransformH LCore String) instance Extern (TransformH LCore String) where type Box (TransformH LCore String) = TransformLCoreStringBox@@ -396,7 +390,7 @@ ----------------------------------------------------------------- -data TransformLCoreUnitBox = TransformLCoreUnitBox (TransformH LCore ()) deriving Typeable+data TransformLCoreUnitBox = TransformLCoreUnitBox (TransformH LCore ()) instance Extern (TransformH LCore ()) where type Box (TransformH LCore ()) = TransformLCoreUnitBox@@ -405,7 +399,7 @@ ----------------------------------------------------------------- -data TransformLCorePathBox = TransformLCorePathBox (TransformH LCore LocalPathH) deriving Typeable+data TransformLCorePathBox = TransformLCorePathBox (TransformH LCore LocalPathH) instance Extern (TransformH LCore LocalPathH) where type Box (TransformH LCore LocalPathH) = TransformLCorePathBox@@ -414,7 +408,7 @@ ----------------------------------------------------------------- -data BiRewriteLCoreBox = BiRewriteLCoreBox (BiRewriteH LCore) deriving Typeable+data BiRewriteLCoreBox = BiRewriteLCoreBox (BiRewriteH LCore) instance Extern (BiRewriteH LCore) where type Box (BiRewriteH LCore) = BiRewriteLCoreBox@@ -423,7 +417,7 @@ ----------------------------------------------------------------- -data RewriteLCoreListBox = RewriteLCoreListBox [RewriteH LCore] deriving Typeable+data RewriteLCoreListBox = RewriteLCoreListBox [RewriteH LCore] instance Extern [RewriteH LCore] where type Box [RewriteH LCore] = RewriteLCoreListBox@@ -432,7 +426,7 @@ ----------------------------------------------------------------- -data RewriteLCoreTCBox = RewriteLCoreTCBox (RewriteH LCoreTC) deriving Typeable+data RewriteLCoreTCBox = RewriteLCoreTCBox (RewriteH LCoreTC) instance Extern (RewriteH LCoreTC) where type Box (RewriteH LCoreTC) = RewriteLCoreTCBox@@ -441,7 +435,7 @@ ----------------------------------------------------------------- -data TransformLCoreTCStringBox = TransformLCoreTCStringBox (TransformH LCoreTC String) deriving Typeable+data TransformLCoreTCStringBox = TransformLCoreTCStringBox (TransformH LCoreTC String) instance Extern (TransformH LCoreTC String) where type Box (TransformH LCoreTC String) = TransformLCoreTCStringBox@@ -450,7 +444,7 @@ ----------------------------------------------------------------- -data TransformLCoreTCUnitBox = TransformLCoreTCUnitBox (TransformH LCoreTC ()) deriving Typeable+data TransformLCoreTCUnitBox = TransformLCoreTCUnitBox (TransformH LCoreTC ()) instance Extern (TransformH LCoreTC ()) where type Box (TransformH LCoreTC ()) = TransformLCoreTCUnitBox@@ -459,7 +453,7 @@ ----------------------------------------------------------------- -data TransformLCoreTCLCoreBox = TransformLCoreTCLCoreBox (TransformH LCoreTC LCore) deriving Typeable+data TransformLCoreTCLCoreBox = TransformLCoreTCLCoreBox (TransformH LCoreTC LCore) instance Extern (TransformH LCoreTC LCore) where type Box (TransformH LCoreTC LCore) = TransformLCoreTCLCoreBox@@ -468,7 +462,7 @@ ----------------------------------------------------------------- -data TransformLCoreTCPathBox = TransformLCoreTCPathBox (TransformH LCoreTC LocalPathH) deriving Typeable+data TransformLCoreTCPathBox = TransformLCoreTCPathBox (TransformH LCoreTC LocalPathH) instance Extern (TransformH LCoreTC LocalPathH) where type Box (TransformH LCoreTC LocalPathH) = TransformLCoreTCPathBox@@ -477,7 +471,7 @@ ----------------------------------------------------------------- -data BiRewriteLCoreTCBox = BiRewriteLCoreTCBox (BiRewriteH LCoreTC) deriving Typeable+data BiRewriteLCoreTCBox = BiRewriteLCoreTCBox (BiRewriteH LCoreTC) instance Extern (BiRewriteH LCoreTC) where type Box (BiRewriteH LCoreTC) = BiRewriteLCoreTCBox@@ -486,7 +480,7 @@ ----------------------------------------------------------------- -data RewriteLCoreTCListBox = RewriteLCoreTCListBox [RewriteH LCoreTC] deriving Typeable+data RewriteLCoreTCListBox = RewriteLCoreTCListBox [RewriteH LCoreTC] instance Extern [RewriteH LCoreTC] where type Box [RewriteH LCoreTC] = RewriteLCoreTCListBox
src/HERMIT/GHC.hs view
@@ -18,15 +18,11 @@ , qualifiedName , unqualifiedName , alphaTyVars- , Type(..)- , TyLit(..) , GhcException(..) , throwGhcException , throwCmdLineErrorS , exprArity , occurAnalyseExpr_NoBinderSwap- , isKind- , isLiftedTypeKindCon , notElemVarSet , varSetToStrings , showVarSet@@ -43,6 +39,7 @@ , injectDependency , reportAllUnsolved , zEncodeString+ , collectTyBinders #ifdef mingw32_HOST_OS , initStaticOpts #endif@@ -51,24 +48,33 @@ , module DsMonad , module DynamicLoading , module ErrUtils+ , module Kind+ , module MkId , module PrelNames , module TcEnv-#if __GLASGOW_HASKELL__ < 710- , module TcMType-#else- , module TcSMonad+#if __GLASGOW_HASKELL__ > 710+ , module TcEvidence #endif+ , module TcMType , module TcRnMonad , module TcRnTypes , module TcSimplify+#if __GLASGOW_HASKELL__ > 710+ , module TcSMonad+#endif , module TcType+#if __GLASGOW_HASKELL__ > 710+ , module TyCoRep+#else+ , module TypeRep+#endif , module Unify , getHscEnvCoreM ) where -- Imports from GHC. import qualified Bag-import Class (classTyCon)+import Class (classAllSelIds, classTyCon) import qualified CoAxiom -- for coAxiomName import Convert (thRdrNameGuesses) import CoreArity@@ -77,13 +83,19 @@ import DsMonad (DsM, initDsTc) import DynamicLoading (forceLoadTyCon, getValueSafely, lookupRdrNameInModuleForPlugins) import Encoding (zEncodeString)-import ErrUtils (pprErrMsgBag) import Finder (findImportedModule, cannotFindModule) -- we hide these so that they don't get inadvertently used. -- several are redefined in Core.hs and elsewhere-import GhcPlugins hiding (exprSomeFreeVars, exprFreeVars, exprFreeIds, bindFreeVars, getHscEnv, RuleName)+import GhcPlugins hiding (exprSomeFreeVars, exprFreeVars, exprFreeIds, bindFreeVars, getHscEnv, RuleName, collectTyBinders)+#if __GLASGOW_HASKELL__ > 710+import Kind (classifiesTypeWithValues,isStarKind)+#else import Kind (isKind,isLiftedTypeKindCon)+#endif import LoadIface (loadSysInterface)+import MkId (mkDictSelRhs)+import TcRnMonad (initIfaceTcRn)+import ErrUtils (pprErrMsgBagWithLoc) import qualified OccName -- for varName import OccurAnal (occurAnalyseExpr_NoBinderSwap) import Pair (Pair(..))@@ -94,20 +106,24 @@ #endif import TcEnv (tcLookupClass) import TcErrors (reportAllUnsolved)-#if __GLASGOW_HASKELL__ < 710-import TcMType (newWantedEvVar)-#else-import TcSMonad (newWantedEvVar)+#if __GLASGOW_HASKELL__ > 710+import TcEvidence (evBindMapBinds) #endif-import TcRnMonad (getCtLoc, initIfaceTcRn)-#if __GLASGOW_HASKELL__ < 710-import TcRnTypes (TcM, mkNonCanonical, mkFlatWC, CtEvidence(..), SkolemInfo(..), CtOrigin(..))+import TcMType (newEvVar)+#if __GLASGOW_HASKELL__ > 710+import TcRnTypes (TcM, mkNonCanonical, mkSimpleWC, CtEvidence(..), SkolemInfo(..), CtOrigin(..), TcEvDest(..))+import TcSimplify (solveWanteds)+import TcSMonad (runTcS) #else import TcRnTypes (TcM, mkNonCanonical, mkSimpleWC, CtEvidence(..), SkolemInfo(..), CtOrigin(..))-#endif import TcSimplify (solveWantedsTcM)+#endif import TcType (mkPhiTy, mkSigmaTy)-import TypeRep (Type(..),TyLit(..))+#if __GLASGOW_HASKELL__ > 710+import TyCoRep (Type(..), TyBinder(..), TyLit(..), Coercion(..), UnivCoProvenance(..))+#else+import TypeRep (Type(..), TyLit(..))+#endif import TysPrim (alphaTyVars) import Unify (tcUnifyTys, BindFlag(..)) @@ -200,7 +216,11 @@ unf_info = unfoldingInfo info has_unf = hasSomeUnfolding unf_info +#if __GLASGOW_HASKELL__ > 710+ RuleInfo rules _rulefvs = ruleInfo info+#else rules = specInfoRules (specInfo info)+#endif showAttributes :: [(Bool,SDoc)] -> SDoc showAttributes stuff@@ -232,6 +252,15 @@ -------------------------------------------------------------------------- +-- | Collect as many type bindings as possible from the front of a nested lambda+collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)+collectTyBinders expr = go [] expr+ where+ go tvs (Lam b e) | isTyVar b = go (b:tvs) e+ go tvs e = (reverse tvs, e)++--------------------------------------------------------------------------+ -- This function used to be in GHC itself, but was removed. -- It compares core for equality modulo alpha. eqExprX :: IdUnfoldingFun -> RnEnv2 -> CoreExpr -> CoreExpr -> Bool@@ -257,8 +286,13 @@ go _ (Lit lit1) (Lit lit2) = lit1 == lit2 go env (Type t1) (Type t2) = eqTypeX env t1 t2+#if __GLASGOW_HASKELL__ > 710+ go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2+ go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2+#else go env (Coercion co1) (Coercion co2) = coreEqCoercion2 env co1 co2 go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 env co1 co2 && go env e1 e2+#endif go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 go env (Tick n1 e1) (Tick n2 e2) = go_tickish n1 n2 && go env e1 e2 @@ -328,7 +362,11 @@ -- 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 }+#if __GLASGOW_HASKELL__ <= 710 provenance = Imported [ImpSpec decl_spec ImpAll]+#else+ provenance = Just $ ImpSpec decl_spec ImpAll+#endif env = mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface)) case lookupGRE_RdrName rdr_name env of [gre] -> return (Just (gre_name gre))
src/HERMIT/GHC/Typechecker.hs view
@@ -24,18 +24,20 @@ import Data.IORef ( newIORef, readIORef ) import TcEnv ( tcLookupGlobal )-#if __GLASGOW_HASKELL__ < 710-import TcType ( noUntouchables )-#else import DynFlags ( getSigOf )+#if __GLASGOW_HASKELL__ > 710+import Module ( moduleName )+#else import Module ( mkModuleSet, moduleName )-import TcType ( topTcLevel ) #endif+import TcType ( topTcLevel ) import FastString import Bag +#if __GLASGOW_HASKELL__ <= 710 import qualified Data.Set as Set+#endif import qualified Data.Map as Map import Prelude hiding (mod)@@ -57,23 +59,32 @@ errs_var <- newIORef (emptyBag, emptyBag) ; tvs_var <- newIORef emptyVarSet ; keep_var <- newIORef emptyNameSet ;+#if __GLASGOW_HASKELL__ > 710 + used_gre_var <- newIORef [] ;+#else used_rdr_var <- newIORef Set.empty ;+#endif th_var <- newIORef False ; th_splice_var<- newIORef False ;+#if __GLASGOW_HASKELL__ > 710 + infer_var <- newIORef (True, emptyBag) ;+#else infer_var <- newIORef True ;+#endif lie_var <- newIORef emptyWC ; dfun_n_var <- newIORef (mk_dfun_n guts) ; type_env_var <- newIORef type_env ; dependent_files_var <- newIORef [] ;-#if __GLASGOW_HASKELL__ >= 710 static_wc_var <- newIORef emptyWC ;-#endif th_topdecls_var <- newIORef [] ; th_topnames_var <- newIORef emptyNameSet ; th_modfinalizers_var <- newIORef [] ; th_state_var <- newIORef Map.empty ;+#if __GLASGOW_HASKELL__ > 710 + th_remote_state_var <- newIORef Nothing ;+#endif let { dflags = hsc_dflags hsc_env ;@@ -94,10 +105,8 @@ -- queried during tcrnif tcg_mod = mod, tcg_src = hsc_src,-#if __GLASGOW_HASKELL__ >= 710 tcg_sig_of = getSigOf dflags (moduleName mod), tcg_impl_rdr_env = Nothing,-#endif tcg_rdr_env = mg_rdr_env guts, tcg_default = Nothing, tcg_fix_env = mg_fix_env guts,@@ -107,17 +116,15 @@ tcg_inst_env = mg_inst_env guts, tcg_fam_inst_env = mg_fam_inst_env guts, tcg_ann_env = emptyAnnEnv,-#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ <= 710 tcg_visible_orphan_mods = mkModuleSet [mod], #endif tcg_dfun_n = dfun_n_var, -- accumulated, not queried, during tcrnif tcg_dependent_files = dependent_files_var,-#if __GLASGOW_HASKELL__ >= 710 tcg_tc_plugins = [], tcg_static_wc = static_wc_var,-#endif tcg_exports = [], tcg_warns = NoWarnings, tcg_anns = [],@@ -140,15 +147,23 @@ tcg_sigs = emptyNameSet, tcg_imp_specs = [], tcg_rn_decls = maybe_rn_syntax emptyRnGroup,+#if __GLASGOW_HASKELL__ <= 710 tcg_used_rdrnames = used_rdr_var,+#endif tcg_rn_imports = [], tcg_rn_exports = maybe_rn_syntax [], tcg_keep = keep_var,+#if __GLASGOW_HASKELL__ > 710 + tcg_self_boot = NoSelfBoot, -- Assume there are no hsboot files+ tcg_used_gres = used_gre_var,+ tcg_th_remote_state = th_remote_state_var,+ tcg_tr_module = Nothing,+#endif tcg_th_splice_used = th_splice_var } ; lcl_env = TcLclEnv { tcl_errs = errs_var,- tcl_loc = mkGeneralSrcSpan (fsLit "Top level"),+ tcl_loc = realSrcLocSpan $ mkRealSrcLoc (fsLit "Top level") 1 1, tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage,@@ -159,11 +174,7 @@ tcl_tidy = emptyTidyEnv, tcl_tyvars = tvs_var, tcl_lie = lie_var,-#if __GLASGOW_HASKELL__ < 710- tcl_untch = noUntouchables-#else tcl_tclvl = topTcLevel-#endif } ; } ; @@ -178,12 +189,7 @@ lie <- readIORef lie_var ; if isEmptyWC lie then return ()-#if __GLASGOW_HASKELL__ < 710- else pprPanic "initTc: unsolved constraints"- (pprWantedsWithLocs lie) ;-#else else pprPanic "initTc: unsolved constraints" (ppr lie) ;-#endif -- Collect any error messages msgs <- readIORef errs_var ;@@ -201,7 +207,11 @@ (mg_fam_insts guts) mk_field_env :: ModGuts -> RecFieldEnv -- TODO+#if __GLASGOW_HASKELL__ > 710+mk_field_env _ = emptyNameEnv +#else mk_field_env _ = RecFields emptyNameEnv emptyNameSet+#endif mk_dfun_n :: ModGuts -> OccSet -- TODO
src/HERMIT/Kernel.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}@@ -33,7 +32,6 @@ import Data.IORef import Data.Map-import Data.Typeable import HERMIT.Context import HERMIT.External@@ -71,7 +69,7 @@ -- | A /handle/ for a specific version of the 'ModGuts'. newtype AST = AST Int -- ^ Currently 'AST's are identified by an 'Int' label.- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) firstAST :: AST firstAST = AST 0@@ -135,7 +133,7 @@ msgMV :: MVar Msg <- liftIO newEmptyMVar - let withAST :: (MonadIO m, MonadCatch m)+ let withAST :: MonadIO m => AST -> (KernelState -> CoreM (KureM (Maybe KernelState, a))) -> m (AST, a) withAST ast k = do r <- liftIO $ do
src/HERMIT/Kure.hs view
@@ -1,9 +1,9 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -68,7 +68,12 @@ , tyVarT, tyVarR , litTyT, litTyR , appTyT, appTyAllR, appTyAnyR, appTyOneR+#if __GLASGOW_HASKELL__ > 710+ , castTyT, castTyAllR, castTyAnyR, castTyOneR+ , coercionTyT, coercionTyR+#else , funTyT, funTyAllR, funTyAnyR, funTyOneR+#endif , forAllTyT, forAllTyAllR, forAllTyAnyR, forAllTyOneR , tyConAppT, tyConAppAllR, tyConAppAnyR, tyConAppOneR -- ** Coercions@@ -83,19 +88,16 @@ , nthCoT, nthCoAllR, nthCoAnyR, nthCoOneR , instCoT, instCoAllR, instCoAnyR, instCoOneR , lrCoT, lrCoAllR, lrCoAnyR, lrCoOneR+ , subCoT, subCoR+ , univCoT, univCoAllR, univCoAnyR, univCoOneR -- ** Lemmas , conjT, conjAllR , disjT, disjAllR , implT, implAllR , equivT, equivAllR- , forallT, forallR- -- * Applicative- , (<$>)- , (<*>)+ , forallT, forallR, forallsT, forallsR ) where -import Control.Monad (ap, liftM)- import Language.KURE import Language.KURE.BiTransform import Language.KURE.Lens@@ -109,8 +111,6 @@ import HERMIT.Lemma import HERMIT.Monad -import Prelude.Compat hiding ((<$>), (<*>))- --------------------------------------------------------------------- type TransformH a b = Transform HermitC HermitM a b@@ -119,16 +119,6 @@ type LensH a b = Lens HermitC HermitM a b type PathH = Path Crumb --- It is annoying that Applicative is not a superclass of Monad in 7.8.--- This causes a warning which we ignore.-(<$>) :: Monad m => (a -> b) -> m a -> m b-(<$>) = liftM-{-# INLINE (<$>) #-}--(<*>) :: Monad m => m (a -> b) -> m a -> m b-(<*>) = ap-{-# INLINE (<*>) #-}- --------------------------------------------------------------------- -- | Walking over modules, programs, binding groups, definitions, expressions and case alternatives.@@ -144,31 +134,31 @@ AltCore alt -> inject <$> applyT allRalt c alt ExprCore e -> inject <$> applyT allRexpr c e where- allRmodguts :: MonadCatch m => Rewrite c m ModGuts+ allRmodguts :: Rewrite c m ModGuts allRmodguts = modGutsR (extractR r) {-# INLINE allRmodguts #-} - allRprog :: MonadCatch m => Rewrite c m CoreProg+ allRprog :: Rewrite c m CoreProg allRprog = readerT $ \case ProgCons{} -> progConsAllR (extractR r) (extractR r) _ -> idR {-# INLINE allRprog #-} - allRbind :: MonadCatch m => Rewrite c m CoreBind+ allRbind :: Rewrite c m CoreBind allRbind = readerT $ \case NonRec{} -> nonRecAllR idR (extractR r) -- we don't descend into the Var Rec _ -> recAllR (const $ extractR r) {-# INLINE allRbind #-} - allRdef :: MonadCatch m => Rewrite c m CoreDef+ allRdef :: Rewrite c m CoreDef allRdef = defAllR idR (extractR r) -- we don't descend into the Id {-# INLINE allRdef #-} - allRalt :: MonadCatch m => Rewrite c m CoreAlt+ allRalt :: Rewrite c m CoreAlt allRalt = altAllR idR (const idR) (extractR r) -- we don't descend into the AltCon or Vars {-# INLINE allRalt #-} - allRexpr :: MonadCatch m => Rewrite c m CoreExpr+ allRexpr :: Rewrite c m CoreExpr allRexpr = readerT $ \case App{} -> appAllR (extractR r) (extractR r) Lam{} -> lamAllR idR (extractR r) -- we don't descend into the Var@@ -188,7 +178,9 @@ allR r = prefixFailMsg "allR failed: " $ readerT $ \case AppTy{} -> appTyAllR r r+#if __GLASGOW_HASKELL__ <= 710 FunTy{} -> funTyAllR r r+#endif ForAllTy{} -> forAllTyAllR idR r TyConApp{} -> tyConAppAllR idR (const r) _ -> idR@@ -203,8 +195,13 @@ readerT $ \case TyConAppCo{} -> tyConAppCoAllR idR (const r) AppCo{} -> appCoAllR r r+#if __GLASGOW_HASKELL__ > 710+ ForAllCo{} -> forAllCoAllR idR r r+#else ForAllCo{} -> forAllCoAllR idR r+#endif SymCo{} -> symCoR r+ SubCo{} -> subCoR r TransCo{} -> transCoAllR r r NthCo{} -> nthCoAllR idR r InstCo{} -> instCoAllR r idR@@ -223,18 +220,24 @@ TypeCore ty -> inject <$> applyT (allR $ extractR r) c ty -- exploiting the fact that types do not contain coercions CoercionCore co -> inject <$> applyT allRcoercion c co where- allRcoercion :: MonadCatch m => Rewrite c m Coercion+ allRcoercion :: Rewrite c m Coercion allRcoercion = readerT $ \case Refl{} -> reflR (extractR r) TyConAppCo{} -> tyConAppCoAllR idR (const $ extractR r) -- we don't descend into the TyCon AppCo{} -> appCoAllR (extractR r) (extractR r)+#if __GLASGOW_HASKELL__ > 710+ ForAllCo{} -> forAllCoAllR idR (extractR r) (extractR r) -- we don't descend into the TyVar+#else ForAllCo{} -> forAllCoAllR idR (extractR r) -- we don't descend into the TyVar+#endif SymCo{} -> symCoR (extractR r)+ SubCo{} -> subCoR (extractR r) TransCo{} -> transCoAllR (extractR r) (extractR r) InstCo{} -> instCoAllR (extractR r) (extractR r) NthCo{} -> nthCoAllR idR (extractR r) -- we don't descend into the Int LRCo{} -> lrCoAllR idR (extractR r) AxiomInstCo{} -> axiomInstCoAllR idR idR (const $ extractR r) -- we don't descend into the axiom or index+ UnivCo{} -> univCoAllR (extractR r) (extractR r) -- we don't descend into the provenance (FastString) or role _ -> idR {-# INLINE allRcoercion #-} @@ -249,7 +252,7 @@ LClause cl -> inject <$> applyT allRclause c cl LCore core -> inject <$> applyT (allR $ extractR r) c core -- exploiting the fact that clause does not appear within Core where- allRclause :: MonadCatch m => Rewrite c m Clause+ allRclause :: Rewrite c m Clause allRclause = readerT $ \case Forall{} -> forallR idR (extractR r) -- we don't descend into the binders Conj{} -> conjAllR (extractR r) (extractR r)@@ -271,7 +274,7 @@ LTCCore (LCore core) -> inject <$> applyT (allR (extractR r :: Rewrite c m CoreTC)) c (Core core) -- convert to CoreTC, and exploit the fact that quantifiers and clauses will not appear in Core/CoreTC LTCTyCo tyCo -> inject <$> applyT (allR $ extractR r) c tyCo -- exploiting the fact that only types and coercions appear within types and coercions where- allRclause :: MonadCatch m => Rewrite c m Clause+ allRclause :: Rewrite c m Clause allRclause = readerT $ \case Forall{} -> forallR idR (extractR r) -- we don't descend into the binders Conj{} -> conjAllR (extractR r) (extractR r)@@ -297,31 +300,31 @@ Core (ExprCore e) -> inject <$> applyT allRexpr c e TyCo tyCo -> inject <$> applyT (allR $ extractR r) c tyCo -- exploiting the fact that only types and coercions appear within types and coercions where- allRmodguts :: MonadCatch m => Rewrite c m ModGuts+ allRmodguts :: Rewrite c m ModGuts allRmodguts = modGutsR (extractR r) {-# INLINE allRmodguts #-} - allRprog :: MonadCatch m => Rewrite c m CoreProg+ allRprog :: Rewrite c m CoreProg allRprog = readerT $ \case ProgCons{} -> progConsAllR (extractR r) (extractR r) _ -> idR {-# INLINE allRprog #-} - allRbind :: MonadCatch m => Rewrite c m CoreBind+ allRbind :: Rewrite c m CoreBind allRbind = readerT $ \case NonRec{} -> nonRecAllR idR (extractR r) -- we don't descend into the Var Rec _ -> recAllR (const $ extractR r) {-# INLINE allRbind #-} - allRdef :: MonadCatch m => Rewrite c m CoreDef+ allRdef :: Rewrite c m CoreDef allRdef = defAllR idR (extractR r) -- we don't descend into the Id {-# INLINE allRdef #-} - allRalt :: MonadCatch m => Rewrite c m CoreAlt+ allRalt :: Rewrite c m CoreAlt allRalt = altAllR idR (const idR) (extractR r) -- we don't descend into the AltCon or Vars {-# INLINE allRalt #-} - allRexpr :: MonadCatch m => Rewrite c m CoreExpr+ allRexpr :: Rewrite c m CoreExpr allRexpr = readerT $ \case App{} -> appAllR (extractR r) (extractR r) Lam{} -> lamAllR idR (extractR r) -- we don't descend into the Var@@ -991,7 +994,41 @@ appTyOneR r1 r2 = unwrapOneR $ appTyAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE appTyOneR #-} +#if __GLASGOW_HASKELL__ > 710+-- | Transform a type of the form: @CastTy@ 'Type' 'Coercion'+castTyT :: (ExtendPath c Crumb, Monad m) => Transform c m Type a1 -> Transform c m Coercion a2 -> (a1 -> a2 -> b) -> Transform c m Type b+castTyT t1 t2 f = transform $ \ c -> \case+ CastTy ty co -> f <$> applyT t1 (c @@ CastTy_Ty) ty <*> applyT t2 (c @@ CastTy_Co) co+ _ -> fail "not a cast type."+{-# INLINE castTyT #-} +-- | Rewrite all children of a type of the form: @CastTy@ 'Type' 'Coercion'+castTyAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Type -> Rewrite c m Coercion -> Rewrite c m Type+castTyAllR r1 r2 = castTyT r1 r2 CastTy+{-# INLINE castTyAllR #-}++-- | Rewrite any children of a type of the form: @CastTy@ 'Type' 'Coercion'+castTyAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Coercion -> Rewrite c m Type+castTyAnyR r1 r2 = unwrapAnyR $ castTyAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE castTyAnyR #-}++-- | Rewrite one child of a type of the form: @CastTy@ 'Type' 'Coercion'+castTyOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Coercion -> Rewrite c m Type+castTyOneR r1 r2 = unwrapOneR $ castTyAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE castTyOneR #-}++-- | Transform a type of the form: @CoercionTy@ 'Coercion'+coercionTyT :: (ExtendPath c Crumb, Monad m) => Transform c m Coercion a -> Transform c m Type a+coercionTyT t = transform $ \ c -> \case+ CoercionTy co -> applyT t (c @@ CoercionTy_Co) co + _ -> fail "not a coercion type."+{-# INLINE coercionTyT #-}++-- | Rewrite the 'Coercion' child of a type of the form: @CoercionTy@ 'Coercion'+coercionTyR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Coercion -> Rewrite c m Type+coercionTyR r = coercionTyT (CoercionTy <$> r)+{-# INLINE coercionTyR #-}+#else -- | 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@@ -1013,8 +1050,39 @@ funTyOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Type funTyOneR r1 r2 = unwrapOneR $ funTyAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE funTyOneR #-}+#endif +#if __GLASGOW_HASKELL__ > 710+-- | Transform a type of the form: @ForAllTy@ 'TyBinder' 'Type'+forAllTyT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) + => Transform c m TyBinder a1 -> Transform c m Type a2 -> (a1 -> a2 -> b) -> Transform c m Type b+forAllTyT t1 t2 f = transform $ \ c -> \case -- TODO: think about the crumbs here+ ForAllTy b@(Named v _vis) ty -> + f <$> applyT t1 (c @@ ForAllTy_Var) b+ <*> applyT t2 (addForallBinding v c @@ ForAllTy_Body) ty+ ForAllTy b@(Anon _) ty ->+ f <$> applyT t1 (c @@ FunTy_Dom) b <*> applyT t2 (c @@ FunTy_CoDom) ty+ _ -> fail "not a forall type."+{-# INLINE forAllTyT #-} +-- | Rewrite all children of a type of the form: @ForAllTy@ 'TyBinder' 'Type'+forAllTyAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) + => Rewrite c m TyBinder -> Rewrite c m Type -> Rewrite c m Type+forAllTyAllR r1 r2 = forAllTyT r1 r2 ForAllTy+{-# INLINE forAllTyAllR #-}++-- | Rewrite any children of a type of the form: @ForAllTy@ 'TyBinder' 'Type'+forAllTyAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) + => Rewrite c m TyBinder -> Rewrite c m Type -> Rewrite c m Type+forAllTyAnyR r1 r2 = unwrapAnyR $ forAllTyAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE forAllTyAnyR #-}++-- | Rewrite one child of a type of the form: @ForAllTy@ 'TyBinder' 'Type'+forAllTyOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) + => Rewrite c m TyBinder -> Rewrite c m Type -> Rewrite c m Type+forAllTyOneR r1 r2 = unwrapOneR $ forAllTyAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE forAllTyOneR #-}+#else -- | 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@@ -1036,7 +1104,7 @@ forAllTyOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type forAllTyOneR r1 r2 = unwrapOneR $ forAllTyAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE forAllTyOneR #-}-+#endif -- | 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@@ -1123,7 +1191,39 @@ appCoOneR r1 r2 = unwrapOneR $ appCoAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE appCoOneR #-} +#if __GLASGOW_HASKELL__ > 710+-- | Transform a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion' 'Coercion'+forAllCoT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) + => Transform c m TyVar a1 + -> Transform c m Coercion a2 + -> Transform c m Coercion a3+ -> (a1 -> a2 -> a3 -> b) -> Transform c m Coercion b+forAllCoT t1 t2 t3 f = transform $ \ c -> \case+ ForAllCo v c1 c2 -> + f <$> applyT t1 (c @@ ForAllCo_TyVar) v + <*> applyT t2 (c @@ ForAllCo_KindCo) c1 + <*> applyT t3 (addForallBinding v c @@ ForAllCo_Co) c2+ _ -> fail "not a forall coercion."+{-# INLINE forAllCoT #-} +-- | Rewrite all children of a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion' 'Coercion'+forAllCoAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) + => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion -> Rewrite c m Coercion+forAllCoAllR r1 r2 r3 = forAllCoT r1 r2 r3 ForAllCo+{-# INLINE forAllCoAllR #-}++-- | Rewrite any children of a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion' 'Coercion'+forAllCoAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) + => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion -> Rewrite c m Coercion+forAllCoAnyR r1 r2 r3 = unwrapAnyR $ forAllCoAllR (wrapAnyR r1) (wrapAnyR r2) (wrapAnyR r3)+{-# INLINE forAllCoAnyR #-}++-- | Rewrite one child of a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion' 'Coercion'+forAllCoOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) + => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion -> Rewrite c m Coercion+forAllCoOneR r1 r2 r3 = unwrapOneR $ forAllCoAllR (wrapOneR r1) (wrapOneR r2) (wrapOneR r3)+{-# INLINE forAllCoOneR #-}+#else -- | 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@@ -1145,7 +1245,7 @@ forAllCoOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion forAllCoOneR r1 r2 = unwrapOneR $ forAllCoAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE forAllCoOneR #-}-+#endif -- | Transform a coercion of the form: @CoVarCo@ 'CoVar' coVarCoT :: (ExtendPath c Crumb, Monad m) => Transform c m CoVar b -> Transform c m Coercion b@@ -1263,7 +1363,29 @@ lrCoOneR r1 r2 = unwrapOneR $ lrCoAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE lrCoOneR #-} +#if __GLASGOW_HASKELL__ > 710+-- | Transform a coercion of the form: @InstCo@ 'Coercion' 'Coercion'+instCoT :: (ExtendPath c Crumb, Monad m) => Transform c m Coercion a1 -> Transform c m Coercion a2 -> (a1 -> a2 -> b) -> Transform c m Coercion b+instCoT t1 t2 f = transform $ \ c -> \case+ InstCo c1 c2 -> f <$> applyT t1 (c @@ InstCo_Left) c1 <*> applyT t2 (c @@ InstCo_Right) c2+ _ -> fail "not a coercion instantiation."+{-# INLINE instCoT #-} +-- | Rewrite all children of a coercion of the form: @InstCo@ 'Coercion' 'Coercion'+instCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Coercion -> Rewrite c m Coercion -> Rewrite c m Coercion+instCoAllR r1 r2 = instCoT r1 r2 InstCo+{-# INLINE instCoAllR #-}++-- | Rewrite any children of a coercion of the form: @InstCo@ 'Coercion' 'Coercion'+instCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Coercion -> Rewrite c m Coercion -> Rewrite c m Coercion+instCoAnyR r1 r2 = unwrapAnyR $ instCoAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE instCoAnyR #-}++-- | Rewrite one child of a coercion of the form: @InstCo@ 'Coercion' 'Coercion'+instCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Coercion -> Rewrite c m Coercion -> Rewrite c m Coercion+instCoOneR r1 r2 = unwrapOneR $ instCoAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE instCoOneR #-}+#else -- | 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@@ -1285,7 +1407,50 @@ instCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Coercion -> Rewrite c m Type -> Rewrite c m Coercion instCoOneR r1 r2 = unwrapOneR $ instCoAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE instCoOneR #-}+#endif +-- | Transform a coercion of the form: @SubCo@ 'Coercion'+subCoT :: (ExtendPath c Crumb, Monad m) => Transform c m Coercion b -> Transform c m Coercion b+subCoT t = transform $ \ c -> \case+ SubCo co -> applyT t (c @@ SubCo_Co) co+ _ -> fail "not a sub coercion."+{-# INLINE subCoT #-}++-- | Rewrite the 'Coercion' child of a coercion of the form: @SubCo@ 'Coercion'+subCoR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Coercion -> Rewrite c m Coercion+subCoR r = subCoT (SubCo <$> r)+{-# INLINE subCoR #-}++-- | Transform a coercion of the form: @UnivCo@ 'FastString' 'Role' 'Type' 'Type'+univCoT :: (ExtendPath c Crumb, Monad m) + => Transform c m Type a1 + -> Transform c m Type a2 +#if __GLASGOW_HASKELL__ > 710+ -> (UnivCoProvenance -> Role -> a1 -> a2 -> b) +#else+ -> (FastString -> Role -> a1 -> a2 -> b) +#endif+ -> Transform c m Coercion b+univCoT t1 t2 f = transform $ \ c -> \case+ UnivCo s r dom ran -> f s r <$> applyT t1 (c @@ UnivCo_Dom) dom <*> applyT t2 (c @@ UnivCo_Ran) ran+ _ -> fail "not a universal coercion."+{-# INLINE univCoT #-}++-- | Rewrite all children of a coercion of the form: @UnivCo@ 'FastString' 'Role' 'Type' 'Type'+univCoAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Coercion+univCoAllR r1 r2 = univCoT r1 r2 UnivCo+{-# INLINE univCoAllR #-}++-- | Rewrite any children of a coercion of the form: @UnivCo@ 'FastString' 'Role' 'Type' 'Type'+univCoAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Coercion+univCoAnyR r1 r2 = unwrapAnyR $ univCoAllR (wrapAnyR r1) (wrapAnyR r2)+{-# INLINE univCoAnyR #-}++-- | Rewrite one child of a coercion of the form: @UnivCo@ 'FastString' 'Role' 'Type' 'Type'+univCoOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Type -> Rewrite c m Type -> Rewrite c m Coercion+univCoOneR r1 r2 = unwrapOneR $ univCoAllR (wrapOneR r1) (wrapOneR r2)+{-# INLINE univCoOneR #-}+ --------------------------------------------------------------------- -- | Transform a clause of the form: @Conj@ 'Clause' 'Clause'@@ -1304,7 +1469,7 @@ -- | Transform a clause of the form: @Disj@ 'Clause' 'Clause' disjT :: (ExtendPath c Crumb, Monad m) => Transform c m Clause a1 -> Transform c m Clause a2 -> (a1 -> a2 -> b) -> Transform c m Clause b disjT t1 t2 f = transform $ \ c -> \case- Conj q1 q2 -> f <$> applyT t1 (c @@ Disj_Lhs) q1 <*> applyT t2 (c @@ Disj_Rhs) q2+ Disj q1 q2 -> f <$> applyT t1 (c @@ Disj_Lhs) q1 <*> applyT t2 (c @@ Disj_Rhs) q2 _ -> fail "not a disjunction." {-# INLINE disjT #-} @@ -1344,20 +1509,36 @@ --------------------------------------------------------------------- --- | Transform a clause of the form: @Forall@ '[CoreBndr]' 'Clause'+-- | Transform a clause of the form: @Forall@ 'CoreBndr' 'Clause' forallT :: (ExtendPath c Crumb, AddBindings c, ReadPath c Crumb, Monad m)- => Transform c m [CoreBndr] a1 -> Transform c m Clause a2 -> (a1 -> a2 -> b) -> Transform c m Clause b+ => Transform c m CoreBndr a1 -> Transform c m Clause a2 -> (a1 -> a2 -> b) -> Transform c m Clause b forallT t1 t2 f = transform $ \ c -> \case- Forall bs cl -> let c' = foldl (flip addLambdaBinding) c bs- in f <$> applyT t1 c bs <*> applyT t2 (c' @@ Forall_Body) cl- _ -> fail "not a quantified clause."+ Forall b cl -> let c' = addLambdaBinding b c+ in f <$> applyT t1 c b <*> applyT t2 (c' @@ Forall_Body) cl+ _ -> fail "not a quantified clause." {-# INLINE forallT #-} --- | Rewrite the a clause of the form: @Forall@ '[CoreBndr]' 'Clause'+-- | Rewrite the a clause of the form: @Forall@ 'CoreBndr' 'Clause' forallR :: (ExtendPath c Crumb, AddBindings c, ReadPath c Crumb, Monad m)- => Rewrite c m [CoreBndr] -> Rewrite c m Clause -> Rewrite c m Clause-forallR r1 r2 = forallT r1 r2 mkForall+ => Rewrite c m CoreBndr -> Rewrite c m Clause -> Rewrite c m Clause+forallR r1 r2 = forallT r1 r2 Forall {-# INLINE forallR #-}++-- | Transform a clause with nested forall quantifiers.+forallsT :: (ExtendPath c Crumb, AddBindings c, ReadPath c Crumb, Monad m)+ => Transform c m [CoreBndr] a1 -> Transform c m Clause a2 -> (a1 -> a2 -> b) -> Transform c m Clause b+forallsT t1 t2 f = transform $ \ c e -> case collectQs e of+ (bs@(_:_),cl) ->+ let c' = foldl (\ctxt b -> addLambdaBinding b ctxt @@ Forall_Body) c bs+ in f <$> applyT t1 c bs <*> applyT t2 c' cl+ _ -> fail "not a quantified clause."+{-# INLINE forallsT #-}++-- | Rewrite the a clause with nested forall quantifiers.+forallsR :: (ExtendPath c Crumb, AddBindings c, ReadPath c Crumb, Monad m)+ => Rewrite c m [CoreBndr] -> Rewrite c m Clause -> Rewrite c m Clause+forallsR r1 r2 = forallsT r1 r2 mkForall+{-# INLINE forallsR #-} ---------------------------------------------------------------------
src/HERMIT/Kure/Universes.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}@@ -175,7 +176,11 @@ -- | Find all free variables in a 'TyCo' node. freeVarsTyCo :: TyCo -> VarSet freeVarsTyCo = \case+#if __GLASGOW_HASKELL__ > 710+ TypeCore ty -> tyCoVarsOfType ty+#else TypeCore ty -> tyVarsOfType ty+#endif CoercionCore co -> tyCoVarsOfCo co -- | Find all free variables in a 'CoreTC' node.
src/HERMIT/Lemma.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE NoImplicitPrelude #-} module HERMIT.Lemma ( -- * Clause Clause(..) , mkClause , mkForall- , forallQs+ , addBinder+ , collectQs , instClause , instsClause , discardUniVars@@ -27,14 +28,16 @@ , NamedLemma ) where -import Prelude.Compat hiding (lookup)+import Prelude hiding (lookup) import Control.Monad -import Data.Dynamic (Typeable)+import Data.Semigroup (Semigroup(..)) import Data.String (IsString(..)) import qualified Data.Map as M +import GHC.Generics+ import HERMIT.Core import HERMIT.GHC hiding ((<>)) import Language.KURE.MonadCatch@@ -49,7 +52,7 @@ -- mkClause [] (baz y z) (\x. foo x x) === forall x. baz y z x = foo x x -- mkClause [] (\x. foo x) (\y. bar y) === forall x. foo x = bar x mkClause :: [CoreBndr] -> CoreExpr -> CoreExpr -> Clause-mkClause vs lhs rhs = redundantDicts $ dropBinders $ Forall (tvs++vs++lbs++rbs) (Equiv lhs' rbody)+mkClause vs lhs rhs = redundantDicts $ dropBinders $ mkForall (tvs++vs++lbs++rbs) (Equiv lhs' rbody) where (lbs, lbody) = collectBinders lhs rhs' = uncurry mkCoreApps $ betaReduceAll rhs $ map varToCoreExpr lbs (rbs, rbody) = collectBinders rhs'@@ -60,7 +63,7 @@ $ delVarSetList (unionVarSets $ map freeVarsExpr [lhs',rbody]) (vs++lbs++rbs) freeVarsClause :: Clause -> VarSet-freeVarsClause (Forall bs cl) = delVarSetList (freeVarsClause cl) bs+freeVarsClause (Forall b cl) = delVarSet (freeVarsClause cl) b freeVarsClause (Conj q1 q2) = unionVarSets $ map freeVarsClause [q1,q2] freeVarsClause (Disj q1 q2) = unionVarSets $ map freeVarsClause [q1,q2] freeVarsClause (Impl _ q1 q2) = unionVarSets $ map freeVarsClause [q1,q2]@@ -68,36 +71,37 @@ freeVarsClause CTrue = emptyVarSet dropBinders :: Clause -> Clause-dropBinders (Forall bs cl) =- case bs of- [] -> dropBinders cl- (b:bs') -> let c = dropBinders (mkForall bs' cl)- in if b `elemVarSet` freeVarsClause c- then addBinder b c- else c+dropBinders (Forall b cl) =+ let cl' = dropBinders cl+ in if b `elemVarSet` freeVarsClause cl'+ then addBinder b cl'+ else cl' dropBinders (Conj q1 q2) = Conj (dropBinders q1) (dropBinders q2) dropBinders (Disj q1 q2) = Disj (dropBinders q1) (dropBinders q2) dropBinders (Impl nm q1 q2) = Impl nm (dropBinders q1) (dropBinders q2) dropBinders other = other addBinder :: CoreBndr -> Clause -> Clause-addBinder b = mkForall [b]+addBinder = Forall mkForall :: [CoreBndr] -> Clause -> Clause-mkForall bs (Forall bs' cl) = Forall (bs++bs') cl-mkForall bs cl = Forall bs cl+mkForall = flip (foldr Forall) -forallQs :: Clause -> [CoreBndr]-forallQs (Forall bs _) = bs-forallQs _ = []+collectQs :: Clause -> ([CoreBndr], Clause)+collectQs (Forall b cl) = (b:bs, cl')+ where (bs, cl') = collectQs cl+collectQs cl = ([],cl) -- | A name for lemmas. Use a newtype so we can tab-complete in shell.-newtype LemmaName = LemmaName String deriving (Eq, Ord, Typeable)+newtype LemmaName = LemmaName String deriving (Eq, Ord) instance Monoid LemmaName where mempty = LemmaName mempty- mappend (LemmaName n1) (LemmaName n2) = LemmaName (mappend n1 n2)+ mappend = (<>) +instance Semigroup LemmaName where+ LemmaName n1 <> LemmaName n2 = LemmaName (n1 <> n2)+ instance IsString LemmaName where fromString = LemmaName instance Show LemmaName where show (LemmaName s) = s @@ -111,7 +115,7 @@ | Assumed -- ^ Assumed by user | BuiltIn -- ^ Assumed by library/HERMIT | NotProven- deriving (Eq, Typeable)+ deriving Eq instance Show Proven where show Proven = "Proven"@@ -146,14 +150,14 @@ data Used = Obligation -- ^ this MUST be proven immediately | UnsafeUsed -- ^ used, but can be proven later (only introduced in unsafe shell) | NotUsed- deriving (Eq, Typeable)+ deriving (Eq, Generic) instance Show Used where show Obligation = "Obligation" show UnsafeUsed = "Used" show NotUsed = "Not Used" -data Clause = Forall [CoreBndr] Clause+data Clause = Forall CoreBndr Clause | Conj Clause Clause | Disj Clause Clause | Impl LemmaName Clause Clause -- ^ name for the antecedent when it is in scope@@ -169,7 +173,7 @@ ------------------------------------------------------------------------------ discardUniVars :: Clause -> Clause-discardUniVars (Forall _ cl) = cl+discardUniVars (Forall _ cl) = discardUniVars cl discardUniVars cl = cl ------------------------------------------------------------------------------@@ -189,9 +193,9 @@ -- in scope in the *range* of the substitution. substClauseSubst :: Subst -> Clause -> Clause substClauseSubst = go- where go sub (Forall bs cl) =- let (bs', cl') = go1 sub bs [] cl- in mkForall bs' cl'+ where go subst (Forall b cl) =+ let (subst',b') = substBndr subst b+ in addBinder b' (go subst' cl) go _ CTrue = CTrue go subst (Conj q1 q2) = Conj (go subst q1) (go subst q2) go subst (Disj q1 q2) = Disj (go subst q1) (go subst q2)@@ -201,27 +205,18 @@ e2' = substExpr (text "substClauseSubst e2") subst e2 in Equiv e1' e2' - go1 subst [] bs' cl = (reverse bs', go subst cl)- go1 subst (b:bs) bs' cl =- let (subst',b') = substBndr subst b- in go1 subst' bs (b':bs') cl- ------------------------------------------------------------------------------ redundantDicts :: Clause -> Clause-redundantDicts (Forall bs cl) = go [] [] cl bs- where go [] _ c [] = c- go bnds _ c [] = mkForall (reverse bnds) c- go bnds tys c (b:bs')- | isDictTy bTy = -- is a dictionary binder- let match = [ varToCoreExpr pb | (pb,ty) <- tys , eqType bTy ty ]- in if null match- then go (b:bnds) ((b,bTy):tys) c bs' -- not seen before- else let Forall bs'' c' = substClause b (head match) $ mkForall bs' c- in go bnds tys c' bs'' -- seen- | otherwise = go (b:bnds) tys c bs'+redundantDicts = go []+ where go tys (Forall b cl)+ | isDictTy bTy =+ case [ varToCoreExpr pb | (pb,ty) <- tys, eqType bTy ty ] of+ [] -> addBinder b $ go ((b,bTy):tys) cl -- not seen before+ (b':_) -> substClause b b' cl -- seen+ | otherwise = addBinder b (go tys cl) where bTy = varType b-redundantDicts cl = cl+ go _ cl = cl ------------------------------------------------------------------------------ @@ -234,52 +229,53 @@ -> CoreExpr -- expression to instantiate with -> Clause -> m Clause instClause inScope p e = prefixFailMsg "clause instantiation failed: " . liftM fst . go []- where go bbs (Forall bs cl)- | not (any p bs) = -- not quantified at this level, so try further down- let go2 con q1 q2 = do- er <- attemptM $ go (bs++bbs) q1- (cl',s) <- case er of- Right (q1',s) -> return (con q1' q2, s)- Left _ -> do- er' <- attemptM $ go (bs++bbs) q2- case er' of- Right (q2',s) -> return (con q1 q2', s)- Left msg -> fail msg- return (replaceVars s bs cl', s)- in case cl of- Equiv{} -> fail "specified variable is not universally quantified."- CTrue -> fail "specified variable is not universally quantified."- Conj q1 q2 -> go2 Conj q1 q2- Disj q1 q2 -> go2 Disj q1 q2- Impl nm q1 q2 -> go2 (Impl nm) q1 q2- Forall _ _ -> fail "impossible case!"-- | otherwise = do -- quantified here, so do substitution and start bubbling up- let (bs',i:vs) = break p bs -- this is safe because we know i is in bs- (eTvs, eTy) = splitForAllTys $ exprKindOrType e- bsInScope = bs'++bbs- tyVars = eTvs ++ filter isTyVar bsInScope+ where go bs (Forall b cl)+ | p b = do -- quantified here, so do substitution and start bubbling up+ let (eTvs, eTy) = splitForAllTys $ exprKindOrType e+ tyVars = eTvs ++ filter isTyVar bs failMsg = fail "type of provided expression differs from selected binder." bindFn v = if v `elem` tyVars then BindMe else Skolem - sub <- maybe failMsg return $ tcUnifyTys bindFn [varType i] [eTy]+ sub <- maybe failMsg return $ tcUnifyTys bindFn [varType b] [eTy] - -- if i is a tyvar, we know e is a type, so free vars will be tyvars+ -- if b is a tyvar, we know e is a type, so free vars will be tyvars let e' = mkCoreApps e [ case lookupTyVar sub v of Nothing -> Type (mkTyVarTy v)- Just ty -> Type ty | v <- eTvs ]- let newBs = varSetElems+ Just ty -> Type ty+ | v <- eTvs ]+ cl' = substClause b e' cl+ newBs = varSetElems $ filterVarSet (\v -> not (isId v) || isLocalId v)- $ delVarSetList (minusVarSet (freeVarsExpr e') inScope) bsInScope- cl' = substClause i e' $ mkForall vs cl+ $ delVarSetList (minusVarSet (freeVarsExpr e') inScope) bs - return (replaceVars sub (bs' ++ newBs) cl', sub)- go _ _ = fail "only applies to clauses with quantifiers."+ return (replaceVars sub newBs cl', sub)+ | otherwise = do+ (cl', sub) <- go (b:bs) cl+ return (replaceVars sub [b] cl', sub)+ go bs (Conj q1 q2) = go2 bs Conj q1 q2+ go bs (Disj q1 q2) = go2 bs Disj q1 q2+ go bs (Impl nm q1 q2) = go2 bs (Impl nm) q1 q2+ go _ _ = fail "specified variable is not universally quantified." + go2 bs con q1 q2 = do+ er <- attemptM $ go bs q1+ case er of+ Right (q1',s) -> return (con q1' q2, s)+ Left _ -> do+ er' <- attemptM $ go bs q2+ case er' of+ Right (q2',s) -> return (con q1 q2', s)+ Left msg -> fail msg+ -- | The function which 'bubbles up' after the instantiation takes place,--- replacing any type variables that were instantiated as a result of specialization.+-- replacing any type variables that were instantiated as a result of specialization+-- and rebuilding the foralls.+#if __GLASGOW_HASKELL__ > 710+replaceVars :: TCvSubst -> [Var] -> Clause -> Clause+#else replaceVars :: TvSubst -> [Var] -> Clause -> Clause+#endif replaceVars sub vs = go (reverse vs) where go [] cl = cl go (b:bs) cl@@ -305,7 +301,7 @@ -- | Syntactic Equality of clauses. clauseSyntaxEq :: Clause -> Clause -> Bool-clauseSyntaxEq (Forall bs1 c1) (Forall bs2 c2) = (bs1 == bs2) && clauseSyntaxEq c1 c2+clauseSyntaxEq (Forall b1 c1) (Forall b2 c2) = (b1 == b2) && clauseSyntaxEq c1 c2 clauseSyntaxEq (Conj q1 q2) (Conj p1 p2) = clauseSyntaxEq q1 p1 && clauseSyntaxEq q2 p2 clauseSyntaxEq (Disj q1 q2) (Disj p1 p2) = clauseSyntaxEq q1 p1 && clauseSyntaxEq q2 p2 clauseSyntaxEq (Impl n1 q1 q2) (Impl n2 p1 p2) = n1 == n2 && clauseSyntaxEq q1 p1 && clauseSyntaxEq q2 p2
src/HERMIT/Libraries/Int.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module HERMIT.Libraries.Int where@@ -8,14 +8,12 @@ import qualified Data.Map as M import HERMIT.GHC hiding (intTy)-import HERMIT.Kure hiding ((<$>))+import HERMIT.Kure import HERMIT.Lemma import HERMIT.Name import HERMIT.Dictionary.Common import HERMIT.Dictionary.GHC -import Prelude.Compat- {- Defines the following lemmas: @@ -42,12 +40,20 @@ let n = varToCoreExpr nId m = varToCoreExpr mId+#if __GLASGOW_HASKELL__ > 710+ appTo i e = return $ mkCoreApp (text "appTo") (varToCoreExpr i) e+#else appTo i e = return $ mkCoreApp (varToCoreExpr i) e+#endif appToInt i = appTo i (Type intTy) appToDict e = do let (aTys, _) = splitFunTys (exprType e) case aTys of+#if __GLASGOW_HASKELL__ > 710+ (ty:_) | isDictTy ty -> return ty >>> buildDictionaryT >>> arr (mkCoreApp (text "appToDict") e)+#else (ty:_) | isDictTy ty -> return ty >>> buildDictionaryT >>> arr (mkCoreApp e)+#endif _ -> fail "first argument is not a dictionary." appMN e = mkCoreApps e [m,n]
+ src/HERMIT/Libraries/WW.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module HERMIT.Libraries.WW (lemmas) where++import HERMIT.Lemma+import HERMIT.GHC hiding (($$), (<>))+import HERMIT.Kure+import HERMIT.Name++import HERMIT.Dictionary.Common+import HERMIT.Dictionary.Function+import HERMIT.Dictionary.GHC+import HERMIT.Dictionary.Reasoning++import Prelude hiding (abs)++lemmas :: LemmaLibrary+lemmas = workerWrapperLemmaT++-------------------------------------------------++-- | worker/wrapper+--+-- abs :: B -> A+-- rep :: A -> B+-- f :: A -> A+--+-- abs . rep = id \/ abs . rep . f = f \/ fix (abs . rep . f) = fix f+-----------------------------------------------------------------------------+-- fix f = abs (fix (rep . f . abs)) = abs (rep (fix f))+-- ^ 1B ^ ^ 2B ^+--+workerWrapperLemmaT :: LemmaLibrary+workerWrapperLemmaT = do+ idId <- findIdT "Data.Function.id"+ fixId <- findIdT "Data.Function.fix"+ contextonlyT $ \ c -> do+ -- aTv :: Var, aTy :: Type+ [aTv, bTv] <- mapM newTyVar ["a","b"]++ let [aTy, bTy] = map mkTyVarTy [aTv, bTv]++ abs <- newIdH "abs" (bTy --> aTy)+ rep <- newIdH "rep" (aTy --> bTy)+ f <- newIdH "f" (aTy --> aTy)++ -- abs . rep = id+ lhsA <- inContextM c $ buildCompositionT (toCE abs) (toCE rep)+#if __GLASGOW_HASKELL__ > 710+ let preA = lhsA === mkCoreApp (text "workerWrapperLemmaT") (toCE idId) (toCE aTv)+#else+ let preA = lhsA === mkCoreApp (toCE idId) (toCE aTv)+#endif++ -- abs . rep . f = f+ repAfterF <- inContextM c $ buildCompositionT (toCE rep) (toCE f)+ lhsB <- inContextM c $ buildCompositionT (toCE abs) repAfterF+ let preB = lhsB === f++ -- fix (abs . rep . f) = fix f+ lhsC <- fixId $$ lhsB+ fixf <- fixId $$ f+ let preC = lhsC === fixf++ -- 1B+ fAfterAbs <- inContextM c $ buildCompositionT (toCE f) (toCE abs)+ comp1B <- inContextM c $ buildCompositionT (toCE rep) fAfterAbs+ rhs1B <- (abs $$) =<< (fixId $$ comp1B)+ let oneB = fixf === rhs1B++ -- 2B+ rhs2B <- (abs $$) =<< (rep $$ fixf)+ let twoB = fixf === rhs2B++ return $ mconcat+ [ newLemma "ww-split-1B" $+ mkForall [aTv, bTv, abs, rep, f] $+ ("ww-split-1B-antecedent", preA \/ preB \/ preC) ==> oneB+ , newLemma "ww-split-2B" $+ mkForall [aTv, bTv, abs, rep, f] $+ ("ww-split-1B-antecedent", preA \/ preB \/ preC) ==> twoB+ ]++-------------------------------------------------++newTyVar :: MonadUnique m => String -> m TyVar+newTyVar nm = newTyVarH nm liftedTypeKind++-------------------------------------------------
src/HERMIT/Monad.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE NoImplicitPrelude #-} module HERMIT.Monad ( -- * The HERMIT Monad@@ -31,9 +30,10 @@ , sendKEnvMessage ) where -import Prelude.Compat hiding (lookup)+import Prelude hiding (lookup) import Control.Monad+import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class import Data.Map@@ -120,6 +120,10 @@ (return . fail) fail :: String -> HermitM a+ fail = Fail.fail++instance Fail.MonadFail HermitM where+ fail :: String -> HermitM a fail msg = HermitM $ const $ return $ fail msg instance MonadCatch HermitM where@@ -236,8 +240,8 @@ -- What should the boolean flag be set to? (msgs, mr) <- liftIO $ initTcFromModGuts env guts HsSrcFile False m let showMsgs (warns, errs) = showSDoc dflags $ vcat- $ text "Errors:" : pprErrMsgBag errs- ++ text "Warnings:" : pprErrMsgBag warns+ $ text "Errors:" : pprErrMsgBagWithLoc errs+ ++ text "Warnings:" : pprErrMsgBagWithLoc warns maybe (fail $ showMsgs msgs) return mr runDsM :: (HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadIO m) => DsM a -> m a
src/HERMIT/Name.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -8,6 +7,8 @@ ( HermitName , cmpHN2Name , cmpHN2Var+ , mkQualified+ , mkUnqualified , fromRdrName , toRdrName , toRdrNames@@ -36,7 +37,6 @@ , newIdH , newTyVarH , newCoVarH- , newVarH , cloneVarH , cloneVarFSH -- * Name Lookup@@ -46,13 +46,13 @@ , findType , findInNameSpace , findInNameSpaces+ , findInNSModGuts ) where import Control.Monad import Control.Monad.IO.Class import Data.List (intercalate)-import Data.Dynamic (Typeable) import Data.String (IsString(..)) import HERMIT.Context@@ -61,8 +61,6 @@ import HERMIT.Kure import HERMIT.Monad -import Prelude.Compat hiding ((<$>), (<*>))- -- | Possible results from name lookup. -- Invariant: One constructor for each NameSpace. data Named = NamedId Id@@ -109,7 +107,7 @@ data HermitName = HermitName { hnModuleName :: Maybe ModuleName , hnUnqualified :: FastString }- deriving (Eq, Typeable)+ deriving Eq instance Extern HermitName where type Box HermitName = HermitName@@ -178,7 +176,7 @@ -- Newtype wrappers used for type-based command completion -newtype BindingName = BindingName { unBindingName :: HermitName } deriving Typeable+newtype BindingName = BindingName { unBindingName :: HermitName } instance Extern BindingName where type Box BindingName = BindingName@@ -188,7 +186,7 @@ mkBindingPred :: BindingName -> Var -> Bool mkBindingPred (BindingName hnm) = cmpHN2Var hnm -newtype OccurrenceName = OccurrenceName { unOccurrenceName :: HermitName } deriving Typeable+newtype OccurrenceName = OccurrenceName { unOccurrenceName :: HermitName } instance Extern OccurrenceName where type Box OccurrenceName = OccurrenceName@@ -198,14 +196,14 @@ mkOccPred :: OccurrenceName -> Var -> Bool mkOccPred (OccurrenceName hnm) = cmpHN2Var hnm -newtype OccurrenceNameListBox = OccurrenceNameListBox [OccurrenceName] deriving Typeable+newtype OccurrenceNameListBox = OccurrenceNameListBox [OccurrenceName] instance Extern [OccurrenceName] where type Box [OccurrenceName] = OccurrenceNameListBox box = OccurrenceNameListBox unbox (OccurrenceNameListBox l) = l -newtype RhsOfName = RhsOfName { unRhsOfName :: HermitName } deriving Typeable+newtype RhsOfName = RhsOfName { unRhsOfName :: HermitName } instance Extern RhsOfName where type Box RhsOfName = RhsOfName@@ -251,7 +249,7 @@ NamedDataCon dc -> return $ dataConWrapId dc other -> fail $ "findVar: impossible Named returned: " ++ show other -findTyCon :: (BoundVars c, LiftCoreM m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+findTyCon :: (BoundVars c, LiftCoreM m, HasHermitMEnv m, MonadIO m, MonadThings m) => HermitName -> c -> m TyCon findTyCon nm c = do nmd <- findInNameSpace tyConClassNS nm c@@ -354,13 +352,6 @@ -- | Make a unique coercion variable for a specified type, using a provided name. newCoVarH :: MonadUnique m => String -> Type -> m TyVar newCoVarH nm ty = mkCoVar <$> newName nm <*> return ty---- TODO: not sure if the predicates are correct.--- | Experimental, use at your own risk.-newVarH :: MonadUnique m => String -> KindOrType -> m Var-newVarH name tk | isCoVarType tk = newCoVarH name tk- | isKind tk = newTyVarH name tk- | otherwise = newIdH name tk -- | Make a new variable of the same type, with a modified textual name. cloneVarH :: MonadUnique m => (String -> String) -> Var -> m Var
src/HERMIT/Plugin.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -48,13 +47,8 @@ import HERMIT.Dictionary import HERMIT.External import HERMIT.Kernel-import HERMIT.Context import HERMIT.Kure hiding (apply)-#if __GLASGOW_HASKELL__ < 710-import HERMIT.GHC hiding (singleton, liftIO, display)-#else import HERMIT.GHC hiding (singleton, liftIO)-#endif import qualified HERMIT.GHC as GHC import HERMIT.Plugin.Builder@@ -121,13 +115,13 @@ resume :: PluginM a resume = gets ps_cursor >>= throwError . PResume -apply :: (Injection GHC.ModGuts g, Walker HermitC g) => CommitMsg -> RewriteH g -> PluginM ()+apply :: (Injection GHC.ModGuts g) => CommitMsg -> RewriteH g -> PluginM () apply cm rr = do kernel <- asks pr_kernel env <- gets mkKernelEnv runA (applyK kernel (extractR rr) cm env) -query :: (Injection GHC.ModGuts g, Walker HermitC g) => CommitMsg -> TransformH g a -> PluginM a+query :: (Injection GHC.ModGuts g) => CommitMsg -> TransformH g a -> PluginM a query cm tr = do kernel <- asks pr_kernel env <- gets mkKernelEnv@@ -195,7 +189,7 @@ getPassInfo = asks pr_pass display :: PluginM ()-display = Display.display Nothing Nothing+display = Display.printDisplay Nothing Nothing setPretty :: PrettyPrinter -> PluginM () setPretty pp = modify $ \s -> s { ps_pretty = pp }
src/HERMIT/Plugin/Builder.hs view
@@ -35,7 +35,7 @@ #ifdef mingw32_HOST_OS liftIO $ hSetEncoding stdout utf8 -- This is a hacky workaround of a bug in Windows GHC.- -- See https://ghc.haskell.org/trac/ghc/ticket/8276+ -- See https://ghc.haskell.org/trac/ghc/ticket/10301 liftIO initStaticOpts #endif @@ -85,12 +85,8 @@ len = lengthFS (moduleNameFS mname) + 1 -- for the colon -- | An enumeration type for GHC's passes.-#if __GLASGOW_HASKELL__ >= 710 data CorePass = CallArity | CSE-#else-data CorePass = CSE-#endif | Desugar | DesugarOpt | FloatInwards@@ -131,9 +127,7 @@ , (Vectorisation, CoreDoVectorisation) , (Desugar , CoreDesugar) -- Right after desugaring, no simple optimisation yet! , (DesugarOpt , CoreDesugarOpt) -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces-#if __GLASGOW_HASKELL__ >= 710 , (CallArity , CoreDoCallArity)-#endif , (Tidy , CoreTidy) , (Prep , CorePrep) , (NoOp , CoreDoNothing)@@ -160,10 +154,7 @@ getCorePass (CoreDoPasses {}) = Passes -- these should be flattened out in practice getCorePass (CoreDoPluginPass nm _) = PluginPass nm getCorePass CoreDoNothing = NoOp-#if __GLASGOW_HASKELL__ >= 710 getCorePass CoreDoCallArity = CallArity-#endif--- getCorePass _ = Unknown flattenTodos :: [CoreToDo] -> [CoreToDo] flattenTodos = concatMap f
src/HERMIT/Plugin/Display.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-} module HERMIT.Plugin.Display- ( display+ ( showDisplay+ , printDisplay , ps_putStr , ps_putStrLn ) where@@ -17,26 +17,34 @@ import HERMIT.Plugin.Types import HERMIT.PrettyPrinter.Common -import Prelude.Compat- import System.IO -display :: Maybe Handle -> Maybe PathH -> PluginM ()-display mbh window = do+showDisplay :: Maybe PathH -> PluginM DocH+showDisplay window = do k <- asks pr_kernel st <- get let ast = ps_cursor st ppOpts = pOptions $ ps_pretty st- h = fromMaybe stdout mbh- d <- queryK k (extractT $ pathT (fromMaybe mempty window) $ liftPrettyH ppOpts $ pCoreTC $ ps_pretty st)+ d <- queryK k (extractT $ pathT (fromMaybe mempty window) $ liftPrettyH ppOpts $ pLCoreTC $ ps_pretty st) Never (mkKernelEnv st) ast- liftIO $ ps_render st h ppOpts $ Right $ snd d -- discard new AST, assuming pretty printer won't create one+ return $ snd d -- discard new AST, assuming pretty printer won't create one +-- TODO: rm+printDisplay :: Maybe Handle -> Maybe PathH -> PluginM ()+printDisplay mbh window = do+ doc <- showDisplay window+ st <- get+ let ppOpts = pOptions $ ps_pretty st+ h = fromMaybe stdout mbh+ liftIO $ ps_render st h ppOpts $ Right $ doc++-- TODO: rm ps_putStr :: (MonadIO m, MonadState PluginState m) => String -> m () ps_putStr str = do st <- get liftIO $ ps_render st stdout (pOptions $ ps_pretty st) (Left str) +-- TODO: rm ps_putStrLn :: (MonadIO m, MonadState PluginState m) => String -> m () ps_putStrLn = ps_putStr . (++"\n")
src/HERMIT/Plugin/Renderer.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-} module HERMIT.Plugin.Renderer where @@ -8,6 +7,7 @@ import Control.Monad.State import Data.List (isInfixOf, isPrefixOf, isSuffixOf)+import Data.Semigroup (Semigroup(..)) import HERMIT.Dictionary (traceR) import HERMIT.Kure@@ -17,8 +17,6 @@ import HERMIT.Win32.IO (hPutStr, hPutStrLn) #endif -import Prelude.Compat- import System.Console.ANSI #ifdef mingw32_HOST_OS import System.IO hiding (hPutStr, hPutStrLn)@@ -48,8 +46,11 @@ instance Monoid UnicodeTerminal where mempty = UnicodeTerminal $ \ _ _ -> return ()- mappend (UnicodeTerminal f1) (UnicodeTerminal f2) = UnicodeTerminal $ \ h p -> f1 h p >> f2 h p+ mappend = (<>) +instance Semigroup UnicodeTerminal where+ UnicodeTerminal f1 <> UnicodeTerminal f2 = UnicodeTerminal $ \ h p -> f1 h p >> f2 h p+ 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@@ -115,9 +116,9 @@ , 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 :: Injection a LCoreTC => PrettyPrinter -> String -> RewriteH a -> RewriteH a diffR pp msg rr = do- let ppT = extractT $ liftPrettyH (pOptions pp) (pCoreTC pp)+ let ppT = extractT $ liftPrettyH (pOptions pp) (pLCoreTC pp) runDiff b a = do doc1 <- return b >>> ppT doc2 <- return a >>> ppT
src/HERMIT/Plugin/Types.hs view
@@ -1,10 +1,8 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -12,13 +10,13 @@ import Control.Concurrent.STM import Control.Monad.Error.Class (MonadError(..))+import qualified Control.Monad.Fail as Fail (MonadFail(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT(..)) import Control.Monad.State (MonadState(..), StateT(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT, runExceptT) -import Data.Dynamic import qualified Data.Map as M import HERMIT.Kure@@ -27,15 +25,13 @@ import HERMIT.Monad import HERMIT.Plugin.Builder import HERMIT.PrettyPrinter.Common-import HERMIT.Dictionary.Reasoning -import Prelude.Compat- import System.IO type PluginM = PluginT IO newtype PluginT m a = PluginT { unPluginT :: ExceptT PException (ReaderT PluginReader (StateT PluginState m)) a }- deriving (Functor, Applicative, MonadIO, MonadError PException, MonadState PluginState, MonadReader PluginReader)+ deriving (Functor, Applicative, MonadIO, MonadError PException,+ MonadState PluginState, MonadReader PluginReader) runPluginT :: PluginReader -> PluginState -> PluginT m a -> m (Either PException a, PluginState) runPluginT pr ps = flip runStateT ps . flip runReaderT pr . runExceptT . unPluginT@@ -43,6 +39,9 @@ instance Monad m => Monad (PluginT m) where return = PluginT . return PluginT m >>= k = PluginT (m >>= unPluginT . k)+ fail = Fail.fail++instance Monad m => Fail.MonadFail (PluginT m) where fail = PluginT . throwError . PError instance MonadTrans PluginT where@@ -68,16 +67,16 @@ , ps_render :: Handle -> PrettyOptions -> Either String DocH -> IO () -- ^ the way of outputing to the screen , 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- } deriving (Typeable)+ } data PluginReader = PluginReader { pr_kernel :: Kernel , pr_pass :: PassInfo- } deriving (Typeable)+ } data PException = PAbort | PResume AST | PError String -newtype PSBox = PSBox PluginState deriving Typeable+newtype PSBox = PSBox PluginState instance Extern PluginState where type Box PluginState = PSBox unbox (PSBox st) = st@@ -104,6 +103,6 @@ out $ "<" ++ show c ++ "> " ++ msg' DebugCore msg' cxt qc -> do out $ "[" ++ msg' ++ "]"- doc :: DocH <- applyT (ppLCoreTCT pp) (liftPrettyC (pOptions pp) cxt) qc+ doc :: DocH <- applyT (pLCoreTC pp) (liftPrettyC (pOptions pp) cxt) qc liftIO $ ps_render st stdout (pOptions pp) (Right doc) AddObligation _ nm l -> insertLemma nm l
src/HERMIT/PrettyPrinter/AST.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+ -- | Output the raw Expr constructors. Helpful for writing pattern matching rewrites. module HERMIT.PrettyPrinter.AST ( -- * HERMIT's AST Pretty-Printer for GHC Core@@ -43,9 +46,9 @@ externals = [ external "ast" pretty ["AST pretty printer."] ] pretty :: PrettyPrinter-pretty = PP { pForall = ppForallQuantification- , pCoreTC = ppCoreTC+pretty = PP { pLCoreTC = promoteT ppCoreTC -- TODO , pOptions = def+ , pTag = "ast" } -- | Pretty print a fragment of GHC Core using HERMIT's \"AST\" pretty printer.@@ -100,28 +103,78 @@ ppCoreDef = defT ppVar ppCoreExpr (\ i e -> text "Def" <+> i $$ nest 2 (parens e)) ppKindOrType :: PrettyH Type-ppKindOrType =- tyVarT (ppVar >>^ \ v -> tyText "TyVarTy" <+> v)- <+ litTyT (ppSDoc >>^ \ l -> tyText "LitTy" <+> l)- <+ appTyT ppKindOrType ppKindOrType (\ ty1 ty2 -> tyText "AppTy" $$ nest 2 (cat [parens ty1, parens ty2]))- <+ funTyT ppKindOrType ppKindOrType (\ ty1 ty2 -> tyText "FunTy" $$ nest 2 (cat [parens ty1, parens ty2]))- <+ forAllTyT ppVar ppKindOrType (\ v ty -> tyText "ForAllTy" <+> v $$ nest 2 (parens ty))- <+ tyConAppT ppSDoc (const ppKindOrType) (\ con tys -> tyText "TyConApp" <+> con $$ nest 2 (vlist $ map parens tys))+ppKindOrType = readerT $ \case+ TyVarTy{} -> tyVarT (ppVar >>^ \ v -> tyText "TyVarTy" <+> v)+ AppTy{} -> appTyT ppKindOrType ppKindOrType (\ ty1 ty2 -> tyText "AppTy" $$ nest 2 (cat [parens ty1, parens ty2]))+ TyConApp{} -> tyConAppT ppSDoc (const ppKindOrType) $ \ con tys -> + tyText "TyConApp" <+> con $$ nest 2 (vlist $ map parens tys)+#if __GLASGOW_HASKELL__ > 710+ CastTy{} -> castTyT ppKindOrType ppCoercion (\ ty co -> tyText "CastTy" $$ nest 2 (cat [parens ty, parens co]))+ CoercionTy{} -> coercionTyT ppCoercion >>= \ co -> return (tyText "CoercionTy" $$ nest 2 (parens co))+ ForAllTy{} -> forAllTyT ppTyBinder ppKindOrType (\ tb ty -> tyText "ForAllTy" <+> tb $$ nest 2 (parens ty))+#else+ FunTy{} -> funTyT ppKindOrType ppKindOrType (\ ty1 ty2 -> tyText "FunTy" $$ nest 2 (cat [parens ty1, parens ty2]))+ ForAllTy{} -> forAllTyT ppVar ppKindOrType (\ v ty -> tyText "ForAllTy" <+> v $$ nest 2 (parens ty))+#endif+ LitTy{} -> litTyT (ppSDoc >>^ \ l -> tyText "LitTy" <+> l) +#if __GLASGOW_HASKELL__ > 710+ppTyBinder :: PrettyH TyBinder+ppTyBinder = readerT $ \case+ Named tv v -> do+ d <- return tv >>> ppVar+ return $ tyText "Named" <+> d <+> tyText (showVis v)+ Anon ty -> do+ d <- return ty >>> ppKindOrType+ return $ tyText "Anon" <+> d++ppUnivCoProvenance :: PrettyH UnivCoProvenance+ppUnivCoProvenance = readerT $ \case+ UnsafeCoerceProv -> return $ coText "UnsafeCoerceProv"+ PhantomProv co -> do+ d <- return co >>> ppCoercion+ return $ coText "PhantomProv" <+> parens d+ ProofIrrelProv co -> do+ d <- return co >>> ppCoercion+ return $ coText "ProofIrrelProv" <+> parens d+ PluginProv s -> return $ coText "PluginProv" <+> coText s+ HoleProv _ -> return $ coText "HoleProv - IMPOSSIBLE!"+#endif+ ppCoercion :: PrettyH Coercion-ppCoercion = coVarCoT (ppVar >>^ \ v -> coText "CoVarCo" <+> v)- <+ symCoT (ppCoercion >>^ \ co -> coText "SymCo" $$ nest 2 (parens co))- <+ appCoT ppCoercion ppCoercion (\ co1 co2 -> coText "AppCo" $$ nest 2 (cat [parens co1, parens co2]))- <+ forAllCoT ppVar ppCoercion (\ v co -> coText "ForAllCo" <+> v $$ nest 2 (parens co))- <+ transCoT ppCoercion ppCoercion (\ co1 co2 -> coText "TransCo" $$ nest 2 (cat [parens co1, parens co2]))- <+ nthCoT (arr $ coText . show) ppCoercion (\ n co -> coText "NthCo" <+> n $$ parens co)- <+ instCoT ppCoercion ppKindOrType (\ co ty -> coText "InstCo" $$ nest 2 (cat [parens co, parens ty]))--- TODO: Figure out how to properly pp new branched Axioms and Left/Right Coercions- <+ reflT ppKindOrType (\ r ty -> coText "Refl" <+> coText (showRole r) $$ nest 2 (parens ty))- <+ axiomInstCoT ppSDoc ppSDoc (const ppCoercion) (\ ax idx coes -> coText "AxiomInstCo" <+> ax <+> idx $$ nest 2 (vlist $ map parens coes))- <+ lrCoT ppSDoc ppCoercion (\ lr co -> coText "LRCo" <+> lr $$ nest 2 (parens co))- <+ tyConAppCoT ppSDoc (const ppCoercion) (\ r con coes -> coText "TyConAppCo" <+> coText (showRole r) <+> con $$ nest 2 (vlist $ map parens coes))- -- TODO: add UnivCo and SubCo+ppCoercion = readerT $ \case+ Refl{} -> reflT ppKindOrType (\ r ty -> coText "Refl" <+> coText (showRole r) $$ nest 2 (parens ty))+ TyConAppCo{} -> tyConAppCoT ppSDoc (const ppCoercion) $ \ r con coes -> + coText "TyConAppCo" <+> coText (showRole r) <+> con $$ nest 2 (vlist $ map parens coes)+ AppCo{} -> appCoT ppCoercion ppCoercion (\ co1 co2 -> coText "AppCo" $$ nest 2 (cat [parens co1, parens co2]))+#if __GLASGOW_HASKELL__ > 710+ ForAllCo{} -> forAllCoT ppVar ppCoercion ppCoercion $ \ v c1 c2 -> + coText "ForAllCo" <+> v $$ nest 2 (cat [parens c1, parens c2])+#else+ ForAllCo{} -> forAllCoT ppVar ppCoercion (\ v co -> coText "ForAllCo" <+> v $$ nest 2 (parens co))+#endif+ CoVarCo{} -> coVarCoT (ppVar >>^ \ v -> coText "CoVarCo" <+> v)+ AxiomInstCo{} -> axiomInstCoT ppSDoc ppSDoc (const ppCoercion) $ \ ax idx coes -> + coText "AxiomInstCo" <+> ax <+> idx $$ nest 2 (vlist $ map parens coes)+#if __GLASGOW_HASKELL__ > 710+ UnivCo p _ _ _ -> do+ pd <- return p >>> ppUnivCoProvenance+ univCoT ppKindOrType ppKindOrType $ \ _ r dom ran -> + coText "UnivCo" <+> pd <+> coText (showRole r) $$ nest 2 (cat [parens dom, parens ran])+#else+ UnivCo{} -> univCoT ppKindOrType ppKindOrType $ \ s r dom ran -> + coText "UnivCo" <+> coText (show s) <+> coText (showRole r) $$ nest 2 (cat [parens dom, parens ran])+#endif+ SymCo{} -> symCoT (ppCoercion >>^ \ co -> coText "SymCo" $$ nest 2 (parens co))+ TransCo{} -> transCoT ppCoercion ppCoercion (\ co1 co2 -> coText "TransCo" $$ nest 2 (cat [parens co1, parens co2]))+ NthCo{} -> nthCoT (arr $ coText . show) ppCoercion (\ n co -> coText "NthCo" <+> n $$ parens co)+ LRCo{} -> lrCoT ppSDoc ppCoercion (\ lr co -> coText "LRCo" <+> lr $$ nest 2 (parens co))+#if __GLASGOW_HASKELL__ > 710+ InstCo{} -> instCoT ppCoercion ppCoercion (\ c1 c2 -> coText "InstCo" $$ nest 2 (cat [parens c1, parens c2]))+#else+ InstCo{} -> instCoT ppCoercion ppKindOrType (\ co ty -> coText "InstCo" $$ nest 2 (cat [parens co, parens ty]))+#endif+ SubCo{} -> subCoT (ppCoercion >>^ \ co -> coText "SubCo" $$ nest 2 (parens co)) ppVar :: PrettyH Var ppVar = readerT $ \ v -> ppSDoc >>^ modCol v
src/HERMIT/PrettyPrinter/Clean.hs view
@@ -1,6 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NoImplicitPrelude #-} module HERMIT.PrettyPrinter.Clean ( -- * HERMIT's Clean Pretty-Printer for GHC Core@@ -14,7 +14,6 @@ , ppCoreAlt , ppKindOrType , ppCoercion- , ppForallQuantification ) where import Control.Arrow hiding ((<+>))@@ -25,14 +24,14 @@ import HERMIT.Context import HERMIT.Core import HERMIT.External-import HERMIT.GHC hiding ((<+>), (<>), ($$), ($+$), cat, sep, fsep, hsep, empty, nest, vcat, char, text, keyword, hang)-import HERMIT.Kure hiding ((<$>))+import HERMIT.GHC hiding + ((<+>), (<>), ($$), ($+$), cat, sep, fsep, hsep, empty, isEmpty, nest, vcat, char, text, keyword, hang, parens)+import HERMIT.Kure +import HERMIT.Lemma import HERMIT.Monad import HERMIT.PrettyPrinter.Common import HERMIT.Syntax -import Prelude.Compat- import Text.PrettyPrint.MarkedHughesPJ as PP ------------------------------------------------------------------------------------------------@@ -41,60 +40,60 @@ externals = [ external "clean" pretty ["Clean pretty printer."] ] pretty :: PrettyPrinter-pretty = PP { pForall = ppForallQuantification- , pCoreTC = ppCoreTC+pretty = PP { pLCoreTC = promoteT ppClauseT <+ promoteT ppCoreTC , pOptions = def+ , pTag = "clean" } data RetExpr- = RetLam AbsolutePathH [DocH] AbsolutePathH DocH- | RetLet AbsolutePathH [DocH] AbsolutePathH DocH- | RetApp DocH [(AbsolutePathH,RetExpr)]- | RetForAll AbsolutePathH [DocH] AbsolutePathH DocH- | RetArrowType ArrowType DocH [(AbsolutePathH,DocH)] -- f -> (a -> (b -> c)) The path is for each arrow, starting from the left.+ = RetLam [DocH] DocH+ | RetLet [DocH] DocH+ | RetApp DocH [RetExpr]+ | RetForAll [DocH] DocH+ | RetArrowType ArrowType DocH [DocH] | RetExpr DocH | RetAtom DocH -- parens not needed | RetEmpty data ArrowType = ATType | ATCoercion deriving (Eq, Show) -retApp :: AbsolutePathH -> Crumb -> Crumb -> RetExpr -> RetExpr -> RetExpr-retApp _ _ _ f RetEmpty = f-retApp _ _ _ RetEmpty e = e-retApp p _ cr2 (RetApp f pes) e = RetApp f (pes ++ [(p @@ cr2, e)])-retApp p cr1 cr2 f e = RetApp (normalParens (p @@ cr1) f) [(p @@ cr2, e)]+retApp :: RetExpr -> RetExpr -> RetExpr+retApp f RetEmpty = f+retApp RetEmpty e = e+retApp (RetApp f es) e = RetApp f (es ++ [e])+retApp f e = RetApp (normalParens f) [e] -- empties should not arise-retApps :: AbsolutePathH -> (Int -> Crumb) -> DocH -> [RetExpr] -> RetExpr-retApps p crumb f es = RetApp f [ ((p @@ crumb n),e) | (e,n) <- zip es [1..]]+retApps :: DocH -> [RetExpr] -> RetExpr+retApps = RetApp -retLam :: AbsolutePathH -> DocH -> RetExpr -> RetExpr-retLam p v = if isEmpty v- then id- else \case- RetLam _ vs pb e -> RetLam p (v : vs) pb e- e -> RetLam p [v] (p @@ Lam_Body) (normalExpr e)+retLam :: DocH -> RetExpr -> RetExpr+retLam v = if isEmpty v+ then id+ else \case+ RetLam vs e -> RetLam (v : vs) e+ e -> RetLam [v] (normalExpr e) -retLet :: AbsolutePathH -> DocH -> RetExpr -> RetExpr-retLet p bnd = if isEmpty bnd- then id- else \case- RetLet _ bnds pb body -> RetLet p (bnd : bnds) pb body- body -> RetLet p [bnd] (p @@ Let_Body) (normalExpr body)+retLet :: DocH -> RetExpr -> RetExpr+retLet bnd = if isEmpty bnd+ then id+ else \case+ RetLet bnds body -> RetLet (bnd : bnds) body+ body -> RetLet [bnd] (normalExpr body) -retForAll :: AbsolutePathH -> Crumb -> DocH -> RetExpr -> RetExpr-retForAll p cr v = if isEmpty v- then id- else \case- RetForAll _ vs pb ty -> RetForAll p (v : vs) pb ty- ty -> RetForAll p [v] (p @@ cr) (normalExpr ty)+retForAll :: DocH -> RetExpr -> RetExpr+retForAll v = if isEmpty v+ then id+ else \case+ RetForAll vs ty -> RetForAll (v : vs) ty+ ty -> RetForAll [v] (normalExpr ty) -- This is very hacky. There must be a better way of handling arrow types.-retArrowType :: ArrowType -> AbsolutePathH -> Crumb -> Crumb -> RetExpr -> RetExpr -> RetExpr-retArrowType at@ATType p cr1 _cr2 ty1 (RetArrowType _ ty2 ptys)- = RetArrowType at (normalParensExceptApp (p @@ cr1) ty1) ((p,ty2) : ptys)-retArrowType at p cr1 cr2 ty1 ty2- = RetArrowType at (normalParensExceptApp (p @@ cr1) ty1) [(p , normalParensExceptApp (p @@ cr2) ty2)]+retArrowType :: ArrowType -> RetExpr -> RetExpr -> RetExpr+retArrowType at@ATType ty1 (RetArrowType _ ty2 tys)+ = RetArrowType at (normalParensExceptApp ty1) (ty2 : tys)+retArrowType at ty1 ty2+ = RetArrowType at (normalParensExceptApp ty1) [normalParensExceptApp ty2] ------------------------------------------------------------------------------------------------ @@ -102,101 +101,111 @@ normalExpr RetEmpty = empty normalExpr (RetAtom e) = e normalExpr (RetExpr e) = e-normalExpr (RetLam p vs pb e) = hang (specialSymbol p LambdaSymbol <+> hsep vs <+> specialSymbol pb RightArrowSymbol) 2 e-normalExpr (RetLet p vs pb e) = sep [ keyword p "let" <+> vcat vs, keyword pb "in" <+> e ]-normalExpr (RetApp f pes) = f <+> fsep (map (uncurry normalParens) pes)-normalExpr (RetForAll p vs pb ty) = specialSymbol p ForallSymbol <+> hsep vs <+> symbol pb '.' <+> ty-normalExpr (RetArrowType at ty ptys) = let a = case at of+normalExpr (RetLam vs e) = hang (specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e+normalExpr (RetLet vs e) = sep [ keyword "let" <+> vcat vs, keyword "in" <+> e ]+normalExpr (RetApp f es) = f <+> fsep (map normalParens es)+normalExpr (RetForAll vs ty) = specialSymbol ForallSymbol <+> hsep vs <+> symbol '.' <+> ty+normalExpr (RetArrowType at ty tys) = let a = case at of ATType -> typeArrow ATCoercion -> coArrow- in foldl (\ ty1 (p,ty2) -> ty1 <+> a p <+> ty2) ty ptys+ in foldl (\ ty1 ty2 -> ty1 <+> a <+> ty2) ty tys ------------------------------------------------------------------------------------------------ -cleanParens :: AbsolutePathH -> DocH -> DocH-cleanParens p e = symbol p '(' <> e <> symbol p ')'+cleanParens :: DocH -> DocH+cleanParens e = symbol '(' <> e <> symbol ')' -normalParens :: AbsolutePathH -> RetExpr -> DocH-normalParens p = \case- RetEmpty -> empty- RetAtom e -> e- RetApp f [] -> f- e -> cleanParens p (normalExpr e)+normalParens :: RetExpr -> DocH+normalParens = \case+ RetEmpty -> empty+ RetAtom e -> e+ RetApp f [] -> f+ e -> cleanParens (normalExpr e) -normalParensExceptApp :: AbsolutePathH -> RetExpr -> DocH-normalParensExceptApp p = \case- e@RetApp{} -> normalExpr e- e -> normalParens p e+normalParensExceptApp :: RetExpr -> DocH+normalParensExceptApp = \case+ e@RetApp{} -> normalExpr e+ e -> normalParens e ------------------------------------------------------------------------------------------------ parenExpr :: PrettyH RetExpr-parenExpr = do p <- absPathT- arr (normalParens p)+parenExpr = arr normalParens parenExprExceptApp :: PrettyH RetExpr-parenExprExceptApp = do p <- absPathT- arr (normalParensExceptApp p)+parenExprExceptApp = arr normalParensExceptApp ------------------------------------------------------------------------------------------------ -idText :: AbsolutePathH -> String -> DocH-idText p = attrP p . text---coText :: AbsolutePathH -> String -> DocH-coText p = attrP p . coercionColor . text+coText :: String -> DocH+coText = coercionColor . text -coChar :: AbsolutePathH -> Char -> DocH-coChar p = attrP p . coercionColor . char+coChar :: Char -> DocH+coChar = coercionColor . char -coSymbol :: AbsolutePathH -> SpecialSymbol -> DocH-coSymbol p = attrP p . coercionColor . specialFont . char . renderSpecial+coSymbol :: SpecialSymbol -> DocH+coSymbol = coercionColor . specialFont . char . renderSpecial -castSymbol :: AbsolutePathH -> DocH-castSymbol p = coSymbol p CastSymbol+castSymbol :: DocH+castSymbol = coSymbol CastSymbol -coercionSymbol :: AbsolutePathH -> DocH-coercionSymbol p = coSymbol p CoercionSymbol+coercionSymbol :: DocH+coercionSymbol = coSymbol CoercionSymbol -coercionBindSymbol :: AbsolutePathH -> DocH-coercionBindSymbol p = coSymbol p CoercionBindSymbol+coercionBindSymbol :: DocH+coercionBindSymbol = coSymbol CoercionBindSymbol -coKeyword :: AbsolutePathH -> String -> DocH+coKeyword :: String -> DocH coKeyword = coText -- An alternative would be keyword. -coArrow :: AbsolutePathH -> DocH-coArrow p = coSymbol p RightArrowSymbol+coArrow :: DocH+coArrow = coSymbol RightArrowSymbol -coTypeSymbol :: AbsolutePathH -> DocH-coTypeSymbol p = coSymbol p TypeOfSymbol+coTypeSymbol :: DocH+coTypeSymbol = coSymbol TypeOfSymbol ------------------------------------------------------------------------------------------------ -tyChar :: AbsolutePathH -> Char -> DocH-tyChar p = attrP p . typeColor . char+tyChar :: Char -> DocH+tyChar = typeColor . char -tyText :: AbsolutePathH -> String -> DocH-tyText p = attrP p . typeColor . text+tyText :: String -> DocH+tyText = typeColor . text -tySymbol :: AbsolutePathH -> SpecialSymbol -> DocH-tySymbol p = attrP p . typeColor . specialFont . char . renderSpecial+tySymbol :: SpecialSymbol -> DocH+tySymbol = typeColor . specialFont . char . renderSpecial typeSymbol :: PrettyH a-typeSymbol = do p <- absPathT- return (tySymbol p TypeSymbol)+typeSymbol = return (tySymbol TypeSymbol) -typeBindSymbol :: AbsolutePathH -> DocH-typeBindSymbol p = tySymbol p TypeBindSymbol+typeBindSymbol :: DocH+typeBindSymbol = tySymbol TypeBindSymbol -typeOfSymbol :: AbsolutePathH -> DocH-typeOfSymbol p = tySymbol p TypeOfSymbol+typeOfSymbol :: DocH+typeOfSymbol = tySymbol TypeOfSymbol -typeArrow :: AbsolutePathH -> DocH-typeArrow p = tySymbol p RightArrowSymbol+typeArrow :: DocH+typeArrow = tySymbol RightArrowSymbol ------------------------------------------------------------------------------------------------ +ppForallT :: PrettyH [Var]+ppForallT = do+ vs <- mapT ppBinderMode+ if null $ filter (not . isEmpty) vs+ then return empty+ else return $ specialSymbol ForallSymbol <+> sep vs <> symbol '.'++ppClauseT :: PrettyH Clause+ppClauseT =+ let parenify = ppClauseT >>^ \ d -> syntaxColor (PP.text "(") PP.<> d PP.<> syntaxColor (PP.text ")")+ in (forallsT ppForallT ppClauseT (\ d1 d2 -> PP.sep [d1,d2])+ <+ conjT parenify parenify (\ d1 d2 -> PP.sep [d1,syntaxColor (specialSymbol ConjSymbol),d2])+ <+ disjT parenify parenify (\ d1 d2 -> PP.sep [d1,syntaxColor (specialSymbol DisjSymbol),d2])+ <+ implT parenify parenify (\ _nm d1 d2 -> PP.sep [d1,syntaxColor (specialSymbol ImplSymbol),d2])+ <+ equivT (extractT ppCoreTC) (extractT ppCoreTC) (\ d1 d2 -> PP.sep [d1,specialSymbol EquivSymbol,d2])+ <+ return (syntaxColor $ PP.text "true"))+ -- | Pretty print a fragment of GHC Core using HERMIT's \"Clean\" pretty printer. ppCoreTC :: PrettyH CoreTC ppCoreTC =@@ -213,24 +222,23 @@ -- Use for any GHC structure ppSDoc :: Outputable a => PrettyH a ppSDoc = do dynFlags <- constT getDynFlags- p <- absPathT doc <- arr (showPpr dynFlags) if any isSpace doc- then return (cleanParens p (idText p doc))- else return (idText p doc)+ then return (cleanParens (text doc))+ else return (text doc) -- For var bindings ppVar :: PrettyH Var ppVar = readerT $ \ v -> varName ^>> ppName (varColor v) --- For var occurences (in CoreExpr)+-- For var occurrences (in CoreExpr) ppVarOcc :: PrettyH Var ppVarOcc = do (c,i) <- exposeT let colFn = if isDeadBinder i || (isLocalId i && (i `notElemVarSet` boundVars c)) then const WarningColor else varColor- markBindingSite i c <$> (readerT $ \ v -> varName ^>> ppName (colFn v))+ readerT $ \ v -> varName ^>> ppName (colFn v) varColor :: Var -> SyntaxForColor varColor var | isTyVar var = TypeColor@@ -238,21 +246,19 @@ | otherwise = IdColor ppName :: SyntaxForColor -> PrettyH Name-ppName color = do p <- absPathT- c <- contextT+ppName color = do c <- contextT name <- arr (\ n -> unqualifiedName n ++ (if po_showUniques (prettyC_options c) then '_' : show (getUnique n) else ""))- let doc = attrP p $ markColor color $ text name+ let doc = markColor color $ text name -- TODO: is "isScriptInfixId" the right predicate to use here? if all isScriptInfixIdChar name- then return (cleanParens p doc)+ then return (cleanParens doc) else return doc ppLitTy :: PrettyH TyLit-ppLitTy = do p <- absPathT- arr $ \ lit -> tyText p $ case lit of- NumTyLit i -> show i- StrTyLit fs -> show fs+ppLitTy = arr $ \ lit -> tyText $ case lit of+ NumTyLit i -> show i+ StrTyLit fs -> show fs ppTyCon :: PrettyH TyCon ppTyCon = getName ^>> ppName TypeColor@@ -262,114 +268,105 @@ ppDetailedVar :: PrettyH Var ppDetailedVar = do- p <- absPathT (v,ty) <- ppVar &&& (varType ^>> ppKindOrType)- return $ cleanParens p $ v <+> typeOfSymbol p <+> ty+ return $ cleanParens $ v <+> typeOfSymbol <+> ty -- binders are vars that is bound by lambda or case, etc. -- depending on the mode, they might not be displayed ppBinderMode :: PrettyH Var-ppBinderMode = do p <- absPathT- v <- idR- opts <- prettyC_options ^<< contextT- if- | isTyVar v -> case po_exprTypes opts of- Omit -> return empty- Abstract -> return (typeBindSymbol p)- Detailed -> ppDetailedVar- _ -> ppVar- | isCoVar v -> case po_coercions opts of- Omit -> return empty- Abstract -> return (coercionBindSymbol p)- Detailed -> ppDetailedVar- Show -> ppVar- Kind -> do pCoKind <- ppCoKind <<^ CoVarCo- return $ cleanParens p (coercionBindSymbol p <+> typeOfSymbol p <+> pCoKind)- -- TODO: refactor this to be more systematic. It should be possible to request type sigs for all type bindings.- | otherwise -> case po_exprTypes opts of- Detailed -> ppDetailedVar- _ -> ppVar+ppBinderMode = do+ v <- idR+ opts <- prettyC_options ^<< contextT+ if | isTyVar v -> case po_exprTypes opts of+ Omit -> return empty+ Abstract -> return typeBindSymbol+ Detailed -> ppDetailedVar+ _ -> ppVar+ | isCoVar v -> case po_coercions opts of+ Omit -> return empty+ Abstract -> return coercionBindSymbol+ Detailed -> ppDetailedVar+ Show -> ppVar+ Kind -> do pCoKind <- ppCoKind <<^ CoVarCo+ return $ cleanParens (coercionBindSymbol <+> typeOfSymbol <+> pCoKind)+ -- TODO: refactor this to be more systematic.+ -- It should be possible to request type sigs for all type bindings.+ | otherwise -> case po_exprTypes opts of+ Detailed -> ppDetailedVar+ _ -> ppVar ppModGuts :: PrettyH ModGuts-ppModGuts = do p <- absPathT- name <- ppSDoc <<^ mg_module- modGutsT ppProg (\ _ prog -> hang (keyword p "module" <+> name <+> keyword p "where") 2 prog)+ppModGuts = do name <- ppSDoc <<^ mg_module+ modGutsT ppProg (\ _ prog -> hang (keyword "module" <+> name <+> keyword "where") 2 prog) where ppProg :: PrettyH CoreProg ppProg = progConsT ppBind ppProg ($+$) <+ progNilT empty ppBind :: PrettyH CoreBind- ppBind = (absPathT >>= \ p -> nonRecT ppVar (exprKindOrType ^>> ppKindOrType) (\ v ty -> v <+> typeOfSymbol p <+> ty))- <+ recT (\ _ -> absPathT &&& defT ppVar (exprKindOrType ^>> ppKindOrType) (,)) (\ pvtys -> vcat [ v <+> typeOfSymbol p <+> ty | (p,(v,ty)) <- pvtys ])+ ppBind = (nonRecT ppVar (exprKindOrType ^>> ppKindOrType) (\ v ty -> v <+> typeOfSymbol <+> ty))+ <+ recT (\ _ -> defT ppVar (exprKindOrType ^>> ppKindOrType) (,)) (\ pvtys -> vcat [ v <+> typeOfSymbol <+> ty | (v,ty) <- pvtys ]) ppCoreProg :: PrettyH CoreProg ppCoreProg = progConsT ppCoreBind ppCoreProg ($+$) <+ progNilT empty ppCoreBind :: PrettyH CoreBind-ppCoreBind = (nonRecT idR (ppCoreExprR &&& ppTypeSig) (,) >>> ppDef NonRec_RHS)- <+ (do p <- absPathT- recT (const ppCoreDef) (\ bnds -> keyword p "rec" <+> vcat bnds)+ppCoreBind = (nonRecT idR (ppCoreExprR &&& ppTypeSig) (,) >>> ppDef)+ <+ (recT (const ppCoreDef) (\ bnds -> keyword "rec" <+> vcat bnds) ) ppCoreAlt :: PrettyH CoreAlt-ppCoreAlt = do p <- absPathT- altT (do p' <- absPathT- readerT $ \case- DataAlt dcon -> return (getName dcon) >>> ppName IdColor- LitAlt lit -> return lit >>> ppSDoc- DEFAULT -> return (symbol p' '_')- )- (\ _ -> ppBinderMode)- ppCoreExpr- (\ con vs e -> hang (con <+> fsep vs <+> specialSymbol p RightArrowSymbol) 2 e)+ppCoreAlt = altT (do readerT $ \case+ DataAlt dcon -> return (getName dcon) >>> ppName IdColor+ LitAlt lit -> return lit >>> ppSDoc+ DEFAULT -> return (symbol '_')+ )+ (\ _ -> ppBinderMode)+ ppCoreExpr+ (\ con vs e -> hang (con <+> fsep vs <+> specialSymbol RightArrowSymbol) 2 e) ppCoreDef :: PrettyH CoreDef-ppCoreDef = defT idR (ppCoreExprR &&& ppTypeSig) (,) >>> ppDef Def_RHS+ppCoreDef = defT idR (ppCoreExprR &&& ppTypeSig) (,) >>> ppDef -ppDef :: Crumb -> PrettyH (Var,(RetExpr,DocH))-ppDef cr = do p <- absPathT- (v,(e,ty)) <- idR- opts <- prettyC_options ^<< contextT- let eq = symbol p '='- case po_coercions opts of- Omit | isCoVar v -> return empty- Kind | isCoVar v -> return $ case po_exprTypes opts of- Show -> (coercionBindSymbol p <+> typeOfSymbol p <+> ty) $+$ (coercionBindSymbol p <+> eq <+> coercionSymbol (p @@ cr))- _ -> coercionBindSymbol p <+> eq <+> normalExpr e- _ -> do pv <- ppBinderMode <<< return v- let pre = pv <+> eq- body = case e of -- This is an ugly hack- RetLam p' vs pb e0 -> hang (pre <+> specialSymbol p' LambdaSymbol <+> hsep vs <+> specialSymbol pb RightArrowSymbol) 2 e0- _ -> hang pre 2 (normalExpr e)- return $ case po_exprTypes opts of- Omit | isTyVar v -> empty- Show -> (pv <+> typeOfSymbol p <+> ty) $+$ body- _ -> body+ppDef :: PrettyH (Var,(RetExpr,DocH))+ppDef = do (v,(e,ty)) <- idR+ opts <- prettyC_options ^<< contextT+ let eq = symbol '='+ case po_coercions opts of+ Omit | isCoVar v -> return empty+ Kind | isCoVar v -> return $ case po_exprTypes opts of+ Show -> (coercionBindSymbol <+> typeOfSymbol <+> ty) $+$ (coercionBindSymbol <+> eq <+> coercionSymbol)+ _ -> coercionBindSymbol <+> eq <+> normalExpr e+ _ -> do pv <- ppBinderMode <<< return v+ let pre = pv <+> eq+ body = case e of -- This is an ugly hack+ RetLam vs e0 -> hang (pre <+> specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e0+ _ -> hang pre 2 (normalExpr e)+ return $ case po_exprTypes opts of+ Omit | isTyVar v -> empty+ Show -> (pv <+> typeOfSymbol <+> ty) $+$ body+ _ -> body ppCoreExpr :: PrettyH CoreExpr ppCoreExpr = ppCoreExprR >>^ normalExpr ppCoreExprR :: Transform PrettyC HermitM CoreExpr RetExpr-ppCoreExprR = absPathT >>= ppCoreExprPR- where- ppCoreExprPR :: AbsolutePathH -> Transform PrettyC HermitM CoreExpr RetExpr- ppCoreExprPR p =- lamT ppBinderMode ppCoreExprR (retLam p)- <+ letT ppCoreBind ppCoreExprR (retLet p)- <+ appT ppCoreExprR ppCoreExprR (retApp p App_Fun App_Arg)- <+ caseT ppCoreExpr ppVar (ppTypeModeR >>> parenExpr) (const ppCoreAlt)- (\ s w ty alts -> RetExpr (hang (keyword p "case" <+> s) 1 (keyword p "of" <+> w <+> ty) $+$ nest 2 (vcat alts)))- <+ varT (RetAtom <$> ppVarOcc)- <+ litT (RetAtom <$> ppSDoc)- <+ typeT ppTypeModeR- <+ coercionT ppCoercionModeR- <+ (castT ppCoreExprR (ppCoercionModeR >>> parenExpr) (,) >>> readerT (\ (_,co) -> if isEmpty co- then arr fst- else toFst parenExprExceptApp >>^ \ e -> RetExpr (hang e 2 (castSymbol p <+> co))+ppCoreExprR =+ lamT ppBinderMode ppCoreExprR retLam+ <+ letT ppCoreBind ppCoreExprR retLet+ <+ appT ppCoreExprR ppCoreExprR retApp+ <+ caseT ppCoreExpr ppVar (ppTypeModeR >>> parenExpr) (const ppCoreAlt)+ (\ s w ty alts -> RetExpr (hang (keyword "case" <+> s) 1 (keyword "of" <+> w <+> ty) $+$ nest 2 (vcat alts)))+ <+ varT (RetAtom <$> ppVarOcc)+ <+ litT (RetAtom <$> ppSDoc)+ <+ typeT ppTypeModeR+ <+ coercionT ppCoercionModeR+ <+ (castT ppCoreExprR (ppCoercionModeR >>> parenExpr) (,) >>> readerT (\ (_,co) -> if isEmpty co+ then arr fst+ else toFst parenExprExceptApp >>^ \ e -> RetExpr (hang e 2 (castSymbol <+> co)) ))- <+ tickT ppSDoc (ppCoreExprR >>> parenExpr) (\ tk e -> RetExpr $ attrP p (text "Tick") $$ nest 2 (tk <+> e))+ <+ tickT ppSDoc (ppCoreExprR >>> parenExpr) (\ tk e -> RetExpr $ (text "Tick") $$ nest 2 (tk <+> e)) -------------------------------------------------------------------- @@ -385,38 +382,64 @@ _ -> ppKindOrTypeR ppKindOrTypeR :: Transform PrettyC HermitM KindOrType RetExpr-ppKindOrTypeR = absPathT >>= ppKindOrTypePR- where- ppKindOrTypePR :: AbsolutePathH -> Transform PrettyC HermitM KindOrType RetExpr- ppKindOrTypePR p =- tyVarT (RetAtom <$> ppVarOcc)- <+ litTyT (RetAtom <$> ppLitTy)- <+ appTyT ppKindOrTypeR ppKindOrTypeR (retApp p AppTy_Fun AppTy_Arg)- <+ funTyT ppKindOrTypeR ppKindOrTypeR (retArrowType ATType p FunTy_Dom FunTy_CoDom)- <+ forAllTyT ppVar ppKindOrTypeR (retForAll p ForAllTy_Body)- <+ tyConAppT (forkFirst ppTyCon) (\ _ -> ppKindOrTypeR)- (\ (pCon,tyCon) tys -> if | isFunTyCon tyCon && length tys == 2 -> let [ty1,ty2] = tys in retArrowType ATType p (TyConApp_Arg 0) (TyConApp_Arg 1) ty1 ty2- | tyCon == listTyCon -> RetAtom $ tyChar p '[' <> (case tys of- [] -> empty- t:_ -> normalExpr t)- <> tyChar p ']'- | isTupleTyCon tyCon -> RetAtom $ tyChar p '(' <> (if null tys- then empty- else foldr1 (\ ty r -> ty <> tyChar p ',' <+> r) (map normalExpr tys)- )- <> tyChar p ')'- | isLiftedTypeKindCon tyCon -> RetAtom $ tyChar p '*'- | otherwise -> retApps p TyConApp_Arg pCon tys- )+ppKindOrTypeR = readerT $ \case+ TyVarTy{} -> tyVarT (RetAtom <$> ppVarOcc)+ AppTy{} -> appTyT ppKindOrTypeR ppKindOrTypeR retApp+ TyConApp{} -> do+ ty <- idR + tyConAppT (forkFirst ppTyCon) (\ _ -> ppKindOrTypeR)+ (\ (pCon,tyCon) tys -> + if | isFunTyCon tyCon && length tys == 2 -> let [ty1,ty2] = tys in retArrowType ATType ty1 ty2+ | tyCon == listTyCon -> RetAtom $ tyChar '[' <> (case tys of+ [] -> empty+ t:_ -> normalExpr t) <> tyChar ']'+ | isTupleTyCon tyCon -> RetAtom $ tyChar '(' <> (if null tys+ then empty+ else foldr1 (\ t r -> t <> tyChar ',' <+> r) (map normalExpr tys)+ )+ <> tyChar ')'+#if __GLASGOW_HASKELL__ > 710+ | isStarKind ty -> RetAtom $ tyChar '*'+#else+ | isLiftedTypeKindCon tyCon -> RetAtom $ tyChar '*'+#endif+ | otherwise -> retApps pCon tys+ )+#if __GLASGOW_HASKELL__ > 710+ -- TODO: these are in AST format... FIXME+ CastTy{} -> castTyT ppKindOrType ppCoercion (\ ty co -> RetExpr $ tyText "CastTy" $$ nest 2 (cat [parens ty, parens co]))+ CoercionTy{} -> coercionTyT ppCoercion >>= \ co -> return (RetExpr $ tyText "CoercionTy" $$ nest 2 (parens co))+ ForAllTy{} -> forAllTyT ppTyBinder ppKindOrType (\ tb ty -> RetExpr $ tyText "ForAllTy" <+> tb $$ nest 2 (parens ty))+#else+ FunTy{} -> funTyT ppKindOrTypeR ppKindOrTypeR (retArrowType ATType)+ ForAllTy{} -> forAllTyT ppVar ppKindOrTypeR retForAll+#endif+ LitTy{} -> litTyT (RetAtom <$> ppLitTy) +#if __GLASGOW_HASKELL__ > 710+-- TODO: these are in AST format... FIXME+ppTyBinder :: PrettyH TyBinder+ppTyBinder = readerT $ \case+ Named tv v -> do+ d <- return tv >>> ppVar+ return $ tyText "Named" <+> d <+> tyText (showVis v)+ Anon ty -> do+ d <- return ty >>> ppKindOrType+ return $ tyText "Anon" <+> d --- A bit hacky, currently only used to pretty-print Lemmas.-ppForallQuantification :: PrettyH [Var]-ppForallQuantification =- do vs <- mapT ppBinderMode- if null $ filter (not . isEmpty) vs- then return empty- else return $ specialSymbol mempty ForallSymbol <+> sep vs <> symbol mempty '.'+-- TODO: these are in AST format... FIXME+ppUnivCoProvenance :: PrettyH UnivCoProvenance+ppUnivCoProvenance = readerT $ \case+ UnsafeCoerceProv -> return $ coText "UnsafeCoerceProv"+ PhantomProv co -> do+ d <- return co >>> ppCoercion+ return $ coText "PhantomProv" <+> parens d+ ProofIrrelProv co -> do+ d <- return co >>> ppCoercion+ return $ coText "ProofIrrelProv" <+> parens d+ PluginProv s -> return $ coText "PluginProv" <+> coText s+ HoleProv _ -> return $ coText "HoleProv - IMPOSSIBLE!"+#endif -------------------------------------------------------------------- @@ -424,48 +447,72 @@ ppCoercion = ppCoercionR >>^ normalExpr ppCoercionModeR :: Transform PrettyC HermitM Coercion RetExpr-ppCoercionModeR = do p <- absPathT- opts <- prettyC_options ^<< contextT+ppCoercionModeR = do opts <- prettyC_options ^<< contextT case po_coercions opts of Omit -> return RetEmpty- Abstract -> return (RetAtom $ coercionSymbol p)- Kind -> ppCoKind >>^ (\ k -> RetExpr (coercionSymbol p <+> coTypeSymbol p <+> k))+ Abstract -> return (RetAtom coercionSymbol)+ Kind -> ppCoKind >>^ (\ k -> RetExpr (coercionSymbol <+> coTypeSymbol <+> k)) _ -> ppCoercionR ppCoercionR :: Transform PrettyC HermitM Coercion RetExpr-ppCoercionR = absPathT >>= ppCoercionPR- where- ppCoercionPR :: AbsolutePathH -> Transform PrettyC HermitM Coercion RetExpr- ppCoercionPR p =- coVarCoT (RetAtom <$> ppVarOcc)- <+ symCoT (ppCoercionR >>> parenExpr >>^ \ co -> RetExpr (coKeyword p "sym" <+> co))- <+ forAllCoT ppBinderMode ppCoercionR (retForAll p ForAllCo_Body)- <+ transCoT (ppCoercionR >>> parenExprExceptApp) (ppCoercionR >>> parenExprExceptApp) (\ co1 co2 -> RetExpr (co1 <+> coChar p ';' <+> co2))- <+ nthCoT (arr show) (ppCoercionR >>> parenExpr) (\ n co -> RetExpr (coKeyword p "nth" <+> coText (p @@ NthCo_Int) n <+> co))- <+ instCoT (ppCoercionR >>> parenExpr &&& parenExprExceptApp) (ppTypeModeR >>> parenExprExceptApp) (\ (cop1,cop2) ty -> if isEmpty ty- then RetExpr (coText p "inst" <+> cop1)- else RetExpr (cop2 <+> coChar p '@' <+> ty)- )- <+ appCoT ppCoercionR ppCoercionR (retApp p AppCo_Fun AppCo_Arg)--- TODO: Figure out how to properly pp new branched Axioms and Left/Right Coercions- <+ reflT (ppTypeModeR >>^ normalExpr) (\ r ty -> RetAtom $ if isEmpty ty then coText p "refl" else coChar p '<' <> coText p (showRole r ++ ":") <> ty <> coChar p '>')- <+ tyConAppCoT (forkFirst ppTyConCo) (const ppCoercionR)- (\ r (ptc, tc) cs -> if isFunTyCon tc && (length cs == 2)- then let [c1,c2] = cs- in retArrowType ATCoercion p (TyConApp_Arg 0) (TyConApp_Arg 1) c1 c2- else retApps p TyConApp_Arg (coText p (showRole r ++ ":") <> ptc) cs)- <+ axiomInstCoT (coAxiomName ^>> ppName CoercionColor) ppSDoc (\ _ -> ppCoercionR >>> parenExpr) (\ ax idx coes -> RetExpr (coText p "axiomInst" <+> ax <+> idx <+> sep coes))- <+ lrCoT ppSDoc (ppCoercionR >>> parenExpr) (\ lr co -> RetExpr (coercionColor lr <+> co))- -- TODO: UnivCo and SubCo- <+ constT (return . RetAtom $ text "Unsupported Coercion Constructor")+ppCoercionR = readerT $ \case+ Refl{} -> reflT (ppTypeModeR >>^ normalExpr) (\ r ty -> RetAtom $ if isEmpty ty then coText "refl" else coChar '<' <> coText (showRole r ++ ":") <> ty <> coChar '>')+ TyConAppCo{} -> + tyConAppCoT (forkFirst ppTyConCo) (const ppCoercionR)+ (\ r (ptc, tc) cs -> if isFunTyCon tc && (length cs == 2)+ then let [c1,c2] = cs+ in retArrowType ATCoercion c1 c2+ else retApps (coText (showRole r ++ ":") <> ptc) cs)+ AppCo{} -> appCoT ppCoercionR ppCoercionR retApp+#if __GLASGOW_HASKELL__ > 710+ -- TODO: these are in AST format... FIXME+ ForAllCo{} -> forAllCoT ppVar ppCoercion ppCoercion $ \ v c1 c2 ->+ RetExpr $ coText "ForAllCo" <+> v $$ nest 2 (cat [parens c1, parens c2])+#else+ ForAllCo{} -> forAllCoT ppBinderMode ppCoercionR retForAll+#endif+ CoVarCo{} -> coVarCoT (RetAtom <$> ppVarOcc)+ AxiomInstCo{} -> axiomInstCoT (coAxiomName ^>> ppName CoercionColor) ppSDoc + (\ _ -> ppCoercionR >>> parenExpr) + (\ ax idx coes -> RetExpr (coText "axiomInst" <+> ax <+> idx <+> sep coes))+#if __GLASGOW_HASKELL__ > 710+ -- TODO: these are in AST format... FIXME+ UnivCo p _ _ _ -> do+ pd <- return p >>> ppUnivCoProvenance+ univCoT ppKindOrType ppKindOrType $ \ _ r dom ran ->+ RetExpr $ coText "UnivCo" <+> pd <+> coText (showRole r) $$ nest 2 (cat [parens dom, parens ran])+#else+ UnivCo{} -> univCoT ppTypeModeR ppTypeModeR+ (\ s r dom ran -> retApps (coKeyword "univ" <+> coText (show s) <+> coText (showRole r)) [dom,ran])+#endif+ SymCo{} -> symCoT (ppCoercionR >>> parenExpr >>^ \ co -> RetExpr (coKeyword "sym" <+> co))+ TransCo{} -> transCoT (ppCoercionR >>> parenExprExceptApp) + (ppCoercionR >>> parenExprExceptApp) + (\ co1 co2 -> RetExpr (co1 <+> coChar ';' <+> co2))+ NthCo{} -> nthCoT (arr show) (ppCoercionR >>> parenExpr) (\ n co -> RetExpr (coKeyword "nth" <+> coText n <+> co))+ LRCo{} -> lrCoT ppSDoc (ppCoercionR >>> parenExpr) (\ lr co -> RetExpr (coercionColor lr <+> co))+ +#if __GLASGOW_HASKELL__ > 710+ -- TODO: these are in AST format... FIXME+ InstCo{} -> instCoT ppCoercion ppCoercion (\ c1 c2 -> RetExpr $ coText "InstCo" $$ nest 2 (cat [parens c1, parens c2]))+#else+ InstCo{} -> instCoT (ppCoercionR >>> parenExpr &&& parenExprExceptApp) + (ppTypeModeR >>> parenExprExceptApp) + (\ (cop1,cop2) ty -> if isEmpty ty+ then RetExpr (coText "inst" <+> cop1)+ else RetExpr (cop2 <+> coChar '@' <+> ty)+ )+#endif+ SubCo{} -> subCoT (ppCoercionR >>> parenExpr >>^ \ co -> RetExpr (coKeyword "sub" <+> co))+ -- TODO: comment this out and add missing cases+ -- _ -> constT (return . RetAtom $ text "Unsupported Coercion Constructor") ppCoKind :: PrettyH Coercion ppCoKind = do- p <- absPathT (r, Pair co1 co2) <- arr (coercionRole &&& coercionKind) ty1 <- return co1 >>> ppTypeModeR >>> parenExprExceptApp ty2 <- return co2 >>> ppTypeModeR >>> parenExprExceptApp- return $ cat [ty1, pad (coText p ("~" ++ showRole r)), ty2]+ return $ cat [ty1, pad (coText ("~" ++ showRole r)), ty2] --------------------------------------------------------------------
src/HERMIT/PrettyPrinter/Common.hs view
@@ -1,16 +1,15 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} module HERMIT.PrettyPrinter.Common ( -- * Documents DocH , Attr(..)- , attrP , HTML(..) , ASCII(..) -- ** Colors@@ -18,7 +17,6 @@ , idColor , keywordColor , syntaxColor- , markBindingSite , markColor , typeColor , ShowOption(..)@@ -40,8 +38,6 @@ , PrettyH , PrettyHLCoreBox(..) , PrettyHLCoreTCBox(..)- , TransformLCoreDocHBox(..)- , TransformLCoreTCDocHBox(..) , liftPrettyH , PrettyC(..) , initPrettyC@@ -56,13 +52,19 @@ , hlist , vlist , showRole+#if __GLASGOW_HASKELL__ > 710+ , showVis+#endif+ , HermitMark(..) -- AJG: for now ) where import Data.Char import Data.Default.Class import qualified Data.Map as M-import Data.Typeable+import qualified Data.Semigroup as Semigroup +import GHC.Generics+ import HERMIT.Context import HERMIT.Core import HERMIT.External@@ -71,8 +73,6 @@ import HERMIT.Lemma import HERMIT.Monad -import Prelude.Compat- import Text.PrettyPrint.MarkedHughesPJ as PP showRole :: Role -> String@@ -80,6 +80,13 @@ showRole Representational = "R" showRole Phantom = "P" +#if __GLASGOW_HASKELL__ > 710+showVis :: VisibilityFlag -> String+showVis Visible = "Visible"+showVis Specified = "Specified"+showVis Invisible = "Invisible"+#endif+ -- A HERMIT document type DocH = MDoc HermitMark @@ -87,14 +94,12 @@ data HermitMark = PushAttr Attr | PopAttr- deriving Show+ deriving (Show, Generic) -- These are the attributes-data Attr = BndrAttr AbsolutePathH -- path to binding of a variable- | Color SyntaxForColor- | PathAttr AbsolutePathH -- path to this spot+data Attr = Color SyntaxForColor | SpecialFont- deriving (Eq, Show)+ deriving (Eq, Show, Generic) data SyntaxForColor -- (suggestion) = KeywordColor -- bold@@ -104,14 +109,11 @@ | TypeColor | LitColor | WarningColor -- highlight problems like unbound variables- deriving (Eq, Show)+ deriving (Eq, Show, Generic) attr :: Attr -> DocH -> DocH attr a p = mark (PushAttr a) <> p <> mark PopAttr -attrP :: AbsolutePathH -> DocH -> DocH-attrP = attr . PathAttr- idColor :: DocH -> DocH idColor = markColor IdColor @@ -133,20 +135,19 @@ specialFont :: DocH -> DocH specialFont = attr SpecialFont -specialSymbol :: AbsolutePathH -> SpecialSymbol -> DocH-specialSymbol p = attrP p . markColor SyntaxColor . specialFont . char . renderSpecial+specialSymbol :: SpecialSymbol -> DocH+specialSymbol = markColor SyntaxColor . specialFont . char . renderSpecial -symbol :: AbsolutePathH -> Char -> DocH-symbol p = attrP p . markColor SyntaxColor . char+symbol :: Char -> DocH+symbol = markColor SyntaxColor . char -keyword :: AbsolutePathH -> String -> DocH-keyword p = attrP p . markColor KeywordColor . text+keyword :: String -> DocH+keyword = markColor KeywordColor . text -data PrettyPrinter = PP { pForall :: PrettyH [Var]- , pCoreTC :: PrettyH CoreTC+data PrettyPrinter = PP { pLCoreTC :: PrettyH LCoreTC , pOptions :: PrettyOptions+ , pTag :: String }- deriving Typeable instance Extern PrettyPrinter where type Box PrettyPrinter = PrettyPrinter@@ -156,34 +157,20 @@ type PrettyH a = Transform PrettyC HermitM a DocH -- TODO: change monads to something more restricted? -data PrettyHLCoreBox = PrettyHLCoreBox (PrettyH LCore) deriving Typeable+data PrettyHLCoreBox = PrettyHLCoreBox (PrettyH LCore) instance Extern (PrettyH LCore) where type Box (PrettyH LCore) = PrettyHLCoreBox box = PrettyHLCoreBox unbox (PrettyHLCoreBox i) = i -data TransformLCoreDocHBox = TransformLCoreDocHBox (TransformH LCore DocH) deriving Typeable--instance Extern (TransformH LCore DocH) where- type Box (TransformH LCore DocH) = TransformLCoreDocHBox- box = TransformLCoreDocHBox- unbox (TransformLCoreDocHBox i) = i--data PrettyHLCoreTCBox = PrettyHLCoreTCBox (PrettyH LCoreTC) deriving Typeable+data PrettyHLCoreTCBox = PrettyHLCoreTCBox (PrettyH LCoreTC) instance Extern (PrettyH LCoreTC) where type Box (PrettyH LCoreTC) = PrettyHLCoreTCBox box = PrettyHLCoreTCBox unbox (PrettyHLCoreTCBox i) = i -data TransformLCoreTCDocHBox = TransformLCoreTCDocHBox (TransformH LCoreTC DocH) deriving Typeable--instance Extern (TransformH LCoreTC DocH) where- type Box (TransformH LCoreTC DocH) = TransformLCoreTCDocHBox- box = TransformLCoreTCDocHBox- unbox (TransformLCoreTCDocHBox i) = i- ------------------------------------------------------------------------------- -- | Context for PrettyH translations.@@ -193,11 +180,6 @@ , prettyC_lemmas :: Lemmas } -markBindingSite :: Var -> PrettyC -> DocH -> DocH-markBindingSite i c d = case M.lookup i (prettyC_vars c) of- Nothing -> d- Just p -> attr (BndrAttr p) d- ------------------------------------------------------------------------ instance ReadPath PrettyC Crumb where@@ -222,7 +204,7 @@ instance HasEmptyContext PrettyC where setEmptyContext :: PrettyC -> PrettyC setEmptyContext c = c { prettyC_path = mempty- , prettyC_vars = M.empty}+ , prettyC_vars = M.empty } instance LemmaContext PrettyC where addAntecedent nm l c = c { prettyC_lemmas = M.insert nm l (prettyC_lemmas c) }@@ -249,6 +231,7 @@ } -- These are *recommendations* to the pretty printer.+-- AJG: These seem to be in two places, the PrettyC context, and inside PrettyPrinter. data PrettyOptions = PrettyOptions { po_fullyQualified :: Bool -- ^ Do you show fully qualified names?@@ -260,10 +243,11 @@ , po_depth :: Maybe Int -- ^ below this depth are ..., Nothing => infinite , po_notes :: Bool -- ^ notes might be added to output , po_ribbon :: Float- , po_width :: Int- } deriving Show+ , po_width :: Int -- AJG: The width is not a pretty option, but rather a render option (?)+ } deriving (Generic, Show) -data ShowOption = Show | Abstract | Detailed | Omit | Kind deriving (Eq, Ord, Show, Read)+data ShowOption = Show | Abstract | Detailed | Omit | Kind+ deriving (Eq, Generic, Ord, Show, Read) -- Types don't have a Kind showing option. updateTypeShowOption :: ShowOption -> PrettyOptions -> PrettyOptions@@ -313,7 +297,6 @@ class RenderSpecial a where renderSpecial :: SpecialSymbol -> a - -- This instance is special. It is used as an index, forming an association list. -- Thus all of the rhs must be distinct characters. -- Think of RenderSpecial as a special font.@@ -336,8 +319,11 @@ instance Monoid ASCII where mempty = ASCII ""- mappend (ASCII xs) (ASCII ys) = ASCII (xs ++ ys)+ mappend = (Semigroup.<>) +instance Semigroup.Semigroup ASCII where+ ASCII xs <> ASCII ys = ASCII (xs ++ ys)+ instance RenderSpecial ASCII where renderSpecial LambdaSymbol = ASCII "\\" -- lambda renderSpecial TypeOfSymbol = ASCII "::" -- ::@@ -374,8 +360,11 @@ instance Monoid LaTeX where mempty = LaTeX ""- mappend (LaTeX xs) (LaTeX ys) = LaTeX (xs ++ ys)+ mappend = (Semigroup.<>) +instance Semigroup.Semigroup LaTeX where+ LaTeX xs <> LaTeX ys = LaTeX (xs ++ ys)+ instance RenderSpecial LaTeX where renderSpecial LambdaSymbol = LaTeX "\\ensuremath{\\lambda}" renderSpecial TypeOfSymbol = LaTeX ":\\!:" -- too wide@@ -396,8 +385,11 @@ instance Monoid HTML where mempty = HTML ""- mappend (HTML xs) (HTML ys) = HTML (xs ++ ys)+ mappend = (Semigroup.<>) +instance Semigroup.Semigroup HTML where+ HTML xs <> HTML ys = HTML (xs ++ ys)+ instance RenderSpecial HTML where renderSpecial LambdaSymbol = HTML "λ" renderSpecial TypeOfSymbol = HTML "∷"@@ -544,7 +536,10 @@ instance Monoid DebugPretty where mempty = DebugPretty ""- mappend (DebugPretty xs) (DebugPretty ys) = DebugPretty $ xs ++ ys+ mappend = (Semigroup.<>)++instance Semigroup.Semigroup DebugPretty where+ DebugPretty xs <> DebugPretty ys = DebugPretty $ xs ++ ys instance RenderCode DebugPretty where rStart = DebugPretty "(START)\n"
src/HERMIT/PrettyPrinter/GHC.hs view
@@ -11,7 +11,6 @@ , ppCoreAlt , ppKindOrType , ppCoercion- , ppForallQuantification ) where @@ -35,9 +34,9 @@ externals = [ external "ghc" pretty ["GHC pretty printer."] ] pretty :: PrettyPrinter-pretty = PP { pForall = ppForallQuantification- , pCoreTC = ppCoreTC+pretty = PP { pLCoreTC = promoteT ppCoreTC -- TODO , pOptions = def+ , pTag = "ghc" } -- | This pretty printer is just a reflection of GHC's standard pretty printer.@@ -83,12 +82,13 @@ ppCoercion :: PrettyH Coercion ppCoercion = ppSDoc --- A bit hacky, currently only used to pretty-print Lemmas.+{- TODO: lemma pp for GHC-style ppForallQuantification :: PrettyH [Var] ppForallQuantification = do vs <- mapT ppSDoc if null vs then return empty else return $ text "forall" <+> hsep vs <> text "."+-} ---------------------------------------------------------------------------
+ src/HERMIT/PrettyPrinter/Glyphs.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+module HERMIT.PrettyPrinter.Glyphs where++import Data.Semigroup (Semigroup(..))+import Data.Typeable++import HERMIT.Kure+import HERMIT.External+import HERMIT.PrettyPrinter.Common++import GHC.Generics++import System.Console.ANSI++-- | Glyph+data Glyph = Glyph { gText :: String+ , gStyle :: Maybe SyntaxForColor+ } deriving Show++-- | Glyphs+newtype Glyphs = Glyphs [Glyph] deriving (Generic, Show)++withStyle :: Maybe SyntaxForColor -> String -> IO ()+withStyle Nothing str = putStr str+withStyle (Just sty) str = do+ setSGR $ styleSGR sty+ putStr str+ setSGR [Reset]++withNoStyle :: Maybe SyntaxForColor -> String -> IO ()+withNoStyle _ str = putStr str++styleSGR :: SyntaxForColor -> [SGR]+styleSGR KeywordColor = [simpleColor Blue]+styleSGR SyntaxColor = [simpleColor Red]+styleSGR IdColor = []+styleSGR CoercionColor = [simpleColor Yellow]+styleSGR TypeColor = [simpleColor Green]+styleSGR LitColor = [simpleColor Cyan]+styleSGR WarningColor = [SetColor Background Vivid Yellow+ ,SetColor Foreground Dull Black+ ]++simpleColor :: Color -> SGR+simpleColor = SetColor Foreground Vivid++instance RenderSpecial Glyphs where+ renderSpecial sym = Glyphs [ Glyph [ch] (Just style) ]+ where Unicode ch = renderSpecial sym+ style =+ case sym of+ TypeSymbol -> TypeColor+ TypeBindSymbol -> TypeColor+ _ -> SyntaxColor++instance Monoid Glyphs where+ mempty = Glyphs mempty+ mappend = (<>)++instance Semigroup Glyphs where+ Glyphs rs1 <> Glyphs rs2 =+ Glyphs . flattenGlyphs . mergeGlyphs $ rs1 ++ rs2++flattenGlyphs :: [Glyph] -> [Glyph]+flattenGlyphs = go Nothing+ where go :: Maybe SyntaxForColor -> [Glyph] -> [Glyph]+ go _ [] = []+ go s (Glyph str Nothing:r) = Glyph str s : go s r+ go _ (Glyph [] s@Just{}:r) = go s r+ go s (g:r) = g : go s r++mergeGlyphs :: [Glyph] -> [Glyph]+mergeGlyphs [] = []+mergeGlyphs [r] = [r]+mergeGlyphs (g:h:r) = case merge g h of+ Left g' -> mergeGlyphs (g':r)+ Right (g',h') -> g' : mergeGlyphs (h':r)+ where merge (Glyph s1 Nothing) (Glyph s2 Nothing) =+ Left $ Glyph (s1 ++ s2) Nothing+ merge (Glyph [] Just{}) g2@(Glyph [] Just{}) = Left g2+ merge g1 g2 = Right (g1,g2)++instance RenderCode Glyphs where+ rPutStr txt = Glyphs [ Glyph txt Nothing, Glyph [] (Just IdColor) ]+ rDoHighlight _ [] = mempty+ rDoHighlight _ (Color col:_) = Glyphs [Glyph [] (Just col)]+ rDoHighlight o (_:rest) = rDoHighlight o rest++-- External Instances+data TransformLCoreGlyphsBox = TransformLCoreGlyphsBox (TransformH LCore Glyphs) deriving Typeable++instance Extern (TransformH LCore Glyphs) where+ type Box (TransformH LCore Glyphs) = TransformLCoreGlyphsBox+ box = TransformLCoreGlyphsBox+ unbox (TransformLCoreGlyphsBox i) = i++data TransformLCoreTCGlyphsBox = TransformLCoreTCGlyphsBox (TransformH LCoreTC Glyphs) deriving Typeable++instance Extern (TransformH LCoreTC Glyphs) where+ type Box (TransformH LCoreTC Glyphs) = TransformLCoreTCGlyphsBox+ box = TransformLCoreTCGlyphsBox+ unbox (TransformLCoreTCGlyphsBox i) = i
src/HERMIT/Shell/Command.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -21,9 +20,14 @@ , cl_kernel_env , getFocusPath , evalScript+ , performTypedEffectH+ , TypedEffectH(..)++ -- ** Exported for hermit-shell+ , stubExprH ) where -import Control.Monad ((>=>), when)+import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import Control.Monad.State (get, gets, modify)@@ -41,6 +45,7 @@ import HERMIT.Plugin.Renderer import HERMIT.PrettyPrinter.Common+import HERMIT.PrettyPrinter.Glyphs import HERMIT.Shell.Completion import HERMIT.Shell.Externals@@ -55,8 +60,6 @@ import HERMIT.Win32.Console #endif -import Prelude.Compat- import System.IO -- import System.Console.ANSI@@ -147,7 +150,7 @@ mExpr <- lift popScriptLine case mExpr of Nothing -> do -- no script running- when firstInput $ lift $ showWindowAlways Nothing+ when firstInput $ lift $ printWindowAlways Nothing st <- lift get mLine <- if cl_nav st then liftIO getNavCmd@@ -172,7 +175,7 @@ catchFailHard m failure = catchM m $ \ msg -> ifM (gets cl_failhard) (do pp <- gets cl_pretty- performQuery (QueryPrettyH $ pCoreTC pp) (CmdName "display")+ performQuery (QueryPrettyH $ pLCoreTC pp) (CmdName "display") cl_putStrLn msg abort) (failure msg)@@ -190,28 +193,68 @@ interpShell = [ interpEM $ \ (CrumbBox cr) -> setPath (return (mempty @@ cr) :: TransformH LCoreTC LocalPathH) , interpEM $ \ (PathBox p) -> setPath (return p :: TransformH LCoreTC LocalPathH)- , interpEM $ \ (StringBox str) -> performQuery (message str)- , interpEM $ \ (effect :: KernelEffect) -> flip performKernelEffect effect- , interpM $ \ (effect :: ShellEffect) -> performShellEffect effect+ , interpEM $ \ (StringBox str) -> performQuery (message str) -- QueryH+ , interpEM $ \ (effect :: KernelEffect) -> flip performKernelEffect effect -- KernelEffectH+ , interpM $ \ (ShellEffectBox effect) -> performShellEffect effect >> return () -- ShellEffectH , interpM $ \ (effect :: ScriptEffect) -> performScriptEffect effect- , interpEM $ \ (query :: QueryFun) -> performQuery query+ , interpEM $ \ (QueryFunBox query) -> performQuery' query -- QueryH , interpEM $ \ (t :: UserProofTechnique) -> performProofShellCommand $ PCEnd $ UserProof t- , interpEM $ \ (cmd :: ProofShellCommand) -> performProofShellCommand cmd- , interpEM $ \ (TransformLCoreStringBox tt) -> performQuery (QueryString tt)- , interpEM $ \ (TransformLCoreTCStringBox tt) -> performQuery (QueryString tt)- , interpEM $ \ (TransformLCoreUnitBox tt) -> performQuery (QueryUnit tt)- , interpEM $ \ (TransformLCoreTCUnitBox tt) -> performQuery (QueryUnit tt)- , interpEM $ \ (TransformLCorePathBox tt) -> setPath tt- , interpEM $ \ (TransformLCoreTCPathBox tt) -> setPath tt- , interpEM $ \ (TransformLCoreDocHBox t) -> performQuery (QueryDocH t)- , interpEM $ \ (TransformLCoreTCDocHBox t) -> performQuery (QueryDocH t)- , interpEM $ \ (RewriteLCoreBox rr) -> applyRewrite $ promoteLCoreR rr- , interpEM $ \ (RewriteLCoreTCBox rr) -> applyRewrite rr+ , interpEM $ \ (cmd :: ProofShellCommand) -> performProofShellCommand cmd -- ProofShellCommandHH+ , interpEM $ \ (TransformLCoreStringBox tt) -> performQuery' (QueryString tt) -- QueryH+ , interpEM $ \ (TransformLCoreTCStringBox tt) -> performQuery' (QueryString tt) -- QueryH+ , interpEM $ \ (TransformLCoreUnitBox tt) -> performQuery' (QueryUnit tt) -- QueryH+ , interpEM $ \ (TransformLCoreTCUnitBox tt) -> performQuery' (QueryUnit tt) -- QueryH+ , interpEM $ \ (TransformLCorePathBox tt) -> setPath tt -- SetPathH+ , interpEM $ \ (TransformLCoreTCPathBox tt) -> setPath tt -- SetPathH+ , interpEM $ \ (TransformLCoreGlyphsBox t) -> performQuery' (QueryGlyphs t) -- QueryH+ , interpEM $ \ (TransformLCoreTCGlyphsBox t) -> performQuery' (QueryGlyphs t) -- QueryH+ , interpEM $ \ (RewriteLCoreBox rr) -> applyRewrite $ promoteLCoreR rr -- RewriteLCoreH+ , interpEM $ \ (RewriteLCoreTCBox rr) -> applyRewrite rr -- RewriteLCoreTCH , interpEM $ \ (BiRewriteLCoreBox br) -> applyRewrite $ promoteLCoreR $ whicheverR br , interpEM $ \ (BiRewriteLCoreTCBox br) -> applyRewrite $ whicheverR br- , interpEM $ \ (PrettyHLCoreBox t) -> performQuery (QueryPrettyH t)- , interpEM $ \ (PrettyHLCoreTCBox t) -> performQuery (QueryPrettyH t)+ , interpEM $ \ (PrettyHLCoreBox t) -> performQuery' (QueryPrettyH t) -- QueryH+ , interpEM $ \ (PrettyHLCoreTCBox t) -> performQuery' (QueryPrettyH t) -- QueryH ]+ where performQuery' :: (MonadCatch m, CLMonad m) => QueryFun a -> ExprH -> m ()+ performQuery' x y = performQuery x y >> return () -- TODO: Replace with void once GHC 7.8 is dropped++-------------------------------------------------------------------------------++-- Wish: New Shell entry point+-- * (Wish) This shell returns LocalPathH instead of using setPath. This means *all* the (not Rewrite) Transformations+-- have no effect, and only have a return value.++data TypedEffectH :: * -> * where+ ShellEffectH :: ShellEffect a -> TypedEffectH a+ RewriteLCoreH :: RewriteH LCore -> TypedEffectH ()+ RewriteLCoreTCH :: RewriteH LCoreTC -> TypedEffectH ()+ SetPathH :: (Injection a LCoreTC)+ => TransformH a LocalPathH -> TypedEffectH ()+ QueryH :: QueryFun a -> TypedEffectH a+ ProofShellCommandH :: ProofShellCommand -> TypedEffectH ()+ KernelEffectH :: KernelEffect -> TypedEffectH ()+ EvalH :: String -> TypedEffectH () -- TODO: rm with the old shell+ FmapTypedEffectH :: (a -> b)+ -> TypedEffectH a -> TypedEffectH b++instance Functor TypedEffectH where+ fmap f e = FmapTypedEffectH f e++performTypedEffectH :: (MonadCatch m, CLMonad m)+ => String -> TypedEffectH a -> m a+performTypedEffectH _ (ShellEffectH effect) = performShellEffect effect+performTypedEffectH err (RewriteLCoreH rr ) = applyRewrite (promoteLCoreR rr) (stubExprH err)+performTypedEffectH err (RewriteLCoreTCH rr ) = applyRewrite rr (stubExprH err)+performTypedEffectH err (SetPathH tt ) = setPath tt (stubExprH err)+performTypedEffectH err (QueryH q ) = performQuery q (stubExprH err)+performTypedEffectH err (ProofShellCommandH ps ) = performProofShellCommand ps (stubExprH err)+performTypedEffectH err (KernelEffectH k ) = performKernelEffect (stubExprH err) k+performTypedEffectH _ (EvalH e ) = evalScript e+performTypedEffectH err (FmapTypedEffectH f e ) = performTypedEffectH err e >>= return . f++-- Hacky stub until we replace the ExprH for error messages+stubExprH :: String -> ExprH+stubExprH = SrcName -------------------------------------------------------------------------------
src/HERMIT/Shell/Completion.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-} module HERMIT.Shell.Completion (completer) where @@ -29,8 +28,6 @@ import HERMIT.Shell.Interpreter import HERMIT.Shell.Proof import HERMIT.Shell.Types--import Prelude.Compat import System.Console.Haskeline hiding (catch, display)
src/HERMIT/Shell/Externals.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} module HERMIT.Shell.Externals where@@ -32,8 +31,6 @@ import HERMIT.Shell.ShellEffect import HERMIT.Shell.Types -import Prelude.Compat- ---------------------------------------------------------------------------------- shell_externals :: [External]@@ -48,7 +45,7 @@ [ "garbage-collect a given AST" ] , external "gc" (CLSModify gc) [ "garbage-collect all ASTs except for the initial and current AST" ]- , external "display" (CLSModify $ showWindowAlways Nothing)+ , external "display" (CLSModify $ printWindowAlways Nothing) [ "redisplays current state" ] , external "up" (Direction U) [ "move to the parent node"]@@ -56,7 +53,7 @@ [ "switch to navigate mode" ] , external "command-line" (CLSModify $ modify $ \ st -> st { cl_nav = False }) [ "switch to command line mode" ]- , external "set-window" (CLSModify $ setWindow >> showWindow Nothing)+ , external "set-window" (CLSModify $ setWindow >> printWindow Nothing) [ "fix the window to the current focus" ] , external "top" (Direction T) [ "move to root of current scope" ]@@ -76,7 +73,7 @@ [ "show diff of two ASTs" ] .+ VersionControl , external "set-pp-diffonly" (\ bStr -> CLSModify $ case reads bStr of- [(b,"")] -> modify (\st -> st { cl_diffonly = b }) >> showWindow Nothing+ [(b,"")] -> modify (\st -> st { cl_diffonly = b }) >> printWindow Nothing _ -> fail "valid arguments are True and False" ) [ "set-pp-diffonly <True|False>; False by default" , "print diffs rather than full code after a rewrite" ]@@ -96,7 +93,7 @@ case M.lookup name pp_dictionary of Nothing -> fail $ "List of Pretty Printers: " ++ intercalate ", " (M.keys pp_dictionary) Just pp -> do modify $ \ st -> setPrettyOpts (setPretty st pp) (cl_pretty_opts st) -- careful to preserve the current options- showWindow Nothing)+ printWindow Nothing) [ "set the pretty printer" , "use 'set-pp ls' to list available pretty printers" ] , external "set-pp-renderer" (PluginComp . changeRenderer)@@ -116,24 +113,24 @@ , "dump-lemma <lemma-name> <filename> <pretty-printer> <renderer> <width>" ] , external "set-pp-width" (\ w -> CLSModify $ do modify $ \ st -> setPrettyOpts st (updateWidthOption w (cl_pretty_opts st))- showWindow Nothing)+ printWindow Nothing) ["set the width of the screen"] , external "set-pp-type" (\ str -> CLSModify $ case reads str :: [(ShowOption,String)] of [(opt,"")] -> do modify $ \ st -> setPrettyOpts st (updateTypeShowOption opt (cl_pretty_opts st))- showWindow Nothing+ printWindow Nothing _ -> fail "valid arguments are Show, Abstract, and Omit") ["set how to show expression-level types (Show|Abstact|Omit)"] , external "set-pp-coercion" (\ str -> CLSModify $ case reads str :: [(ShowOption,String)] of [(opt,"")] -> do modify $ \ st -> setPrettyOpts st (updateCoShowOption opt (cl_pretty_opts st))- showWindow Nothing+ printWindow Nothing _ -> fail "valid arguments are Show, Abstract, and Omit") ["set how to show coercions (Show|Abstact|Omit)"] , external "set-pp-uniques" (\ str -> CLSModify $ case reads str of [(b,"")] -> do modify $ \ st -> setPrettyOpts st ((cl_pretty_opts st) { po_showUniques = b })- showWindow Nothing+ printWindow Nothing _ -> fail "valid arguments are True and False") ["set whether uniques are printed with variable names"] , external "{" BeginScope@@ -193,7 +190,7 @@ let ps = fromMaybe ([],mempty) (M.lookup (cl_cursor st) (cl_foci st)) in st { cl_window = pathStack2Path ps } -showRenderers :: QueryFun+showRenderers :: QueryFun () showRenderers = message $ "set-renderer " ++ show (map fst shellRenderers) --------------------------------------------------------@@ -205,13 +202,13 @@ case whereTo of Goto ast -> if ast `elem` [ ast' | (ast',_,_) <- all_asts ]- then modify (setCursor ast) >> showWindow Nothing+ then modify (setCursor ast) >> printWindow Nothing else fail $ "Cannot find AST #" ++ show ast ++ "." GotoTag nm -> do tags <- gets cl_tags case [ ast | (ast,nms) <- M.toList tags, nm `elem` nms ] of [] -> fail $ "No tag named: " ++ nm- (ast:_) -> modify (setCursor ast) >> showWindow Nothing+ (ast:_) -> modify (setCursor ast) >> printWindow Nothing Tag nm -> do modify $ \st -> st { cl_tags = M.insertWith (++) (cl_cursor st) [nm] (cl_tags st) } cl_putStrLn $ "Tag: " ++ nm ++ " added."@@ -223,7 +220,7 @@ [(cmd,ast)] -> do cl_putStrLn $ "step : " ++ cmd modify $ setCursor ast- showWindow Nothing+ printWindow Nothing _ -> fail $ "Cannot step forward (multiple choices), use goto {" ++ intercalate "," (map (show.snd) ns) ++ "}" Back -> do@@ -234,7 +231,7 @@ [(cmd,ast)] -> do cl_putStrLn $ "back, unstepping : " ++ cmd modify $ setCursor ast- showWindow Nothing+ printWindow Nothing _ -> fail "Cannot step backwards (multiple choices, impossible!)." -------------------------------------------------------------------------------@@ -267,7 +264,7 @@ ------------------------------------------------------------------------------- -displayScripts :: QueryFun+displayScripts :: QueryFun () displayScripts = Inquiry (const (return . showScripts . cl_scripts)) showScripts :: [(ScriptName,Script)] -> String
src/HERMIT/Shell/Interpreter.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE ConstraintKinds, KindSignatures, GADTs, InstanceSigs,- FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} module HERMIT.Shell.Interpreter ( -- * The HERMIT Interpreter@@ -33,18 +37,18 @@ -- | An 'Interp' @cmd@ is a /possible/ means of converting a 'Typeable' value to a value of type @cmd@. data Interp :: (* -> *) -> * -> * where- Interp :: Typeable b => (b -> ExprH -> m a) -> Interp m a+ Interp :: Typeable b => (b -> ExprH -> m a) -> Interp m a -- | An 'Interp' with no effects. interp :: (Monad m, Typeable b) => (b -> a) -> Interp m a interp f = Interp (const . return . f) -- | An 'Interp' which can affect the shell.-interpM :: (CLMonad m, Typeable b) => (b -> m a) -> Interp m a+interpM :: Typeable b => (b -> m a) -> Interp m a interpM f = Interp (const . f) -- | Like 'InterpM', but with access to the original expression.-interpEM :: (CLMonad m, Typeable b) => (b -> ExprH -> m a) -> Interp m a+interpEM :: Typeable b => (b -> ExprH -> m a) -> Interp m a interpEM = Interp instance Monad m => Functor (Interp m) where
src/HERMIT/Shell/KernelEffect.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts, LambdaCase, TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} module HERMIT.Shell.KernelEffect ( KernelEffect(..)@@ -14,7 +17,6 @@ import qualified Data.Map as M import Data.Monoid-import Data.Typeable import HERMIT.Context import HERMIT.Dictionary@@ -34,7 +36,6 @@ | BeginScope -- Begin scope. | EndScope -- End scope. | Delete AST -- Delete an AST- deriving Typeable instance Extern KernelEffect where type Box KernelEffect = KernelEffect@@ -72,13 +73,13 @@ putStrToConsole warns addAST ast'- showWindow Nothing+ printWindow Nothing setPath :: (Injection a LCoreTC, MonadCatch m, CLMonad m) => TransformH a LocalPathH -> ExprH -> m () setPath t expr = do p <- prefixFailMsg "Cannot find path: " $ queryInContext (promoteT t) Never modifyLocalPath (<> p) expr- showWindow Nothing+ printWindow Nothing goUp :: (MonadCatch m, CLMonad m) => Direction -> ExprH -> m () goUp T expr = modifyLocalPath (const mempty) expr@@ -90,7 +91,7 @@ case rel of SnocPath [] -> fail "cannot move up, at root of scope." SnocPath (_:cs) -> modifyLocalPath (const $ SnocPath cs) expr- showWindow Nothing+ printWindow Nothing beginScope :: (MonadCatch m, CLMonad m) => ExprH -> m () beginScope expr = do@@ -108,7 +109,7 @@ addAST =<< logExpr let todos' = Unproven nm l c (p : base, mempty) : todos modify $ \ st -> st { cl_proofstack = M.insert (cl_cursor st) todos' (cl_proofstack st) }- showWindow Nothing+ printWindow Nothing endScope :: (MonadCatch m, CLMonad m) => ExprH -> m () endScope expr = do@@ -132,7 +133,7 @@ addAST =<< logExpr let todos' = Unproven nm l c (base', p) : todos modify $ \ st -> st { cl_proofstack = M.insert (cl_cursor st) todos' (cl_proofstack st) }- showWindow Nothing+ printWindow Nothing deleteAST :: (MonadCatch m, CLMonad m) => AST -> m () deleteAST ast = asks pr_kernel >>= flip deleteK ast
src/HERMIT/Shell/Proof.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -19,18 +17,20 @@ , performProofShellCommand , forceProofs , ProofShellCommand(PCEnd)- , ProofReason(UserProof)+ , ProofReason(UserProof, UserAssume, Reflexivity)++ -- ** Exposed for hermit-shell:+ , interactiveProof ) where import Control.Arrow hiding (loop, (<+>)) import Control.Concurrent.STM-import Control.Monad (forM_,unless)+import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class import Control.Monad.Reader (asks) import Control.Monad.State (MonadState(get), modify, gets) -import Data.Dynamic import Data.Function (on) import Data.List (nubBy) @@ -49,14 +49,12 @@ import HERMIT.Shell.ShellEffect import HERMIT.Shell.Types -import Prelude.Compat- -------------------------------------------------------------------------------------------------------- -- | Externals that get us into the prover shell. externals :: [External] externals = map (.+ Proof)- [ external "prove-lemma" (\nm -> CLSModify $ interactiveProof nm >> showWindow Nothing)+ [ external "prove-lemma" (\nm -> CLSModify $ interactiveProof nm >> printWindow Nothing) [ "Proof a lemma interactively." ] ] @@ -116,7 +114,7 @@ forM_ nls' $ \ ((_,c),nm,l) -> do cl_putStrLn $ "Forcing obligation: " ++ show nm pushProofStack (Unproven nm l c mempty)- showWindow Nothing+ printWindow Nothing -- | Verify that the lemma has been proven. Throws an exception if it has not. endProof :: (MonadCatch m, CLMonad m) => ProofReason -> ExprH -> m ()@@ -140,12 +138,11 @@ -- can generate additional lemmas, and add to the version history. performProofShellCommand :: (MonadCatch m, CLMonad m) => ProofShellCommand -> ExprH -> m ()-performProofShellCommand cmd expr = go cmd >> showWindow Nothing+performProofShellCommand cmd expr = go cmd >> printWindow Nothing where go (PCEnd why) = endProof why expr data ProofShellCommand = PCEnd ProofReason- deriving Typeable data ProofReason = UserProof UserProofTechnique -- ^ Run the technique, mark Proven if succeeds | UserAssume -- ^ Assume@@ -153,7 +150,6 @@ -- keep abstract to avoid breaking things if we modify this later newtype UserProofTechnique = UserProofTechnique (TransformH LCoreTC ())- deriving Typeable userProofTechnique :: TransformH LCoreTC () -> UserProofTechnique userProofTechnique = UserProofTechnique
src/HERMIT/Shell/ScriptToRewrite.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -29,7 +27,6 @@ import Control.Monad.State (MonadState, gets, modify) import Control.Exception hiding (catch) -import Data.Dynamic import qualified Data.Map as M import HERMIT.Context (LocalPathH, getAntecedents)@@ -48,8 +45,6 @@ import HERMIT.Shell.ShellEffect import HERMIT.Shell.Types -import Prelude.Compat hiding ((<$>))- import qualified Text.PrettyPrint.MarkedHughesPJ as PP ------------------------------------ @@ -63,7 +58,6 @@ | SaveScript FilePath ScriptName | ScriptToRewrite RewriteName ScriptName | SeqMeta [ScriptEffect]- deriving Typeable instance Extern ScriptEffect where type Box ScriptEffect = ScriptEffect@@ -103,9 +97,9 @@ else return $ PP.text "Assumed lemmas: " : ds ) :: TransformH LCoreTC [DocH]) Never d <- queryInFocus (liftPrettyH opts $- return q >>> extractT (pathT (pathStack2Path p) (ppLCoreTCT Clean.pretty)) :: TransformH Core DocH) Never+ return q >>> extractT (pathT (pathStack2Path p) (pLCoreTC Clean.pretty)) :: TransformH Core DocH) Never return $ PP.vcat $ as ++ [PP.text "Goal:", d]- _ -> queryInFocus (liftPrettyH opts $ pCoreTC Clean.pretty) Never+ _ -> queryInFocus (liftPrettyH opts $ pLCoreTC Clean.pretty) Never let ASCII str = renderCode opts doc str' = unlines $ ("" :) $ map ("-- " ++) $ lines str modify $ setCursor now@@ -207,7 +201,7 @@ (ScriptScope rs :) <$> parse zs (_, ScriptEndScope) -> fail "unmatched end-of-scope." - parseUntilEndScope :: Monad m => [(ExprH, UnscopedScriptR)] -> m ([ScopedScriptR], [(ExprH, UnscopedScriptR)])+ parseUntilEndScope :: [(ExprH, UnscopedScriptR)] -> m ([ScopedScriptR], [(ExprH, UnscopedScriptR)]) parseUntilEndScope [] = fail "missing end-of-scope." parseUntilEndScope (y:ys) = case y of (_, ScriptEndScope) -> return ([],ys)@@ -233,8 +227,8 @@ BeginScope -> ScriptBeginScope EndScope -> ScriptEndScope _ -> ScriptUnsupported "Kernel effect" )- , interp (\ (_ :: ShellEffect) -> ScriptUnsupported "shell effect")- , interp (\ (_ :: QueryFun) -> ScriptUnsupported "query")+ , interp (\ (ShellEffectBox _) -> ScriptUnsupported "shell effect")+ , interp (\ (QueryFunBox _) -> ScriptUnsupported "query") , interp (\ (TransformLCoreStringBox _) -> ScriptUnsupported "query") , interp (\ (TransformLCoreTCStringBox _) -> ScriptUnsupported "query") , interp (\ (TransformLCoreUnitBox _) -> ScriptUnsupported "predicate")
src/HERMIT/Shell/ShellEffect.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -11,6 +10,7 @@ module HERMIT.Shell.ShellEffect ( ShellEffect(..)+ , ShellEffectBox(..) , performShellEffect , dumpT , dump@@ -36,22 +36,31 @@ ---------------------------------------------------------------------------------- -data ShellEffect :: * where- Abort :: ShellEffect- CLSModify :: CLT IO () -> ShellEffect- PluginComp :: PluginM () -> ShellEffect- Continue :: ShellEffect- Resume :: ShellEffect- deriving Typeable+data ShellEffect :: * -> * where+ Abort :: ShellEffect ()+ CLSModify :: CLT IO a -> ShellEffect a+ PluginComp :: PluginM () -> ShellEffect ()+ Continue :: ShellEffect ()+ Resume :: ShellEffect ()+ FmapShellEffect :: (a -> b) -> ShellEffect a -> ShellEffect b -instance Extern ShellEffect where- type Box ShellEffect = ShellEffect- box i = i- unbox i = i+instance Functor ShellEffect where+ fmap = FmapShellEffect +data ShellEffectBox where+ ShellEffectBox :: Typeable a => ShellEffect a -> ShellEffectBox++instance Typeable a => Extern (ShellEffect a) where+ type Box (ShellEffect _a) = ShellEffectBox+ box = ShellEffectBox+ unbox (ShellEffectBox i) =+ case cast i of+ Just res -> res+ Nothing -> error "Extern -- unbox: casting of shell effect failed."+ ---------------------------------------------------------------------------------- -performShellEffect :: (MonadCatch m, CLMonad m) => ShellEffect -> m ()+performShellEffect :: (MonadCatch m, CLMonad m) => ShellEffect a -> m a performShellEffect Abort = abort performShellEffect Resume = announceUnprovens >> gets cl_cursor >>= resume performShellEffect Continue = announceUnprovens >> get >>= continue@@ -59,6 +68,7 @@ performShellEffect (CLSModify m) = clm2clt m performShellEffect (PluginComp m) = pluginM m+performShellEffect (FmapShellEffect f s) = fmap f (performShellEffect s) dumpT :: FilePath -> PrettyPrinter -> String -> Int -> TransformH DocH () dumpT fileName pp renderer width = do@@ -77,7 +87,7 @@ (er, _st'') <- runCLT env st' $ do pluginM (changeRenderer renderer) h <- liftIO $ openFile fileName WriteMode- showWindowAlways (Just h)+ printWindowAlways (Just h) liftIO $ hClose h either throwError return er
src/HERMIT/Shell/Types.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-}@@ -8,7 +6,6 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -17,79 +14,87 @@ module HERMIT.Shell.Types where -import Control.Arrow-import Control.Concurrent.STM-import Control.Monad (liftM, unless, when, forM_, forM, unless)-import Control.Monad.Error.Class (MonadError(..))-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)-import Control.Monad.State (MonadState(..), StateT(..), gets, modify)-import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad.Trans.Except (ExceptT(..), runExceptT)+import Control.Arrow+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Error.Class (MonadError(..))+import qualified Control.Monad.Fail as Fail (MonadFail(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)+import Control.Monad.State (MonadState(..), StateT(..), gets, modify)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Except (ExceptT(..), runExceptT) -import Data.Dynamic+import Data.Dynamic import qualified Data.Map as M-import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (fromMaybe, isJust) -import HERMIT.Context-import HERMIT.Core-import HERMIT.Dictionary.Reasoning hiding (externals)-import HERMIT.External+import HERMIT.Context+import HERMIT.Core+import HERMIT.Dictionary.Reasoning hiding (externals)+import HERMIT.External import qualified HERMIT.GHC as GHC-import HERMIT.Kernel-import HERMIT.Kure-import HERMIT.Lemma-import HERMIT.Monad-import HERMIT.Parser-import HERMIT.PrettyPrinter.Common--import HERMIT.Plugin.Display-import HERMIT.Plugin.Renderer-import HERMIT.Plugin.Types--import Prelude.Compat hiding ((<$>))+import HERMIT.Kernel+import HERMIT.Kure+import HERMIT.Lemma+import HERMIT.Monad+import HERMIT.Parser+import HERMIT.PrettyPrinter.Common+import HERMIT.PrettyPrinter.Glyphs -import System.Console.Haskeline hiding (catch, display)-import System.IO (Handle, stdout)+import HERMIT.Plugin.Display+import HERMIT.Plugin.Renderer+import HERMIT.Plugin.Types -#ifdef mingw32_HOST_OS-import HERMIT.Win32.Console-#else-import System.Console.Terminfo (setupTermFromEnv, getCapability, termColumns, termLines)-#endif+import System.Console.Haskeline hiding (catch, display)+import System.Console.Terminal.Size (Window(..), size)+import System.IO (Handle, stdout) import qualified Text.PrettyPrint.MarkedHughesPJ as PP ---------------------------------------------------------------------------------- -data QueryFun :: * where- QueryString :: Injection a LCoreTC => TransformH a String -> QueryFun- QueryDocH :: Injection a LCoreTC => TransformH a DocH -> QueryFun- QueryPrettyH :: Injection a LCoreTC => PrettyH a -> QueryFun- Diff :: AST -> AST -> QueryFun- Inquiry :: (PluginReader -> CommandLineState -> IO String) -> QueryFun- QueryUnit :: Injection a LCoreTC => TransformH a () -> QueryFun- deriving Typeable+data QueryFun :: * -> * where+ QueryString :: Injection a LCoreTC => TransformH a String -> QueryFun String+ QueryGlyphs :: Injection a LCoreTC => TransformH a Glyphs -> QueryFun Glyphs+ QueryPrettyH :: Injection a LCoreTC => PrettyH a -> QueryFun ()+ Diff :: AST -> AST -> QueryFun ()+ Inquiry :: (PluginReader -> CommandLineState -> IO String) -> QueryFun ()+ QueryUnit :: Injection a LCoreTC => TransformH a () -> QueryFun ()+ QueryA :: (Typeable a, Injection c LCoreTC)+ => TransformH c a -> QueryFun a -message :: String -> QueryFun+message :: String -> QueryFun () message = Inquiry . const . const . return -instance Extern QueryFun where- type Box QueryFun = QueryFun- box i = i- unbox i = i+data QueryFunBox where+ QueryFunBox :: Typeable a => QueryFun a -> QueryFunBox -performQuery :: (MonadCatch m, CLMonad m) => QueryFun -> ExprH -> m ()+instance Typeable a => Extern (QueryFun a) where+ type Box (QueryFun _a) = QueryFunBox+ box = QueryFunBox+ unbox (QueryFunBox i) =+ case cast i of+ Just res -> res+ Nothing -> error "Extern -- unbox: casting of query function failed."++performQuery :: (MonadCatch m, CLMonad m) => QueryFun a -> ExprH -> m a performQuery qf expr = go qf where cm = Changed $ unparseExprH expr go (QueryString q) =- putStrToConsole =<< prefixFailMsg "Query failed: " (queryInContext (promoteT q) cm)+ do str <- prefixFailMsg "Query failed: " (queryInContext (promoteT q) cm)+ putStrToConsole str+ return str - go (QueryDocH q) = do- doc <- prefixFailMsg "Query failed: " $ queryInContext (promoteT q) cm- st <- get- liftIO $ cl_render st stdout (cl_pretty_opts st) (Right doc) + go (QueryGlyphs q) = do+ res@(Glyphs gs) <- prefixFailMsg "Query failed: " $ queryInContext (promoteT q) cm+ sequence_ [ liftIO $ withStyle sty txt+ | Glyph txt sty <- gs+ ]+ liftIO $ putStr "\n"+ return res+ go (QueryPrettyH q) = do st <- get doc <- prefixFailMsg "Query failed: " $ queryInContext (liftPrettyH (pOptions (cl_pretty st)) $ promoteT q) cm@@ -127,12 +132,19 @@ modFailMsg (\ err -> str ++ " [exception: " ++ err ++ "]") $ queryInContext (promoteT q) cm putStrToConsole $ str ++ " [correct]" + go (QueryA q) = do+ let str = unparseExprH expr+ res <- modFailMsg (\ err -> str ++ " [exception: " ++ err ++ "]") $+ queryInContext (promoteT q) cm+ putStrToConsole $ str ++ " [correct]"+ return res+ ppWholeProgram :: (CLMonad m, MonadCatch m) => AST -> m DocH ppWholeProgram ast = do st <- get k <- asks pr_kernel d <- queryK k- (extractT $ pathT [ModGuts_Prog] $ liftPrettyH (cl_pretty_opts st) $ pCoreTC $ cl_pretty st)+ (extractT $ pathT [ModGuts_Prog] $ liftPrettyH (cl_pretty_opts st) $ pLCoreTC $ cl_pretty st) Never (cl_kernel_env st) ast return $ snd d -- discard new AST, assuming pp won't create one@@ -185,7 +197,8 @@ -- -- NB: an alternative to monad transformers, like Oleg's Extensible Effects, might be useful here. newtype CLT m a = CLT { unCLT :: ExceptT CLException (ReaderT PluginReader (StateT CommandLineState m)) a }- deriving (Functor, Applicative, MonadIO, MonadError CLException, MonadState CommandLineState, MonadReader PluginReader)+ deriving (Functor, Applicative, MonadIO, MonadError CLException,+ MonadState CommandLineState, MonadReader PluginReader) -- Adapted from System.Console.Haskeline.MonadException, which hasn't provided an instance for ExceptT yet instance MonadException m => MonadException (ExceptT e m) where@@ -217,6 +230,9 @@ instance Monad m => Monad (CLT m) where return = CLT . return (CLT m) >>= k = CLT (m >>= unCLT . k)+ fail = Fail.fail++instance Monad m => Fail.MonadFail (CLT m) where fail = CLT . throwError . CLError -- | Run a CLT computation.@@ -284,7 +300,7 @@ , cl_templemmas :: TVar [(HermitC,LemmaName,Lemma)] -- ^ updated by kernel env with temporary obligations , cl_failhard :: Bool -- ^ Any exception will cause an abort. , cl_diffonly :: Bool -- ^ Print diffs instead of full focus.- } deriving (Typeable)+ } type PathStack = ([LocalPathH], LocalPathH) @@ -296,7 +312,7 @@ } data Safety = StrictSafety | NormalSafety | NoSafety- deriving (Read, Show, Eq, Typeable)+ deriving (Read, Show, Eq) filterSafety :: Safety -> [External] -> [External] filterSafety NoSafety = id@@ -368,19 +384,14 @@ } return $ setPrettyOpts st $ (cl_pretty_opts st) { po_width = w } +-- | Returns the (width, height) of the terminal HERMIT is running in.+-- If it can't figure it out, it uses a default of (80, 25). getTermDimensions :: IO (Int, Int) getTermDimensions = do-#ifdef mingw32_HOST_OS- consoleSz <- getConsoleWindowSize- return $ fromMaybe (80,25) consoleSz-#else- term <- setupTermFromEnv- let w = fromMaybe 80 $ getCapability term termColumns- h = fromMaybe 25 $ getCapability term termLines- return (w,h)-#endif+ Window h w <- fromMaybe (Window 25 80) <$> size+ return (w, h) -newtype CLSBox = CLSBox CommandLineState deriving Typeable+newtype CLSBox = CLSBox CommandLineState instance Extern CommandLineState where type Box CommandLineState = CLSBox unbox (CLSBox st) = st@@ -422,7 +433,7 @@ -- | A primitive means of denoting navigation of a tree (within a local scope). data Direction = U -- ^ Up | T -- ^ Top- deriving (Eq,Show)+ deriving (Eq, Show) pathStackToLens :: (Injection a g, Walker HermitC g) => [LocalPathH] -> LocalPathH -> LensH a g pathStackToLens ps p = injectL >>> pathL (pathStack2Path (ps,p))@@ -554,13 +565,23 @@ $ put $ st { cl_window = focusPath } -} modify $ \ st -> st { cl_window = focusPath } -- TODO: temporary until we figure out a better highlight interface --- showWindow only calls display if a script is not running-showWindow :: (MonadCatch m, CLMonad m) => Maybe Handle -> m ()-showWindow = ifM isRunningScript (return ()) . showWindowAlways+{-+getWindow :: (MonadCatch m, CLMonad m) => m DocH+getWindow = do+ render <- gets (ps_render . cl_pstate)+ printWindowAlways Nothing+ -- restore the state+ modify (\ s -> s { cl_pstate = (cl_pstate s) { ps_render = render }})+ return undefined+-} --- always prints the current view-showWindowAlways :: (MonadCatch m, CLMonad m) => Maybe Handle -> m ()-showWindowAlways mbh = do+-- printWindow only calls display if a script is not running+printWindow :: (MonadCatch m, CLMonad m) => Maybe Handle -> m ()+printWindow = ifM isRunningScript (return ()) . printWindowAlways++-- always prints the current view. This a wrapper around 'display'.+printWindowAlways :: (MonadCatch m, CLMonad m) => Maybe Handle -> m ()+printWindowAlways mbh = do (ps,(ast,(pp,render))) <- gets (cl_proofstack &&& cl_cursor &&& cl_pretty &&& (ps_render . cl_pstate)) let h = fromMaybe stdout mbh pStr = render h (pOptions pp) . Left@@ -577,15 +598,30 @@ ast' = head $ [ cur | (cur, _, Just p) <- all_asts, p == ast ] ++ [ast] ppOpts = cl_pretty_opts st - q <- addFocusT $ liftPrettyH ppOpts $ pCoreTC pp+ q <- addFocusT $ liftPrettyH ppOpts $ pLCoreTC pp (_,doc1) <- queryK k q Never kEnv ast (_,doc2) <- queryK k q Never kEnv ast' diffDocH pp doc1 doc2 >>= liftIO . pStr -- TODO- else fixWindow >> gets cl_window >>= pluginM . display mbh . Just --TODO+ else fixWindow >> gets cl_window >>= pluginM . printDisplay mbh . Just --TODO +-- always prints the current view. This a wrapper around 'display'.+showWindow :: (MonadCatch m, CLMonad m) => m DocH+showWindow = do+ (ps,(ast,_)) <- gets (cl_proofstack &&& cl_cursor &&& cl_pretty &&& (ps_render . cl_pstate))+ case M.lookup ast ps of+ Just (Unproven _ l c p : _) -> showLemma c p ("Goal:",l)+ _ -> fixWindow >> gets cl_window >>= pluginM . showDisplay . Just --TODO+ printLemma :: (MonadCatch m, CLMonad m) => Handle -> HermitC -> PathStack -> (LemmaName,Lemma) -> m ()-printLemma h c p (nm,Lemma q _ _) = do -- TODO+printLemma h c p (nm,lm) = do -- TODO+ doc' <- showLemma c p (nm,lm)+ st <- get+ liftIO $ cl_render st h (cl_pretty_opts st) (Right doc')++showLemma :: (MonadCatch m, CLMonad m)+ => HermitC -> PathStack -> (LemmaName,Lemma) -> m DocH+showLemma c p (nm,Lemma q _ _) = do -- TODO (pp,opts) <- gets (cl_pretty &&& cl_pretty_opts) as <- queryInContext ((liftPrettyH opts $ do m <- getAntecedents <$> contextT@@ -594,10 +630,8 @@ then return [] else return $ PP.text "Assumed lemmas: " : ds ) :: TransformH LCoreTC [DocH]) Never- doc <- queryInFocus ((constT $ applyT (extractT (liftPrettyH (pOptions pp) (pathT (pathStack2Path p) (ppLCoreTCT pp)))) c q) :: TransformH Core DocH) Never- let doc' = PP.vcat $ as ++ [PP.text (show nm) PP.$+$ PP.nest 2 doc]- st <- get- liftIO $ cl_render st h (cl_pretty_opts st) (Right doc')+ doc <- queryInFocus ((constT $ applyT (extractT (liftPrettyH (pOptions pp) (pathT (pathStack2Path p) (pLCoreTC pp)))) c q) :: TransformH Core DocH) Never+ return $ PP.vcat $ as ++ [PP.text (show nm) PP.$+$ PP.nest 2 doc] ------------------------------------------------------------------------------
+ src/HERMIT/Win32/Console.hs view
@@ -0,0 +1,12 @@+module HERMIT.Win32.Console (isCygwinConsole) where++import Control.Exception (try)+import System.Environment++-- TODO: Figure out a more intelligent way to do this+isCygwinConsole :: IO Bool+isCygwinConsole = do+ result <- try $ getEnv "_" -- Cygwin defines this, Windows Cmd does not+ return $ case (result :: Either IOError String) of+ Left _ -> False+ Right _ -> True
− src/HERMIT/Win32/Console.hsc
@@ -1,105 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--- | Taken from <https://github.com/batterseapower/ansi-terminal/blob/master/System/Console/ANSI/Windows/Foreign.hs> in the ansi-terminal package by batterseapower, licensed under BSD3-module HERMIT.Win32.Console- (- getConsoleWindowSize- , isCygwinConsole- ) where--import Control.Applicative-import Control.Exception (try)--import Foreign.C.Types-import Foreign.Marshal-import Foreign.Ptr-import Foreign.Storable--import System.Environment-import System.Win32.Types--#include <windows.h>-#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)--type SHORT = CShort--isCygwinConsole :: IO Bool-isCygwinConsole = do- result <- try $ getEnv "_" -- Cygwin defines this, Windows Cmd does not- return $ case (result :: Either IOError String) of- Left _ -> False- Right _ -> True--getConsoleWindowSize :: IO (Maybe (Int, Int))-getConsoleWindowSize = do- hStdout <- getStdHandle sTD_OUTPUT_HANDLE- csbiInfo <- getConsoleScreenBufferInfo hStdout- return $ fmap coords csbiInfo- where coords :: CONSOLE_SCREEN_BUFFER_INFO -> (Int, Int)- coords info = case csbi_maximum_window_size info of- (COORD x y) -> (fromIntegral x, fromIntegral y)--sTD_OUTPUT_HANDLE :: DWORD-sTD_OUTPUT_HANDLE = #{const STD_OUTPUT_HANDLE}--foreign import ccall unsafe "windows.h GetStdHandle"- getStdHandle :: DWORD -> IO HANDLE-foreign import ccall unsafe "windows.h GetConsoleScreenBufferInfo"- cGetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL--getConsoleScreenBufferInfo :: HANDLE -> IO (Maybe CONSOLE_SCREEN_BUFFER_INFO)-getConsoleScreenBufferInfo handle = alloca $ \ptr_console_screen_buffer_info -> do- ret <- cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info- if ret then peek ptr_console_screen_buffer_info >>= return . Just- else return Nothing--data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO {- _csbi_size :: COORD,- _csbi_cursor_position :: COORD,- _csbi_attributes :: WORD,- _csbi_window :: SMALL_RECT,- csbi_maximum_window_size :: COORD- }--instance Storable CONSOLE_SCREEN_BUFFER_INFO where- sizeOf _ = #{size CONSOLE_SCREEN_BUFFER_INFO}- alignment _ = #{alignment CONSOLE_SCREEN_BUFFER_INFO}- peek ptr = CONSOLE_SCREEN_BUFFER_INFO <$>- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr <*>- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr <*>- #{peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr <*>- #{peek CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr <*>- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr- poke ptr (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) = do- #{poke CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr size- #{poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr cursor_position- #{poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr attributes- #{poke CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr window- #{poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr maximum_window_size--data COORD = COORD SHORT SHORT--instance Storable COORD where- sizeOf _ = #{size COORD}- alignment _ = #{alignment COORD}- peek ptr =- COORD <$> #{peek COORD, X} ptr- <*> #{peek COORD, Y} ptr- poke ptr (COORD x y) = do- #{poke COORD, X} ptr x- #{poke COORD, Y} ptr y--data SMALL_RECT = SMALL_RECT SHORT SHORT SHORT SHORT--instance Storable SMALL_RECT where- sizeOf _ = #{size SMALL_RECT}- alignment _ = #{alignment SMALL_RECT}- peek ptr =- SMALL_RECT <$> #{peek SMALL_RECT, Left} ptr- <*> #{peek SMALL_RECT, Top} ptr- <*> #{peek SMALL_RECT, Right} ptr- <*> #{peek SMALL_RECT, Bottom} ptr- poke ptr (SMALL_RECT l t r b) = do- #{poke SMALL_RECT, Left} ptr l- #{poke SMALL_RECT, Top} ptr t- #{poke SMALL_RECT, Right} ptr r- #{poke SMALL_RECT, Bottom} ptr b
+ tests/Main.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+module Main (main) where++import Constants (hiVersion)+import Control.Monad++import Data.Char (isSpace)+import Data.List+import Data.Maybe (listToMaybe)++import GHC.Paths (ghc)++import HERMIT.Driver++import System.Directory+import System.FilePath as F+#if defined(darwin_HOST_OS)+import System.Info (arch)+#else+import System.Info (arch, os)+#endif+import System.IO+import System.IO.Temp (withSystemTempFile)+import System.Process++import Test.Tasty (TestTree, TestName, defaultMain, testGroup)+import Test.Tasty.Golden (goldenVsFileDiff)++type HermitTestArgs = (FilePath, FilePath, FilePath, [String])++main :: IO ()+main = defaultMain hermitTests++hermitTests :: TestTree+hermitTests = testGroup "HERMIT tests" $ map mkHermitTest testArgs++-- subdirectory names+golden, dump, rootDir, examples :: FilePath+golden = "golden" </> "golden-ghc-" ++ show hiVersion+dump = "dump"+rootDir = "tests"+examples = "examples"++testArgs :: [HermitTestArgs]+testArgs = [ ("concatVanishes", "Flatten.hs", "Flatten.hss", ["-safety=unsafe"])+ , ("concatVanishes", "QSort.hs" , "QSort.hss" , ["-safety=unsafe"])+ , ("concatVanishes", "Rev.hs" , "Rev.hss" , ["-safety=unsafe"])+ , ("evaluation" , "Eval.hs" , "Eval.hss" , [])+#if __GLASGOW_HASKELL__ < 710+ -- broken on GHC 7.10 due to not satisfying the let/app invariant. I should probably fix this.+ , ("factorial" , "Fac.hs" , "Fac.hss" , [])+#endif+ -- broken due to Core Parser: , ("fib-stream" , "Fib.hs" , "Fib.hss" )+ , ("fib-tuple" , "Fib.hs" , "Fib.hss" , [])+ , ("flatten" , "Flatten.hs", "Flatten.hec", ["-safety=unsafe"])+ -- for some reason loops in testsuite but not normally: , ("hanoi" , "Hanoi.hs" , "Hanoi.hss" )+ , ("last" , "Last.hs" , "Last.hss" , ["-safety=unsafe"])+ , ("last" , "Last.hs" , "NewLast.hss", ["-safety=strict"])+ -- broken due to Core Parser: , ("map" , "Map.hs" , "Map.hss" )+ , ("mean" , "Mean.hs" , "Mean.hss" , [])+ -- TODO: re-enable once fixed , ("nub" , "Nub.hs" , "Nub.hss" , [])+ , ("qsort" , "QSort.hs" , "QSort.hss" , [])+ , ("reverse" , "Reverse.hs", "Reverse.hss", ["-safety=unsafe"])+ , ("new_reverse" , "Reverse.hs", "Reverse.hec", [])+ ]++fixName :: FilePath -> FilePath+fixName = map (\c -> if c == '.' then '_' else c)++mkTestScript :: Handle -> FilePath -> IO ()+mkTestScript h hss = do+ hPutStrLn h+ $ unlines [ "set-auto-corelint True"+ , "set-pp-type Show"+ , "set-fail-hard True"+ , "load-and-run \"" ++ hss ++ "\""+ , "top ; prog"+ , "display" -- all the bindings+ , "show-lemmas"+ , "resume" ]+ hClose h++-- | Get the path to the sandbox database if any+-- Taken from hoogle-index (by Ben Gamari, under BSD3)+getSandboxDb :: IO (Maybe FilePath)+getSandboxDb = do+ dir <- getCurrentDirectory+ let f = dir </> "cabal.sandbox.config"+ ex <- doesFileExist f+ if ex+ then+ (listToMaybe .+ map ((</> archOSCompilerConf) .+ dropFileName .+ dropWhile isSpace .+ tail .+ dropWhile (/= ':')) .+ filter (isPrefixOf "package-db") .+ lines) <$> readFile f+ else return Nothing+ where+ archOSCompilerConf :: String+ archOSCompilerConf = intercalate "-" [arch, theOS, takeFileName ghc, "packages.conf.d"]++ theOS :: String+#if defined(darwin_HOST_OS)+ theOS = "osx" -- System.Info.os gives "darwin", which isn't what is actually+ -- used, for some silly reason+#else+ theOS = os+#endif++mkHermitTest :: HermitTestArgs -> TestTree+mkHermitTest (dir, hs, hss, extraFlags) =+ goldenVsFileDiff testName diff gfile dfile hermitOutput+ where+ testName :: TestName+ testName = dir </> hs++ fixed, gfile, dfile, pathp :: FilePath+ fixed = fixName (concat [dir, "_", hs, "_", hss])+ gfile = rootDir </> golden </> fixed <.> "ref"+ dfile = rootDir </> dump </> fixed <.> "dump"+ pathp = examples </> dir++ diff :: FilePath -> FilePath -> [String]+ diff ref new = ["diff", "-b", "-U 5", ref, new]++ -- For some incredibly bizarre reason, HERMIT's output can be have different+ -- line orderings depending on if it's been run once before. As far as I can+ -- tell, this is due to the presence of object (.o) and interface (.hi) files.+ -- Wat.+ --+ -- Luckily, removing any object or interface before running HERMIT seems to+ -- provide a guarantee that HERMIT's output will be the same on subsequent runs.+ cleanObjectFiles :: IO ()+ cleanObjectFiles = do+ files <- getDirectoryContents pathp+ forM_ files $ \file ->+ when (takeExtension file `elem` [".o", ".hi"]) $+ removeFile $ pathp </> file++ hermitOutput :: IO ()+ hermitOutput = do+ cleanObjectFiles+ mbDb <- getSandboxDb+ createDirectoryIfMissing True (dropFileName gfile)++ let dbFlags :: String+ dbFlags | Just db <- mbDb+ = unwords ["-no-user-package-db", "-package-db", db]+ | otherwise = ""++ withSystemTempFile "Test.hss" $ \ fp h -> do+ mkTestScript h hss++ let cmd :: String+ cmd = unwords $ [ "("+ , "cd"+ , pathp+ , ";"+ , ghc+ , dbFlags+ , hs+ , "-w" -- Disable all warnings+ ]+ ++ ghcFlags+ ++ [ "-fplugin=HERMIT"+ , "-fplugin-opt=HERMIT:Main:" ++ fp -- made by mkTestScript+ , "-v0"+ ]+ ++ [ "-fplugin-opt=HERMIT:Main:" ++ f | f <- extraFlags]+ ++ [ ")" ]++ -- Adding a &> dfile redirect in cmd causes the call to GHC to not block+ -- until the compiler is finished (on Linux, not OSX). So we do the Haskell+ -- equivalent here by opening our own file.+ fh <- openFile dfile WriteMode+ -- putStrLn cmd+ (_,_,_,rHermit) <- createProcess $ (shell cmd) { std_out = UseHandle fh, std_err = UseHandle fh }+ _ <- waitForProcess rHermit++ -- Ensure that the golden file exists prior to calling diff+ goldenExists <- doesFileExist gfile+ unless goldenExists $ copyFile dfile gfile