hermit 0.7.1.0 → 1.0.0.0

raw patch · 65 files changed

+1774/−1775 lines, 65 filesdep +base-compatdep −operationaldep ~ghcPVP ok

version bump matches the API change (PVP)

Dependencies added: base-compat

Dependencies removed: operational

Dependency ranges changed: ghc

API changes (from Hackage documentation)

Files

• README.md +0/−0
• dist/build/HERMIT/Parser.hs +3/−1
• dist/build/HERMIT/ParserCore.hs +6/−5
• dist/build/HERMIT/ParserType.hs +3/−2
• examples/new_reverse/Reverse.hec +35/−258
• examples/new_reverse/Reverse.hs +1/−0
• examples/nub/Nub.hss +5/−2
• hermit.cabal +9/−9
• src/HERMIT/Context.hs +83/−43
• src/HERMIT/Core.hs +7/−1
• src/HERMIT/Dictionary.hs +4/−0
• src/HERMIT/Dictionary/AlphaConversion.hs +3/−1
• src/HERMIT/Dictionary/Common.hs +11/−7
• src/HERMIT/Dictionary/Composite.hs +20/−12
• src/HERMIT/Dictionary/Debug.hs +9/−6
• src/HERMIT/Dictionary/FixPoint.hs +10/−6
• src/HERMIT/Dictionary/Fold.hs +45/−56
• src/HERMIT/Dictionary/Function.hs +7/−4
• src/HERMIT/Dictionary/GHC.hs +48/−29
• src/HERMIT/Dictionary/Induction.hs +46/−29
• src/HERMIT/Dictionary/Inline.hs +5/−2
• src/HERMIT/Dictionary/Kure.hs +1/−1
• src/HERMIT/Dictionary/Local/Case.hs +14/−7
• src/HERMIT/Dictionary/Local/Cast.hs +1/−1
• src/HERMIT/Dictionary/Local/Let.hs +11/−5
• src/HERMIT/Dictionary/Navigation.hs +22/−22
• src/HERMIT/Dictionary/Query.hs +3/−2
• src/HERMIT/Dictionary/Reasoning.hs +348/−217
• src/HERMIT/Dictionary/Remembered.hs +6/−6
• src/HERMIT/Dictionary/Rules.hs +39/−31
• src/HERMIT/Dictionary/Undefined.hs +24/−22
• src/HERMIT/Dictionary/Unfold.hs +5/−1
• src/HERMIT/Dictionary/WorkerWrapper/Common.hs +43/−40
• src/HERMIT/Dictionary/WorkerWrapper/Fix.hs +7/−3
• src/HERMIT/Dictionary/WorkerWrapper/FixResult.hs +6/−5
• src/HERMIT/Driver.hs +9/−9
• src/HERMIT/External.hs +10/−1
• src/HERMIT/GHC.hs +40/−7
• src/HERMIT/GHC/Typechecker.hs +37/−5
• src/HERMIT/Kernel.hs +12/−14
• src/HERMIT/Kure.hs +58/−68
• src/HERMIT/Kure/Universes.hs +2/−38
• src/HERMIT/Lemma.hs +108/−100
• src/HERMIT/Libraries/Int.hs +9/−5
• src/HERMIT/Monad.hs +41/−69
• src/HERMIT/Name.hs +17/−10
• src/HERMIT/ParserCore.y +3/−4
• src/HERMIT/ParserType.y +0/−1
• src/HERMIT/Plugin.hs +104/−106
• src/HERMIT/Plugin/Builder.hs +23/−12
• src/HERMIT/Plugin/Display.hs +7/−3
• src/HERMIT/Plugin/Renderer.hs +6/−2
• src/HERMIT/Plugin/Types.hs +28/−19
• src/HERMIT/PrettyPrinter/AST.hs +0/−2
• src/HERMIT/PrettyPrinter/Clean.hs +7/−14
• src/HERMIT/PrettyPrinter/Common.hs +58/−7
• src/HERMIT/Shell/Command.hs +11/−7
• src/HERMIT/Shell/Completion.hs +11/−11
• src/HERMIT/Shell/Externals.hs +89/−71
• src/HERMIT/Shell/KernelEffect.hs +24/−18
• src/HERMIT/Shell/Proof.hs +50/−206
• src/HERMIT/Shell/ScriptToRewrite.hs +26/−17
• src/HERMIT/Shell/ShellEffect.hs +10/−12
• src/HERMIT/Shell/Types.hs +83/−100
• src/HERMIT/Win32/IO.hsc +1/−1

@@ -17,8 +17,10 @@ import HERMIT.Syntax (isScriptInfixIdChar, isScriptIdFirstChar, isScriptIdChar) import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts+import Control.Applicative(Applicative(..))+import Control.Monad (ap) --- parser produced by Happy Version 1.19.3+-- parser produced by Happy Version 1.19.5  newtype HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607

@@ -1,6 +1,5 @@ {-# OPTIONS_GHC -w #-} {-# OPTIONS -fglasgow-exts -cpp #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} module HERMIT.ParserCore     ( parseCore@@ -32,8 +31,10 @@ import Language.KURE.MonadCatch (prefixFailMsg) import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts+import Control.Applicative(Applicative(..))+import Control.Monad (ap) --- parser produced by Happy Version 1.19.3+-- parser produced by Happy Version 1.19.5  newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607@@ -356,16 +357,16 @@ -- These should probably go somewhere else.  -- | Parse a 'CoreString' to a 'CoreExpr', using the current context.-parseCoreExprT :: (ReadBindings c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m)+parseCoreExprT :: (ReadBindings c, HasHermitMEnv m, HasLemmas m, LiftCoreM m)                => CoreString -> Transform c m a CoreExpr parseCoreExprT cs = contextonlyT $ embedHermitM . parseCore cs -parse2BeforeT :: (ReadBindings c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m)+parse2BeforeT :: (ReadBindings c, HasHermitMEnv m, HasLemmas m, LiftCoreM m)               => (CoreExpr -> CoreExpr -> Translate c m a b)               -> CoreString -> CoreString -> Translate c m a b parse2BeforeT f s1 s2 = parseCoreExprT s1 &&& parseCoreExprT s2 >>= uncurry f -parse3BeforeT :: (ReadBindings c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m)+parse3BeforeT :: (ReadBindings c, HasHermitMEnv m, HasLemmas m, LiftCoreM m)               => (CoreExpr -> CoreExpr -> CoreExpr -> Translate c m a b)               -> CoreString -> CoreString -> CoreString -> Translate c m a b parse3BeforeT f s1 s2 s3 = (parseCoreExprT s1 &&& parseCoreExprT s2) &&& parseCoreExprT s3 >>= (uncurry . uncurry $ f)

@@ -1,6 +1,5 @@ {-# OPTIONS_GHC -w #-} {-# OPTIONS -fglasgow-exts -cpp #-}-{-# LANGUAGE CPP #-} module HERMIT.ParserType     ( parseType     , parseTypeT@@ -25,8 +24,10 @@ import Language.KURE.MonadCatch (prefixFailMsg) import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts+import Control.Applicative(Applicative(..))+import Control.Monad (ap) --- parser produced by Happy Version 1.19.3+-- parser produced by Happy Version 1.19.5  newtype HappyAbsSyn t4 t5 t6 t7 t8 = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607

@@ -28,80 +28,37 @@ -- Goal: -- forall *. myAppend * (undefined *) ([] *) = undefined * -lhs unfold---- Goal:--- forall *.--- case undefined * of wild *---   [] -> [] *---   (:) x xs -> (:) * x (myAppend * xs ([] *))--- =--- undefined *--lhs undefined-expr---- Goal:--- forall *. undefined * = undefined *--end-case -- proven "++ []-induction-case-undefined"---- Goal:--- forall *. myAppend * ([] *) ([] *) = [] *--lhs unfold---- Goal:--- forall *.--- case [] * of wild *---   [] -> [] *---   (:) x xs -> (:) * x (myAppend * xs ([] *))--- =--- [] *--lhs simplify---- Goal:--- forall *. [] * = [] *--end-case -- proven "++ []-induction-case-[]"---- Assumed lemmas:--- ind-hyp-0 (Assumed)---   myAppend * b ([] *) = b--- Goal:--- forall * a b. myAppend * ((:) * a b) ([] *) = (:) * a b--lhs unfold---- Assumed lemmas:--- ind-hyp-0 (Assumed)---   myAppend * b ([] *) = b--- Goal:--- forall * a b.--- case (:) * a b of wild *---   [] -> [] *---   (:) x xs -> (:) * x (myAppend * xs ([] *))--- =--- (:) * a b--lhs simplify---- Assumed lemmas:--- ind-hyp-0 (Assumed)---   myAppend * b ([] *) = b--- Goal:--- forall * a b. (:) * a (myAppend * b ([] *)) = (:) * a b--lhs (one-td (lemma-forward ind-hyp-0))+any-bu (unfold 'myAppend >>> undefined-expr)+any-bu (unfold 'myAppend >>> case-reduce)+simplify-lemma+forall-body ; consequent+one-td (lemma-forward ind-hyp-0)+end-case --- Assumed lemmas:--- ind-hyp-0 (Assumed)---   myAppend * b ([] *) = b--- Goal:--- forall * a b. (:) * a b = (:) * a b+rule-to-lemma "myAppend-assoc"+prove-lemma "myAppend-assoc"+induction 'xs+{ forall-body+    { conj-lhs+      any-bu ((unfold 'myAppend) >>> undefined-case)+      reflexivity+    }+    conj-rhs+    { conj-lhs+      any-bu ((unfold 'myAppend) >>> case-reduce)+      reflexivity+    }+    { conj-rhs+      forall-body ; consequent+      any-bu (unfold 'myAppend)+      smash+      rhs (one-td (fold 'myAppend))+      one-td (lemma-forward ind-hyp-0)+      reflexivity+    }+}+end-proof -end-case -- proven "++ []-induction-case-:"--- proven "++ []" rule-to-lemma "repH []"  -- module main:Main where@@ -216,192 +173,12 @@ -- Goal: -- forall * xs ys. \ x -> myAppend * (myAppend * xs ys) x = \ x -> myAppend * xs (myAppend * ys x) -induction 'xs---- Goal:--- forall * ys x. myAppend * (myAppend * (undefined *) ys) x = myAppend * (undefined *) (myAppend * ys x)--both (replicate 2 (any-call (unfold 'myAppend)))---- Goal:--- forall * ys x.--- case case undefined * of wild *---        [] -> ys---        (:) x xs -> (:) * x (myAppend * xs ys)---  of wild *---   [] -> x---   (:) x xs ->---     (:) * x---         (case xs of wild *---            [] -> x---            (:) x xs -> (:) * x (myAppend * xs x))--- =--- case undefined * of wild *---   [] ->---     case ys of wild *---       [] -> x---       (:) x xs ->---         (:) * x---             (case xs of wild *---                [] -> x---                (:) x xs -> (:) * x (myAppend * xs x))---   (:) x xs ->---     (:) * x---         (case xs of wild *---            [] ->---              case ys of wild *---                [] -> x---                (:) x xs ->---                  (:) * x---                      (case xs of wild *---                         [] -> x---                         (:) x xs -> (:) * x (myAppend * xs x))---            (:) x xs ->---              (:) * x---                  (myAppend * xs---                            (case ys of wild *---                               [] -> x---                               (:) x xs ->---                                 (:) * x---                                     (case xs of wild *---                                        [] -> x---                                        (:) x xs -> (:) * x (myAppend * xs x)))))--both (innermost undefined-expr)---- Goal:--- forall * ys x. undefined * = undefined *--end-case -- proven "repH ++-induction-case-undefined"---- Goal:--- forall * ys x. myAppend * (myAppend * ([] *) ys) x = myAppend * ([] *) (myAppend * ys x)--both (replicate 2 (any-call (unfold 'myAppend)))---- Goal:--- forall * ys x.--- case case [] * of wild *---        [] -> ys---        (:) x xs -> (:) * x (myAppend * xs ys)---  of wild *---   [] -> x---   (:) x xs ->---     (:) * x---         (case xs of wild *---            [] -> x---            (:) x xs -> (:) * x (myAppend * xs x))--- =--- case [] * of wild *---   [] ->---     case ys of wild *---       [] -> x---       (:) x xs ->---         (:) * x---             (case xs of wild *---                [] -> x---                (:) x xs -> (:) * x (myAppend * xs x))---   (:) x xs ->---     (:) * x---         (case xs of wild *---            [] ->---              case ys of wild *---                [] -> x---                (:) x xs ->---                  (:) * x---                      (case xs of wild *---                         [] -> x---                         (:) x xs -> (:) * x (myAppend * xs x))---            (:) x xs ->---              (:) * x---                  (myAppend * xs---                            (case ys of wild *---                               [] -> x---                               (:) x xs ->---                                 (:) * x---                                     (case xs of wild *---                                        [] -> x---                                        (:) x xs -> (:) * x (myAppend * xs x)))))--both smash---- Goal:--- forall * ys x.--- case ys of wild *---   [] -> x---   (:) x xs ->---     (:) * x---         (case xs of wild *---            [] -> x---            (:) x xs -> (:) * x (myAppend * xs x))--- =--- case ys of wild *---   [] -> x---   (:) x xs ->---     (:) * x---         (case xs of wild *---            [] -> x---            (:) x xs -> (:) * x (myAppend * xs x))--end-case -- proven "repH ++-induction-case-[]"---- Assumed lemmas:--- ind-hyp-0 (Assumed)---   \ x -> myAppend * (myAppend * b ys) x = \ x -> myAppend * b (myAppend * ys x)--- Goal:--- forall * ys a b x. myAppend * (myAppend * ((:) * a b) ys) x = myAppend * ((:) * a b) (myAppend * ys x)--both (one-td unfold)---- Assumed lemmas:--- ind-hyp-0 (Assumed)---   \ x -> myAppend * (myAppend * b ys) x = \ x -> myAppend * b (myAppend * ys x)--- Goal:--- forall * ys a b x.--- case myAppend * ((:) * a b) ys of wild *---   [] -> x---   (:) x xs -> (:) * x (myAppend * xs x)--- =--- case (:) * a b of wild *---   [] -> myAppend * ys x---   (:) x xs -> (:) * x (myAppend * xs (myAppend * ys x))--lhs (one-td unfold)---- Assumed lemmas:--- ind-hyp-0 (Assumed)---   \ x -> myAppend * (myAppend * b ys) x = \ x -> myAppend * b (myAppend * ys x)--- Goal:--- forall * ys a b x.--- case case (:) * a b of wild *---        [] -> ys---        (:) x xs -> (:) * x (myAppend * xs ys)---  of wild *---   [] -> x---   (:) x xs -> (:) * x (myAppend * xs x)--- =--- case (:) * a b of wild *---   [] -> myAppend * ys x---   (:) x xs -> (:) * x (myAppend * xs (myAppend * ys x))--both smash---- Assumed lemmas:--- ind-hyp-0 (Assumed)---   \ x -> myAppend * (myAppend * b ys) x = \ x -> myAppend * b (myAppend * ys x)--- Goal:--- forall * ys a b x. (:) * a (myAppend * (myAppend * b ys) x) = (:) * a (myAppend * b (myAppend * ys x))--rhs (one-td (lemma-backward ind-hyp-0))---- Assumed lemmas:--- ind-hyp-0 (Assumed)---   \ x -> myAppend * (myAppend * b ys) x = \ x -> myAppend * b (myAppend * ys x)--- Goal:--- forall * ys a b x. (:) * a (myAppend * (myAppend * b ys) x) = (:) * a (myAppend * (myAppend * b ys) x)--end-case -- proven "repH ++-induction-case-:"--- proven "repH ++"+extensionality 'zs+simplify+{ forall-body+  lemma "myAppend-assoc"+}+end-proof  -- module main:Main where --   absR :: forall a . ([a] -> H a) -> [a] -> [a]

@@ -20,3 +20,4 @@  -- 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) #-}

@@ -19,13 +19,16 @@ one-td (case-float-arg-lemma nubStrict)  -- prove strictness condition-lhs (unfold >>> undefined-expr)-end-proof+lhs unfold ; smash ; end-proof  one-td (unfold 'nub') simplify  one-td (case-float-arg-lemma nubStrict)++-- prove strictness condition+lhs unfold ; smash ; end-proof+ { consider case ; consider case ; case-alt 1 ; alt-rhs   unfold ; simplify   one-td (unfold-rule "filter-fusion") ; assume

@@ -1,5 +1,5 @@ Name:                hermit-Version:             0.7.1.0+Version:             1.0.0.0 Synopsis:            Haskell Equational Reasoning Model-to-Implementation Tunnel Description:   HERMIT is a Haskell-specific toolkit designed to mechanize@@ -15,12 +15,12 @@   .   @    $ hermit Reverse.hs Reverse.hss resume-   [starting HERMIT v0.7.1.0 on Reverse.hs]+   [starting HERMIT v1.0.0.0 on Reverse.hs]    % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:Main:Reverse.hss -fplugin-opt=HERMIT:Main:resume    [1 of 2] Compiling HList            ( HList.hs, HList.o )    Loading package ghc-prim ... linking ... done.    ...-   Loading package hermit-0.7.1.0 ... linking ... done.+   Loading package hermit-1.0.0.0 ... linking ... done.    [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )    Linking Reverse ...    $ ./Reverse@@ -31,12 +31,12 @@   .   @    $ hermit Reverse.hs-   [starting HERMIT v0.7.1.0 on Reverse.hs]+   [starting HERMIT v1.0.0.0 on Reverse.hs]    % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:*:    [1 of 2] Compiling HList            ( HList.hs, HList.o )    Loading package ghc-prim ... linking ... done.    ...-   Loading package hermit-0.7.1.0 ... linking ... done.+   Loading package hermit-1.0.0.0 ... linking ... done.    [2 of 2] Compiling Main             ( Reverse.hs, Reverse.o )    ===================== Welcome to HERMIT =====================    HERMIT is a toolkit for the interactive transformation of GHC@@ -130,19 +130,19 @@     examples/new_reverse/Reverse.hec  Library-  ghc-options: -Wall -fno-warn-orphans+  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,+                 ghc                 == 7.8.* || == 7.10.*,                  haskeline           >= 0.7.0.3,                  kure                >= 2.16.8,                  marked-pretty       >= 0.1,                  mtl                 >= 2.1.2,-                 operational         >= 0.2.2.1,                  process             >= 1.1.0.2,                  stm                 >= 2.4,                  temporary           >= 1.2.0.3,@@ -255,7 +255,7 @@     default-language: Haskell2010     Main-Is: Main.hs     Hs-Source-Dirs: driver-    Ghc-Options:+    Ghc-Options: -Wall  source-repository head     type:     git

@@ -1,52 +1,59 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, InstanceSigs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module HERMIT.Context-       ( -- * HERMIT Contexts-         -- ** Path Synonyms-         AbsolutePathH-       , LocalPathH-         -- ** The Standard Context-       , HermitC-       , topLevelHermitC-         -- ** Bindings-       , HermitBindingSite(..)-       , BindingDepth-       , HermitBinding-       , hbDepth-       , hbSite-       , hbPath-       , hermitBindingSiteExpr-       , hermitBindingSummary-       , hermitBindingExpr-         -- ** Adding bindings to contexts-       , AddBindings(..)-       , addBindingGroup-       , addDefBinding-       , addDefBindingsExcept-       , addLambdaBinding-       , addAltBindings-       , addCaseBinderBinding-       , addForallBinding-         -- ** Reading bindings from the context-       , BoundVars(..)-       , boundIn-       , findBoundVars-       , ReadBindings(..)-       , lookupHermitBinding-       , lookupHermitBindingDepth-       , lookupHermitBindingSite-       , inScope-         -- ** Accessing GHC rewrite rules from the context-       , HasCoreRules(..)-         -- ** An empty Context-       , HasEmptyContext(..)-) where+    ( -- * HERMIT Contexts+      -- ** Path Synonyms+      AbsolutePathH+    , LocalPathH+      -- ** The Standard Context+    , HermitC+    , topLevelHermitC+    , toHermitC+      -- ** Bindings+    , HermitBindingSite(..)+    , BindingDepth+    , HermitBinding+    , hbDepth+    , hbSite+    , hbPath+    , hermitBindingSiteExpr+    , hermitBindingSummary+    , hermitBindingExpr+      -- ** Adding bindings to contexts+    , AddBindings(..)+    , addBindingGroup+    , addDefBinding+    , addDefBindingsExcept+    , addLambdaBinding+    , addAltBindings+    , addCaseBinderBinding+    , addForallBinding+      -- ** Reading bindings from the context+    , BoundVars(..)+    , boundIn+    , findBoundVars+    , ReadBindings(..)+    , lookupHermitBinding+    , lookupHermitBindingDepth+    , lookupHermitBindingSite+    , inScope+      -- ** Accessing GHC rewrite rules from the context+    , HasCoreRules(..)+      -- ** Accessing temporary lemmas in scope+    , LemmaContext(..)+      -- ** An empty Context+    , HasEmptyContext(..)+    ) where -import Prelude hiding (lookup)+import Prelude.Compat hiding (lookup)  import Control.Monad (liftM) -import Data.Monoid (mempty) import Data.Map hiding (map, foldr, filter)  import Language.KURE@@ -54,6 +61,7 @@  import HERMIT.Core import HERMIT.GHC hiding (empty)+import HERMIT.Lemma  ------------------------------------------------------------------------ @@ -228,6 +236,18 @@  ------------------------------------------------------------------------ +-- | A class of contexts that can store local Lemmas as we descend past implications.+class LemmaContext c where+    addAntecedent :: LemmaName -> Lemma -> c -> c+    getAntecedents :: c -> Lemmas++instance LemmaContext c => LemmaContext (ExtendContext c e) where+    addAntecedent nm l ec = extendContext (extraContext ec)+                                          (addAntecedent nm l $ baseContext ec)+    getAntecedents = getAntecedents . baseContext++------------------------------------------------------------------------+ type AbsolutePathH = AbsolutePath Crumb type LocalPathH = LocalPath Crumb @@ -239,8 +259,19 @@     , hermitC_depth     :: BindingDepth          -- ^ The depth of the most recent bindings.     , hermitC_path      :: AbsolutePathH         -- ^ The 'AbsolutePath' to the current node from the root.     , hermitC_specRules :: [CoreRule]            -- ^ In-scope GHC RULES found in IdInfos.+    , hermitC_lemmas    :: Lemmas                -- ^ Local lemmas as we pass implications in a proof.     } +-- | Build a HermitC out of any context that has the capabilities.+toHermitC :: (HasCoreRules c, LemmaContext c, ReadBindings c, ReadPath c Crumb) => c -> HermitC+toHermitC c =+    HermitC { hermitC_bindings = hermitBindings c+            , hermitC_depth = hermitDepth c+            , hermitC_path = absPath c+            , hermitC_specRules = hermitCoreRules c+            , hermitC_lemmas = getAntecedents c+            }+ ------------------------------------------------------------------------  -- | The |HermitC| empty context has an initial depth of 0, an empty path, and no bindings nor rules.@@ -251,6 +282,7 @@                  , hermitC_depth         = 0                  , hermitC_path          = mempty                  , hermitC_specRules     = []+                 , hermitC_lemmas        = empty                  }  -- | A special HERMIT context intended for use only when focussed on ModGuts.@@ -262,6 +294,7 @@                        , hermitC_depth         = 0                        , hermitC_path          = mempty                        , hermitC_specRules     = concatMap (idCoreRules . fst) ies+                       , hermitC_lemmas        = empty                        }  ------------------------------------------------------------------------@@ -308,3 +341,10 @@   hermitCoreRules = hermitC_specRules  ------------------------------------------------------------------------++instance LemmaContext HermitC where+    addAntecedent :: LemmaName -> Lemma -> HermitC -> HermitC+    addAntecedent nm l c = c { hermitC_lemmas = insert nm l (hermitC_lemmas c) }++    getAntecedents :: HermitC -> Lemmas+    getAntecedents = hermitC_lemmas

@@ -1,4 +1,6 @@-{-# LANGUAGE CPP, LambdaCase #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+ module HERMIT.Core     ( -- * Generic Data Type       CoreProg(..)@@ -193,7 +195,11 @@ 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+#else+coercionSyntaxEq (UnivCo fs1 role1 ty11 ty12) (UnivCo fs2 role2 ty21 ty22) = fs1 == fs2 && role1 == role2 && typeSyntaxEq ty11 ty21 && typeSyntaxEq ty12 ty22+#endif coercionSyntaxEq (SubCo co1)             (SubCo co2)             = coercionSyntaxEq co1 co2 coercionSyntaxEq (SymCo co1)             (SymCo co2)             = coercionSyntaxEq co1 co2 coercionSyntaxEq (TransCo co11 co12)     (TransCo co21 co22)     = coercionSyntaxEq co11 co21 && coercionSyntaxEq co12 co22

@@ -9,6 +9,7 @@     , module HERMIT.Dictionary.Fold     , module HERMIT.Dictionary.Function     , module HERMIT.Dictionary.GHC+    , module HERMIT.Dictionary.Induction     , module HERMIT.Dictionary.Inline     , module HERMIT.Dictionary.Kure     , module HERMIT.Dictionary.Local@@ -44,6 +45,8 @@ import qualified HERMIT.Dictionary.Function as Function import           HERMIT.Dictionary.GHC hiding (externals) import qualified HERMIT.Dictionary.GHC as GHC+import           HERMIT.Dictionary.Induction hiding (externals)+import qualified HERMIT.Dictionary.Induction as Induction import           HERMIT.Dictionary.Inline hiding (externals) import qualified HERMIT.Dictionary.Inline as Inline import           HERMIT.Dictionary.Kure hiding (externals)@@ -92,6 +95,7 @@     ++ Fold.externals     ++ Function.externals     ++ GHC.externals+    ++ Induction.externals     ++ Inline.externals     ++ Kure.externals     ++ Local.externals

@@ -1,4 +1,6 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module HERMIT.Dictionary.AlphaConversion     ( -- * Alpha-Renaming and Shadowing       externals

@@ -1,4 +1,7 @@-{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleContexts, LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Note: this module should NOT export externals. It is for common --   transformations needed by the other primitive modules.@@ -43,8 +46,7 @@  where -import Data.List-import Data.Monoid+import Data.List (nub)  import Control.Arrow import Control.Monad.IO.Class@@ -56,6 +58,8 @@ import HERMIT.Monad import HERMIT.Name +import Prelude.Compat+ ------------------------------------------------------------------------------  -- | apply a transformation to a value in the current context.@@ -194,22 +198,22 @@ --------------------------------------------------------------------------------------------------  -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.-findIdT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)+findIdT :: (BoundVars c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m)         => HermitName -> Transform c m a Id findIdT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findId nm)  -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.-findVarT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)+findVarT :: (BoundVars c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m)          => HermitName -> Transform c m a Var findVarT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findVar nm)  -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.-findTyConT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)+findTyConT :: (BoundVars c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m)            => HermitName -> Transform c m a TyCon findTyConT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findTyCon nm)  -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.-findTypeT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)+findTypeT :: (BoundVars c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m)           => HermitName -> Transform c m a Type findTypeT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findType nm) 

@@ -15,6 +15,7 @@  import Control.Arrow import Control.Monad+import Control.Monad.IO.Class  import Data.String (fromString) @@ -31,6 +32,8 @@ import HERMIT.Dictionary.GHC hiding (externals) import HERMIT.Dictionary.Inline hiding (externals) import HERMIT.Dictionary.Local hiding (externals)+import HERMIT.Dictionary.Reasoning hiding (externals)+import HERMIT.Dictionary.Undefined hiding (externals) import HERMIT.Dictionary.Unfold hiding (externals)  ------------------------------------------------------------------------------------------------------@@ -73,7 +76,7 @@     where f nm = voidM (callNameT nm) >> voidM callSaturatedT >> unfoldR           voidM = liftM (const ()) -- can't wait for AMP -simplifyR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+simplifyR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb              , MonadCatch m, MonadUnique m )           => Rewrite c m LCore simplifyR = setFailMsg "Simplify failed: nothing to simplify." $@@ -93,13 +96,13 @@ -- basic combinators. See 'bashComponents' for a list of rewrites performed. -- Bash also performs occurrence analysis and de-zombification on the result, to update -- IdInfo attributes relied-upon by GHC.-bashR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+bashR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb          , MonadCatch m, MonadUnique m )       => Rewrite c m LCore bashR = bashExtendedWithR []  -- | An extensible bash. Given rewrites are performed before normal bash rewrites.-bashExtendedWithR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+bashExtendedWithR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb                      , MonadCatch m, MonadUnique m )                   => [Rewrite c m LCore] -> Rewrite c m LCore bashExtendedWithR rs = bashUsingR (rs ++ map fst bashComponents)@@ -109,14 +112,14 @@ -- If core lint fails, shows core fragment before and after the sub-rewrite which introduced the problem. -- Note: core fragment which fails linting is still returned! Otherwise would behave differently than bashR. -- Useful for debugging the bash command itself.-bashDebugR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb-              , HasDebugChan m, HasDynFlags m, MonadCatch m, MonadUnique m )+bashDebugR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb+              , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadUnique m )            => Rewrite c m LCore bashDebugR = bashUsingR [ bracketR nm r >>> catchM (promoteT lintExprT >> idR) traceR                         | (r,nm) <- bashComponents ]  -- | Perform the 'bash' algorithm with a given list of rewrites.-bashUsingR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb, MonadCatch m)+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@@ -178,18 +181,18 @@ -- | Smash is a more powerful but less efficient version of bash. -- Unlike bash, smash is not concerned with whether it duplicates work, -- and is intended for use during proving tasks.-smashR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb-          , MonadCatch m, MonadUnique m )+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 )        => Rewrite c m LCore smashR = smashExtendedWithR [] -smashExtendedWithR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb-                      , MonadCatch m, MonadUnique m )+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 )                    => [Rewrite c m LCore] -> Rewrite c m LCore smashExtendedWithR rs = smashUsingR (rs ++ map fst smashComponents1) (map fst smashComponents2)  -smashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => [Rewrite c m LCore] -> [Rewrite c m LCore] -> Rewrite c m LCore+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@@ -203,7 +206,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-                    , MonadCatch m, MonadUnique m )+                    , HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )                  => [(Rewrite c m LCore, String)] smashComponents1 =   [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr")    -- ??@@ -232,6 +235,7 @@   , (promoteExprR castElimSymR, "cast-elim-sym")                     -- O(1)   , (promoteExprR castFloatAppR, "cast-float-app")                   -- O(1)   , (promoteExprR castFloatLamR, "cast-float-lam")                   -- O(1)+  , (promoteExprR undefinedExprR, "undefined-expr")                  -- O(1) --  , (promoteExprR dezombifyR, "dezombify")                           -- O(1) -- performed at the end   ] @@ -240,4 +244,8 @@                  => [(Rewrite c m LCore, String)] smashComponents2 =     [ (promoteExprR caseElimMergeAltsR, "case-elim-merge-alts") -- do this last, lest it prevent other simplifications+      -- neither of these will create interesting new terms for the stuff in smashComponents1+      -- so might as well have them here so they are run at the end+    , (promoteClauseR quantIdentitiesR, "quant-indentities")+    , (promoteClauseR reflexivityR, "reflexivity")     ]

@@ -30,21 +30,24 @@     ]  -- | If the 'Rewrite' fails, print out the 'Core', with a message.-observeFailureR :: (Injection a LCoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, MonadCatch m)+observeFailureR :: ( Injection a LCoreTC, LemmaContext c, ReadBindings c, ReadPath c Crumb+                   , HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m )                 => String -> Rewrite c m a -> Rewrite c m a observeFailureR str m = m <+ observeR str  -- | Print out the 'Core', with a message.-observeR :: (Injection a LCoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, Monad m)+observeR :: ( Injection a LCoreTC, LemmaContext c, ReadBindings c, ReadPath c Crumb+            , HasHermitMEnv m, HasLemmas m, LiftCoreM m )          => String -> Rewrite c m a-observeR msg = extractR $ sideEffectR $ \ cxt -> sendDebugMessage . DebugCore msg cxt+observeR msg = extractR $ sideEffectR $ \ cxt -> sendKEnvMessage . DebugCore msg cxt  -- | Just say something, every time the rewrite is done.-traceR :: (HasDebugChan m, Monad m) => String -> Rewrite c m a-traceR msg = sideEffectR $ \ _ _ -> sendDebugMessage $ DebugTick msg+traceR :: (HasHermitMEnv m, HasLemmas m, LiftCoreM m) => String -> Rewrite c m a+traceR msg = sideEffectR $ \ _ _ -> sendKEnvMessage $ DebugTick msg  -- | Show before and after a rewrite.-bracketR :: (Injection a LCoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, MonadCatch m)+bracketR :: ( Injection a LCoreTC, LemmaContext c, ReadBindings c, ReadPath c Crumb+            , HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m )          => String -> Rewrite c m a -> Rewrite c m a bracketR msg rr = do     -- Be careful to only run the rr once, in case it has side effects.

@@ -1,4 +1,6 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}  module HERMIT.Dictionary.FixPoint     ( -- * Operations on the Fixed Point Operator (fix)@@ -23,7 +25,7 @@ import HERMIT.Context import HERMIT.Core import HERMIT.Monad-import HERMIT.Kure+import HERMIT.Kure hiding ((<$>)) import HERMIT.External import HERMIT.GHC import HERMIT.Name@@ -37,6 +39,8 @@ import HERMIT.Dictionary.Undefined import HERMIT.Dictionary.Unfold +import Prelude.Compat+ --------------------------------------------------------------------------------------------------  -- | Externals for manipulating fixed points.@@ -83,12 +87,12 @@ --------------------------------------------------------------------------------------------------  fixIntroR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb-             , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+             , 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-                   , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+                   , HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )                 => Rewrite c m CoreBind fixIntroNonRecR = prefixFailMsg "fix introduction failed: " $ do     NonRec f rhs <- idR@@ -97,7 +101,7 @@  -- |  @f = e@   ==\>   @f = fix (\\ f -> e)@ fixIntroRecR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb-                , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+                , HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )              => Rewrite c m CoreDef fixIntroRecR = prefixFailMsg "fix introduction failed: " $ do     Def f rhs <- idR@@ -108,7 +112,7 @@ -- Meant to be applied to RHS of function. polyFixT :: forall c m.             ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb-            , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+            , HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )          => Id -> Rewrite c m CoreExpr polyFixT f = do     (tvs, body) <- arr collectTyBinders

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -24,7 +25,7 @@     ) where  import Control.Arrow-import Control.Monad+import Control.Monad (liftM) import Control.Monad.IO.Class  import Data.List (delete, (\\), intersect)@@ -37,7 +38,7 @@ import HERMIT.Context import HERMIT.External import HERMIT.GHC-import HERMIT.Kure+import HERMIT.Kure hiding ((<$>)) import HERMIT.Lemma import HERMIT.Monad import HERMIT.Name@@ -49,7 +50,7 @@ import HERMIT.PrettyPrinter.Common import qualified Text.PrettyPrint.MarkedHughesPJ as PP -import Prelude hiding (exp)+import Prelude.Compat hiding (exp)  ------------------------------------------------------------------------ @@ -71,7 +72,7 @@  ------------------------------------------------------------------------ -foldR :: (ReadBindings c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m)+foldR :: (ReadBindings c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m)       => HermitName -> Rewrite c m CoreExpr foldR nm = prefixFailMsg "Fold failed: " $ findIdT nm >>= foldVarR Nothing @@ -411,20 +412,22 @@ sameExpr e1 e2 = snd <$> soleElement (findFold e2 m)     where m = insertFold emptyAlphaEnv [] e1 () EMEmpty --- | Determine if the left Quantified 'proves' the right one.--- Here, 'proves' means that the right Quantified is a substitution--- of the left one, where only the top-level binders of the left--- Quantified can be substituted.-proves :: Quantified -> Quantified -> Bool-proves (Quantified bs cl1) (Quantified _ cl2) = maybe False (const True) $ soleElement (findFold cl2 m)-    where m = insertFold emptyAlphaEnv bs cl1 () CLMEmpty+-- | Determine if the left Clause 'proves' the right Clause.+-- Here, 'proves' means that the clause is a substitution instance+-- of the left one, where the top-level binders of the left clause are the holes.+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) --- | Determine if the right Quantified is a substitution--- instance of the left Quantified (which is a pattern+-- | Determine if the right Clause is a substitution+-- instance of the left Clause (which is a pattern -- with a given set of holes).-lemmaMatch :: [Var] -> Quantified -> Quantified -> Maybe (VarEnv CoreExpr)-lemmaMatch hs ql qr = fmap fst $ soleElement (findFold qr m)-    where m = insertFold emptyAlphaEnv hs ql () emptyQMapWrapper+lemmaMatch :: [Var] -> Clause -> Clause -> Maybe (VarEnv CoreExpr)+lemmaMatch hs cl cr = fmap fst $ soleElement (findFold cr m)+    where m = insertFold emptyAlphaEnv hs cl () CLMEmpty  ------------------------------------------------------------------------ @@ -485,38 +488,17 @@  ---------------------------------------------------------------------------- -data QMap a = QM { qmap :: CLMap (ListMap BMap a) }--emptyQMapWrapper :: QMap a-emptyQMapWrapper = QM fEmpty--instance Fold QMap where-    type Key QMap = Quantified--    fEmpty :: QMap a-    fEmpty = emptyQMapWrapper--    fAlter :: AlphaEnv -> [Var] -> Key QMap -> A a -> QMap a -> QMap a-    fAlter env vs (Quantified bs cl) f m =-        m { qmap = fAlter (foldr extendAlphaEnv env bs) (vs \\ bs) cl-                          (toA (fAlter env vs (map varType bs) f)) (qmap m) }--    fFold :: VarEnv CoreExpr -> AlphaEnv -> Key QMap -> QMap a -> [(VarEnv CoreExpr, a)]-    fFold hs env (Quantified bs cl) m = do-        (hs', m') <- fFold hs (foldr extendAlphaEnv env bs) cl (qmap m)-        fFold hs' env (map varType bs) m'------------------------------------------------------------------------------- data CLMap a = CLMEmpty-             | CLM { clmConj  :: QMap (QMap a)-                   , clmDisj  :: QMap (QMap a)-                   , clmImpl  :: QMap (QMap a)-                   , clmEquiv :: EMap (EMap a)+             | CLM { clmForall :: CLMap (ListMap BMap a)+                   , clmConj   :: CLMap (CLMap a)+                   , clmDisj   :: CLMap (CLMap a)+                   , clmImpl   :: CLMap (CLMap a) -- note we do not care about the name+                   , clmEquiv  :: EMap (EMap a)+                   , clmTrue   :: Maybe a                    }  emptyCLMapWrapper :: CLMap a-emptyCLMapWrapper = CLM fEmpty fEmpty fEmpty fEmpty+emptyCLMapWrapper = CLM fEmpty fEmpty fEmpty fEmpty fEmpty Nothing  instance Fold CLMap where     type Key CLMap = Clause@@ -527,26 +509,33 @@     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 (Conj  q1 q2) = m { clmConj  = fAlter env vs q1 (toA (fAlter env vs q2 f)) (clmConj  m) }+        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) }+              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) }+              go (Impl _ q1 q2) = m { clmImpl  = fAlter env vs q1 (toA (fAlter env vs q2 f)) (clmImpl  m) }               go (Equiv e1 e2) = m { clmEquiv = fAlter env vs e1 (toA (fAlter env vs e2 f)) (clmEquiv m) }+              go CTrue         = m { clmTrue  = f (clmTrue m) }      fFold :: VarEnv CoreExpr -> AlphaEnv -> Key CLMap -> CLMap a -> [(VarEnv CoreExpr, a)]     fFold _  _   _  CLMEmpty = []     fFold hs env cl m@CLM{}  = go cl-        where go (Conj q1 q2) = do+        where go (Forall bs cl') = do+                (hs', m') <- fFold hs (foldr extendAlphaEnv env bs) cl' (clmForall m)+                fFold hs' env (map varType bs) m'+              go (Conj q1 q2) = do                 (hs', m') <- fFold hs env q1 (clmConj m)                 fFold hs' env q2 m'               go (Disj q1 q2) = do                 (hs', m') <- fFold hs env q1 (clmDisj m)                 fFold hs' env q2 m'-              go (Impl q1 q2) = do+              go (Impl _ q1 q2) = do                 (hs', m') <- fFold hs env q1 (clmImpl m)                 fFold hs' env q2 m'               go (Equiv e1 e2) = do                 (hs', m') <- fFold hs env e1 (clmEquiv m)                 fFold hs' env e2 m'+              go CTrue = maybe [] (\v-> [(hs,v)]) (clmTrue m)  ---------------------------------------------------------------------------- @@ -561,16 +550,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 mkQuantified vs lhs rhs of-                            Quantified vs' (Equiv lhs' rhs') -> Equality vs' lhs' rhs'+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' -toEqualities :: Quantified -> [Equality]+toEqualities :: Clause -> [Equality] toEqualities = go []-    where go qs (Quantified vs cl) = go2 (qs++vs) cl--          go2 qs (Equiv e1 e2) = [mkEquality qs e1 e2]-          go2 qs (Conj q1 q2)  = go qs q1 ++ go qs q2-          go2 _  _             = []+    where go qs (Forall vs cl) = go (qs++vs) cl+          go qs (Equiv e1 e2) = [mkEquality qs e1 e2]+          go qs (Conj q1 q2)  = go qs q1 ++ go qs q2+          go _  _             = []  ppEqualityT :: PrettyPrinter -> PrettyH Equality ppEqualityT pp = do

@@ -1,4 +1,7 @@-{-# LANGUAGE CPP, FlexibleContexts, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module HERMIT.Dictionary.Function     ( externals     , appArgM@@ -132,7 +135,7 @@                              else return $ l !! n  -- | Build composition of two functions.-buildCompositionT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)+buildCompositionT :: (BoundVars c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m)                   => CoreExpr -> CoreExpr -> Transform c m x CoreExpr buildCompositionT f g = do     composeId <- findIdT $ fromString "Data.Function.."@@ -162,7 +165,7 @@     return $ mkCoreLams vs $ mkCoreApp f' x'  -- | Given expression for f, build fix f.-buildFixT :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+buildFixT :: (BoundVars c, LiftCoreM m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)           => CoreExpr -> Transform c m x CoreExpr buildFixT f = do     (tvs, ty) <- endoFunExprTypeM f@@ -171,7 +174,7 @@     return $ mkCoreLams tvs $ mkCoreApps (varToCoreExpr fixId) [Type ty, f']  -- | Build an expression that is the monomorphic id function for given type.-buildIdT :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+buildIdT :: (BoundVars c, LiftCoreM m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)          => Type -> Transform c m x CoreExpr buildIdT ty = do     idId <- findIdT $ fromString "Data.Function.id"

@@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module HERMIT.Dictionary.GHC     ( -- * GHC-based Transformations       -- | This module contains transformations that are reflections of GHC functions, or derived from GHC functions.@@ -8,6 +10,7 @@       -- ** Dynamic Loading     , loadLemmaLibraryT     , LemmaLibrary+    , injectDependencyT       -- ** Substitution     , substR       -- ** Utilities@@ -17,7 +20,6 @@       -- A zombie is an identifer that has 'OccInfo' 'IAmDead', but still has occurrences.     , lintExprT     , lintModuleT-    , lintQuantifiedT     , lintClauseT     , occurAnalyseR     , occurAnalyseChangedR@@ -26,7 +28,9 @@     , dezombifyR     , buildDictionary     , buildDictionaryT+#if __GLASGOW_HASKELL__ < 710     , buildTypeable+#endif     ) where  import qualified Bag@@ -38,7 +42,7 @@  import           Data.Char (isSpace) import           Data.Either (partitionEithers)-import           Data.List (mapAccumL)+import           Data.List (mapAccumL, nub) import qualified Data.Map as M import           Data.String @@ -70,12 +74,14 @@         , "will catch that however."] .+ Deep .+ Debug .+ Query     , external "lint-module" (promoteModGutsT lintModuleT :: TransformH LCoreTC String)         [ "Runs GHC's Core Lint, which typechecks the current module."] .+ Deep .+ Debug .+ Query-    , external "lint" (promoteT lintQuantifiedT :: TransformH LCoreTC String)-        [ "Lint check a quantified clause." ]+    , external "lint" (promoteT lintClauseT :: TransformH LCoreTC String)+        [ "Lint check a clause." ]     , external "load-lemma-library" (flip loadLemmaLibraryT Nothing :: HermitName -> TransformH LCore String)         [ "Dynamically load a library of lemmas." ]     , external "load-lemma-library" ((\nm -> loadLemmaLibraryT nm . Just) :: HermitName -> LemmaName -> TransformH LCore String)         [ "Dynamically load a specific lemma from a library of lemmas." ]+    , external "inject-dependency" (promoteModGutsT . injectDependencyT . mkModuleName :: String -> TransformH LCore ())+        [ "Inject a dependency on the given module." ]     ]  ------------------------------------------------------------------------@@ -126,7 +132,13 @@ 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+     -- [] 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+#endif          dumpSDocs endMsg = Bag.foldBag (\ d r -> d ++ ('\n':r)) (showSDoc dynFlags) endMsg      if Bag.isEmptyBag errs        then return $ dumpSDocs "Core Lint Passed" warns@@ -139,8 +151,10 @@ lintExprT :: (BoundVars c, Monad m, HasDynFlags m) => Transform c m CoreExpr String lintExprT = transform $ \ c e -> do     dflags <- getDynFlags-    maybe (return "Core Lint Passed") (fail . showSDoc dflags)-                 $ CoreLint.lintExpr (varSetElems $ boundVars c) e+    case e of+        Type _ -> fail "cannot core lint types."+        _ -> maybe (return "Core Lint Passed") (fail . showSDoc dflags)+                   (CoreLint.lintExpr (varSetElems $ boundVars c) e)  ------------------------------------------- @@ -160,7 +174,7 @@ dezombifyR = varR (acceptR isDeadBinder >>^ zapVarOccInfo)  -- | Apply 'occurAnalyseExprR' to all sub-expressions.-occurAnalyseR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m, Walker c u, Injection CoreExpr u) => Rewrite c m u+occurAnalyseR :: (Injection CoreExpr u, Walker c u, MonadCatch m) => Rewrite c m u occurAnalyseR = let r  = promoteExprR (arr occurAnalyseExpr_NoBinderSwap) -- See Note [No Binder Swap]                     go = r <+ anyR go                  in tryR go -- always succeed@@ -180,7 +194,7 @@ occurAnalyseExprChangedR = changedByR exprSyntaxEq (arr occurAnalyseExpr_NoBinderSwap) -- See Note [No Binder Swap]  -- | Occurrence analyse all sub-expressions, failing if the result is syntactically equal to the initial expression.-occurAnalyseChangedR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m LCore+occurAnalyseChangedR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadPath c Crumb, MonadCatch m) => Rewrite c m LCore occurAnalyseChangedR = changedByR lcoreSyntaxEq occurAnalyseR  -- | Run GHC's occurrence analyser, and also eliminate any zombies.@@ -192,31 +206,37 @@  ---------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ < 710 -- TODO: this is mostly an example, move somewhere?-buildTypeable :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadIO m) => Type -> m (Id, [CoreBind])+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     buildDictionary evar+#endif  -- | Build a dictionary for the given-buildDictionary :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadIO m) => Id -> m (Id, [CoreBind])+buildDictionary :: (HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadIO m) => Id -> m (Id, [CoreBind]) buildDictionary evar = do     (i, bs) <- runTcM $ do         loc <- getCtLoc $ GivenOrigin UnkSkol         let predTy = varType evar             nonC = mkNonCanonical $ CtWanted { ctev_pred = predTy, ctev_evar = evar, ctev_loc = loc }+#if __GLASGOW_HASKELL__ < 710             wCs = mkFlatWC [nonC]-        (wCs', bnds) <- solveWantedsTcM wCs-        -- reportAllUnsolved wCs' -- this is causing a panic with dictionary instantiation+#else+            wCs = mkSimpleWC [nonC]+#endif+        (_wCs', bnds) <- solveWantedsTcM wCs+        -- reportAllUnsolved _wCs' -- this is causing a panic with dictionary instantiation                                   -- revist and fix!         return (evar, bnds)     bnds <- runDsM $ dsEvBinds bs     return (i,bnds) -buildDictionaryT :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadUnique m)+buildDictionaryT :: (HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadUnique m)                  => Transform c m Type CoreExpr buildDictionaryT = prefixFailMsg "buildDictionaryT failed: " $ contextfreeT $ \ ty -> do     dflags <- getDynFlags@@ -229,21 +249,15 @@  ---------------------------------------------------------------------- -lintQuantifiedT :: (AddBindings c, BoundVars c, ReadPath c Crumb, ExtendPath c Crumb, HasDynFlags m, MonadCatch m)-                => Transform c m Quantified String-lintQuantifiedT = lintQuantifiedWorkT []--lintQuantifiedWorkT :: (AddBindings c, BoundVars c, ReadPath c Crumb, ExtendPath c Crumb, HasDynFlags m, MonadCatch m)-                    => [Var] -> Transform c m Quantified String-lintQuantifiedWorkT bs = readerT $ \ (Quantified bs' _) -> quantifiedT successT (lintClauseT (bs++bs')) (flip const)--lintClauseT :: (AddBindings c, BoundVars c, ReadPath c Crumb, ExtendPath c Crumb, HasDynFlags m, MonadCatch m)-            => [Var] -> Transform c m Clause String-lintClauseT bs = do-    t <- readerT $ \case Equiv {} -> return $ promoteT ({- arr (mkCoreLams bs) >>> -} lintExprT) -- TODO: why does this break core lint?!-                         _        -> return $ promoteT (lintQuantifiedWorkT bs)-    (w1,w2) <- clauseT t t (const (,))-    return $ unlines [w1,w2]+lintClauseT :: forall c m.+               ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadPath c Crumb+               , HasDynFlags m, MonadCatch m )+            => Transform c m Clause String+lintClauseT = do+    strs <- extractT (collectPruneT (promoteExprT $ lintExprT `catchM` return) :: Transform c m LCore [String])+    let strs' = nub $ filter notNull strs+    guardMsg (null strs' || (strs' == ["Core Lint Passed"])) $ unlines strs'+    return "Core Lint Passed"  ---------------------------------------------------------------------- @@ -265,7 +279,7 @@                                     (M.lookup lnm ls))                      mblnm         r <- forM nls $ \ nl@(n, l) -> do-                    er <- attemptM $ applyT lintQuantifiedT c $ lemmaQ l+                    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@@ -298,3 +312,8 @@             , ptext (sLit "did not export the name")             , ppr rdrName ])           return mbName++injectDependencyT :: (LiftCoreM m, MonadIO m) => ModuleName -> Transform c m ModGuts ()+injectDependencyT mn = contextfreeT $ \ guts -> do+    env <- getHscEnv+    liftIO $ injectDependency env guts mn

@@ -1,56 +1,73 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, MultiWayIf #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}  module HERMIT.Dictionary.Induction   ( -- * Induction-    inductionCaseSplit+    externals+  , caseSplitOnR   ) where -import Control.Arrow+import Control.Monad+import Data.String  import HERMIT.Context import HERMIT.Core+import HERMIT.External import HERMIT.GHC import HERMIT.Kure-import HERMIT.Monad+import HERMIT.Lemma import HERMIT.Name  import HERMIT.Dictionary.Common-import HERMIT.Dictionary.Local.Case (caseSplitInlineR)-import HERMIT.Dictionary.Undefined+import HERMIT.Dictionary.Local.Case hiding (externals)+import HERMIT.Dictionary.Undefined hiding (externals)  ------------------------------------------------------------------------------ --- TODO: Warning, this is very experimental+externals :: [External]+externals =+    [ external "induction" (promoteClauseR . caseSplitOnR True . cmpHN2Var :: HermitName -> RewriteH LCore)+        [ "Induct on specified value quantifier." ]+    , external "prove-by-cases" (promoteClauseR . caseSplitOnR False . cmpHN2Var :: HermitName -> RewriteH LCore)+        [ "Case split on specified value quantifier." ]+    ]  ------------------------------------------------------------------------------ -inductionCaseSplit :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb)-                   => [Var] -> Id -> CoreExpr -> CoreExpr -> Transform c HermitM x [(Maybe DataCon,[Var],CoreExpr,CoreExpr)]-inductionCaseSplit vs i lhsE rhsE =-    do -- first construct an expression containing both the LHS and the RHS-       il <- constT $ newIdH "dummyL" (exprKindOrType lhsE)-       ir <- constT $ newIdH "dummyR" (exprKindOrType rhsE)-       let contrivedExpr = Let (NonRec il lhsE)-                               (Let (NonRec ir rhsE)-                                    (Var i)-                               )+caseSplitOnR :: Bool -> (Id -> Bool) -> RewriteH Clause+caseSplitOnR induction idPred = do+    let p b = idPred b && isId b+    Forall bs cl <- idR+    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." -       -- then case split on the identifier, inlining the pattern-       -- we consider the other universally quantified variables to be in scope while doing so-       Case _ _ _ alts <- withVarsInScope vs (caseSplitInlineR (varToCoreExpr i)) <<< return contrivedExpr-       let dataConCases = map compressAlts alts+    ue <- mkUndefinedValT (varType b) -- undefined case+    cases <- liftM (ue:) $ constT $ caseExprsForM $ varToCoreExpr b -       lhsUndefined <- extractR (replaceIdWithUndefinedR i) <<< return lhsE-       rhsUndefined <- extractR (replaceIdWithUndefinedR i) <<< return rhsE+    let newBs = as ++ bs'+        substructural = filter (typeAlphaEq (varType b) . varType) -       let undefinedCase = (Nothing,[],lhsUndefined,rhsUndefined)+        go [] = return []+        go (e:es) = do+            let cl' = substClause b e cl+                fvs = varSetElems $ delVarSetList (localFreeVarsExpr e) newBs -       return (undefinedCase : dataConCases)+            -- Generate induction hypotheses for the recursive cases.+            antes <- if induction+                     then forM (zip [(0::Int)..] $ substructural fvs) $ \ (i,b') ->+                            withVarsInScope fvs $ transform $ \ c q ->+                                let nm = fromString $ "ind-hyp-" ++ show i+                                in liftM ((nm,) . discardUniVars) $ instClause (boundVars c) (==b) (Var b') q+                     else return [] -  where-    compressAlts :: CoreAlt -> (Maybe DataCon,[Var],CoreExpr,CoreExpr)-    compressAlts (DataAlt con,bs,Let (NonRec _ lhsE') (Let (NonRec _ rhsE') _)) = (Just con,bs,lhsE',rhsE')-    compressAlts _ = error "Bug in inductionCaseSplit"+            rs <- go es+            return $ mkForall fvs (foldr (uncurry Impl) cl' antes) : rs +    qs <- go cases++    return $ mkForall newBs $ foldr1 Conj qs 

@@ -1,4 +1,7 @@-{-# LANGUAGE CPP, TupleSections, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+ module HERMIT.Dictionary.Inline     ( -- * Inlining       externals@@ -214,7 +217,7 @@  -- | Get list of possible inline targets. Used by shell for completion. inlineTargetsT :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c-                  , ReadBindings c, HasEmptyContext c, MonadCatch m )+                  , HasEmptyContext c, LemmaContext c, ReadBindings c, MonadCatch m )                => Transform c m LCore [String] inlineTargetsT = collectT $ promoteT $ whenM (testM inlineR) (varT $ arr unqualifiedName) 

@@ -160,7 +160,7 @@                            _                 -> anyR (anyCallR rr)  -- | Top-down traversal tuned to matching function calls.-anyCallR_LCore :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m)+anyCallR_LCore :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, LemmaContext c, MonadCatch m)          => Rewrite c m LCore -> Rewrite c m LCore anyCallR_LCore rr = prefixFailMsg "any-call failed: " $               readerT $ \case

@@ -1,4 +1,9 @@-{-# LANGUAGE CPP, MultiWayIf, LambdaCase, ScopedTypeVariables, FlexibleContexts, TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}  module HERMIT.Dictionary.Local.Case     ( -- * Rewrites on Case Expressions@@ -33,11 +38,10 @@     ) where  import Control.Arrow-import Control.Monad+import Control.Monad ((>=>), forM, liftM) import Control.Monad.IO.Class -import Data.List-import Data.Monoid+import Data.List (intersect, transpose)  import HERMIT.Core import HERMIT.Context@@ -57,6 +61,8 @@ import HERMIT.Dictionary.Undefined (verifyStrictT, buildStrictnessLemmaT) import HERMIT.Dictionary.Unfold (unfoldR) +import Prelude.Compat hiding ((<$>))+ ------------------------------------------------------------------------------  -- | Externals relating to Case expressions.@@ -181,7 +187,7 @@ -- | @f (case s of alt1 -> e1; alt2 -> e2)@ ==> @case s of alt1 -> f e1; alt2 -> f e2@ --   Only safe if @f@ is strict. caseFloatArgR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c-                 , HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+                 , HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )               => Maybe CoreExpr -> Maybe (Rewrite c m CoreExpr) -- ^ Maybe the function to float past, and maybe a proof of its strictness.               -> Rewrite c m CoreExpr caseFloatArgR mf mstrict = prefixFailMsg "Case floating from App argument failed: " $@@ -205,8 +211,9 @@  -- | @f (case s of alt1 -> e1; alt2 -> e2)@ ==> @case s of alt1 -> f e1; alt2 -> f e2@ --   Only safe if @f@ is strict, so introduces a lemma to prove.-caseFloatArgLemmaR :: ( AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasHermitMEnv m-                      , HasHscEnv m, HasDynFlags m, HasLemmas m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+caseFloatArgLemmaR :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, LemmaContext c, ReadBindings c, ReadPath c Crumb+                      , HasHermitMEnv m, LiftCoreM m, HasDynFlags m, HasLemmas m, MonadCatch m, MonadIO m+                      , MonadThings m, MonadUnique m )                    => Used -> LemmaName -> Rewrite c m CoreExpr caseFloatArgLemmaR u nm = prefixFailMsg "Case floating from application argument failed: " $                           withPatFailMsg "App f (Case s w ty alts)" $ do

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}  module HERMIT.Dictionary.Local.Cast     ( -- * Rewrites on Case Expressions

@@ -1,4 +1,8 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, MultiWayIf, LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}  module HERMIT.Dictionary.Local.Let     ( -- * Rewrites on Let Expressions@@ -42,10 +46,10 @@     ) where  import Control.Arrow-import Control.Monad+import Control.Monad (ap, liftM, when) import Control.Monad.IO.Class -import Data.List+import Data.List (intersect, partition) import Data.Monoid  import HERMIT.Core@@ -64,6 +68,8 @@  import HERMIT.Dictionary.Local.Bind hiding (externals) +import Prelude.Compat hiding ((<$))+ ------------------------------------------------------------------------------  -- | Externals relating to 'Let' expressions.@@ -121,7 +127,7 @@         [ "let v = ev in e ==> case ev of v -> e" ]                             .+ Commute .+ Shallow .+ PreCondition --    , external "let-to-case-unbox" (promoteR $ not_defined "let-to-case-unbox" :: RewriteH LCore) --        [ "let v = ev in e ==> case ev of C v1..vn -> let v = C v1..vn in e" ]-    , external "let-float-in" (promoteExprR letFloatInR :: RewriteH LCore)+    , external "let-float-in" (promoteExprR letFloatInR >+> anybuR (promoteExprR letElimR) :: RewriteH LCore)         [ "Float-in a let if possible." ]                                        .+ Commute .+ Shallow     , external "let-float-in-app" ((promoteExprR letFloatInAppR >+> anybuR (promoteExprR letElimR)) :: RewriteH LCore)         [ "let v = ev in f a ==> (let v = ev in f) (let v = ev in a)" ]         .+ Commute .+ Shallow@@ -590,7 +596,7 @@  -- | Introduce a local definition for a (possibly imported) identifier. -- Rewrites occurences of the identifier to point to this new local definiton.-letIntroUnfoldingR :: ( BoundVars c, ReadBindings c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m+letIntroUnfoldingR :: ( BoundVars c, ReadBindings c, HasDynFlags m, HasHermitMEnv m, LiftCoreM m                       , MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )                    => HermitName -> Rewrite c m CoreExpr letIntroUnfoldingR nm = do

@@ -5,6 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module HERMIT.Dictionary.Navigation     ( -- * Navigation@@ -36,7 +37,7 @@ import HERMIT.External import HERMIT.GHC hiding ((<>)) import HERMIT.Kure-import HERMIT.Lemma(Quantified(..))+import HERMIT.Lemma(Clause(..)) import HERMIT.Name  import HERMIT.Dictionary.Navigation.Crumbs@@ -84,7 +85,7 @@ -----------------------------------------------------------------------  -- | Find the path to the RHS of a binding.-rhsOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m LCoreTC LocalPathH+rhsOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, LemmaContext c, MonadCatch m) => (Var -> Bool) -> Transform c m LCoreTC LocalPathH rhsOfT p = prefixFailMsg ("rhs-of failed: ") $            do lp <- onePathToT (arr $ bindingOf p . inject)               case lastCrumb lp of@@ -96,23 +97,23 @@                 Nothing -> promoteCoreT (defOrNonRecT successT lastCrumbT (\ () cr -> mempty @@ cr))  -- | Find the path to the binding group of a variable.-bindingGroupOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m LCoreTC LocalPathH+bindingGroupOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, LemmaContext c, MonadCatch m) => (Var -> Bool) -> Transform c m LCoreTC LocalPathH bindingGroupOfT p = prefixFailMsg ("binding-group-of failed: ") $                     oneNonEmptyPathToT (promoteBindT $ arr $ bindingGroupOf p)  -- | Find the path to the binding of a variable.-bindingOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => (Var -> Bool) -> Transform c m LCoreTC LocalPathH+bindingOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, LemmaContext c, MonadCatch m) => (Var -> Bool) -> Transform c m LCoreTC LocalPathH bindingOfT p = prefixFailMsg ("binding-of failed: ") $                oneNonEmptyPathToT (arr $ bindingOf p)  -- | Find the path to the first occurrence of a variable.-occurrenceOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m)+occurrenceOfT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, LemmaContext c, MonadCatch m)               => (Var -> Bool) -> Transform c m LCoreTC LocalPathH occurrenceOfT p = prefixFailMsg ("occurrence-of failed: ") $                   oneNonEmptyPathToT (arr $ occurrenceOf p)  -- | Find the path to an application of a given function.-applicationOfT :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, MonadCatch m, ReadPath c Crumb)+applicationOfT :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, MonadCatch m, LemmaContext c, ReadPath c Crumb)                => (Var -> Bool) -> Transform c m LCoreTC LocalPathH applicationOfT p = prefixFailMsg "application-of failed:" $ oneNonEmptyPathToT go     where go = promoteExprT (appT (extractT go) successT const) <+ arr (occurrenceOf p)@@ -127,13 +128,12 @@ bindingOf :: (Var -> Bool) -> LCoreTC -> Bool bindingOf p = any p . varSetElems . binders --- TODO: check this is correct, written in a hurry binders :: LCoreTC -> VarSet-binders (LTCCore (LQuantified (Quantified 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 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  bindersCore :: Core -> VarSet bindersCore (BindCore bnd)  = binderBind bnd@@ -188,19 +188,19 @@ -----------------------------------------------------------------------  -- | Find all possible targets of 'occurrenceOfT'.-occurrenceOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m LCoreTC VarSet+occurrenceOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, LemmaContext c, MonadCatch m) => Transform c m LCoreTC VarSet occurrenceOfTargetsT = allT $ crushbuT (arr varOccurrence >>> projectT >>^ unitVarSet)  -- | Find all possible targets of 'bindingOfT'.-bindingOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m LCoreTC VarSet+bindingOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, LemmaContext c, MonadCatch m) => Transform c m LCoreTC VarSet bindingOfTargetsT = allT $ crushbuT (arr binders)  -- | Find all possible targets of 'bindingGroupOfT'.-bindingGroupOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m LCoreTC VarSet+bindingGroupOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, LemmaContext c, MonadCatch m) => Transform c m LCoreTC VarSet bindingGroupOfTargetsT = allT $ crushbuT (promoteBindT $ arr (mkVarSet . bindVars))  -- | Find all possible targets of 'rhsOfT'.-rhsOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m) => Transform c m LCoreTC VarSet+rhsOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, LemmaContext c, MonadCatch m) => Transform c m LCoreTC VarSet rhsOfTargetsT = crushbuT (promoteBindT (arr binderBind) <+ promoteDefT (arr binderDef))  -----------------------------------------------------------------------@@ -235,7 +235,7 @@                   ]  -- | Find the path to the first matching construct.-considerConstructT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Considerable -> Transform c m LCore LocalPathH+considerConstructT :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, LemmaContext c, MonadCatch m) => Considerable -> Transform c m LCore LocalPathH considerConstructT con = oneNonEmptyPathToT (arr $ underConsiderationLCore con)  string2considerable :: String -> Maybe Considerable@@ -280,22 +280,22 @@   setEmptyContext ec = ec { baseContext = setEmptyContext (baseContext ec)                           , extraContext = mempty } -exhaustRepeatCrumbT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext 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, Walker c LCoreTC, 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 lambdas.-lamsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, Walker c LCoreTC, MonadCatch m) => Transform c m CoreExpr LocalPathH+lamsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, Walker c LCoreTC, 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, Walker c LCoreTC, MonadCatch m) => Transform c m CoreExpr LocalPathH+letsBodyT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, Walker c LCoreTC, 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, Walker c LCoreTC, MonadCatch m) => Transform c m CoreProg LocalPathH+progEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, Walker c LCoreTC, 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, Walker c LCoreTC, MonadCatch m) => Transform c m ModGuts LocalPathH+gutsProgEndT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, Walker c LCoreTC, MonadCatch m) => Transform c m ModGuts LocalPathH gutsProgEndT = modGutsT progEndT (\ _ p -> (mempty @@ ModGuts_Prog) <> p)

@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, LambdaCase, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}  module HERMIT.Dictionary.Query     ( -- * Queries and Predicates@@ -163,7 +164,7 @@ --------------------------------------------------------  -- | 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, MonadCatch m) => Transform c m LCoreTC LocalPathH -> Transform c m LCoreTC LocalPathH -> Transform c m LCoreTC ()+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 p1T p2T =   do p1 <- p1T      p2 <- p2T

@@ -1,9 +1,9 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -19,7 +19,6 @@     , extensionalityR     , getLemmasT     , getLemmaByNameT-    , getObligationNotProvenT     , insertLemmaT     , insertLemmasT     , lemmaBiR@@ -30,32 +29,44 @@     , showLemmaT     , showLemmasT     , ppLemmaT-    , ppQuantifiedT+    , ppClauseT     , ppLCoreTCT-      -- ** Lifting transformations over 'Quantified'+      -- ** Lifting transformations over 'Clause'     , lhsT     , rhsT     , bothT     , lhsR     , rhsR     , bothR-    , verifyQuantifiedT-    , verifyEquivalentT+    , verifyClauseT+    , lemmaR+    , quantIdentitiesR     , verifyOrCreateT     , verifyEqualityLeftToRightT     , verifyEqualityCommonTargetT     , verifyIsomorphismT     , verifyRetractionT+    , reflexivityR+    , simplifyClauseR     , retractionBR-    , unshadowQuantifiedR+    , unshadowClauseR     , instantiateDictsR-    , instantiateQuantifiedVarR-    , abstractQuantifiedR-    , discardUniVars+    , instantiateClauseVarR+    , abstractClauseR+      -- * Constructing Composite Lemmas+    , ($$)+    , ($$$)+    , (==>)+    , (-->)+    , (===)+    , (/\)+    , (\/)+    , ToCoreExpr(..)+    , newLemma     ) where  import           Control.Arrow hiding ((<+>))-import           Control.Monad+import           Control.Monad ((>=>), forM, liftM)  import           Data.Either (partitionEithers) import           Data.List (isInfixOf, nubBy)@@ -66,7 +77,7 @@ import           HERMIT.Context import           HERMIT.Core import           HERMIT.External-import           HERMIT.GHC hiding ((<>), (<+>), nest, ($+$))+import           HERMIT.GHC hiding ((<>), (<+>), nest, ($+$), ($$)) import           HERMIT.Kure import           HERMIT.Lemma import           HERMIT.Monad@@ -74,14 +85,16 @@ import           HERMIT.ParserCore import           HERMIT.ParserType import           HERMIT.PrettyPrinter.Common-import           HERMIT.PrettyPrinter.Clean (symbol) -- this should be in Common import           HERMIT.Utilities  import           HERMIT.Dictionary.Common import           HERMIT.Dictionary.Fold hiding (externals)+import           HERMIT.Dictionary.Function hiding (externals) import           HERMIT.Dictionary.GHC hiding (externals) import           HERMIT.Dictionary.Local.Let (nonRecIntroR) +import           Prelude.Compat hiding ((<$>), (<*>))+ import qualified Text.PrettyPrint.MarkedHughesPJ as PP  ------------------------------------------------------------------------------@@ -97,7 +110,7 @@         , "f (g y) <==> y."         , "Note that the precondition (f (g y) == y) is expected to hold."         ] .+ Shallow .+ PreCondition-    , external "unshadow-quantified" (promoteQuantifiedR unshadowQuantifiedR :: RewriteH LCoreTC)+    , external "unshadow-quantified" (promoteClauseR unshadowClauseR :: RewriteH LCoreTC)         [ "Unshadow a quantified clause." ]     , external "merge-quantifiers" (\n1 n2 -> promoteR (mergeQuantifiersR (cmpHN2Var n1) (cmpHN2Var n2)) :: RewriteH LCore)         [ "Merge quantifiers from two clauses if they have the same type."@@ -122,7 +135,7 @@         [ "Generate a rewrite from a lemma, left-to-right." ]     , external "lemma-backward" (backwardT . promoteExprBiR . lemmaBiR Obligation :: LemmaName -> RewriteH LCore)         [ "Generate a rewrite from a lemma, right-to-left." ]-    , external "lemma-consequent" (promoteQuantifiedR . lemmaConsequentR Obligation :: LemmaName -> RewriteH LCore)+    , external "lemma-consequent" (promoteClauseR . lemmaConsequentR Obligation :: LemmaName -> RewriteH LCore)         [ "Match the current lemma with the consequent of an implication lemma."         , "Upon success, replaces with antecedent of the implication, properly instantiated." ]     , external "lemma-consequent-birewrite" (promoteExprBiR . lemmaConsequentBiR Obligation :: LemmaName -> BiRewriteH LCore)@@ -134,21 +147,21 @@     , external "lemma-rhs-intro" (promoteCoreR . lemmaRhsIntroR :: LemmaName -> RewriteH LCore)         [ "Introduce the RHS of a lemma as a non-recursive binding, in either an expression or a program."         , "body ==> let v = rhs in body" ] .+ Introduce .+ Shallow-    , external "inst-lemma" (\ nm v cs -> modifyLemmaT nm id (instantiateQuantifiedVarR (cmpHN2Var v) cs) id id :: TransformH LCore ())+    , external "inst-lemma" (\ nm v cs -> modifyLemmaT nm id (instantiateClauseVarR (cmpHN2Var v) cs) id id :: TransformH LCore ())         [ "Instantiate one of the universally quantified variables of the given lemma,"         , "with the given Core expression, creating a new lemma. Instantiating an"         , "already proven lemma will result in the new lemma being considered proven." ]-    , external "inst-dictionaries" (promoteQuantifiedR instantiateDictsR :: RewriteH LCore)+    , external "inst-dictionaries" (promoteClauseR instantiateDictsR :: RewriteH LCore)         [ "Instantiate all of the universally quantified dictionaries of the given lemma." ]-    , external "abstract" ((\nm -> promoteQuantifiedR . abstractQuantifiedR nm . csInQBodyT) :: String -> CoreString -> RewriteH LCore)+    , external "abstract-forall" ((\nm -> promoteClauseR . abstractClauseR nm . csInQBodyT) :: String -> CoreString -> RewriteH LCore)         [ "Weaken a lemma by abstracting an expression to a new quantifier." ]-    , external "abstract" ((\nm rr -> promoteQuantifiedR $ abstractQuantifiedR nm $ extractT rr >>> setFailMsg "path must focus on an expression" projectT) :: String -> RewriteH LCore -> RewriteH LCore)+    , external "abstract-forall" ((\nm rr -> promoteClauseR $ abstractClauseR nm $ extractT rr >>> setFailMsg "path must focus on an expression" projectT) :: String -> RewriteH LCore -> RewriteH LCore)         [ "Weaken a lemma by abstracting an expression to a new quantifier." ]     , external "copy-lemma" (\ nm newName -> modifyLemmaT nm (const newName) idR id id :: TransformH LCore ())         [ "Copy a given lemma, with a new name." ]     , external "modify-lemma" ((\ nm rr -> modifyLemmaT nm id (extractR rr) (const NotProven) (const NotUsed)) :: LemmaName -> RewriteH LCore -> TransformH LCore ())         [ "Modify a given lemma. Resets proven status to Not Proven and used status to Not Used." ]-    , external "query-lemma" ((\ nm t -> getLemmaByNameT nm >>> arr lemmaQ >>> extractT t) :: LemmaName -> TransformH LCore String -> TransformH LCore String)+    , external "query-lemma" ((\ nm t -> getLemmaByNameT nm >>> arr lemmaC >>> extractT t) :: LemmaName -> TransformH LCore String -> TransformH LCore String)         [ "Apply a transformation to a lemma, returning the result." ]     , external "show-lemma" ((\pp n -> showLemmaT n pp) :: PrettyPrinter -> LemmaName -> PrettyH LCore)         [ "Display a lemma." ]@@ -161,18 +174,28 @@         , "f == g  ==>  forall x.  f x == g x" ]     , external "extensionality" (promoteR (extensionalityR Nothing) :: RewriteH LCore)         [ "f == g  ==>  forall x.  f x == g x" ]-    , external "lhs" (promoteQuantifiedR . lhsR :: RewriteH LCore -> RewriteH LCore)-        [ "Apply a rewrite to the LHS of a quantified clause." ]-    , external "lhs" (promoteQuantifiedT . lhsT :: TransformH LCore String -> TransformH LCore String)+    , external "lhs" (promoteClauseT . lhsT :: TransformH LCore String -> TransformH LCore String)         [ "Apply a transformation to the LHS of a quantified clause." ]-    , external "rhs" (promoteQuantifiedR . rhsR :: RewriteH LCore -> RewriteH LCore)-        [ "Apply a rewrite to the RHS of a quantified clause." ]-    , external "rhs" (promoteQuantifiedT . rhsT :: TransformH LCore String -> TransformH LCore String)+    , external "lhs" (promoteClauseR . lhsR :: RewriteH LCore -> RewriteH LCore)+        [ "Apply a rewrite to the LHS of a quantified clause." ]+    , external "rhs" (promoteClauseT . rhsT :: TransformH LCore String -> TransformH LCore String)         [ "Apply a transformation to the RHS of a quantified clause." ]-    , external "both" (promoteQuantifiedR . bothR :: RewriteH LCore -> RewriteH LCore)+    , external "rhs" (promoteClauseR . rhsR :: RewriteH LCore -> RewriteH LCore)+        [ "Apply a rewrite to the RHS of a quantified clause." ]+    , external "both" (promoteClauseR . bothR :: RewriteH LCore -> RewriteH LCore)         [ "Apply a rewrite to both sides of an equality, succeeding if either succeed." ]-    , external "both" ((\t -> do (r,s) <- promoteQuantifiedT (bothT t); return (unlines [r,s])) :: TransformH LCore String -> TransformH LCore String)+    , 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)+        [ "Rewrite alpha-equivalence to true." ]+    , external "simplify-lemma" (simplifyClauseR :: RewriteH LCore)+        [ "Reduce a proof by applying reflexivity and logical operator identities." ]+    , external "split-antecedent" (promoteClauseR splitAntecedentR :: RewriteH LCore)+        [ "Split an implication of the form (q1 ^ q2) => q3 into q1 => (q2 => q3)" ]+    , external "lemma" (promoteClauseR . lemmaR Obligation :: LemmaName -> RewriteH LCore)+        [ "Rewrite clause to true using given lemma." ]+    , external "lemma-unsafe" (promoteClauseR . lemmaR UnsafeUsed :: LemmaName -> RewriteH LCore)+        [ "Rewrite clause to true using given lemma." ] .+ Unsafe     ]  ------------------------------------------------------------------------------@@ -180,9 +203,9 @@ type EqualityProof c m = (Rewrite c m CoreExpr, Rewrite c m CoreExpr)  -- | f == g  ==>  forall x.  f x == g x-extensionalityR :: Maybe String -> Rewrite c HermitM Quantified+extensionalityR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb) => Maybe String -> Rewrite c HermitM Clause extensionalityR mn = prefixFailMsg "extensionality failed: " $-  do Quantified vs (Equiv lhs rhs) <- idR+  do (vs,(lhs,rhs)) <- forallT idR (equivT idR idR (,)) (,) <+ equivT idR idR (\l r -> ([],(l,r)))       let tyL = exprKindOrType lhs          tyR = exprKindOrType rhs@@ -194,64 +217,68 @@       let x = varToCoreExpr v -     return $ Quantified (vs ++ [v]) $ Equiv (mkCoreApp lhs x) (mkCoreApp rhs x)+     return $ Forall (vs ++ [v]) $ Equiv (mkCoreApp lhs x) (mkCoreApp rhs x)  ------------------------------------------------------------------------------  -- | @e@ ==> @let v = lhs in e@-eqLhsIntroR :: Quantified -> Rewrite c HermitM Core-eqLhsIntroR (Quantified bs (Equiv lhs _)) = nonRecIntroR "lhs" (mkCoreLams bs lhs)-eqLhsIntroR _                             = fail "compound lemmas not supported."+eqLhsIntroR :: Clause -> Rewrite c HermitM Core+eqLhsIntroR (Forall bs (Equiv lhs _)) = nonRecIntroR "lhs" (mkCoreLams bs lhs)+eqLhsIntroR _                         = fail "compound lemmas not supported."  -- | @e@ ==> @let v = rhs in e@-eqRhsIntroR :: Quantified -> Rewrite c HermitM Core-eqRhsIntroR (Quantified bs (Equiv _ rhs)) = nonRecIntroR "rhs" (mkCoreLams bs rhs)-eqRhsIntroR _                             = fail "compound lemmas not supported."+eqRhsIntroR :: Clause -> Rewrite c HermitM Core+eqRhsIntroR (Forall bs (Equiv _ rhs)) = nonRecIntroR "rhs" (mkCoreLams bs rhs)+eqRhsIntroR _                         = fail "compound lemmas not supported."  ------------------------------------------------------------------------------ --- | Create a 'BiRewrite' from a 'Quantified'.+-- | Create a 'BiRewrite' from a 'Clause'. birewrite :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c              , ReadPath c Crumb, MonadCatch m, MonadUnique m )-          => Quantified -> BiRewrite c m CoreExpr-birewrite q = bidirectional (foldUnfold "left" id) (foldUnfold "right" flipEquality)+          => 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")-                                . fold (map f (toEqualities q)) c+                                . fold (map f (toEqualities cl)) c  ------------------------------------------------------------------------------ -- TODO: deprecate these? -- Yes, but later.  They're in the paper now. -- We should be using "childR crumb", really. --- | Lift a transformation over 'LCoreTC' into a transformation over the left-hand side of a 'Quantified'.-lhsT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Monad m)-     => Transform c m LCore a -> Transform c m Quantified a-lhsT t = quantifiedT successT (clauseT t successT (\_ l _ -> l)) (flip const)+-- | 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] ] --- | Lift a transformation over 'LCoreTC' into a transformation over the right-hand side of a 'Quantified'.-rhsT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Monad m)-     => Transform c m LCore a -> Transform c m Quantified a-rhsT t = quantifiedT successT (clauseT successT t (\_ _ r -> r)) (flip const)+-- | 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] ] --- | Lift a transformation over 'LCoreTC' into a transformation over both sides of a 'Quantified'.-bothT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Monad m)-      => Transform c m LCore a -> Transform c m Quantified (a, a)-bothT t = quantifiedT successT (clauseT t t (const (,))) (flip const)+-- | 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)+      => Transform c m LCore a -> Transform c m Clause (a, a)+bothT t = (,) <$> lhsT t <*> rhsT t --- | Lift a rewrite over 'LCoreTC' into a rewrite over the left-hand side of a 'Quantified'.-lhsR :: (AddBindings c, Monad m, ReadPath c Crumb, ExtendPath c Crumb)-     => Rewrite c m LCore -> Rewrite c m Quantified-lhsR r = quantifiedR idR (clauseR r idR)+-- | 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] ] --- | Lift a rewrite over 'LCoreTC' into a rewrite over the right-hand side of a 'Quantified'.-rhsR :: (AddBindings c, Monad m, ReadPath c Crumb, ExtendPath c Crumb)-     => Rewrite c m LCore -> Rewrite c m Quantified-rhsR r = quantifiedR idR (clauseR idR r)+-- | 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] ] --- | Lift a rewrite over 'LCoreTC' into a rewrite over both sides of a 'Quantified'.-bothR :: (AddBindings c, MonadCatch m, ReadPath c Crumb, ExtendPath c Crumb)-      => Rewrite c m LCore -> Rewrite c m Quantified+-- | 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)+      => Rewrite c m LCore -> Rewrite c m Clause bothR r = lhsR r >+> rhsR r  ------------------------------------------------------------------------------@@ -268,60 +295,113 @@  ppLemmaT :: PrettyPrinter -> LemmaName -> PrettyH Lemma ppLemmaT pp nm = do-    Lemma q p _u _t <- idR-    qDoc <- return q >>> ppQuantifiedT pp+    Lemma q p _u <- idR+    qDoc <- return q >>> ppClauseT 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 (ppQuantifiedT pp) <+ promoteT (ppClauseT pp) <+ promoteT (pCoreTC pp)--ppQuantifiedT :: PrettyPrinter -> PrettyH Quantified-ppQuantifiedT pp = do-    (d1,d2) <- quantifiedT (pForall pp) (ppClauseT pp) (,)-    return $ PP.sep [d1,d2]+ppLCoreTCT pp = promoteT (ppClauseT pp) <+ promoteT (pCoreTC pp)  ppClauseT :: PrettyPrinter -> PrettyH Clause ppClauseT pp = do-    let t = absPathT &&& (promoteT (ppQuantifiedT pp) <+ promoteT (extractT (pCoreTC pp) :: PrettyH Core)) -- TODO: temporary hack, need to think about what's going on here and fix it-        parenify (p1,d1) (p2,d2) o = ( symbol p1 '(' PP.<> d1 PP.<> symbol p1 ')'-                                     , symbol p2 '(' PP.<> d2 PP.<> symbol p2 ')'-                                     , syntaxColor (PP.text o)-                                     )-    (d1,d2,oper) <- clauseT t t (\ cl r1 r2 ->-                                    case cl of-                                        Conj {} -> parenify r1 r2 "^"-                                        Disj {} -> parenify r1 r2 "v"-                                        Impl {} -> parenify r1 r2 "=>"-                                        Equiv {} -> (snd r1, snd r2, syntaxColor $ PP.text "="))-    return $ PP.sep [d1,oper,d2]+    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"))  ------------------------------------------------------------------------------ -verifyQuantifiedT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, MonadCatch m) => Transform c m Quantified ()-verifyQuantifiedT = quantifiedT successT verifyClauseT (flip const)- verifyClauseT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, MonadCatch m) => Transform c m Clause ()-verifyClauseT =-    readerT (\case Conj  q1 q2 -> (return q1 >>> verifyQuantifiedT) >> (return q2 >>> verifyQuantifiedT)-                   Disj  q1 q2 -> (return q1 >>> verifyQuantifiedT) <+ (return q2 >>> verifyQuantifiedT)-                   Impl  _  _  -> fail "verifyClauseT: Impl TODO"-                   Equiv e1 e2 -> guardMsg (exprAlphaEq e1 e2) "the two sides of the equality do not match.")+verifyClauseT = setFailMsg "verification failed: clause must be true (perhaps try reflexivity first)" $ do+    CTrue <- idR+    return () -verifyEquivalentT :: (HasLemmas m, MonadCatch m) => Used -> LemmaName -> Transform c m Quantified ()-verifyEquivalentT used nm = prefixFailMsg "verification failed: " $ do-    Lemma q _ _ _ <- getLemmaByNameT nm-    eq <- arr (q `proves`)+lemmaR :: (LemmaContext c, HasLemmas m, MonadCatch m) => Used -> LemmaName -> Rewrite c m Clause+lemmaR used nm = prefixFailMsg "verification failed: " $ do+    Lemma cl _ _ <- getLemmaByNameT nm+    eq <- arr (cl `proves`)     guardMsg eq "lemmas are not equivalent."     markLemmaUsedT nm used+    return CTrue -verifyOrCreateT :: (HasLemmas m, MonadCatch m) => Used -> LemmaName -> Lemma -> Transform c m a ()-verifyOrCreateT u nm l = do+verifyOrCreateT :: ( AddBindings c, ExtendPath c Crumb, 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     exists <- testM $ getLemmaByNameT nm     if exists-    then return (lemmaQ l) >>> verifyEquivalentT u nm-    else insertLemmaT nm l+    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+    Equiv lhs rhs <- idR+    guardMsg (exprAlphaEq lhs rhs) "the two sides are not alpha-equivalent."+    return CTrue++simplifyClauseR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadPath c Crumb, MonadCatch m)+                => Rewrite c m LCore+simplifyClauseR = anybuR (promoteR quantIdentitiesR <+ promoteR reflexivityR)++quantIdentitiesR :: MonadCatch m => Rewrite c m Clause+quantIdentitiesR =+    trueConjLR <+ trueConjRR <++    trueDisjLR <+ trueDisjRR <++    trueImpliesR <+ impliesTrueR <++    aImpliesAR <+ forallTrueR++trueConjLR :: Monad m => Rewrite c m Clause+trueConjLR = do+    Conj CTrue cl <- idR+    return cl++trueConjRR :: Monad m => Rewrite c m Clause+trueConjRR = do+    Conj cl CTrue <- idR+    return cl++trueDisjLR :: Monad m => Rewrite c m Clause+trueDisjLR = do+    Disj CTrue _ <- idR+    return CTrue++trueDisjRR :: Monad m => Rewrite c m Clause+trueDisjRR = do+    Disj _ CTrue <- idR+    return CTrue++trueImpliesR :: Monad m => Rewrite c m Clause+trueImpliesR = do+    Impl _ CTrue cl <- idR+    return cl++impliesTrueR :: Monad m => Rewrite c m Clause+impliesTrueR = do+    Impl _ _ CTrue <- idR+    return CTrue++forallTrueR :: Monad m => Rewrite c m Clause+forallTrueR = do+    Forall _ CTrue <- idR+    return CTrue++aImpliesAR :: Monad m => Rewrite c m Clause+aImpliesAR = do+    Impl _ a c <- idR+    guardMsg (a `proves` c) "antecedent does not prove consequent."+    return CTrue++splitAntecedentR :: MonadCatch m => Rewrite c m Clause+splitAntecedentR = prefixFailMsg "antecedent split failed: " $+                   withPatFailMsg (wrongExprForm "(ante1 ^ ante2) => con") $ do+    Impl nm (Conj c1 c2) con <- idR+    return $ Impl (nm <> "0") c1 $ Impl (nm <> "1") c2 con+ ------------------------------------------------------------------------------  -- TODO: everything between here and instantiateDictsR needs to be rethought/removed@@ -396,9 +476,9 @@ ------------------------------------------------------------------------------  -- TODO: revisit this for binder re-ordering issue-instantiateDictsR :: RewriteH Quantified+instantiateDictsR :: RewriteH Clause instantiateDictsR = prefixFailMsg "Dictionary instantiation failed: " $ do-    bs <- forallVarsT idR+    bs <- forallT idR successT const     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."@@ -420,44 +500,44 @@                 if b `elem` uniqDs                 then return $ lookup2 b ds                 else buildSubst b-    transform (\ c -> instsQuantified (boundVars c) allDs) >>> arr redundantDicts+    transform (\ c -> instsClause (boundVars c) allDs) >>> arr redundantDicts  ------------------------------------------------------------------------------ -conjunctLemmasT :: (HasLemmas m, Monad m) => LemmaName -> LemmaName -> LemmaName -> Transform c m a ()+conjunctLemmasT :: (LemmaContext c, HasLemmas m, Monad m) => LemmaName -> LemmaName -> LemmaName -> Transform c m a () conjunctLemmasT new lhs rhs = do-    Lemma ql pl _ tl <- getLemmaByNameT lhs-    Lemma qr pr _ tr <- getLemmaByNameT rhs-    insertLemmaT new $ Lemma (Quantified [] (Conj ql qr)) (pl `andP` pr) NotUsed (tl || tr)+    Lemma ql pl _ <- getLemmaByNameT lhs+    Lemma qr pr _ <- getLemmaByNameT rhs+    insertLemmaT new $ Lemma (Conj ql qr) (pl `andP` pr) NotUsed -disjunctLemmasT :: (HasLemmas m, Monad m) => LemmaName -> LemmaName -> LemmaName -> Transform c m a ()+disjunctLemmasT :: (LemmaContext c, HasLemmas m, Monad m) => LemmaName -> LemmaName -> LemmaName -> Transform c m a () disjunctLemmasT new lhs rhs = do-    Lemma ql pl _ tl <- getLemmaByNameT lhs-    Lemma qr pr _ tr <- getLemmaByNameT rhs-    insertLemmaT new $ Lemma (Quantified [] (Disj ql qr)) (pl `orP` pr) NotUsed (tl || tr)+    Lemma ql pl _ <- getLemmaByNameT lhs+    Lemma qr pr _ <- getLemmaByNameT rhs+    insertLemmaT new $ Lemma (Disj ql qr) (pl `orP` pr) NotUsed -implyLemmasT :: (HasLemmas m, Monad m) => LemmaName -> LemmaName -> LemmaName -> Transform c m a ()+implyLemmasT :: (LemmaContext c, HasLemmas m, Monad m) => LemmaName -> LemmaName -> LemmaName -> Transform c m a () implyLemmasT new lhs rhs = do-    Lemma ql _  _ tl <- getLemmaByNameT lhs-    Lemma qr pr _ tr <- getLemmaByNameT rhs-    insertLemmaT new $ Lemma (Quantified [] (Impl ql qr)) pr NotUsed (tl || tr)+    Lemma ql _  _ <- getLemmaByNameT lhs+    Lemma qr pr _ <- getLemmaByNameT rhs+    insertLemmaT new $ Lemma (Impl lhs ql qr) pr NotUsed  ------------------------------------------------------------------------------ -mergeQuantifiersR :: MonadCatch m => (Var -> Bool) -> (Var -> Bool) -> Rewrite c m Quantified+mergeQuantifiersR :: MonadCatch m => (Var -> Bool) -> (Var -> Bool) -> Rewrite c m Clause mergeQuantifiersR pl pr = contextfreeT $ mergeQuantifiers pl pr -mergeQuantifiers :: MonadCatch m => (Var -> Bool) -> (Var -> Bool) -> Quantified -> m Quantified-mergeQuantifiers pl pr (Quantified bs cl) = prefixFailMsg "merge-quantifiers failed: " $ do-    (con,lq@(Quantified bsl cll),rq@(Quantified bsr clr)) <- case cl of+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         Conj q1 q2 -> return (Conj,q1,q2)         Disj q1 q2 -> return (Disj,q1,q2)-        Impl q1 q2 -> return (Impl,q1,q2)+        Impl nm q1 q2 -> return (Impl nm,q1,q2)         _ -> fail "no quantifiers on either side."      let (lBefore,lbs) = break pl bsl         (rBefore,rbs) = break pr bsr-        check b q l r = guardMsg (not (b `elemVarSet` freeVarsQuantified q)) $+        check b q l r = guardMsg (not (b `elemVarSet` freeVarsClause q)) $                                  "specified "++l++" binder would capture in "++r++"-hand clause."         checkUB v vs = let fvs = freeVarsVar v                        in guardMsg (not (any (`elemVarSet` fvs) vs)) $ "binder " ++ getOccString v ++@@ -468,11 +548,11 @@         ([],rb:rAfter) -> do             check rb lq "right" "left"             checkUB rb rBefore-            return $ Quantified (bs++[rb]) $ con lq (Quantified (rBefore++rAfter) clr)+            return $ mkForall [rb] $ con lq (mkForall (rBefore++rAfter) clr)         (lb:lAfter,[]) -> do             check lb rq "left" "right"             checkUB lb lBefore-            return $ Quantified (bs++[lb]) $ con (Quantified (lBefore++lAfter) cll) rq+            return $ mkForall [lb] $ con (mkForall (lBefore++lAfter) cll) rq         (lb:lAfter,rb:rAfter) -> do             guardMsg (eqType (varType lb) (varType rb)) "specified quantifiers have differing types."             check lb rq "left" "right"@@ -480,26 +560,43 @@             checkUB lb lBefore             checkUB rb rBefore -            let Quantified partial clr' = substQuantified rb (varToCoreExpr lb) $ Quantified rAfter clr-                rq' = Quantified (rBefore ++ partial) clr'-                lq' = Quantified (lBefore ++ lAfter) cll+            let clr' = substClause rb (varToCoreExpr lb) $ mkForall rAfter clr+                rq' = mkForall rBefore clr'+                lq' = mkForall (lBefore ++ lAfter) cll -            return $ Quantified (bs++[lb]) (con lq' rq')+            return $ mkForall [lb] (con lq' rq')  ------------------------------------------------------------------------------ -unshadowQuantifiedR :: MonadUnique m => Rewrite c m Quantified-unshadowQuantifiedR = contextfreeT unshadowQuantified+unshadowClauseR :: MonadUnique m => Rewrite c m Clause+unshadowClauseR = contextfreeT unshadowClause -unshadowQuantified :: MonadUnique m => Quantified -> m Quantified-unshadowQuantified q = go emptySubst (mapUniqSet fs (freeVarsQuantified q)) q+unshadowClause :: MonadUnique m => Clause -> m Clause+unshadowClause c = go emptySubst (mapUniqSet fs (freeVarsClause c)) c     where fs = occNameFS . getOccName -          go subst seen (Quantified bs cl) = go1 subst seen bs [] cl+          go subst seen (Forall bs cl) = go1 subst seen bs [] cl+          go subst seen (Conj q1 q2) = do+            q1' <- go subst seen q1+            q2' <- go subst seen q2+            return $ Conj q1' q2'+          go subst seen (Disj q1 q2) = do+            q1' <- go subst seen q1+            q2' <- go subst seen q2+            return $ Disj q1' q2'+          go subst seen (Impl nm q1 q2) = do+            q1' <- go subst seen q1+            q2' <- go subst seen q2+            return $ Impl nm q1' q2'+          go subst _ (Equiv e1 e2) =+            let e1' = substExpr (text "unshadowClause e1") subst e1+                e2' = substExpr (text "unshadowClause e2") subst e2+            in return $ Equiv e1' e2'+          go _ _ CTrue = return CTrue            go1 subst seen []     bs' cl = do-            cl' <- go2 subst seen cl-            return $ Quantified (reverse bs') cl'+            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'@@ -508,22 +605,6 @@                 where fsb = fs b'                       (subst', b') = substBndr subst b -          go2 subst seen (Conj q1 q2) = do-            q1' <- go subst seen q1-            q2' <- go subst seen q2-            return $ Conj q1' q2'-          go2 subst seen (Disj q1 q2) = do-            q1' <- go subst seen q1-            q2' <- go subst seen q2-            return $ Disj q1' q2'-          go2 subst seen (Impl q1 q2) = do-            q1' <- go subst seen q1-            q2' <- go subst seen q2-            return $ Impl q1' q2'-          go2 subst _ (Equiv e1 e2) =-            let e1' = substExpr (text "unshadowQuantified e1") subst e1-                e2' = substExpr (text "unshadowQuantified e2") subst e2-            in return $ Equiv e1' e2'  inventNames :: UniqSet FastString -> FastString -> FastString inventNames s nm = head [ nm' | i :: Int <- [0..]@@ -532,97 +613,96 @@  ------------------------------------------------------------------------------ -instantiateQuantifiedVarR :: (Var -> Bool) -> CoreString -> RewriteH Quantified-instantiateQuantifiedVarR p cs = prefixFailMsg "instantiation failed: " $ do-    bs <- forallVarsT idR+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-    transform (\ c -> instQuantified (boundVars c) p e) >>> (lintQuantifiedT >> idR) -- lint for sanity+    transform (\ c -> instClause (boundVars c) p e) >>> (lintClauseT >> idR) -- lint for sanity  ------------------------------------------------------------------------------  -- | Replace all occurrences of the given expression with a new quantified variable.-abstractQuantifiedR :: forall c m.+abstractClauseR :: forall c m.                        ( AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb-                       , HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadUnique m )-                    => String -> Transform c m Quantified CoreExpr -> Rewrite c m Quantified-abstractQuantifiedR nm tr = prefixFailMsg "abstraction failed: " $ do+                       , LemmaContext c, HasHermitMEnv m, HasLemmas m, 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-    Quantified bs cl <- idR+    cl <- idR     b <- constT $ newVarH 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 (Quantified (bs++[b]) cl) >>>+    liftM dropBinders $ return (mkForall [b] cl) >>>                             extractR (anytdR $ promoteExprR $ runFoldR f :: Rewrite c m LCoreTC) -csInQBodyT :: ( AddBindings c, ReadBindings c, ReadPath c Crumb, HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m ) => CoreString -> Transform c m Quantified CoreExpr-csInQBodyT cs = do-    Quantified bs _ <- idR-    withVarsInScope bs $ parseCoreExprT cs+csInQBodyT :: ( AddBindings c, ExtendPath c Crumb, ReadBindings c, ReadPath c Crumb, HasHermitMEnv m, HasLemmas m, LiftCoreM m ) => CoreString -> Transform c m Clause CoreExpr+csInQBodyT cs = forallT successT (parseCoreExprT cs) (flip const)  ------------------------------------------------------------------------------ -getLemmasT :: HasLemmas m => Transform c m x Lemmas-getLemmasT = constT getLemmas+getLemmasT :: (LemmaContext c, HasLemmas m, Monad m) => Transform c m x Lemmas+getLemmasT = contextonlyT $ \ c -> liftM (Map.union (getAntecedents c)) getLemmas -getLemmaByNameT :: (HasLemmas m, Monad m) => LemmaName -> Transform c m x Lemma+getLemmaByNameT :: (LemmaContext c, HasLemmas m, Monad m) => LemmaName -> Transform c m x Lemma getLemmaByNameT nm = getLemmasT >>= maybe (fail $ "No lemma named: " ++ show nm) return . Map.lookup nm -getObligationNotProvenT :: (HasLemmas m, Monad m) => Transform c m x [NamedLemma]-getObligationNotProvenT = do-    ls <- getLemmasT-    return [ (nm,l) | (nm, l@(Lemma _ NotProven Obligation _)) <- Map.toList ls ]- ------------------------------------------------------------------------------ -lemmaBiR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb+lemmaBiR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb             , HasLemmas m, MonadCatch m, MonadUnique m)          => Used -> LemmaName -> BiRewrite c m CoreExpr-lemmaBiR u nm = afterBiR (beforeBiR (getLemmaByNameT nm) (birewrite . lemmaQ)) (markLemmaUsedT nm u >> idR)+lemmaBiR u nm = afterBiR (beforeBiR (getLemmaByNameT nm) (birewrite . lemmaC)) (markLemmaUsedT nm u >> idR) -lemmaConsequentR :: forall c m. ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c+lemmaConsequentR :: forall c m. ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c                                 , ReadPath c Crumb, HasLemmas m, MonadCatch m, MonadUnique m)-                 => Used -> LemmaName -> Rewrite c m Quantified+                 => Used -> LemmaName -> Rewrite c m Clause lemmaConsequentR u nm = prefixFailMsg "lemma-consequent failed:" $                         withPatFailMsg "lemma is not an implication." $ do-    Quantified hs (Impl ante con) <- lemmaQ <$> getLemmaByNameT nm-    q' <- transform $ \ c q -> do-        m <- maybeM ("consequent did not match.") $ lemmaMatch hs con q+    (hs,ante,pat) <- (getLemmaByNameT nm >>^ lemmaC) >>= \case Forall bs (Impl _ ante con) -> return (bs,ante,con)+                                                               Impl _ ante con             -> return ([],ante,con)+    cl' <- transform $ \ c cl -> do+        m <- maybeM ("consequent did not match.") $ lemmaMatch hs pat cl         subs <- maybeM ("some quantifiers not instantiated.") $                 mapM (\h -> (h,) <$> lookupVarEnv m h) hs-        let q' = substQuantifieds subs ante-        guardMsg (all (inScope c) $ varSetElems (freeVarsQuantified q'))+        let cl' = substClauses subs ante+        guardMsg (all (inScope c) $ varSetElems (freeVarsClause cl'))                  "some variables in result would be out of scope."-        return q'+        return cl'     markLemmaUsedT nm u-    return q'+    return cl' -lemmaConsequentBiR :: forall c m. ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c-                                  , ReadPath c Crumb, HasLemmas m, MonadCatch m, MonadUnique m)+lemmaConsequentBiR :: forall c m. ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, HasEmptyContext c, LemmaContext c+                                  , ReadBindings c, ReadPath c Crumb, HasHermitMEnv m, HasLemmas m, LiftCoreM m+                                  , MonadCatch m, MonadUnique m)                    => Used -> LemmaName -> BiRewrite c m CoreExpr-lemmaConsequentBiR u nm = afterBiR (beforeBiR (getLemmaByNameT nm) (go . lemmaQ)) (markLemmaUsedT nm u >> idR)-    where go :: Quantified -> BiRewrite c m CoreExpr-          go (Quantified bs (Impl ante (Quantified bs' cl))) = do-            let eqs = toEqualities $ Quantified (bs++bs') cl -- consequent-                foldUnfold side f =-                    transform $ \ c e -> do-                        let cf = compileFold $ map f eqs-                        (e',hs) <- maybeM ("expression did not match "++side++"-hand side") $ runFoldMatches cf c e-                        let matches = [ case lookupVarEnv hs b of-                                            Nothing -> Left b-                                            Just arg -> Right (b,arg)-                                      | b <- bs ]-                            (unmatched, subs) = partitionEithers matches-                            Quantified aBs acl = substQuantifieds subs ante-                            q = Quantified (unmatched++aBs) acl-                        insertLemma (nm <> "-antecedent") $ Lemma q NotProven u True-                        return e'+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'+                eqs = toEqualities con'+                foldUnfold side f = do+                    (cl,e) <- transform $ \ c e -> do+                                let cf = compileFold $ map f eqs+                                (e',hs) <- maybeM ("expression did not match "++side++"-hand side") $ runFoldMatches cf c e+                                let matches = [ case lookupVarEnv hs b of+                                                    Nothing -> Left b+                                                    Just arg -> Right (b,arg)+                                              | b <- bs ]+                                    (unmatched, subs) = partitionEithers matches+                                    acl = substClauses subs ante+                                    cl = mkForall unmatched acl+                                return (cl,e')+                    verifyOrCreateT u anteNm cl+                    return e             bidirectional (foldUnfold "left" id) (foldUnfold "right" flipEquality)-          go _ = let t = fail $ show nm ++ " is not an implication."-                 in bidirectional t t+          go _ _ = let t = fail $ show nm ++ " is not an implication."+                   in bidirectional t t  ------------------------------------------------------------------------------ @@ -632,35 +712,86 @@ insertLemmasT :: (HasLemmas m, Monad m) => [NamedLemma] -> Transform c m a () insertLemmasT = constT . mapM_ (uncurry insertLemma) -modifyLemmaT :: (HasLemmas m, Monad m)+modifyLemmaT :: (LemmaContext c, HasLemmas m, Monad m)              => LemmaName              -> (LemmaName -> LemmaName) -- ^ modify lemma name-             -> Rewrite c m Quantified   -- ^ rewrite the quantified clause+             -> Rewrite c m Clause       -- ^ rewrite the quantified clause              -> (Proven -> Proven)       -- ^ modify proven status              -> (Used -> Used)           -- ^ modify used status              -> Transform c m a () modifyLemmaT nm nFn rr pFn uFn = do-    Lemma q p u t <- getLemmaByNameT nm-    q' <- rr <<< return q-    constT $ insertLemma (nFn nm) $ Lemma q' (pFn p) (uFn u) t+    Lemma cl p u <- getLemmaByNameT nm+    cl' <- rr <<< return cl+    constT $ insertLemma (nFn nm) $ Lemma cl' (pFn p) (uFn u) -markLemmaUsedT :: (HasLemmas m, Monad m) => LemmaName -> Used -> Transform c m a ()-markLemmaUsedT nm u = modifyLemmaT nm id idR id (const u)+markLemmaUsedT :: (LemmaContext c, HasLemmas m, MonadCatch m) => LemmaName -> Used -> Transform c m a ()+markLemmaUsedT nm u = ifM (lemmaExistsT nm) (modifyLemmaT nm id idR id (const u)) (return ()) -markLemmaProvenT :: (HasLemmas m, Monad m) => LemmaName -> Proven -> Transform c m a ()-markLemmaProvenT nm p = modifyLemmaT nm id idR (const p) id+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 nm = constT $ Map.member nm <$> getLemmas+ ------------------------------------------------------------------------------ -lemmaNameToQuantifiedT :: (HasLemmas m, Monad m) => LemmaName -> Transform c m x Quantified-lemmaNameToQuantifiedT nm = liftM lemmaQ $ getLemmaByNameT nm+lemmaNameToClauseT :: (LemmaContext c, HasLemmas m, Monad m) => LemmaName -> Transform c m x Clause+lemmaNameToClauseT nm = liftM lemmaC $ getLemmaByNameT nm  -- | @e@ ==> @let v = lhs in e@  (also works in a similar manner at Program nodes) lemmaLhsIntroR :: LemmaName -> RewriteH Core-lemmaLhsIntroR = lemmaNameToQuantifiedT >=> eqLhsIntroR+lemmaLhsIntroR = lemmaNameToClauseT >=> eqLhsIntroR  -- | @e@ ==> @let v = rhs in e@  (also works in a similar manner at Program nodes) lemmaRhsIntroR :: LemmaName -> RewriteH Core-lemmaRhsIntroR = lemmaNameToQuantifiedT >=> eqRhsIntroR+lemmaRhsIntroR = lemmaNameToClauseT >=> eqRhsIntroR  ------------------------------------------------------------------------------++-- Little DSL for building composite lemmas++infixr 5 -->++(-->) :: Type -> Type -> Type+(-->) = mkFunTy++infixr 3 ==>++(==>) :: (LemmaName, Clause) -> Clause -> Clause+(==>) = uncurry Impl++infixr 5 /\++(/\) :: Clause -> Clause -> Clause+(/\) = Conj++infixr 4 \/++(\/) :: Clause -> Clause -> Clause+(\/) = Disj++infix 8 ===++(===) :: (ToCoreExpr a, ToCoreExpr b) => a -> b -> Clause+lhs === rhs = Equiv (toCE lhs) (toCE rhs)++infixl 9 $$++($$) :: (ToCoreExpr a, ToCoreExpr b, MonadCatch m) => a -> b -> m CoreExpr+f $$ e = buildAppM (toCE f) (toCE e)++($$$) :: (ToCoreExpr a, ToCoreExpr b, MonadCatch m) => a -> [b] -> m CoreExpr+f $$$ es = buildAppsM (toCE f) (map toCE es)++class ToCoreExpr a where+    toCE :: a -> CoreExpr++instance ToCoreExpr CoreExpr where toCE = id++instance ToCoreExpr Var where toCE = varToCoreExpr++instance ToCoreExpr Type where toCE = Type++-- Create new lemma library with single unproven lemma.+newLemma :: LemmaName -> Clause -> Map.Map LemmaName Lemma+newLemma nm cl = Map.singleton nm (Lemma cl NotProven NotUsed)

@@ -59,29 +59,29 @@           => LemmaName -> Transform c m Core () rememberR nm = prefixFailMsg "remember failed: " $ do     Def v e <- setFailMsg "not applied to a binding." $ defOrNonRecT idR idR Def-    insertLemmaT (prefixRemembered nm) $ Lemma (mkQuantified [] (varToCoreExpr v) e) Proven NotUsed False+    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, ReadBindings c, ReadPath c Crumb+unfoldRememberedR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb                      , HasLemmas m, MonadCatch m, MonadUnique 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, ReadBindings c, ReadPath c Crumb+foldRememberedR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb                    , HasLemmas m, MonadCatch m, MonadUnique 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, ReadBindings c, ReadPath c Crumb+foldAnyRememberedR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadBindings c, ReadPath c Crumb                       , HasLemmas m, MonadCatch m, MonadUnique m)                    => Rewrite c m CoreExpr foldAnyRememberedR = setFailMsg "Fold failed: no definitions could be folded."                    $ compileRememberedT >>= runFoldR  -- | Compile all remembered definitions into something that can be run with `runFoldR`-compileRememberedT :: (HasLemmas m, Monad m) => Transform c m x CompiledFold+compileRememberedT :: (LemmaContext c, HasLemmas m, Monad m) => Transform c m x CompiledFold compileRememberedT = do-    qs <- liftM (map lemmaQ . Map.elems . Map.filterWithKey (\ k _ -> "remembered-" `isPrefixOf` show k)) getLemmasT+    qs <- liftM (map lemmaC . Map.elems . Map.filterWithKey (\ k _ -> "remembered-" `isPrefixOf` show k)) getLemmasT     return $ compileFold $ concatMap (map flipEquality . toEqualities) qs -- fold rhs to lhs

@@ -1,4 +1,8 @@-{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+ module HERMIT.Dictionary.Rules     ( -- * GHC Rewrite Rules and Specialisation       externals@@ -10,8 +14,8 @@     , unfoldRuleR     , unfoldRulesR     , compileRulesT-    , ruleToQuantifiedT-    , ruleNameToQuantifiedT+    , ruleToClauseT+    , ruleNameToClauseT     , getHermitRuleT     , getHermitRulesT       -- ** Specialisation@@ -95,30 +99,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, ReadBindings c, ReadPath c Crumb-               , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+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 )             => Used -> RuleName -> Rewrite c m CoreExpr foldRuleR u nm = do-    q <- ruleNameToQuantifiedT nm-    backwardT (birewrite q) >>> (verifyOrCreateT u (fromString (show nm)) (Lemma q NotProven u False) >> idR)+    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, ReadBindings c, ReadPath c Crumb-              , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+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 )            => 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, ReadBindings c, ReadPath c Crumb-               , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+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 )             => Used -> RuleName -> Rewrite c m CoreExpr unfoldRuleR u nm = do-    q <- ruleNameToQuantifiedT nm-    forwardT (birewrite q) >>> (verifyOrCreateT u (fromString (show nm)) (Lemma q NotProven u False) >> idR)+    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, ReadBindings c, ReadPath c Crumb-                , HasDynFlags m, HasHermitMEnv m, HasLemmas m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+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 )              => Used -> [RuleName] -> Rewrite c m CoreExpr unfoldRulesR u = orR . map (unfoldRuleR u) @@ -134,7 +142,7 @@     case filter ((`elem` nms) . fst) allRules of         [] -> fail (failMsg nms)         rs -> liftM (compileFold . concatMap toEqualities)-                $ forM (map snd rs) $ \ r -> return r >>> ruleToQuantifiedT+                $ forM (map snd rs) $ \ r -> return r >>> ruleToClauseT   -- | Return all in-scope CoreRules (including specialization RULES on binders), with their names.@@ -142,7 +150,7 @@ getHermitRulesT = contextonlyT $ \ c -> do     rb      <- liftCoreM getRuleBase     mgRules <- liftM mg_rules getModGuts-    hscEnv  <- liftCoreM getHscEnv+    hscEnv  <- getHscEnv     rb'     <- liftM eps_rule_base $ liftIO $ runIOEnv () $ readMutVar (hsc_EPS hscEnv)     let allRules = hermitCoreRules c ++ mgRules ++ concat (nameEnvElts rb) ++ concat (nameEnvElts rb')     return [ (fromString (unpackFS (ruleName r)), r) | r <- allRules ]@@ -164,30 +172,30 @@     return (intercalate "\n" $ reverse $ map (show.fst) rulesEnv)  -- | Print a named CoreRule using the quantified printer.-ruleHelpT :: (HasCoreRules c, ReadBindings c, ReadPath c Crumb) => PrettyPrinter -> RuleName -> Transform c HermitM a DocH-ruleHelpT pp nm = ruleNameToQuantifiedT nm >>> liftPrettyH (pOptions pp) (ppQuantifiedT pp)+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) --- | Build an Quantified from a named GHC rewrite rule.-ruleNameToQuantifiedT :: ( BoundVars c, HasCoreRules c, HasDynFlags m, HasHermitMEnv m+-- | 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 )-                    => RuleName -> Transform c m a Quantified-ruleNameToQuantifiedT name = getHermitRuleT name >>> ruleToQuantifiedT+                  => RuleName -> Transform c m a Clause+ruleNameToClauseT name = getHermitRuleT name >>> ruleToClauseT --- | Transform GHC's CoreRule into an Quantified.-ruleToQuantifiedT :: (BoundVars c, HasHermitMEnv m, MonadThings m, MonadCatch m)-                => Transform c m CoreRule Quantified-ruleToQuantifiedT = withPatFailMsg "HERMIT cannot handle built-in rules yet." $ do+-- | Transform GHC's CoreRule into an Clause.+ruleToClauseT :: (BoundVars c, HasHermitMEnv m, 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"     f <- lookupId $ ru_fn r     let lhs = mkCoreApps (varToCoreExpr f) (ru_args r)-    return $ mkQuantified (ru_bndrs r) lhs (ru_rhs r)+    return $ mkClause (ru_bndrs r) lhs (ru_rhs r)  ruleToLemmaT :: ( BoundVars c, HasCoreRules c, HasDynFlags m, HasHermitMEnv m, HasLemmas m                 , LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m)              => RuleName -> Transform c m a () ruleToLemmaT nm = do-    q <- ruleNameToQuantifiedT nm-    insertLemmaT (fromString (show nm)) $ Lemma q NotProven NotUsed False+    q <- ruleNameToClauseT nm+    insertLemmaT (fromString (show nm)) $ Lemma q NotProven NotUsed  ------------------------------------------------------------------------ @@ -245,6 +253,6 @@ rulesToRewrite :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb                   , HasDynFlags m, HasHermitMEnv m, MonadCatch m, MonadThings m, MonadUnique m )                => [CoreRule] -> Rewrite c m CoreExpr-rulesToRewrite rs = catchesM [ (return r >>> ruleToQuantifiedT) >>= forwardT . birewrite | r <- rs ]+rulesToRewrite rs = catchesM [ (return r >>> ruleToClauseT) >>= forwardT . birewrite | r <- rs ]  ------------------------------------------------------------------------

@@ -86,11 +86,11 @@ undefinedLocation :: HermitName undefinedLocation = fromString "GHC.Err.undefined" -findUndefinedIdT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id+findUndefinedIdT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, LiftCoreM m, MonadIO m, MonadThings m) => Transform c m a Id findUndefinedIdT = findIdT undefinedLocation  -- | Check if the current expression is an undefined value.-isUndefinedValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m CoreExpr ()+isUndefinedValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags 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 +102,11 @@ errorLocation :: HermitName errorLocation = fromString "GHC.Err.error" -findErrorIdT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m a Id+findErrorIdT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags 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, HasHscEnv m, MonadIO m, MonadThings m) => Transform c m CoreExpr ()+isErrorValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags 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 +116,13 @@ ------------------------------------------------------------------------  -- | error ty string ==> undefined ty-errorToUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+errorToUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags 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, HasHscEnv m, MonadIO m, MonadThings m) => Type -> Transform c m a CoreExpr+mkUndefinedValT :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags 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 +130,67 @@ ------------------------------------------------------------------------------------------------------  -- | Set the current expression to 'undefined'.-replaceCurrentExprWithUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags m, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+replaceCurrentExprWithUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags 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, HasHscEnv m, MonadIO m, MonadThings m) => Id -> Rewrite c m Core+replaceIdWithUndefinedR :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags 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, HasHscEnv m, MonadIO m, MonadThings m)                        => HermitName -> Rewrite c m Core+replaceIdWithUndefined :: (BoundVars c, MonadCatch m, HasHermitMEnv m, HasDynFlags 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, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, 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, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedAppR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags 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, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedLamR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, 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, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedLetR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, 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, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedCastR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags 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, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedTickR :: (BoundVars c, ExtendPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags 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, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, 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, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, 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, HasHscEnv m, MonadIO m, MonadThings m) => Rewrite c m CoreExpr+undefinedCaseAltsR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, HasHermitMEnv m, HasDynFlags m, 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 +198,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, HasHscEnv m, MonadIO m, MonadThings m) => CoreExpr -> Rewrite c m CoreExpr -> Transform c m a ()+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 f r = prefixFailMsg "strictness verification failed: " $   do (_, argTy, resTy) <- constT (funExprArgResTypesM f)      undefArg       <- mkUndefinedValT argTy@@ -207,7 +207,7 @@      verifyEqualityLeftToRightT lhs rhs r  -- | Apply the given expression to undefined, at the proper type.-applyToUndefinedT :: (BoundVars c, HasDynFlags m, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+applyToUndefinedT :: (BoundVars c, HasDynFlags m, LiftCoreM m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)                   => CoreExpr -> Transform c m x CoreExpr applyToUndefinedT f = do     let (tvs, body) = collectTyBinders f@@ -217,11 +217,13 @@  -- | Add a lemma for the strictness of a function. -- Note: assumes added lemma has been used-buildStrictnessLemmaT :: (BoundVars c, HasDynFlags m, HasHscEnv m, HasHermitMEnv m, HasLemmas m, MonadCatch m, MonadIO m, MonadThings m)+buildStrictnessLemmaT :: ( AddBindings c, ExtendPath c Crumb, HasCoreRules c, LemmaContext c, ReadBindings c+                         , ReadPath c Crumb, HasDynFlags m, LiftCoreM m, HasHermitMEnv m, HasLemmas m+                         , MonadCatch m, MonadIO m, MonadThings m)                       => Used -> LemmaName -> CoreExpr -> Transform c m x () buildStrictnessLemmaT u nm f = do     (tvs, lhs) <- liftM collectTyBinders $ applyToUndefinedT f     rhs <- mkUndefinedValT (exprType lhs)-    verifyOrCreateT u nm $ Lemma (mkQuantified tvs lhs rhs) NotProven u False+    verifyOrCreateT u nm (mkClause tvs lhs rhs)  ------------------------------------------------------------------------

@@ -1,4 +1,8 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TupleSections, LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+ module HERMIT.Dictionary.Unfold     ( externals     , betaReducePlusR

@@ -1,11 +1,14 @@-{-# LANGUAGE CPP, DeriveDataTypeable, TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+ module HERMIT.Dictionary.WorkerWrapper.Common     ( externals     , WWAssumptionTag(..)     , WWAssumption(..)-    , assumptionAQuantifiedT-    , assumptionBQuantifiedT-    , assumptionCQuantifiedT+    , assumptionAClauseT+    , assumptionBClauseT+    , assumptionCClauseT     , split1BetaR     , split2BetaR     , workLabel@@ -37,20 +40,20 @@ externals = map (.+ Proof)     [ external "intro-ww-assumption-A"         (\nm absC repC -> do-            q <- parse2BeforeT assumptionAQuantifiedT absC repC-            insertLemmaT nm $ Lemma q NotProven NotUsed False :: TransformH LCore ())+            q <- parse2BeforeT assumptionAClauseT absC repC+            insertLemmaT nm $ Lemma q NotProven NotUsed :: TransformH LCore ())         [ "Introduce a lemma for worker/wrapper assumption A"         , "using given abs and rep functions." ]     , external "intro-ww-assumption-B"         (\nm absC repC bodyC -> do-            q <- parse3BeforeT assumptionBQuantifiedT absC repC bodyC-            insertLemmaT nm $ Lemma q NotProven NotUsed False :: TransformH LCore ())+            q <- parse3BeforeT assumptionBClauseT absC repC bodyC+            insertLemmaT nm $ Lemma q NotProven NotUsed :: TransformH LCore ())         [ "Introduce a lemma for worker/wrapper assumption B"         , "using given abs, rep, and body functions." ]     , external "intro-ww-assumption-C"         (\nm absC repC bodyC -> do-            q <- parse3BeforeT assumptionCQuantifiedT absC repC bodyC-            insertLemmaT nm $ Lemma q NotProven NotUsed False :: TransformH LCore ())+            q <- parse3BeforeT assumptionCClauseT absC repC bodyC+            insertLemmaT nm $ Lemma q NotProven NotUsed :: TransformH LCore ())         [ "Introduce a lemma for worker/wrapper assumption C"         , "using given abs, rep, and body functions." ]     , external "split-1-beta" (\ nm absC -> promoteExprR . parse2BeforeT (split1BetaR Obligation nm) absC :: CoreString -> RewriteH LCore)@@ -94,51 +97,50 @@ --------------------------------------------------------------------------------------------------  -- Given abs and rep expressions, build "abs . rep = id"-assumptionAQuantifiedT :: ( BoundVars c, HasHermitMEnv m, HasHscEnv m-                        , MonadCatch m, MonadIO m, MonadThings m )-                     => CoreExpr -> CoreExpr -> Transform c m x Quantified-assumptionAQuantifiedT absE repE = prefixFailMsg "Building assumption A failed: " $ do+assumptionAClauseT :: ( BoundVars c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m )+                     => CoreExpr -> CoreExpr -> Transform c m x Clause+assumptionAClauseT absE repE = prefixFailMsg "Building assumption A failed: " $ do     comp <- buildCompositionT absE repE     let (_,compBody) = collectTyBinders comp     (tvs, xTy, _) <- splitFunTypeM (exprType comp)     idE <- buildIdT xTy-    return $ Quantified tvs (Equiv compBody idE)+    return $ Forall tvs (Equiv compBody idE)  -- Given abs, rep, and f expressions, build "abs . rep . f = f"-assumptionBQuantifiedT :: ( BoundVars c, HasHermitMEnv m, HasHscEnv m-                        , MonadCatch m, MonadIO m, MonadThings m)-                     => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Quantified-assumptionBQuantifiedT absE repE fE = prefixFailMsg "Building assumption B failed: " $ do+assumptionBClauseT :: ( BoundVars c, HasHermitMEnv m, LiftCoreM m, MonadCatch m, MonadIO m, MonadThings m)+                     => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Clause+assumptionBClauseT absE repE fE = prefixFailMsg "Building assumption B failed: " $ do     repAfterF <- buildCompositionT repE fE     comp <- buildCompositionT absE repAfterF     let (tvs,lhs) = collectTyBinders comp     rhs <- appArgM 5 lhs >>= appArgM 5 -- get f with proper tvs applied-    return $ Quantified tvs (Equiv lhs rhs)+    return $ Forall tvs (Equiv lhs rhs)  -- Given abs, rep, and f expressions, build "fix (abs . rep . f) = fix f"-assumptionCQuantifiedT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)-                     => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Quantified-assumptionCQuantifiedT absE repE fE = prefixFailMsg "Building assumption C failed: " $ do-    Quantified vs (Equiv lhs rhs) <- assumptionBQuantifiedT absE repE fE+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     lhs' <- buildFixT lhs     rhs' <- buildFixT rhs-    return $ Quantified vs (Equiv lhs' rhs')+    return $ Forall vs (Equiv lhs' rhs')  -- Given abs, rep, and 'fix g' expressions, build "rep (abs (fix g)) = fix g"-wwFusionQuantifiedT :: MonadCatch m => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Quantified-wwFusionQuantifiedT absE repE fixgE = prefixFailMsg "Building worker/wrapper fusion lemma failed: " $ do+wwFusionClauseT :: MonadCatch m => CoreExpr -> CoreExpr -> CoreExpr -> Transform c m x Clause+wwFusionClauseT absE repE fixgE = prefixFailMsg "Building worker/wrapper fusion lemma failed: " $ do     protoLhs <- buildAppM repE =<< buildAppM absE fixgE     let (tvs, lhs) = collectTyBinders protoLhs     -- This way, the rhs is applied to the proper type variables.     rhs <- case lhs of             (App _ (App _ rhs)) -> return rhs             _                   -> fail "lhs malformed"-    return $ Quantified tvs (Equiv lhs rhs)+    return $ Forall 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 :: ( BoundVars c, HasHermitMEnv m, HasHscEnv m, HasLemmas m-               , MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+split1BetaR :: ( AddBindings c, ExtendPath c Crumb, 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 split1BetaR u nm absE repE = do     (_fixId, [_tyA, f]) <- callNameT $ fromString "Data.Function.fix"@@ -153,16 +155,17 @@     newRhs <- prefixFailMsg "building (abs work) failed: "             $ buildAppM absE (varToCoreExpr workId) -    assumptionQ <- assumptionCQuantifiedT absE repE f-    verifyOrCreateT u (fromString (show nm ++ "-assumption")) $ Lemma assumptionQ NotProven u False -- unproven, used, permanent+    assumptionQ <- assumptionCClauseT absE repE f+    verifyOrCreateT u (fromString (show nm ++ "-assumption")) assumptionQ -    wwFusionQ <- wwFusionQuantifiedT absE repE workRhs-    insertLemmaT (fromString (show nm ++ "-fusion")) $ Lemma wwFusionQ BuiltIn NotUsed False -- assumed, unused, permanent+    wwFusionQ <- wwFusionClauseT absE repE workRhs+    insertLemmaT (fromString (show nm ++ "-fusion")) $ Lemma wwFusionQ BuiltIn NotUsed      return $ mkCoreLets [NonRec gId g, NonRec workId workRhs] newRhs -split2BetaR :: ( BoundVars c, HasHermitMEnv m, HasHscEnv m, HasLemmas m-               , MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )+split2BetaR :: ( AddBindings c, ExtendPath c Crumb, 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 split2BetaR u nm absE repE = do     (_fixId, [_tyA, f]) <- callNameT $ fromString "Data.Function.fix"@@ -173,10 +176,10 @@      newRhs <- buildAppM absE (varToCoreExpr workId) -    assumptionQ <- assumptionCQuantifiedT absE repE f-    verifyOrCreateT u (fromString (show nm ++ "-assumption")) $ Lemma assumptionQ NotProven u False -- unproven, used, permanent+    assumptionQ <- assumptionCClauseT absE repE f+    verifyOrCreateT u (fromString (show nm ++ "-assumption")) assumptionQ -    wwFusionQ <- wwFusionQuantifiedT absE repE (varToCoreExpr workId)-    insertLemmaT (fromString (show nm ++ "-fusion")) $ Lemma wwFusionQ BuiltIn NotUsed False -- assumed, unused, permanent+    wwFusionQ <- wwFusionClauseT absE repE (varToCoreExpr workId)+    insertLemmaT (fromString (show nm ++ "-fusion")) $ Lemma wwFusionQ BuiltIn NotUsed      return $ mkCoreLets [NonRec workId repFixFE] newRhs

@@ -1,3 +1,5 @@+{-# 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.@@ -19,7 +21,7 @@ import HERMIT.Core import HERMIT.External import HERMIT.GHC-import HERMIT.Kure+import HERMIT.Kure hiding ((<$>)) import HERMIT.Lemma import HERMIT.Monad import HERMIT.Name@@ -37,6 +39,8 @@  import HERMIT.Dictionary.WorkerWrapper.Common +import Prelude.Compat+ --------------------------------------------------------------------------------------------------  -- | Externals for manipulating fixed points, and for the worker/wrapper transformation.@@ -203,7 +207,7 @@ wwFusionBR =     beforeBiR (prefixFailMsg "worker/wrapper fusion failed: " $                withPatFailMsg "malformed WW Fusion rule." $-               do Quantified _ (Equiv w (App unwrap (App _f (App wrap w')))) <- constT (lemmaQ <$> findLemma workLabel)+               do Equiv w (App unwrap (App _f (App wrap w'))) <- constT (lemmaC <$> findLemma workLabel)                   guardMsg (exprSyntaxEq w w') "malformed WW Fusion rule."                   return (wrap,unwrap,w)               )@@ -244,7 +248,7 @@     do Def w e@(App unwrap (App f (App wrap (Var w')))) <- projectT        guardMsg (w == w') wrongForm        whenJust (verifyWWAss wrap unwrap f) mAss-       insertLemmaT workLabel $ Lemma (Quantified [] (Equiv (varToCoreExpr w) e)) Proven NotUsed False+       insertLemmaT workLabel $ Lemma (Equiv (varToCoreExpr w) e) Proven NotUsed   where     wrongForm = "definition does not have the form: work = unwrap (f (wrap work))" 

@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TupleSections #-}  module HERMIT.Dictionary.WorkerWrapper.FixResult@@ -14,7 +15,7 @@     , wwResultAssC     ) where -import Prelude hiding (abs)+import Prelude.Compat hiding (abs)  import Control.Arrow @@ -23,7 +24,7 @@ import HERMIT.Core import HERMIT.External import HERMIT.GHC-import HERMIT.Kure+import HERMIT.Kure hiding ((<$>)) import HERMIT.Lemma import HERMIT.Monad import HERMIT.Name@@ -224,13 +225,13 @@ wwResultFusionBR =     beforeBiR (prefixFailMsg "worker/wrapper fusion failed: " $                withPatFailMsg "malformed WW Fusion rule." $-               do Quantified _ (Equiv w+               do Equiv w                         (Lam x1 (App rep                                      (App (App _ (Lam x2 (App abs (App w' (Var x2')))))                                           (Var x1')                                      )                                 )-                        )) <- constT (lemmaQ <$> findLemma workLabel)+                        ) <- constT (lemmaC <$> findLemma workLabel)                   guardMsg (exprSyntaxEq w w' && x1 == x1' && x2 == x2') "malformed WW Fusion rule."                   return (abs,rep,w)               )@@ -276,7 +277,7 @@                ) <- projectT        guardMsg (w == w' && x1 == x1' && x2 == x2') wrongForm        whenJust (verifyWWAss abs rep f) mAss-       insertLemmaT workLabel $ Lemma (Quantified [] (Equiv (varToCoreExpr w) e)) Proven NotUsed False+       insertLemmaT workLabel $ Lemma (Equiv (varToCoreExpr w) e) Proven NotUsed   where     wrongForm = "definition does not have the form: work = \\ x1 -> rep (f (\\ x2 -> abs (work x2)) x1)" 

@@ -34,7 +34,7 @@         ,"       hermit File.hs [HERMIT_ARGS] [+module_name [MOD_ARGS]]* [-- [ghc-args]]"         ,""         ,"examples: hermit Foo.hs Foo.hss"-        ,"          hermit Foo.hs -p6 +Main Foo.hss"+        ,"          hermit Foo.hs +Main -p6 Foo.hss"         ,"          hermit Foo.hs +Main Foo.hss resume"         ,"          hermit Foo.hs +Main Foo.hss +Other.Module.Name Bar.hss"         ,"          hermit Foo.hs -- -ddump-simpl -ddump-to-file"@@ -43,17 +43,17 @@         ,"If a module name is not supplied, * is assumed."         ,""         ,"HERMIT_ARGS"-        ,"  -opt=MODULE : where MODULE is the module containing a HERMIT optimization plugin"-        ,"  -pN         : where 0<=N<=17 is the stage in the optimization pipeline HERMIT targets"-        ,"  -vN         : controls verbosity, where N is one of the following values:"-        ,"                  0 : suppress HERMIT messages, pass -v0 to GHC"-        ,"                  1 : suppress HERMIT messages"-        ,"                  2 : pass -v0 to GHC"-        ,"                  3 : (default) display all HERMIT and GHC messages"+        ,"  -plugin=MODULE : where MODULE is the module containing a HERMIT plugin"+        ,"  -vN            : controls verbosity, where N is one of the following values:"+        ,"                     0 : suppress HERMIT messages, pass -v0 to GHC"+        ,"                     1 : suppress HERMIT messages"+        ,"                     2 : pass -v0 to GHC"+        ,"                     3 : (default) display all HERMIT and GHC messages"         ,""-        ,"MOD_ARGS"+        ,"MOD_ARGS        (note, only valid when -plugin flag is NOT specified)"         ,"  SCRIPTNAME : name of script file to run for this module"         ,"  resume     : skip interactive mode and resume compilation after any scripts"+        ,"  -pN        : where 0<=N<=17 is the stage in the pipeline HERMIT targets"         ]  usage :: IO ()

@@ -1,4 +1,9 @@-{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances, DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}  module HERMIT.External     ( -- * Externals@@ -262,7 +267,11 @@                                          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  -----------------------------------------------------------------

@@ -1,4 +1,7 @@-{-# LANGUAGE CPP, InstanceSigs, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- Above shadowing disabled because the eqExprX function has lots of shadowing module HERMIT.GHC@@ -37,6 +40,7 @@     , eqExprX     , loadSysInterface     , lookupRdrNameInModule+    , injectDependency     , reportAllUnsolved     , zEncodeString #ifdef mingw32_HOST_OS@@ -49,7 +53,11 @@     , module ErrUtils     , module PrelNames     , module TcEnv+#if __GLASGOW_HASKELL__ < 710     , module TcMType+#else+    , module TcSMonad+#endif     , module TcRnMonad     , module TcRnTypes     , module TcSimplify@@ -81,14 +89,22 @@ import           Pair (Pair(..)) import           Panic (throwGhcException, throwGhcExceptionIO, GhcException(..)) import           PrelNames (typeableClassName)-#if mingw32_HOST_OS+#ifdef mingw32_HOST_OS import           StaticFlags #endif import           TcEnv (tcLookupClass) import           TcErrors (reportAllUnsolved)+#if __GLASGOW_HASKELL__ < 710 import           TcMType (newWantedEvVar)+#else+import           TcSMonad (newWantedEvVar)+#endif import           TcRnMonad (getCtLoc, initIfaceTcRn)+#if __GLASGOW_HASKELL__ < 710 import           TcRnTypes (TcM, mkNonCanonical, mkFlatWC, CtEvidence(..), SkolemInfo(..), CtOrigin(..))+#else+import           TcRnTypes (TcM, mkNonCanonical, mkSimpleWC, CtEvidence(..), SkolemInfo(..), CtOrigin(..))+#endif import           TcSimplify (solveWantedsTcM) import           TcType (mkPhiTy, mkSigmaTy) import           TypeRep (Type(..),TyLit(..))@@ -164,13 +180,13 @@     , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)     , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)     , (notNull rules,  ptext (sLit "RULES:") <+> vcat (map ppr rules))-    ]	-- Inline pragma, occ, demand, lbvar info-	-- printed out with all binders (when debug is on);-	-- see PprCore.pprIdBndr+    ] -- Inline pragma, occ, demand, lbvar info+      -- printed out with all binders (when debug is on);+      -- see PprCore.pprIdBndr   where     pp_scope | isGlobalId v   = ptext (sLit "GblId")-    	     | isExportedId v = ptext (sLit "LclIdX")-    	     | otherwise      = ptext (sLit "LclId")+             | isExportedId v = ptext (sLit "LclIdX")+             | otherwise      = ptext (sLit "LclId")      arity = arityInfo info     has_arity = arity /= 0@@ -331,3 +347,20 @@  throwCmdLineError :: String -> IO a throwCmdLineError = throwGhcExceptionIO . CmdLineError++-- | Populate the EPS with a module, as if it were imported in the target program.+injectDependency :: HscEnv -> ModGuts -> ModuleName -> IO ()+injectDependency hsc_env guts mod_name = do+    -- First find the package the module resides in by searching exposed packages and home modules+    found_module <- findImportedModule hsc_env mod_name Nothing+    case found_module of+        Found _ mod -> do+            -- Populate the EPS+            _ <- initTcFromModGuts hsc_env guts HsSrcFile False $+                 initIfaceTcRn $+                 loadSysInterface doc mod+            return ()+        err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err+  where+    dflags = hsc_dflags hsc_env+    doc = ptext (sLit "dependency injection requested by HERMIT")

@@ -1,4 +1,6 @@-{-# LANGUAGE CPP, RankNTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+ module HERMIT.GHC.Typechecker     (       initTcFromModGuts@@ -22,7 +24,13 @@ import Data.IORef ( newIORef, readIORef )  import TcEnv ( tcLookupGlobal )+#if __GLASGOW_HASKELL__ < 710 import TcType   ( noUntouchables )+#else+import DynFlags ( getSigOf )+import Module   ( mkModuleSet, moduleName )+import TcType   ( topTcLevel )+#endif  import FastString import Bag@@ -30,7 +38,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map -import Prelude+import Prelude hiding (mod) import VarSet (emptyVarSet)  -- Note: the contents of this module should eventually be folded into GHC proper.@@ -58,6 +66,9 @@         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 ;@@ -65,6 +76,9 @@         th_state_var         <- newIORef Map.empty ;          let {+             dflags = hsc_dflags hsc_env ;+             mod = mg_module guts ;+              maybe_rn_syntax :: forall a. a -> Maybe a ;              maybe_rn_syntax empty_val                 | keep_rn_syntax = Just empty_val@@ -78,8 +92,12 @@                 tcg_th_state         = th_state_var,                  -- queried during tcrnif-                tcg_mod            = mg_module guts,+                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,@@ -89,10 +107,17 @@                 tcg_inst_env       = mg_inst_env guts,                 tcg_fam_inst_env   = mg_fam_inst_env guts,                 tcg_ann_env        = emptyAnnEnv,+#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           = [],@@ -134,7 +159,11 @@                 tcl_tidy       = emptyTidyEnv,                 tcl_tyvars     = tvs_var,                 tcl_lie        = lie_var,+#if __GLASGOW_HASKELL__ < 710                 tcl_untch      = noUntouchables+#else+                tcl_tclvl      = topTcLevel+#endif              } ;         } ; @@ -149,14 +178,17 @@         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 ; -        let { dflags = hsc_dflags hsc_env-            ; final_res | errorsFound dflags msgs = Nothing+        let { final_res | errorsFound dflags msgs = Nothing                         | otherwise               = maybe_res } ;          return (msgs, final_res)

@@ -45,21 +45,21 @@ -- | A 'Kernel' is a repository for complete Core syntax trees ('ModGuts') and Lemmas. data Kernel = Kernel   { -- | Halt the 'Kernel' and return control to GHC, which compiles the specified 'AST'.-    resumeK :: MonadIO m =>                                   AST -> m ()+    resumeK :: forall m. MonadIO m =>                                   AST -> m ()     -- | Halt the 'Kernel' and abort GHC without compiling.-  , abortK  :: MonadIO m =>                                          m ()+  , abortK  :: forall m. MonadIO m =>                                          m ()     -- | Apply a 'Rewrite' to the specified 'AST' and return a handle to the resulting 'AST'.-  , applyK  :: (MonadIO m, MonadCatch m)-            => RewriteH ModGuts     -> CommitMsg -> KernelEnv -> AST -> m AST+  , applyK  :: forall m. (MonadIO m, MonadCatch m)+            => RewriteH ModGuts     -> CommitMsg -> KernelEnv ->        AST -> m AST     -- | Apply a 'TransformH' to the 'AST', return the resulting value, and potentially a new 'AST'.-  , queryK  :: (MonadIO m, MonadCatch m)-            => TransformH ModGuts a -> CommitMsg -> KernelEnv -> AST -> m (AST,a)+  , queryK  :: forall m a. (MonadIO m, MonadCatch m)+            => TransformH ModGuts a -> CommitMsg -> KernelEnv ->        AST -> m (AST,a)     -- | Delete the internal record of the specified 'AST'.-  , deleteK :: MonadIO m =>                                   AST -> m ()+  , deleteK :: forall m. MonadIO m =>                                   AST -> m ()     -- | List all the 'AST's tracked by the 'Kernel', including version data.-  , listK   :: MonadIO m =>                                          m [(AST,Maybe String, Maybe AST)]+  , listK   :: forall m. MonadIO m =>                                          m [(AST,Maybe String, Maybe AST)]     -- | Log a new AST with same Lemmas/ModGuts as given AST.-  , tellK   :: (MonadIO m, MonadCatch m) => String         -> AST -> m AST+  , tellK   :: forall m. (MonadIO m, MonadCatch m) => String         -> AST -> m AST   }  data CommitMsg = Always String | Changed String | Never@@ -105,7 +105,7 @@                                , _ksCommit :: Maybe String                                } -data KernelEnv = KernelEnv { kEnvChan :: DebugMessage -> HermitM () }+data KernelEnv = KernelEnv { kEnvChan :: KEnvMessage -> HermitM () }  -- | Internal API. The 'Kernel' object wraps these calls. data Msg where@@ -161,8 +161,7 @@                             withAST ast $ \ (KernelState lemmas guts _ _) -> do                                 let handleS hRes = return $ return                                                    (Just (KernelState (hResLemmas hRes) (hResult hRes) (Just ast) (msg cm)), ())-                                runHM (kEnvChan kEnv)-                                      (mkEnv guts lemmas)+                                runHM (mkEnv (kEnvChan kEnv) guts lemmas)                                       handleS                                       (return . fail)                                       (applyT rr (topLevelHermitC guts) guts)@@ -175,8 +174,7 @@                                         | otherwise        = f (Nothing, r) -- pure query, not recorded in AST store                                         where r = hResult hRes                                               f = return . return-                                runHM (kEnvChan kEnv)-                                      (mkEnv guts lemmas)+                                runHM (mkEnv (kEnvChan kEnv) guts lemmas)                                       handleS                                       (return . fail)                                       (applyT t (topLevelHermitC guts) guts)

@@ -1,11 +1,12 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module HERMIT.Kure     ( -- * KURE@@ -24,6 +25,8 @@     , BiRewriteH     , LensH     , PathH+      -- * Utilities+    , inContextM        -- * Congruence combinators       -- ** Modguts@@ -85,14 +88,14 @@     , disjT, disjAllR     , implT, implAllR     , equivT, equivAllR-    , quantifiedT, quantifiedR-    , clauseT, clauseR, forallVarsT+    , forallT, forallR       -- * Applicative-      -- | Remove in 7.10     , (<$>)     , (<*>)     ) where +import Control.Monad (ap, liftM)+ import Language.KURE import Language.KURE.BiTransform import Language.KURE.Lens@@ -106,7 +109,7 @@ import HERMIT.Lemma import HERMIT.Monad -import Control.Monad+import Prelude.Compat hiding ((<$>), (<*>))  --------------------------------------------------------------------- @@ -116,8 +119,8 @@ type LensH a b      = Lens      HermitC HermitM a b type PathH          = Path Crumb --- I find it annoying that Applicative is not a superclass of Monad.--- This causes a warning now, and will need to be CPP'd for 7.10+-- 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 (<$>) #-}@@ -238,50 +241,44 @@ ---------------------------------------------------------------------  -- | Walking over modules, programs, binding groups, definitions, expressions, case alternatives, lemma quantifiers and lemma clauses.-instance (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb) => Walker c LCore where+instance (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadPath c Crumb) => Walker c LCore where      allR :: forall m. MonadCatch m => Rewrite c m LCore -> Rewrite c m LCore     allR r = prefixFailMsg "allR failed: " $                 rewrite $ \ c -> \case-                    LQuantified q  -> inject <$> applyT allRquantified c q                     LClause cl     -> inject <$> applyT allRclause c cl-                    LCore core     -> inject <$> applyT (allR $ extractR r) c core -- exploiting the fact that quantified/clause does not appear within Core+                    LCore core     -> inject <$> applyT (allR $ extractR r) c core -- exploiting the fact that clause does not appear within Core         where-            allRquantified :: MonadCatch m => Rewrite c m Quantified-            allRquantified = quantifiedR idR (extractR r) -- we don't descend into the binders-            {-# INLINE allRquantified #-}-             allRclause :: MonadCatch m => Rewrite c m Clause             allRclause = readerT $ \case-                                Conj{}  -> conjAllR  (extractR r) (extractR r)-                                Disj{}  -> disjAllR  (extractR r) (extractR r)-                                Impl{}  -> implAllR  (extractR r) (extractR r)-                                Equiv{} -> equivAllR (extractR r) (extractR r)+                                Forall{} -> forallR idR (extractR r) -- we don't descend into the binders+                                Conj{}   -> conjAllR  (extractR r) (extractR r)+                                Disj{}   -> disjAllR  (extractR r) (extractR r)+                                Impl{}   -> implAllR  (extractR r) (extractR r)+                                Equiv{}  -> equivAllR (extractR r) (extractR r)+                                CTrue    -> return CTrue             {-# INLINE allRclause #-}  ---------------------------------------------------------------------  -- | Walking over modules, programs, binding groups, definitions, expressions, case alternatives, types, coercions, lemma quantifiers and lemma clauses.-instance (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb) => Walker c LCoreTC where+instance (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, LemmaContext c, ReadPath c Crumb) => Walker c LCoreTC where      allR :: forall m. MonadCatch m => Rewrite c m LCoreTC -> Rewrite c m LCoreTC     allR r = prefixFailMsg "allR failed: " $                 rewrite $ \ c -> \case-                    LTCCore (LQuantified q)  -> inject <$> applyT allRquantified c q                     LTCCore (LClause cl)     -> inject <$> applyT allRclause c cl                     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-            allRquantified :: MonadCatch m => Rewrite c m Quantified-            allRquantified = quantifiedR idR (extractR r) -- we don't descend into the binders-            {-# INLINE allRquantified #-}-             allRclause :: MonadCatch m => Rewrite c m Clause             allRclause = readerT $ \case-                                Conj{}  -> conjAllR (extractR r) (extractR r)-                                Disj{}  -> disjAllR (extractR r) (extractR r)-                                Impl{}  -> implAllR  (extractR r) (extractR r)-                                Equiv{} -> equivAllR (extractR r) (extractR r)+                                Forall{} -> forallR idR (extractR r) -- we don't descend into the binders+                                Conj{}   -> conjAllR (extractR r) (extractR r)+                                Disj{}   -> disjAllR (extractR r) (extractR r)+                                Impl{}   -> implAllR  (extractR r) (extractR r)+                                Equiv{}  -> equivAllR (extractR r) (extractR r)+                                CTrue    -> return CTrue             {-# INLINE allRclause #-}  ---------------------------------------------------------------------@@ -1291,41 +1288,45 @@  --------------------------------------------------------------------- --- | Transform a clause of the form: @Conj@ 'Quantified' 'Quantified'-conjT :: (ExtendPath c Crumb, Monad m) => Transform c m Quantified a1 -> Transform c m Quantified a2 -> (a1 -> a2 -> b) -> Transform c m Clause b+-- | Transform a clause of the form: @Conj@ 'Clause' 'Clause'+conjT :: (ExtendPath c Crumb, Monad m) => Transform c m Clause a1 -> Transform c m Clause a2 -> (a1 -> a2 -> b) -> Transform c m Clause b conjT t1 t2 f = transform $ \ c -> \case                                      Conj q1 q2 -> f <$> applyT t1 (c @@ Conj_Lhs) q1 <*> applyT t2 (c @@ Conj_Rhs) q2                                      _          -> fail "not a conjunction." {-# INLINE conjT #-} --- | Rewrite all children of a clause of the form: : @Conj@ 'Quantified' 'Quantified'-conjAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Quantified -> Rewrite c m Quantified -> Rewrite c m Clause+-- | Rewrite all children of a clause of the form: : @Conj@ 'Clause' 'Clause'+conjAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Clause -> Rewrite c m Clause -> Rewrite c m Clause conjAllR r1 r2 = conjT r1 r2 Conj {-# INLINE conjAllR #-}  --- | Transform a clause of the form: @Disj@ 'Quantified' 'Quantified'-disjT :: (ExtendPath c Crumb, Monad m) => Transform c m Quantified a1 -> Transform c m Quantified a2 -> (a1 -> a2 -> b) -> Transform c m Clause b+-- | 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                                      _          -> fail "not a disjunction." {-# INLINE disjT #-} --- | Rewrite all children of a clause of the form: : @Disj@ 'Quantified' 'Quantified'-disjAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Quantified -> Rewrite c m Quantified -> Rewrite c m Clause+-- | Rewrite all children of a clause of the form: : @Disj@ 'Clause' 'Clause'+disjAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Clause -> Rewrite c m Clause -> Rewrite c m Clause disjAllR r1 r2 = disjT r1 r2 Disj {-# INLINE disjAllR #-}  --- | Transform a clause of the form: @Impl@ 'Quantified' 'Quantified'-implT :: (ExtendPath c Crumb, Monad m) => Transform c m Quantified a1 -> Transform c m Quantified a2 -> (a1 -> a2 -> b) -> Transform c m Clause b+-- | Transform a clause of the form: @Impl@ 'LemmaName' 'Clause' 'Clause'+implT :: (ExtendPath c Crumb, LemmaContext c, Monad m)+      => Transform c m Clause a1 -> Transform c m Clause a2 -> (LemmaName -> a1 -> a2 -> b) -> Transform c m Clause b implT t1 t2 f = transform $ \ c -> \case-                                     Impl q1 q2 -> f <$> applyT t1 (c @@ Impl_Lhs) q1 <*> applyT t2 (c @@ Impl_Rhs) q2+                                     Impl nm q1 q2 -> let l = Lemma q1 BuiltIn NotUsed+                                                      in f nm <$> applyT t1 (c @@ Impl_Lhs) q1+                                                              <*> applyT t2 (addAntecedent nm l c @@ Impl_Rhs) q2                                      _          -> fail "not an implication." {-# INLINE implT #-} --- | Rewrite all children of a clause of the form: : @Impl@ 'Quantified' 'Quantified'-implAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Quantified -> Rewrite c m Quantified -> Rewrite c m Clause+-- | Rewrite all children of a clause of the form: : @Impl@ 'Clause' 'Clause'+implAllR :: (ExtendPath c Crumb, LemmaContext c, Monad m)+         => Rewrite c m Clause -> Rewrite c m Clause -> Rewrite c m Clause implAllR r1 r2 = implT r1 r2 Impl {-# INLINE implAllR #-} @@ -1343,16 +1344,20 @@  --------------------------------------------------------------------- --- | Transform a quantifier of the form: @Quantified@ 'Clause'-quantifiedT :: (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 Quantified b-quantifiedT t1 t2 f = transform $ \ c (Quantified bs cl) -> let c' = foldl (flip addLambdaBinding) c bs-                                                             in f <$> applyT t1 c bs <*> applyT t2 (c' @@ Forall_Body) cl-{-# INLINE quantifiedT #-}+-- | 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+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."+{-# INLINE forallT #-} --- | Rewrite the clause of a quantifier of the form: @Quantified@ 'Clause'-quantifiedR :: (ExtendPath c Crumb, AddBindings c, ReadPath c Crumb, Monad m) => Rewrite c m [CoreBndr] -> Rewrite c m Clause -> Rewrite c m Quantified-quantifiedR r1 r2 = quantifiedT r1 r2 Quantified-{-# INLINE quantifiedR #-}+-- | 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+{-# INLINE forallR #-}  --------------------------------------------------------------------- @@ -1361,22 +1366,7 @@  --------------------------------------------------------------------- --- | Original clause passed to function so it can decide how to handle connective.-clauseT :: (Monad m, ExtendPath c Crumb) => Transform c m LCore a -> Transform c m LCore b -> (Clause -> a -> b -> d) -> Transform c m Clause d-clauseT t1 t2 f = readerT $ \ cl -> case cl of-                                      Conj{}  -> conjT  (extractT t1) (extractT t2) (f cl)-                                      Disj{}  -> disjT  (extractT t1) (extractT t2) (f cl)-                                      Impl{}  -> implT  (extractT t1) (extractT t2) (f cl)-                                      Equiv{} -> equivT (extractT t1) (extractT t2) (f cl)--clauseR :: (Monad m, ExtendPath c Crumb) => Rewrite c m LCore -> Rewrite c m LCore -> Rewrite c m Clause-clauseR r1 r2 = readerT $ \case-                             Conj{}  -> conjAllR (extractR r1) (extractR r2)-                             Disj{}  -> disjAllR (extractR r1) (extractR r2)-                             Impl{}  -> implAllR (extractR r1) (extractR r2)-                             Equiv{} -> equivAllR (extractR r1) (extractR r2)---- | Lift a transformation over '[Var]' into a transformation over the universally quantified variables of a 'Quantified'.-forallVarsT :: (AddBindings c, ReadPath c Crumb, ExtendPath c Crumb, Monad m) => Transform c m [Var] b -> Transform c m Quantified b-forallVarsT t = quantifiedT t successT const+-- Useful for utilities which are Transforms for a reason, but don't use their input.+inContextM :: c -> Transform c m () a -> m a+inContextM c t = applyT t c () 

@@ -36,7 +36,6 @@     , promoteAltT     , promoteTypeT     , promoteCoercionT-    , promoteQuantifiedT     , promoteClauseT     , promoteCoreT     , promoteLCoreT@@ -50,7 +49,6 @@     , promoteAltR     , promoteTypeR     , promoteCoercionR-    , promoteQuantifiedR     , promoteClauseR     , promoteCoreR     , promoteLCoreR@@ -90,9 +88,8 @@  -- | LCore is a KURE universe for traversing HERMIT lemmas and the Core expressions they contain. --   Types and coercions are not traversed (for that, use 'LCoreTC').---   LCore = Core + Quantified + Clause-data LCore = LQuantified Quantified-           | LClause     Clause+--   LCore = Core + Clause+data LCore = LClause     Clause            | LCore       Core  -- | LCoreTC is a KURE universe for traversing HERMIT lemmas and the Core expressions they contain.@@ -155,7 +152,6 @@ lcoreSyntaxEq :: LCore -> LCore -> Bool lcoreSyntaxEq (LCore c1)       (LCore c2)       = coreSyntaxEq c1 c2 lcoreSyntaxEq (LClause cl1)    (LClause cl2)    = clauseSyntaxEq cl1 cl2-lcoreSyntaxEq (LQuantified q1) (LQuantified q2) = quantifiedSyntaxEq q1 q2 lcoreSyntaxEq _                _                = False  -- | Syntactic equality of 'LCoreTC' fragments.@@ -312,17 +308,6 @@   {-# INLINE project #-}  -instance Injection Quantified LCore where--  inject :: Quantified -> LCore-  inject = LQuantified-  {-# INLINE inject #-}--  project :: LCore -> Maybe Quantified-  project (LQuantified q) = Just q-  project _               = Nothing-  {-# INLINE project #-}- ---------------------------------------------------------------------  instance Injection LCore LCoreTC where@@ -414,17 +399,6 @@  --------------------------------------------------------------------- -instance Injection Quantified LCoreTC where--  inject :: Quantified -> LCoreTC-  inject = LTCCore . inject-  {-# INLINE inject #-}--  project :: LCoreTC -> Maybe Quantified-  project (LTCCore lc) = project lc-  project _            = Nothing-  {-# INLINE project #-}- instance Injection Clause LCoreTC where    inject :: Clause -> LCoreTC@@ -711,11 +685,6 @@ promoteCoercionT = promoteWithFailMsgT "This translate can only succeed at coercion nodes." {-# INLINE promoteCoercionT #-} --- | Promote a translate on 'Quantified'.-promoteQuantifiedT :: (Monad m, Injection Quantified g) => Transform c m Quantified b -> Transform c m g b-promoteQuantifiedT = promoteWithFailMsgT "This translate can only succeed at quantified nodes."-{-# INLINE promoteQuantifiedT #-}- -- | Promote a translate on 'Clause'. promoteClauseT :: (Monad m, Injection Clause g) => Transform c m Clause b -> Transform c m g b promoteClauseT = promoteWithFailMsgT "This translate can only succeed at clause nodes."@@ -777,11 +746,6 @@ promoteCoercionR :: (Monad m, Injection Coercion g) => Rewrite c m Coercion -> Rewrite c m g promoteCoercionR = promoteWithFailMsgR "This rewrite can only succeed at coercion nodes." {-# INLINE promoteCoercionR #-}---- | Promote a rewrite on 'Quantified'.-promoteQuantifiedR :: (Monad m, Injection Quantified g) => Rewrite c m Quantified -> Rewrite c m g-promoteQuantifiedR = promoteWithFailMsgR "This rewrite can only succeed at quantified nodes."-{-# INLINE promoteQuantifiedR #-}  -- | Promote a rewrite on 'Clause'. promoteClauseR :: (Monad m, Injection Clause g) => Rewrite c m Clause -> Rewrite c m g

@@ -1,19 +1,20 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE NoImplicitPrelude #-}  module HERMIT.Lemma-    ( -- * Quantified-      Quantified(..)-    , mkQuantified-    , Clause(..)-    , instQuantified-    , instsQuantified+    ( -- * Clause+      Clause(..)+    , mkClause+    , mkForall+    , forallQs+    , instClause+    , instsClause     , discardUniVars-    , freeVarsQuantified+    , freeVarsClause     , clauseSyntaxEq-    , quantifiedSyntaxEq-    , substQuantified-    , substQuantifieds+    , substClause+    , substClauses     , dropBinders     , redundantDicts       -- * Lemmas@@ -26,14 +27,13 @@     , NamedLemma     ) where -import Prelude hiding (lookup)+import Prelude.Compat hiding (lookup)  import Control.Monad  import Data.Dynamic (Typeable) import Data.String (IsString(..)) import qualified Data.Map as M-import Data.Monoid  import HERMIT.Core import HERMIT.GHC hiding ((<>))@@ -41,15 +41,15 @@  ---------------------------------------------------------------------------- --- | Build a Quantified from a list of universally quantified binders and two expressions.+-- | Build a Clause from a list of universally quantified binders and two expressions. -- If the head of either expression is a lambda expression, it's binder will become a universally quantified binder -- over both sides. It is assumed the two expressions have the same type. ----- Ex.    mkQuantified [] (\x. foo x) bar === forall x. foo x = bar x---        mkQuantified [] (baz y z) (\x. foo x x) === forall x. baz y z x = foo x x---        mkQuantified [] (\x. foo x) (\y. bar y) === forall x. foo x = bar x-mkQuantified :: [CoreBndr] -> CoreExpr -> CoreExpr -> Quantified-mkQuantified vs lhs rhs = redundantDicts $ dropBinders $ Quantified (tvs++vs++lbs++rbs) (Equiv lhs' rbody)+-- Ex.    mkClause [] (\x. foo x) bar === forall x. foo x = bar x+--        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)     where (lbs, lbody) = collectBinders lhs           rhs' = uncurry mkCoreApps $ betaReduceAll rhs $ map varToCoreExpr lbs           (rbs, rbody) = collectBinders rhs'@@ -59,31 +59,38 @@               $ filterVarSet isTyVar               $ delVarSetList (unionVarSets $ map freeVarsExpr [lhs',rbody]) (vs++lbs++rbs) -freeVarsQuantified :: Quantified -> VarSet-freeVarsQuantified (Quantified bs cl) = delVarSetList (freeVarsClause cl) bs- freeVarsClause :: Clause -> VarSet-freeVarsClause (Conj  q1 q2) = unionVarSets $ map freeVarsQuantified [q1,q2]-freeVarsClause (Disj  q1 q2) = unionVarSets $ map freeVarsQuantified [q1,q2]-freeVarsClause (Impl  q1 q2) = unionVarSets $ map freeVarsQuantified [q1,q2]-freeVarsClause (Equiv e1 e2) = unionVarSets $ map freeVarsExpr [e1,e2]+freeVarsClause (Forall bs cl) = delVarSetList (freeVarsClause cl) bs+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]+freeVarsClause (Equiv e1 e2)  = unionVarSets $ map freeVarsExpr [e1,e2]+freeVarsClause CTrue          = emptyVarSet -dropBinders :: Quantified -> Quantified-dropBinders (Quantified bs cl) =+dropBinders :: Clause -> Clause+dropBinders (Forall bs cl)  =     case bs of-        []      -> Quantified [] (dropBindersClause cl)-        (b:bs') -> case dropBinders (Quantified bs' cl) of-                    q@(Quantified bs'' cl')-                        | b `elemVarSet` freeVarsQuantified q -> Quantified (b:bs'') cl'-                        | otherwise -> q+        []      -> dropBinders cl+        (b:bs') -> let c = dropBinders (mkForall bs' cl)+                   in if b `elemVarSet` freeVarsClause c+                      then addBinder b c+                      else c+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 -dropBindersClause :: Clause -> Clause-dropBindersClause (Conj q1 q2) = Conj (dropBinders q1) (dropBinders q2)-dropBindersClause (Disj q1 q2) = Disj (dropBinders q1) (dropBinders q2)-dropBindersClause (Impl q1 q2) = Impl (dropBinders q1) (dropBinders q2)-dropBindersClause equiv        = equiv+addBinder :: CoreBndr -> Clause -> Clause+addBinder b = mkForall [b] +mkForall :: [CoreBndr] -> Clause -> Clause+mkForall bs (Forall bs' cl) = Forall (bs++bs') cl+mkForall bs cl              = Forall bs cl +forallQs :: Clause -> [CoreBndr]+forallQs (Forall bs _) = bs+forallQs _             = []+ -- | A name for lemmas. Use a newtype so we can tab-complete in shell. newtype LemmaName = LemmaName String deriving (Eq, Ord, Typeable) @@ -95,10 +102,9 @@ instance Show LemmaName where show (LemmaName s) = s  -- | An equality with a proven/used status.-data Lemma = Lemma { lemmaQ :: Quantified+data Lemma = Lemma { lemmaC :: Clause                    , lemmaP :: Proven     -- whether lemma has been proven                    , lemmaU :: Used       -- whether lemma has been used-                   , lemmaT :: Bool       -- whether lemma is temporary                    }  data Proven = Proven@@ -139,7 +145,7 @@  data Used = Obligation -- ^ this MUST be proven immediately           | UnsafeUsed -- ^ used, but can be proven later (only introduced in unsafe shell)-          | NotUsed    -- ^ not used+          | NotUsed     deriving (Eq, Typeable)  instance Show Used where@@ -147,12 +153,12 @@     show UnsafeUsed = "Used"     show NotUsed    = "Not Used" -data Quantified = Quantified [CoreBndr] Clause--data Clause = Conj Quantified Quantified-            | Disj Quantified Quantified-            | Impl Quantified Quantified+data Clause = Forall [CoreBndr] Clause+            | Conj Clause Clause+            | Disj Clause Clause+            | Impl LemmaName Clause Clause -- ^ name for the antecedent when it is in scope             | Equiv CoreExpr CoreExpr+            | CTrue -- the always true clause  -- | A collection of named lemmas. type Lemmas = M.Map LemmaName Lemma@@ -162,69 +168,73 @@  ------------------------------------------------------------------------------ -discardUniVars :: Quantified -> Quantified-discardUniVars (Quantified _ cl) = Quantified [] cl+discardUniVars :: Clause -> Clause+discardUniVars (Forall _ cl) = cl+discardUniVars cl            = cl  ------------------------------------------------------------------------------ --- | Assumes Var is free in Quantified. If not, no substitution will happen, though uniques might be freshened.-substQuantified :: Var -> CoreArg -> Quantified -> Quantified-substQuantified v e = substQuantifieds [(v,e)]+-- | Assumes Var is free in Clause. If not, no substitution will happen, though uniques might be freshened.+substClause :: Var -> CoreArg -> Clause -> Clause+substClause v e = substClauses [(v,e)] -substQuantifieds :: [(Var,CoreArg)] -> Quantified -> Quantified-substQuantifieds ps q = substQuantifiedSubst (extendSubstList sub ps) q+substClauses :: [(Var,CoreArg)] -> Clause -> Clause+substClauses ps cl = substClauseSubst (extendSubstList sub ps) cl     where (vs,es) = unzip ps           sub = mkEmptySubst               $ mkInScopeSet-              $ delVarSetList (unionVarSets $ freeVarsQuantified q : map freeVarsExpr es) vs+              $ delVarSetList (unionVarSets $ freeVarsClause cl : map freeVarsExpr es) vs  -- | Note: Subst must be properly set up with an InScopeSet that includes all vars -- in scope in the *range* of the substitution.-substQuantifiedSubst :: Subst -> Quantified -> Quantified-substQuantifiedSubst = go-    where go sub (Quantified bs cl) =+substClauseSubst :: Subst -> Clause -> Clause+substClauseSubst = go+    where go sub (Forall bs cl) =             let (bs', cl') = go1 sub bs [] cl-            in Quantified bs' cl'+            in mkForall bs' 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)+          go subst (Impl nm q1 q2) = Impl nm (go subst q1) (go subst q2)+          go subst (Equiv e1 e2)   =+            let e1' = substExpr (text "substClauseSubst e1") subst e1+                e2' = substExpr (text "substClauseSubst e2") subst e2+            in Equiv e1' e2' -          go1 subst [] bs' cl = (reverse bs', go2 subst cl)+          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-          go2 subst (Conj q1 q2) = Conj (go subst q1) (go subst q2)-          go2 subst (Disj q1 q2) = Disj (go subst q1) (go subst q2)-          go2 subst (Impl q1 q2) = Impl (go subst q1) (go subst q2)-          go2 subst (Equiv e1 e2) =-            let e1' = substExpr (text "substQuantified e1") subst e1-                e2' = substExpr (text "substQuantified e2") subst e2-            in Equiv e1' e2'  ------------------------------------------------------------------------------ -redundantDicts :: Quantified -> Quantified-redundantDicts (Quantified bs cl) = go [] [] cl bs-    where go bnds _   c [] = Quantified (reverse bnds) c+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 Quantified bs'' c' = substQuantified b (head match) $ Quantified bs' c+                   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'             where bTy = varType b+redundantDicts cl             = cl  ------------------------------------------------------------------------------ --- | Instantiate one of the universally quantified variables in a 'Quantified'.+-- | Instantiate one of the universally quantified variables in a 'Clause'. -- Note: assumes implicit ordering of variables, such that substitution happens to the right -- as it does in case alternatives. Only first variable that matches predicate is -- instantiated.-instQuantified :: MonadCatch m => VarSet        -- vars in scope-                               -> (Var -> Bool) -- predicate to select var-                               -> CoreExpr      -- expression to instantiate with-                               -> Quantified -> m Quantified-instQuantified inScope p e = liftM fst . go []-    where go bbs (Quantified bs cl)+instClause :: MonadCatch m => VarSet        -- vars in scope+                           -> (Var -> Bool) -- predicate to select var+                           -> 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@@ -235,12 +245,14 @@                                 case er' of                                     Right (q2',s) -> return (con q1 q2', s)                                     Left msg -> fail msg-                        return (replaceVars s bs (Quantified [] cl'), s)+                        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 q1 q2 -> go2 Impl 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@@ -260,31 +272,30 @@                 let newBs = varSetElems                           $ filterVarSet (\v -> not (isId v) || isLocalId v)                           $ delVarSetList (minusVarSet (freeVarsExpr e') inScope) bsInScope-                    q' = substQuantified i e' $ Quantified vs cl+                    cl' = substClause i e' $ mkForall vs cl -                return (replaceVars sub (bs' ++ newBs) q', sub)+                return (replaceVars sub (bs' ++ newBs) cl', sub)+          go _ _ = fail "only applies to clauses with quantifiers."  -- | The function which 'bubbles up' after the instantiation takes place, -- replacing any type variables that were instantiated as a result of specialization.-replaceVars :: TvSubst -> [Var] -> Quantified -> Quantified+replaceVars :: TvSubst -> [Var] -> Clause -> Clause replaceVars sub vs = go (reverse vs)-    where addB b (Quantified bs cl) = Quantified (b:bs) cl--          go [] q = q-          go (b:bs) q+    where go [] cl = cl+          go (b:bs) cl             | isTyVar b = case lookupTyVar sub b of-                            Nothing -> go bs (addB b q)+                            Nothing -> go bs (addBinder b cl)                             Just ty -> let new = varSetElems (freeVarsType ty)-                                       in go (new++bs) (substQuantified b (Type ty) q)-            | otherwise = go bs (addB b q)+                                       in go (new++bs) (substClause b (Type ty) cl)+            | otherwise = go bs (addBinder b cl)  -- tvSubstToSubst :: TvSubst -> Subst -- tvSubstToSubst (TvSubst inS tEnv) = mkSubst inS tEnv emptyVarEnv emptyVarEnv --- | Instantiate a set of universally quantified variables in a 'Quantified'.+-- | Instantiate a set of universally quantified variables in a 'Clause'. -- It is important that all type variables appear before any value-level variables in the first argument.-instsQuantified :: MonadCatch m => VarSet -> [(Var,CoreExpr)] -> Quantified -> m Quantified-instsQuantified inScope = flip (foldM (\ q (v,e) -> instQuantified inScope (==v) e q)) . reverse+instsClause :: MonadCatch m => VarSet -> [(Var,CoreExpr)] -> Clause -> m Clause+instsClause inScope = flip (foldM (\ q (v,e) -> instClause inScope (==v) e q)) . reverse -- foldM is a left-to-right fold, so the reverse is important to do substitutions in reverse order -- which is what we want (all value variables should be instantiated before type variables). @@ -294,14 +305,11 @@  -- | Syntactic Equality of clauses. clauseSyntaxEq :: Clause -> Clause -> Bool-clauseSyntaxEq (Conj q1 q2)  (Conj p1 p2)    = quantifiedSyntaxEq q1 p1 && quantifiedSyntaxEq q2 p2-clauseSyntaxEq (Disj q1 q2)  (Disj p1 p2)    = quantifiedSyntaxEq q1 p1 && quantifiedSyntaxEq q2 p2-clauseSyntaxEq (Impl q1 q2)  (Impl p1 p2)    = quantifiedSyntaxEq q1 p1 && quantifiedSyntaxEq q2 p2-clauseSyntaxEq (Equiv e1 e2) (Equiv e1' e2') = exprSyntaxEq e1 e1'      && exprSyntaxEq e2 e2'-clauseSyntaxEq _             _               = False---- | Syntactic Equality of quantifiers.-quantifiedSyntaxEq :: Quantified -> Quantified -> Bool-quantifiedSyntaxEq (Quantified bs1 cl1) (Quantified bs2 cl2) = (bs1 == bs2) && clauseSyntaxEq cl1 cl2+clauseSyntaxEq (Forall bs1 c1)  (Forall bs2 c2) = (bs1 == bs2) && 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+clauseSyntaxEq (Equiv e1 e2)    (Equiv e1' e2') = exprSyntaxEq e1 e1'      && exprSyntaxEq e2 e2'+clauseSyntaxEq _                _               = False  ------------------------------------------------------------------------------

@@ -1,4 +1,6 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}+ module HERMIT.Libraries.Int where  import Control.Arrow@@ -6,12 +8,14 @@ import qualified Data.Map as M  import HERMIT.GHC hiding (intTy)-import HERMIT.Kure+import HERMIT.Kure hiding ((<$>)) import HERMIT.Lemma import HERMIT.Name import HERMIT.Dictionary.Common import HERMIT.Dictionary.GHC +import Prelude.Compat+ {- Defines the following lemmas: @@ -49,8 +53,8 @@         appMN e = mkCoreApps e [m,n]         appNM e = mkCoreApps e [n,m]         mkEL l r = mkL (Equiv l r)-        mkL cl = Lemma (Quantified [mId,nId] cl) BuiltIn NotUsed False-        mkIL al ar cl cr = mkL (Impl (Quantified [] $ Equiv al ar) (Quantified [] $ Equiv cl cr))+        mkL cl = Lemma (mkForall [mId,nId] cl) BuiltIn NotUsed+        mkIL nm al ar cl cr = mkL (Impl nm (Equiv al ar) (Equiv cl cr))      eqE <- findIdT "Data.Eq.==" >>= appToInt >>= appToDict @@ -69,8 +73,8 @@                 , ("LtGtInt", mkEL (appMN ltE) (appNM gtE))                 , ("LteGteInt", mkEL (appMN lteE) (appNM gteE))                 , ("GteLtInt", mkEL (appMN gteE) (appNM ltE))-                , ("LteFalseImpliesEqFalseInt", mkIL (appMN lteE) falseE (appMN eqE) falseE)-                , ("EqTrueImpliesLteTrueInt", mkIL (appMN eqE) trueE (appMN lteE) trueE)+                , ("LteFalseImpliesEqFalseInt", mkIL "LteFalse" (appMN lteE) falseE (appMN eqE) falseE)+                , ("EqTrueImpliesLteTrueInt", mkIL "EqTrue" (appMN eqE) trueE (appMN lteE) trueE)                 , ("MinCommutativeInt", mkEL (appMN minE) (appNM minE))                 , ("MaxCommutativeInt", mkEL (appMN maxE) (appNM maxE))                 , ("MinLteInt", mkEL (mkCoreApps lteE [appNM minE, n]) trueE)

@@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NoImplicitPrelude #-}  module HERMIT.Monad     ( -- * The HERMIT Monad@@ -11,6 +12,7 @@     , HermitMEnv     , HermitMResult(..)     , LiftCoreM(..)+    , getHscEnv     , runTcM     , runDsM       -- * Lemmas@@ -23,17 +25,14 @@     , HasHermitMEnv(..)     , mkEnv     , getModGuts-    , HasHscEnv(..)       -- * Messages-    , HasDebugChan(..)-    , DebugMessage(..)-    , sendDebugMessage+    , getDebugChan+    , KEnvMessage(..)+    , sendKEnvMessage     ) where -import Prelude hiding (lookup)+import Prelude.Compat hiding (lookup) -import Control.Applicative-import Control.Concurrent.STM import Control.Monad import Control.Monad.IO.Class @@ -52,12 +51,15 @@  -- | The HermitM environment. data HermitMEnv = HermitMEnv { hEnvChanged   :: Bool -- ^ Whether Lemmas have changed+                             , hEnvDebug     :: DebugChan                              , hEnvModGuts   :: ModGuts -- ^ Note: this is a snapshot of the ModGuts from                                                         --         before the current transformation.                              , hEnvLemmas    :: Lemmas                              } -mkEnv :: ModGuts -> Lemmas -> HermitMEnv+type DebugChan = KEnvMessage -> HermitM ()++mkEnv :: DebugChan -> ModGuts -> Lemmas -> HermitMEnv mkEnv = HermitMEnv False  -- | The HermitM result record.@@ -77,34 +79,22 @@ -- -- It provides a reader for ModGuts, state for Lemmas, -- and access to a debugging channel.-newtype HermitM a = HermitM { runHermitM :: DebugChan -> HermitMEnv -> CoreM (KureM (HermitMResult a)) }--type DebugChan = DebugMessage -> HermitM ()+newtype HermitM a = HermitM { runHermitM :: HermitMEnv -> CoreM (KureM (HermitMResult a)) }  -- | Eliminator for 'HermitM'.-runHM :: DebugChan                     -- debug chan-      -> HermitMEnv                    -- env+runHM :: HermitMEnv                    -- env       -> (HermitMResult a -> CoreM b)  -- success       -> (String -> CoreM b)           -- failure       -> HermitM a                     -- ma       -> CoreM b-runHM chan env success failure ma = runHermitM ma chan env >>= runKureM success failure+runHM env success failure ma = runHermitM ma env >>= runKureM success failure  -- | Allow HermitM to be embedded in another monad with proper capabilities.-embedHermitM :: (HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m) => HermitM a -> m a+embedHermitM :: (HasHermitMEnv m, HasLemmas m, LiftCoreM m) => HermitM a -> m a embedHermitM hm = do     env <- getHermitMEnv-    c <- liftCoreM $ liftIO newTChanIO -- we are careful to do IO within liftCoreM to avoid the MonadIO constraint-    r <- liftCoreM (runHermitM hm (liftIO . atomically . writeTChan c) env) >>= runKureM return fail-    chan <- getDebugChan-    let relayDebugMessages = do-            mm <- liftCoreM $ liftIO $ atomically $ tryReadTChan c-            case mm of-                Nothing -> return ()-                Just dm -> chan dm >> relayDebugMessages--    relayDebugMessages-    forM_ (toList (hResLemmas r)) $ uncurry insertLemma -- TODO: fix+    r <- liftCoreM (runHermitM hm env) >>= runKureM return fail+    when (hResChanged r) $ forM_ (toList (hResLemmas r)) $ uncurry insertLemma     return $ hResult r  instance Functor HermitM where@@ -120,22 +110,22 @@  instance Monad HermitM where   return :: a -> HermitM a-  return a = HermitM $ \ _ env -> return (return (mkResult env a))+  return a = HermitM $ \ env -> return (return (mkResult env a))    (>>=) :: HermitM a -> (a -> HermitM b) -> HermitM b   (HermitM gcm) >>= f =-        HermitM $ \ chan env -> gcm chan env >>= runKureM (\ (HermitMResult c ls a) ->-                                                            let env' = env { hEnvChanged = c, hEnvLemmas = ls }-                                                            in  runHermitM (f a) chan env')-                                                          (return . fail)+        HermitM $ \ env -> gcm env >>= runKureM (\ (HermitMResult c ls a) ->+                                                        let env' = env { hEnvChanged = c, hEnvLemmas = ls }+                                                        in  runHermitM (f a) env')+                                                (return . fail)    fail :: String -> HermitM a-  fail msg = HermitM $ \ _ _ -> return (fail msg)+  fail msg = HermitM $ const $ return $ fail msg  instance MonadCatch HermitM where   catchM :: HermitM a -> (String -> HermitM a) -> HermitM a-  (HermitM gcm) `catchM` f = HermitM $ \ chan env -> gcm chan env >>= runKureM (return.return)-                                                                               (\ msg -> runHermitM (f msg) chan env)+  (HermitM gcm) `catchM` f = HermitM $ \ env -> gcm env >>= runKureM (return.return)+                                                                     (\ msg -> runHermitM (f msg) env)  instance MonadIO HermitM where   liftIO :: IO a -> HermitM a@@ -173,50 +163,28 @@     getHermitMEnv :: m HermitMEnv  instance HasHermitMEnv HermitM where-    getHermitMEnv = HermitM $ \ _ env -> return $ return $ mkResult env env+    getHermitMEnv = HermitM $ \ env -> return $ return $ mkResult env env  getModGuts :: (HasHermitMEnv m, Monad m) => m ModGuts getModGuts = liftM hEnvModGuts getHermitMEnv  ---------------------------------------------------------------------------- -class HasDebugChan m where-    -- | Get the debugging channel-    getDebugChan :: m (DebugMessage -> m ())--instance HasDebugChan HermitM where-    getDebugChan = HermitM $ \ chan env -> return $ return $ mkResult env chan--sendDebugMessage :: (HasDebugChan m, Monad m) => DebugMessage -> m ()-sendDebugMessage msg = getDebugChan >>= ($ msg)--------------------------------------------------------------------------------class HasHscEnv m where-    getHscEnv :: m HscEnv--instance HasHscEnv CoreM where-    getHscEnv = getHscEnvCoreM+getDebugChan :: (HasHermitMEnv m, Monad m) => m DebugChan+getDebugChan = liftM hEnvDebug getHermitMEnv -instance HasHscEnv HermitM where-    getHscEnv = liftCoreM getHscEnv+sendKEnvMessage :: (HasHermitMEnv m, HasLemmas m, LiftCoreM m) => KEnvMessage -> m ()+sendKEnvMessage msg = getDebugChan >>= embedHermitM . ($ msg)  ----------------------------------------------------------------------------  class HasLemmas m where     getLemmas :: m Lemmas     putLemmas :: Lemmas -> m ()-    withLemmas :: Lemmas -> m a -> m a  instance HasLemmas HermitM where-    getLemmas = HermitM $ \ _ env -> return $ return $ mkResult env (hEnvLemmas env)-    putLemmas m = HermitM $ \ _ _ -> return $ return $ changedResult m ()-    withLemmas ls (HermitM f) = HermitM $ \ d env -> do-                                    kr <- f d (env { hEnvLemmas = union ls (hEnvLemmas env) })-                                    runKureM (\ (HermitMResult c ls' a) ->-                                                    let ls'' = difference ls' ls-                                                    in return $ return $ HermitMResult c ls'' a)-                                             (return . fail) kr+    getLemmas = HermitM $ \ env -> return $ return $ mkResult env (hEnvLemmas env)+    putLemmas m = HermitM $ \ _ -> return $ return $ changedResult m ()  -- | Insert or replace a lemma. insertLemma :: (HasLemmas m, Monad m) => LemmaName -> Lemma -> m ()@@ -244,18 +212,22 @@     liftCoreM :: CoreM a -> m a  instance LiftCoreM HermitM where-    liftCoreM coreM = HermitM $ \ _ env -> coreM >>= return . return . mkResult env+    liftCoreM coreM = HermitM $ \ env -> coreM >>= return . return . mkResult env +getHscEnv :: LiftCoreM m => m HscEnv+getHscEnv = liftCoreM getHscEnvCoreM+ ----------------------------------------------------------------------------  -- | A message packet.-data DebugMessage :: * where-    DebugTick ::                                       String                 -> DebugMessage-    DebugCore :: (ReadBindings c, ReadPath c Crumb) => String -> c -> LCoreTC -> DebugMessage+data KEnvMessage :: * where+    DebugTick :: String -> KEnvMessage+    DebugCore :: (LemmaContext c, ReadBindings c, ReadPath c Crumb) => String -> c -> LCoreTC -> KEnvMessage+    AddObligation :: HermitC -> LemmaName -> Lemma -> KEnvMessage -- obligation that must be proven  ---------------------------------------------------------------------------- -runTcM :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadIO m) => TcM a -> m a+runTcM :: (HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadIO m) => TcM a -> m a runTcM m = do     env <- getHscEnv     dflags <- getDynFlags@@ -268,5 +240,5 @@                                                    ++ text "Warnings:" : pprErrMsgBag warns     maybe (fail $ showMsgs msgs) return mr -runDsM :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadIO m) => DsM a -> m a+runDsM :: (HasDynFlags m, HasHermitMEnv m, LiftCoreM m, MonadIO m) => DsM a -> m a runDsM = runTcM . initDsTc

@@ -1,4 +1,9 @@-{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+ module HERMIT.Name     ( HermitName     , cmpHN2Name@@ -56,6 +61,8 @@ 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@@ -225,7 +232,7 @@  -------------------------------------------------------------------------------------------------- -findId :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+findId :: (BoundVars c, LiftCoreM m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)        => HermitName -> c -> m Id findId nm c = do     nmd <- findInNameSpaces [varNS, dataConNS] nm c@@ -234,7 +241,7 @@         NamedDataCon dc -> return $ dataConWrapId dc         other -> fail $ "findId: impossible Named returned: " ++ show other -findVar :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+findVar :: (BoundVars c, LiftCoreM m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)        => HermitName -> c -> m Var findVar nm c = do     nmd <- findInNameSpaces [varNS, tyVarNS, dataConNS] nm c@@ -244,7 +251,7 @@         NamedDataCon dc -> return $ dataConWrapId dc         other -> fail $ "findVar: impossible Named returned: " ++ show other -findTyCon :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+findTyCon :: (BoundVars c, LiftCoreM m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)           => HermitName -> c -> m TyCon findTyCon nm c = do     nmd <- findInNameSpace tyConClassNS nm c@@ -252,7 +259,7 @@         NamedTyCon tc -> return tc         other -> fail $ "findTyCon: impossible Named returned: " ++ show other -findType :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+findType :: (BoundVars c, LiftCoreM m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)          => HermitName -> c -> m Type findType nm c = do     nmd <- findInNameSpaces [tyVarNS, tyConClassNS] nm c@@ -263,12 +270,12 @@  -------------------------------------------------------------------------------------------------- -findInNameSpaces :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)+findInNameSpaces :: (BoundVars c, LiftCoreM m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)                  => [NameSpace] -> HermitName -> c -> m Named findInNameSpaces nss nm c = setFailMsg "Variable not in scope." -- because catchesM clobbers failure messages.                           $ catchesM [ findInNameSpace ns nm c | ns <- nss ] -findInNameSpace :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadIO m, MonadThings m)+findInNameSpace :: (BoundVars c, LiftCoreM m, HasHermitMEnv m, MonadIO m, MonadThings m)                 => NameSpace -> HermitName -> c -> m Named findInNameSpace ns nm c =     case varSetElems $ filterVarSet ((== ns) . occNameSpace . getOccName) $ findBoundVars (cmpHN2Var nm) c of@@ -277,7 +284,7 @@         []        -> findInNSModGuts ns nm  -- | Looks for Named in current GlobalRdrEnv. If not present, calls 'findInNSPackageDB'.-findInNSModGuts :: (HasHscEnv m, HasHermitMEnv m, MonadIO m, MonadThings m)+findInNSModGuts :: (LiftCoreM m, HasHermitMEnv m, MonadIO m, MonadThings m)                 => NameSpace -> HermitName -> m Named findInNSModGuts ns nm = do     rdrEnv <- liftM mg_rdr_env getModGuts@@ -287,7 +294,7 @@         _     -> fail "findInNSModGuts: multiple names returned"  -- | Looks for Named in package database, or built-in packages.-findInNSPackageDB :: (HasHscEnv m, HasHermitMEnv m, MonadIO m, MonadThings m)+findInNSPackageDB :: (LiftCoreM m, HasHermitMEnv m, MonadIO m, MonadThings m)                   => NameSpace -> HermitName -> m Named findInNSPackageDB ns nm = do     mnm <- lookupName ns nm@@ -296,7 +303,7 @@         Just n  -> nameToNamed n  -- | Helper to call lookupRdrNameInModule-lookupName :: (HasHermitMEnv m, HasHscEnv m, MonadIO m) => NameSpace -> HermitName -> m (Maybe Name)+lookupName :: (HasHermitMEnv m, LiftCoreM m, MonadIO m) => NameSpace -> HermitName -> m (Maybe Name) lookupName ns nm = case isQual_maybe rdrName of                     Nothing    -> return Nothing -- we can't use lookupName on the current module                     Just (m,_) -> do

@@ -1,5 +1,4 @@ {-{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} module HERMIT.ParserCore     ( parseCore@@ -189,16 +188,16 @@ -- These should probably go somewhere else.  -- | Parse a 'CoreString' to a 'CoreExpr', using the current context.-parseCoreExprT :: (ReadBindings c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m)+parseCoreExprT :: (ReadBindings c, HasHermitMEnv m, HasLemmas m, LiftCoreM m)                => CoreString -> Transform c m a CoreExpr parseCoreExprT cs = contextonlyT $ embedHermitM . parseCore cs -parse2BeforeT :: (ReadBindings c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m)+parse2BeforeT :: (ReadBindings c, HasHermitMEnv m, HasLemmas m, LiftCoreM m)               => (CoreExpr -> CoreExpr -> Translate c m a b)               -> CoreString -> CoreString -> Translate c m a b parse2BeforeT f s1 s2 = parseCoreExprT s1 &&& parseCoreExprT s2 >>= uncurry f -parse3BeforeT :: (ReadBindings c, HasDebugChan m, HasHermitMEnv m, HasLemmas m, LiftCoreM m)+parse3BeforeT :: (ReadBindings c, HasHermitMEnv m, HasLemmas m, LiftCoreM m)               => (CoreExpr -> CoreExpr -> CoreExpr -> Translate c m a b)               -> CoreString -> CoreString -> CoreString -> Translate c m a b parse3BeforeT f s1 s2 s3 = (parseCoreExprT s1 &&& parseCoreExprT s2) &&& parseCoreExprT s3 >>= (uncurry . uncurry $ f)

@@ -1,5 +1,4 @@ {-{-# LANGUAGE CPP #-} module HERMIT.ParserType     ( parseType     , parseTypeT

@@ -1,18 +1,28 @@-{-# LANGUAGE KindSignatures, GADTs, FlexibleContexts, GeneralizedNewtypeDeriving, LambdaCase #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-}+ module HERMIT.Plugin     ( -- * The HERMIT Plugin       hermitPlugin-      -- ** Running translations+      -- ** Stateful reflection of Kernel API+    , abort+    , resume     , query-    , run+    , apply+    , delete+    , list+    , tell       -- ** Using the shell     , interactive     , display     , setPretty     , setPrettyOptions       -- ** Active modifiers-    , at     , pass     , after     , before@@ -22,32 +32,29 @@     , lastPass       -- ** Knobs and Dials     , getPassInfo-    , modifyCLS-      -- ** Types+    , getKernel     , defPS-    , HPM-    , hpmToIO     ) where -import Control.Applicative-import Control.Arrow import Control.Concurrent.STM import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Operational+import Control.Monad.Reader (asks) import Control.Monad.State (gets, modify)-import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Error.Class -import Data.IORef import qualified Data.Map as M-import Data.Monoid  import HERMIT.Dictionary-import HERMIT.External hiding (Query, Shell)+import HERMIT.External import HERMIT.Kernel import HERMIT.Context-import HERMIT.Kure-import HERMIT.GHC hiding (singleton, liftIO, display, (<>))+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@@ -62,145 +69,136 @@  import Prelude hiding (until) -hermitPlugin :: ([CommandLineOption] -> HPM ()) -> Plugin-hermitPlugin f = buildPlugin $ \ store passInfo -> runHPM store passInfo . f+hermitPlugin :: ([CommandLineOption] -> PluginM ()) -> Plugin+hermitPlugin f = buildPlugin $ \ store passInfo opts -> do+    hermitKernel store (lpName passInfo) $ \ kernel initAST -> do+        ps <- defPS initAST+        (r,st) <- runPluginT (PluginReader kernel passInfo) ps $ f opts+        let cleanup ast = do+                if ast /= initAST -- only do this if we actually changed the AST+                then applyK kernel (extractR (occurAnalyseAndDezombifyR :: RewriteH Core)) Never (mkKernelEnv st) ast >>= resumeK kernel+                else resumeK kernel ast+        either (\case PAbort      -> abortK kernel+                      PResume ast -> cleanup ast+                      PError  err -> putStrLn err >> abortK kernel)+               (\ _ -> cleanup $ ps_cursor st) r -defPS :: AST -> Kernel -> PassInfo -> IO PluginState-defPS initAST kernel passInfo = do+defPS :: AST -> IO PluginState+defPS initAST = do     emptyTick <- liftIO $ atomically $ newTVar M.empty     return $ PluginState                 { ps_cursor         = initAST-                , ps_focus          = mempty                 , ps_pretty         = Clean.pretty                 , ps_render         = unicodeConsole                 , ps_tick           = emptyTick                 , ps_corelint       = False-                , ps_diffonly       = False-                , ps_failhard       = False-                , ps_kernel         = kernel-                , ps_pass           = passInfo                 } -data HPMInst :: * -> * where-    Shell    :: [External] -> [CommandLineOption] -> HPMInst ()-    Guard    :: (PassInfo -> Bool) -> HPM ()     -> HPMInst ()-    Focus    :: (Injection ModGuts g, Walker HermitC g) => TransformH g LocalPathH -> HPM a -> HPMInst a-    RR       :: (Injection ModGuts g, Walker HermitC g) => RewriteH g                       -> HPMInst ()-    Query    :: (Injection ModGuts g, Walker HermitC g) => TransformH g a                   -> HPMInst a--newtype HPM a = HPM { unHPM :: ProgramT HPMInst PluginM a }-    deriving (Functor, Applicative, Monad, MonadIO)- lpName :: PassInfo -> String lpName pInfo = case passesDone pInfo of                     [] -> "-- front end" -- comment format in case these appear in dumped script                     ps -> "-- GHC - " ++ show (last ps) -runHPM :: IORef (Maybe (AST, ASTMap)) -> PassInfo -> HPM () -> ModGuts -> CoreM ModGuts-runHPM store passInfo hpass = hermitKernel store (lpName passInfo) $ \ kernel initAST -> do-    ps <- defPS initAST kernel passInfo-    (r,st) <- hpmToIO ps hpass-    let cleanup ast = do-            if ast /= initAST -- only do this if we actually changed the AST-            then applyK kernel (extractR (occurAnalyseAndDezombifyR :: RewriteH Core)) Never (mkKernelEnv st) ast >>= resumeK kernel-            else resumeK kernel ast-    either (\case PAbort      -> abortK kernel-                  PResume ast -> cleanup ast-                  PError  err -> putStrLn err >> abortK kernel)-           (\ _ -> cleanup $ ps_cursor st) r--hpmToIO :: PluginState -> HPM a -> IO (Either PException a, PluginState)-hpmToIO initState = runPluginT initState . eval . unHPM--eval :: ProgramT HPMInst PluginM a -> PluginM a-eval comp = do-    (kernel, (env, path)) <- gets $ ps_kernel &&& mkKernelEnv &&& ps_focus-    v <- viewT comp-    case v of-        Return x           -> return x-        RR rr       :>>= k -> runS (applyK kernel (extractR $ localPathR path rr) Never env) >>= eval . k-        Query tr    :>>= k -> runQ (queryK kernel (extractT $ localPathT path tr) Never env) >>= eval . k-        Shell es os :>>= k -> clm (commandLine os es) >>= eval . k-        Guard p (HPM m)  :>>= k  -> gets (p . ps_pass) >>= \ b -> when b (eval m) >>= eval . k-        Focus tp (HPM m) :>>= k  -> do-            p <- runQ (queryK kernel (extractT tp) Never env)  -- run the pathfinding translation-            old_p <- gets ps_focus-            modify $ \st -> st { ps_focus = old_p <> p }-            r <- eval m             	      -- run the focused computation-            modify $ \st -> st { ps_focus = old_p }-            eval $ k r- ------------------------- Shell-related helpers -------------------------------------- --- | Run a kernel function on the current AST-runK :: (AST -> PluginM a) -> PluginM a-runK f = gets ps_cursor >>= f---- | Run a kernel function on the current AST and update ps_cursor-runS :: (AST -> PluginM AST) -> PluginM ()-runS f = runQ (fmap (,()) . f)+-- | Run a PluginM function on the current AST and update ps_cursor+runA :: (AST -> PluginM AST) -> PluginM ()+runA f = runQ (fmap (,()) . f) +-- | Run a PluginM function on the current AST, update ps_cursor, return result runQ :: (AST -> PluginM (AST, a)) -> PluginM a runQ f = do-    (sast, r) <- runK f+    (sast, r) <- gets ps_cursor >>= f     modify $ \st -> st { ps_cursor = sast }     return r -interactive :: [External] -> [CommandLineOption] -> HPM ()-interactive es os = HPM . singleton $ Shell (externals ++ es) os+interactive :: [External] -> [CommandLineOption] -> PluginM ()+interactive es os = clm $ commandLine os (externals ++ es) -run :: (Injection GHC.ModGuts g, Walker HermitC g) => RewriteH g -> HPM ()-run = HPM . singleton . RR+abort :: PluginM a+abort = throwError PAbort -query :: (Injection GHC.ModGuts g, Walker HermitC g) => TransformH g a -> HPM a-query = HPM . singleton . Query+resume :: PluginM a+resume = gets ps_cursor >>= throwError . PResume ------------------------------ guards ------------------------------+apply :: (Injection GHC.ModGuts g, Walker HermitC g) => CommitMsg -> RewriteH g -> PluginM ()+apply cm rr = do+    kernel <- asks pr_kernel+    env <- gets mkKernelEnv+    runA (applyK kernel (extractR rr) cm env) -guard :: (PassInfo -> Bool) -> HPM () -> HPM ()-guard p = HPM . singleton . Guard p+query :: (Injection GHC.ModGuts g, Walker HermitC g) => CommitMsg -> TransformH g a -> PluginM a+query cm tr = do+    kernel <- asks pr_kernel+    env <- gets mkKernelEnv+    runQ (queryK kernel (extractT tr) cm env) -at :: TransformH CoreTC LocalPathH -> HPM a -> HPM a-at tp = HPM . singleton . Focus tp+list :: PluginM [(AST,Maybe String, Maybe AST)]+list = asks pr_kernel >>= listK -pass :: Int -> HPM () -> HPM ()+delete :: AST -> PluginM ()+delete ast = do+    k <- asks pr_kernel+    cursor <- gets ps_cursor+    if ast == cursor+    then do+        l <- list+        case [ p | (ast',_,Just p) <- l, ast' == ast ] of+            [ast'] -> do modify $ \ st -> st { ps_cursor = ast' }+                         deleteK k ast+            _ -> fail "cannot delete current AST because it has no parent."+    else deleteK k ast++tell :: String -> PluginM ()+tell str = do+    k <- asks pr_kernel+    runA (tellK k str)++----------------------------- guards ------------------------------++guard :: (PassInfo -> Bool) -> PluginM () -> PluginM ()+guard p m = do+    b <- asks (p . pr_pass)+    when b m++pass :: Int -> PluginM () -> PluginM () pass n = guard ((n ==) . passNum) -after :: CorePass -> HPM () -> HPM ()+after :: CorePass -> PluginM () -> PluginM () after cp = guard (\passInfo -> case passesDone passInfo of                             [] -> False                             xs -> last xs == cp) -before :: CorePass -> HPM () -> HPM ()+before :: CorePass -> PluginM () -> PluginM () before cp = guard (\passInfo -> case passesLeft passInfo of                             (x:_) | cp == x -> True                             _               -> False) -until :: CorePass -> HPM () -> HPM ()+until :: CorePass -> PluginM () -> PluginM () until cp = guard ((cp `elem`) . passesLeft) -allPasses :: HPM () -> HPM ()+allPasses :: PluginM () -> PluginM () allPasses = guard (const True) -firstPass :: HPM () -> HPM ()+firstPass :: PluginM () -> PluginM () firstPass = guard (null . passesDone) -lastPass :: HPM () -> HPM ()+lastPass :: PluginM () -> PluginM () lastPass = guard (null . passesLeft)  ----------------------------- other ------------------------------ -getPassInfo :: HPM PassInfo-getPassInfo = HPM $ lift $ gets ps_pass+getKernel :: PluginM Kernel+getKernel = asks pr_kernel -display :: HPM ()-display = HPM $ lift $ Display.display Nothing Nothing+getPassInfo :: PluginM PassInfo+getPassInfo = asks pr_pass -modifyCLS :: (PluginState -> PluginState) -> HPM ()-modifyCLS = HPM . modify+display :: PluginM ()+display = Display.display Nothing Nothing -setPretty :: PrettyPrinter -> HPM ()-setPretty pp = modifyCLS $ \s -> s { ps_pretty = pp }+setPretty :: PrettyPrinter -> PluginM ()+setPretty pp = modify $ \s -> s { ps_pretty = pp } -setPrettyOptions :: PrettyOptions -> HPM ()-setPrettyOptions po = modifyCLS $ \s -> s { ps_pretty = (ps_pretty s) { pOptions = po } }+setPrettyOptions :: PrettyOptions -> PluginM ()+setPrettyOptions po = modify $ \s -> s { ps_pretty = (ps_pretty s) { pOptions = po } }

@@ -85,23 +85,28 @@           len = lengthFS (moduleNameFS mname) + 1 -- for the colon  -- | An enumeration type for GHC's passes.-data CorePass = FloatInwards-              | LiberateCase-              | PrintCore-              | StaticArgs-              | Strictness-              | WorkerWrapper-              | Specialising-              | SpecConstr+#if __GLASGOW_HASKELL__ >= 710+data CorePass = CallArity               | CSE-              | Vectorisation+#else+data CorePass = CSE+#endif               | Desugar               | DesugarOpt-              | Tidy-              | Prep-              | Simplify+              | FloatInwards               | FloatOutwards+              | LiberateCase+              | Prep+              | PrintCore               | RuleCheck+              | Simplify+              | SpecConstr+              | Specialising+              | StaticArgs+              | Strictness+              | Tidy+              | Vectorisation+              | WorkerWrapper               | Passes -- these should be flattened out in practice               | PluginPass String               | NoOp@@ -126,6 +131,9 @@             , (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)@@ -152,6 +160,9 @@ 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]

@@ -1,27 +1,31 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+ module HERMIT.Plugin.Display     ( display     , ps_putStr     , ps_putStrLn     ) where +import Control.Monad.Reader import Control.Monad.State  import Data.Maybe (fromMaybe)-import Data.Monoid  import HERMIT.Kernel (queryK, CommitMsg(..)) import HERMIT.Kure import HERMIT.Plugin.Types import HERMIT.PrettyPrinter.Common +import Prelude.Compat+ import System.IO  display :: Maybe Handle -> Maybe PathH -> PluginM () display mbh window = do+    k <- asks pr_kernel     st <- get-    let k = ps_kernel st-        ast = ps_cursor st+    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)

@@ -1,11 +1,13 @@-{-# LANGUAGE CPP, FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+ module HERMIT.Plugin.Renderer where  import Control.Arrow import Control.Monad.State  import Data.List (isInfixOf, isPrefixOf, isSuffixOf)-import Data.Monoid  import HERMIT.Dictionary (traceR) import HERMIT.Kure@@ -14,6 +16,8 @@ #ifdef mingw32_HOST_OS import HERMIT.Win32.IO (hPutStr, hPutStrLn) #endif++import Prelude.Compat  import System.Console.ANSI #ifdef mingw32_HOST_OS

@@ -1,12 +1,19 @@-{-# LANGUAGE TypeFamilies, DeriveDataTypeable, FlexibleContexts,-             LambdaCase, GADTs, GeneralizedNewtypeDeriving,-             ScopedTypeVariables, FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ module HERMIT.Plugin.Types where -import Control.Applicative import Control.Concurrent.STM import Control.Monad.Error.Class (MonadError(..)) 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)@@ -14,7 +21,6 @@ import Data.Dynamic import qualified Data.Map as M -import HERMIT.Core (Crumb) import HERMIT.Kure import HERMIT.External import HERMIT.Kernel@@ -23,14 +29,16 @@ 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 (StateT PluginState m) a }-    deriving (Functor, Applicative, MonadIO, MonadError PException, MonadState PluginState)+newtype PluginT m a = PluginT { unPluginT :: ExceptT PException (ReaderT PluginReader (StateT PluginState m)) a }+    deriving (Functor, Applicative, MonadIO, MonadError PException, MonadState PluginState, MonadReader PluginReader) -runPluginT :: PluginState -> PluginT m a -> m (Either PException a, PluginState)-runPluginT ps = flip runStateT ps . runExceptT . unPluginT+runPluginT :: PluginReader -> PluginState -> PluginT m a -> m (Either PException a, PluginState)+runPluginT pr ps = flip runStateT ps . flip runReaderT pr . runExceptT . unPluginT  instance Monad m => Monad (PluginT m) where     return = PluginT . return@@ -38,35 +46,35 @@     fail = PluginT . throwError . PError  instance MonadTrans PluginT where-    lift = PluginT . lift . lift+    lift = PluginT . lift . lift . lift  instance Monad m => MonadCatch (PluginT m) where     -- law: fail msg `catchM` f == f msg     -- catchM :: m a -> (String -> m a) -> m a     catchM m f = do         st <- get-        (r,st') <- lift $ runPluginT st m-        case r of+        r <- ask+        (er,st') <- lift $ runPluginT r st m+        case er of             Left err -> case err of                             PError msg -> f msg                             other -> throwError other -- rethrow abort/resume             Right v  -> put st' >> return v --- Session-local issues; things that are never saved.+-- Treat current AST as state, allow pretty-printer to be modified, core lint to be auto-run data PluginState = PluginState     { ps_cursor         :: AST                                      -- ^ the current AST-    , ps_focus          :: AbsolutePath Crumb                       -- ^ current focused path     , ps_pretty         :: PrettyPrinter                            -- ^ which pretty printer to use     , 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-    , ps_diffonly       :: Bool                                     -- ^ if true, show diffs rather than pp full code (TODO: move into pretty opts)-    , ps_failhard       :: Bool                                     -- ^ if true, abort on *any* failure-    -- this should be in a reader-    , ps_kernel         :: Kernel-    , ps_pass           :: PassInfo     } 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@@ -98,3 +106,4 @@                         out $ "[" ++ msg' ++ "]"                         doc :: DocH <- applyT (ppLCoreTCT pp) (liftPrettyC (pOptions pp) cxt) qc                         liftIO $ ps_render st stdout (pOptions pp) (Right doc)+                AddObligation _ nm l -> insertLemma nm l

@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- -- | Output the raw Expr constructors. Helpful for writing pattern matching rewrites. module HERMIT.PrettyPrinter.AST   ( -- * HERMIT's AST Pretty-Printer for GHC Core

@@ -1,4 +1,6 @@-{-# LANGUAGE CPP, LambdaCase, MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NoImplicitPrelude #-}  module HERMIT.PrettyPrinter.Clean     ( -- * HERMIT's Clean Pretty-Printer for GHC Core@@ -13,24 +15,24 @@     , ppKindOrType     , ppCoercion     , ppForallQuantification-    , symbol -- should be in Common     ) where  import Control.Arrow hiding ((<+>))  import Data.Char (isSpace) import Data.Default.Class-import Data.Monoid (mempty)  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+import HERMIT.Kure hiding ((<$>)) import HERMIT.Monad import HERMIT.PrettyPrinter.Common import HERMIT.Syntax +import Prelude.Compat+ import Text.PrettyPrint.MarkedHughesPJ as PP  ------------------------------------------------------------------------------------------------@@ -138,15 +140,6 @@  ------------------------------------------------------------------------------------------------ -specialSymbol :: AbsolutePathH -> SpecialSymbol -> DocH-specialSymbol p = attrP p . markColor SyntaxColor . specialFont . char . renderSpecial--symbol :: AbsolutePathH -> Char -> DocH-symbol p = attrP p . markColor SyntaxColor . char--keyword :: AbsolutePathH -> String -> DocH-keyword p = attrP p . markColor KeywordColor . text- idText :: AbsolutePathH -> String -> DocH idText p = attrP p . text @@ -421,7 +414,7 @@ ppForallQuantification :: PrettyH [Var] ppForallQuantification =   do vs <- mapT ppBinderMode-     if null vs+     if null $ filter (not . isEmpty) vs      then return empty      else return $ specialSymbol mempty ForallSymbol <+> sep vs <> symbol mempty '.' 

@@ -1,4 +1,10 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, TypeFamilies, DeriveDataTypeable, FlexibleContexts, InstanceSigs #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}  module HERMIT.PrettyPrinter.Common     ( -- * Documents@@ -19,6 +25,9 @@     , specialFont     , SpecialSymbol(..)     , SyntaxForColor(..)+    , specialSymbol+    , symbol+    , keyword       -- * Renderers     , coreRenders     , renderCode@@ -51,17 +60,19 @@  import Data.Char import Data.Default.Class-import Data.Monoid hiding ((<>)) import qualified Data.Map as M import Data.Typeable  import HERMIT.Context import HERMIT.Core import HERMIT.External-import HERMIT.GHC hiding (($$), (<>), (<+>), char)+import HERMIT.GHC hiding (($$), (<>), (<+>), char, text, keyword) import HERMIT.Kure+import HERMIT.Lemma import HERMIT.Monad +import Prelude.Compat+ import Text.PrettyPrint.MarkedHughesPJ as PP  showRole :: Role -> String@@ -122,6 +133,15 @@ specialFont :: DocH -> DocH specialFont = attr SpecialFont +specialSymbol :: AbsolutePathH -> SpecialSymbol -> DocH+specialSymbol p = attrP p . markColor SyntaxColor . specialFont . char . renderSpecial++symbol :: AbsolutePathH -> Char -> DocH+symbol p = attrP p . markColor SyntaxColor . char++keyword :: AbsolutePathH -> String -> DocH+keyword p = attrP p . markColor KeywordColor . text+ data PrettyPrinter = PP { pForall  :: PrettyH [Var]                         , pCoreTC  :: PrettyH CoreTC                         , pOptions :: PrettyOptions@@ -170,6 +190,7 @@ data PrettyC = PrettyC { prettyC_path    :: AbsolutePathH                        , prettyC_vars    :: M.Map Var AbsolutePathH                        , prettyC_options :: PrettyOptions+                       , prettyC_lemmas  :: Lemmas                        }  markBindingSite :: Var -> PrettyC -> DocH -> DocH@@ -203,21 +224,28 @@   setEmptyContext c = c { prettyC_path = mempty                         , prettyC_vars = M.empty} +instance LemmaContext PrettyC where+    addAntecedent nm l c = c { prettyC_lemmas = M.insert nm l (prettyC_lemmas c) }+    getAntecedents = prettyC_lemmas+ ------------------------------------------------------------------------ -liftPrettyH :: (ReadBindings c, ReadPath c Crumb) => PrettyOptions -> Transform PrettyC HermitM a b -> Transform c HermitM a b+liftPrettyH :: (LemmaContext c, ReadBindings c, ReadPath c Crumb) => PrettyOptions -> Transform PrettyC HermitM a b -> Transform c HermitM a b liftPrettyH = liftContext . liftPrettyC -liftPrettyC :: (ReadBindings c, ReadPath c Crumb) => PrettyOptions -> c -> PrettyC+liftPrettyC :: (LemmaContext c, ReadBindings c, ReadPath c Crumb) => PrettyOptions -> c -> PrettyC liftPrettyC opts c = PrettyC { prettyC_path    = absPath c                              , prettyC_vars    = M.fromList [ (i,hbPath b) | (i,b) <- M.toList (hermitBindings c) ]-                             , prettyC_options = opts}+                             , prettyC_options = opts+                             , prettyC_lemmas  = getAntecedents c+                             }  initPrettyC :: PrettyOptions -> PrettyC initPrettyC opts = PrettyC                       { prettyC_path    = mempty                       , prettyC_vars    = M.empty                       , prettyC_options = opts+                      , prettyC_lemmas  = M.empty                       }  -- These are *recommendations* to the pretty printer.@@ -276,6 +304,10 @@         | TypeSymbol         | TypeBindSymbol         | ForallSymbol+        | ConjSymbol+        | DisjSymbol+        | ImplSymbol+        | EquivSymbol         deriving (Show, Eq, Ord, Bounded, Enum)  class RenderSpecial a where@@ -295,6 +327,10 @@         renderSpecial TypeSymbol          = 'T'   -- <<type>>>         renderSpecial TypeBindSymbol      = 't'   -- <<type binding>>         renderSpecial ForallSymbol        = 'F'   -- forall+        renderSpecial ConjSymbol          = '^'   -- conjunction+        renderSpecial DisjSymbol          = 'v'   -- disjunction+        renderSpecial ImplSymbol          = '?'   -- implication (we can't use >, because it is used for ->)+        renderSpecial EquivSymbol         = '='   -- equivalence  newtype ASCII = ASCII String @@ -312,6 +348,10 @@         renderSpecial TypeSymbol          = ASCII "*"    -- <<type>>>         renderSpecial TypeBindSymbol      = ASCII "*"    -- <<type binding>>>         renderSpecial ForallSymbol        = ASCII "forall"+        renderSpecial ConjSymbol          = ASCII "^"    -- conjunction+        renderSpecial DisjSymbol          = ASCII "v"    -- disjunction+        renderSpecial ImplSymbol          = ASCII "=>"   -- implication+        renderSpecial EquivSymbol         = ASCII "="    -- equivalence  newtype Unicode = Unicode Char @@ -325,6 +365,10 @@         renderSpecial TypeSymbol          = Unicode '\x25b2'         renderSpecial TypeBindSymbol      = Unicode '\x25b3'         renderSpecial ForallSymbol        = Unicode '\x2200'+        renderSpecial ConjSymbol          = Unicode '\x2227'+        renderSpecial DisjSymbol          = Unicode '\x2228'+        renderSpecial ImplSymbol          = Unicode '\x21D2'+        renderSpecial EquivSymbol         = Unicode '\x2261'  newtype LaTeX = LaTeX String @@ -342,6 +386,10 @@         renderSpecial TypeSymbol          = LaTeX "\\ensuremath{\\blacktriangle}"         renderSpecial TypeBindSymbol      = LaTeX "\\ensuremath{\\vartriangle}"         renderSpecial ForallSymbol        = LaTeX "\\ensuremath{\\forall}"+        renderSpecial ConjSymbol          = LaTeX "\\ensuremath{\\wedge}"+        renderSpecial DisjSymbol          = LaTeX "\\ensuremath{\\lor}"+        renderSpecial ImplSymbol          = LaTeX "\\ensuremath{\\Rightarrow}"+        renderSpecial EquivSymbol         = LaTeX "\\ensuremath{\\equiv}"   newtype HTML = HTML String@@ -360,7 +408,10 @@         renderSpecial TypeSymbol          = HTML "&#9650;"         renderSpecial TypeBindSymbol      = HTML "&#9651;"         renderSpecial ForallSymbol        = HTML "&#8704;"-+        renderSpecial ConjSymbol          = HTML "&and;"+        renderSpecial DisjSymbol          = HTML "&or;"+        renderSpecial ImplSymbol          = HTML "&rArr;"+        renderSpecial EquivSymbol         = HTML "&equiv;"  renderSpecialFont :: RenderSpecial a => Char -> Maybe a renderSpecialFont = fmap renderSpecial . flip M.lookup specialFontMap

@@ -4,6 +4,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -22,12 +23,14 @@     , evalScript     ) where -import Control.Monad.State+import Control.Monad ((>=>), when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.State (get, gets, modify)  import Data.Char import Data.List (isPrefixOf, partition) import Data.Maybe-import Data.Monoid  import HERMIT.Context import HERMIT.External@@ -52,6 +55,8 @@ import HERMIT.Win32.Console #endif +import Prelude.Compat+ import System.IO  -- import System.Console.ANSI@@ -136,14 +141,13 @@     let -- Main proof input loop         loop :: Bool -> InputT m ()         loop firstInput = do-            el <- lift $ do tryM () announceProven-                            tryM () forceProofs-                            attemptM currentLemma-            let prompt = either (const "hermit") (const "proof") el+            ps <- lift $ do tryM () forceProofs+                            getProofStackEmpty+            let prompt = if null ps then "hermit" else "proof"             mExpr <- lift popScriptLine             case mExpr of                 Nothing -> do -- no script running-                    when firstInput $ lift $ showWindow Nothing+                    when firstInput $ lift $ showWindowAlways Nothing                     st <- lift get                     mLine <- if cl_nav st                              then liftIO getNavCmd

@@ -1,11 +1,14 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+ module HERMIT.Shell.Completion (completer) where -import Control.Applicative import Control.Arrow-import Control.Monad.State+import Control.Monad (forM, liftM)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.State (gets)  import Data.Dynamic import Data.List (isPrefixOf, nub)@@ -27,6 +30,8 @@ import HERMIT.Shell.Proof import HERMIT.Shell.Types +import Prelude.Compat+ import System.Console.Haskeline hiding (catch, display)  ----------------------------------------------------------------------------------@@ -86,7 +91,8 @@               , ("IntBox"        , NothingC)               , ("LemmaName"     , LemmaC)               , ("OccurrenceName", OccurrenceOfC)-              , ("RewriteCoreBox", CommandC) -- be more specific than CommandC?+              , ("RewriteLCoreBox", CommandC) -- be more specific than CommandC?+              , ("RewriteLCoreTCBox", CommandC) -- be more specific than CommandC?               , ("RhsOfName"     , RhsOfC)               , ("RuleName"      , RuleC)               , ("StringBox"     , StringC)@@ -96,7 +102,7 @@ filterUnknowns l = if null l' then l else l'     where l' = filter (\case UnknownC _ -> False ; _ -> True) l -completionQuery :: (MonadIO m, MonadState CommandLineState m) => CompletionType -> m (TransformH LCoreTC [String])+completionQuery :: (MonadIO m, CLMonad m) => CompletionType -> m (TransformH LCoreTC [String]) completionQuery ConsiderC       = return $ pure $ map fst considerables completionQuery OccurrenceOfC   = return $ occurrenceOfTargetsT   >>^ GHC.varSetToStrings >>^ map ('\'':) completionQuery BindingOfC      = return $ bindingOfTargetsT      >>^ GHC.varSetToStrings >>^ map ('\'':)@@ -104,13 +110,7 @@ completionQuery RhsOfC          = return $ rhsOfTargetsT          >>^ GHC.varSetToStrings >>^ map ('\'':) completionQuery InlineC         = return $ promoteLCoreT inlineTargetsT >>^                   map ('\'':) completionQuery InScopeC        = return $ pure ["'"] -- TODO-completionQuery LemmaC          = do-    let findTemps [] = []-        findTemps (pt@(Unproven {}) : _) = map (show . fst) (ptAssumed pt)-        findTemps (_ : r) = findTemps r-    cur <- gets cl_cursor-    tempLemmas <- gets (findTemps . fromMaybe [] . M.lookup cur . cl_proofstack)-    return $ liftM ((tempLemmas ++) . map show . M.keys) $ getLemmasT+completionQuery LemmaC          = return $ liftM (map show . M.keys) $ getLemmasT completionQuery NothingC        = return $ pure [] completionQuery RuleC           = return $ liftM (map (show . fst)) $ getHermitRulesT completionQuery StringC         = return $ pure ["\""]

@@ -1,15 +1,18 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}  module HERMIT.Shell.Externals where  import Control.Arrow import Control.Monad (liftM)+import Control.Monad.Reader (asks)+import Control.Monad.State (gets, modify)  import Data.Dynamic (fromDynamic) import Data.List (intercalate) import qualified Data.Map as M import Data.Maybe (fromMaybe)-import Data.Monoid (mempty)  import HERMIT.External import HERMIT.Kernel@@ -17,6 +20,7 @@ import HERMIT.Lemma import HERMIT.Parser import HERMIT.Plugin.Renderer+import HERMIT.Plugin.Types import HERMIT.PrettyPrinter.Common  import HERMIT.Dictionary.Reasoning@@ -28,6 +32,8 @@ import HERMIT.Shell.ShellEffect import HERMIT.Shell.Types +import Prelude.Compat+ ----------------------------------------------------------------------------------  shell_externals :: [External]@@ -40,57 +46,57 @@         [ "exits shell; resumes HERMIT" ]     , external "gc"              Delete         [ "garbage-collect a given AST" ]-    , external "gc"              (CLSModify $ liftM Right . gc)+    , external "gc"              (CLSModify gc)         [ "garbage-collect all ASTs except for the initial and current AST" ]-    , external "display"         (CLSModify $ \ st -> do (er,st') <- runCLT st (showWindow Nothing)-                                                         return $ fmap (const st') er)+    , external "display"         (CLSModify $ showWindowAlways Nothing)         [ "redisplays current state" ]     , external "up"              (Direction U)         [ "move to the parent node"]-    , external "navigate"        (CLSModify $ \ st -> return $ Right $ st { cl_nav = True })+    , external "navigate"        (CLSModify $ modify $ \ st -> st { cl_nav = True })         [ "switch to navigate mode" ]-    , external "command-line"    (CLSModify $ \ st -> return $ Right $ st { cl_nav = False })+    , external "command-line"    (CLSModify $ modify $ \ st -> st { cl_nav = False })         [ "switch to command line mode" ]-    , external "set-window"      (CLSModifyAndShow setWindow)+    , external "set-window"      (CLSModify $ setWindow >> showWindow Nothing)         [ "fix the window to the current focus" ]     , external "top"             (Direction T)         [ "move to root of current scope" ]     , external "log"             (Inquiry showDerivationTree)         [ "go back in the derivation" ]                                          .+ VersionControl-    , external "back"            (CLSModifyAndShow $ versionCmd Back)+    , external "back"            (CLSModify $ versionCmd Back)         [ "go back in the derivation" ]                                          .+ VersionControl-    , external "step"            (CLSModifyAndShow $ versionCmd Step)+    , external "step"            (CLSModify $ versionCmd Step)         [ "step forward in the derivation" ]                                     .+ VersionControl-    , external "goto"            (CLSModifyAndShow . versionCmd . Goto)+    , external "goto"            (CLSModify . versionCmd . Goto)         [ "goto a specific step in the derivation" ]                             .+ VersionControl-    , external "goto"            (CLSModifyAndShow . versionCmd . GotoTag)+    , external "goto"            (CLSModify . versionCmd . GotoTag)         [ "goto a specific step in the derivation by tag name" ]                 .+ VersionControl     , external "tag"             (CLSModify . versionCmd . Tag)         [ "name the current step in the derivation" ]                            .+ VersionControl     , external "diff"            Diff         [ "show diff of two ASTs" ]                                              .+ VersionControl-    , external "set-pp-diffonly" (\ bStr -> CLSModifyAndShow $ \ st ->+    , external "set-pp-diffonly" (\ bStr -> CLSModify $         case reads bStr of-            [(b,"")] -> return $ Right $ setDiffOnly st b-            _        -> return $ Left $ CLError "valid arguments are True and False" )+            [(b,"")] -> modify (\st -> st { cl_diffonly = b }) >> showWindow 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" ]-    , external "set-fail-hard"   (\ bStr -> CLSModify $ \ st ->+    , external "set-fail-hard"   (\ bStr -> CLSModify $         case reads bStr of-            [(b,"")] -> return $ Right $ setFailHard st b-            _        -> return $ Left $ CLError "valid arguments are True and False" )+            [(b,"")] -> modify $ \ st -> st { cl_failhard = b }+            _        -> fail "valid arguments are True and False" )         [ "set-fail-hard <True|False>; False by default"         , "any rewrite failure causes compilation to abort" ]-    , external "set-auto-corelint" (\ bStr -> CLSModify $ \ st ->+    , external "set-auto-corelint" (\ bStr -> CLSModify $         case reads bStr of-            [(b,"")] -> return $ Right $ setCoreLint st b-            _        -> return $ Left $ CLError "valid arguments are True and False" )+            [(b,"")] -> modify $ flip setCoreLint b+            _        -> fail "valid arguments are True and False" )         [ "set-auto-corelint <True|False>; False by default"         , "run core lint type-checker after every rewrite, reverting on failure" ]-    , external "set-pp"          (\ name -> CLSModifyAndShow $ \ st ->+    , external "set-pp"          (\ name -> CLSModify $         case M.lookup name pp_dictionary of-            Nothing -> return $ Left $ CLError $ "List of Pretty Printers: " ++ intercalate ", " (M.keys pp_dictionary)-            Just pp -> return $ Right $ flip setPrettyOpts (cl_pretty_opts st) $ setPretty st pp) -- careful to preserve the current options+            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)         [ "set the pretty printer"         , "use 'set-pp ls' to list available pretty printers" ]     , external "set-pp-renderer"    (PluginComp . changeRenderer)@@ -108,23 +114,27 @@     , external "dump-lemma" ((\pp nm fp r w -> getLemmaByNameT nm >>> liftPrettyH (pOptions pp) (ppLemmaT pp nm) >>> dumpT fp pp r w) :: PrettyPrinter -> LemmaName -> FilePath -> String -> Int -> TransformH LCoreTC ())         [ "Dump named lemma to a file."         , "dump-lemma <lemma-name> <filename> <pretty-printer> <renderer> <width>" ]-    , external "set-pp-width" (\ w -> CLSModifyAndShow $ \ st ->-            return $ Right $ setPrettyOpts st (updateWidthOption w (cl_pretty_opts st)))+    , external "set-pp-width" (\ w -> CLSModify $ do+            modify $ \ st -> setPrettyOpts st (updateWidthOption w (cl_pretty_opts st))+            showWindow Nothing)         ["set the width of the screen"]-    , external "set-pp-type" (\ str -> CLSModifyAndShow $ \ st ->+    , external "set-pp-type" (\ str -> CLSModify $         case reads str :: [(ShowOption,String)] of-            [(opt,"")] -> return $ Right $ setPrettyOpts st (updateTypeShowOption opt (cl_pretty_opts st))-            _          -> return $ Left $ CLError "valid arguments are Show, Abstract, and Omit")+            [(opt,"")] -> do modify $ \ st -> setPrettyOpts st (updateTypeShowOption opt (cl_pretty_opts st))+                             showWindow Nothing+            _          -> fail "valid arguments are Show, Abstract, and Omit")         ["set how to show expression-level types (Show|Abstact|Omit)"]-    , external "set-pp-coercion" (\ str -> CLSModifyAndShow $ \ st ->+    , external "set-pp-coercion" (\ str -> CLSModify $         case reads str :: [(ShowOption,String)] of-            [(opt,"")] -> return $ Right $ setPrettyOpts st (updateCoShowOption opt (cl_pretty_opts st))-            _          -> return $ Left $ CLError "valid arguments are Show, Abstract, and Omit")+            [(opt,"")] -> do modify $ \ st -> setPrettyOpts st (updateCoShowOption opt (cl_pretty_opts st))+                             showWindow Nothing+            _          -> fail "valid arguments are Show, Abstract, and Omit")         ["set how to show coercions (Show|Abstact|Omit)"]-    , external "set-pp-uniques" (\ str -> CLSModifyAndShow $ \ st ->+    , external "set-pp-uniques" (\ str -> CLSModify $         case reads str of-            [(b,"")] -> return $ Right $ setPrettyOpts st ((cl_pretty_opts st) { po_showUniques = b } )-            _        -> return $ Left $ CLError "valid arguments are True and False")+            [(b,"")] -> do modify $ \ st -> setPrettyOpts st ((cl_pretty_opts st) { po_showUniques = b })+                           showWindow Nothing+            _        -> fail "valid arguments are True and False")         ["set whether uniques are printed with variable names"]     , external "{"   BeginScope         ["push current lens onto a stack"]       -- tag as internal@@ -160,7 +170,7 @@         ,"Note that any names in the script will not be resolved until the script is *run*." ]     , external "display-scripts" displayScripts         ["Display all loaded scripts."]-    , external "stop-script" (CLSModify $ \st -> return $ Right $ st { cl_running_script = Nothing })+    , external "stop-script" (CLSModify $ setRunningScript Nothing)         [ "Stop running the current script." ]     --, external "test-rewrites" (testRewrites :: [(ExternalName,RewriteH Core)] -> TransformH Core String)     --  ["Test a given set of rewrites to see if they succeed"] .+ Experiment@@ -169,65 +179,73 @@     -- TODO: maybe add a "list-scripts" as well that just lists the names of loaded scripts?     ] ++ Proof.externals -gc :: CommandLineState -> IO CommandLineState-gc st = do-    let k = cl_kernel st-        cursor = cl_cursor st+gc :: CLT IO ()+gc = do+    k <- asks pr_kernel+    cursor <- gets cl_cursor     asts <- listK k     mapM_ (deleteK k) [ ast | (ast,_,_) <- asts, ast `notElem` [cursor, firstAST] ]-    return st  ---------------------------------------------------------------------------------- -setWindow :: CommandLineState -> IO (Either CLException CommandLineState)-setWindow st = do+setWindow :: CLT IO ()+setWindow = modify $ \ st ->     let ps = fromMaybe ([],mempty) (M.lookup (cl_cursor st) (cl_foci st))-    return $ Right $ st { cl_window = pathStack2Path ps }+    in st { cl_window = pathStack2Path ps }  showRenderers :: QueryFun showRenderers = message $ "set-renderer " ++ show (map fst shellRenderers)  -------------------------------------------------------- -versionCmd :: VersionCmd -> CommandLineState -> IO (Either CLException CommandLineState)-versionCmd whereTo st = do-    all_asts <- listK (cl_kernel st)+versionCmd :: VersionCmd -> CLT IO ()+versionCmd whereTo = do+    k <- asks pr_kernel+    all_asts <- listK k     case whereTo of         Goto ast ->             if ast `elem` [ ast' | (ast',_,_) <- all_asts ]-                then return $ Right $ setCursor ast st-                else return $ Left $ CLError $ "Cannot find AST #" ++ show ast ++ "."-        GotoTag nm ->-            case [ ast | (ast,nms) <- M.toList (cl_tags st), nm `elem` nms ] of-                [] -> return $ Left $ CLError $ "No tag named: " ++ nm-                (ast:_) -> return $ Right $ setCursor ast st-        Tag nm ->-            return $ Right $ st { cl_tags = M.insertWith (++) (cl_cursor st) [nm] (cl_tags st) }+                then modify (setCursor ast) >> showWindow 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+        Tag nm -> do+            modify $ \st -> st { cl_tags = M.insertWith (++) (cl_cursor st) [nm] (cl_tags st) }+            cl_putStrLn $ "Tag: " ++ nm ++ " added."         Step -> do-            let ns = [ (fromMaybe "unknown" msg, ast) | (ast,msg,Just p) <- all_asts, p == cl_cursor st ]+            cursor <- gets cl_cursor+            let ns = [ (fromMaybe "unknown" msg, ast) | (ast,msg,Just p) <- all_asts, p == cursor ]             case ns of-                [] -> return $ Left $ CLError "Cannot step forward (no more steps)."+                [] -> fail "Cannot step forward (no more steps)."                 [(cmd,ast)] -> do-                    putStrLn $ "step : " ++ cmd-                    return $ Right $ setCursor ast st-                _ -> return $ Left $ CLError $ "Cannot step forward (multiple choices), use goto {"-                                                ++ intercalate "," (map (show.snd) ns) ++ "}"+                    cl_putStrLn $ "step : " ++ cmd+                    modify $ setCursor ast+                    showWindow Nothing+                _ -> fail $ "Cannot step forward (multiple choices), use goto {"+                                ++ intercalate "," (map (show.snd) ns) ++ "}"         Back -> do-            let ns = [ (fromMaybe "unknown" msg, p) | (ast,msg,Just p) <- all_asts, ast == cl_cursor st ]+            cursor <- gets cl_cursor+            let ns = [ (fromMaybe "unknown" msg, p) | (ast,msg,Just p) <- all_asts, ast == cursor ]             case ns of-                [] -> return $ Left $ CLError "Cannot step backwards (no more steps)."+                [] -> fail "Cannot step backwards (no more steps)."                 [(cmd,ast)] -> do-                    putStrLn $ "back, unstepping : " ++ cmd-                    return $ Right $ setCursor ast st-                _ -> return $ Left $ CLError "Cannot step backwards (multiple choices, impossible!)."+                    cl_putStrLn $ "back, unstepping : " ++ cmd+                    modify $ setCursor ast+                    showWindow Nothing+                _ -> fail "Cannot step backwards (multiple choices, impossible!)."  ------------------------------------------------------------------------------- -showDerivationTree :: CommandLineState -> IO String-showDerivationTree st = do-    all_asts <- listK (cl_kernel st)+showDerivationTree :: PluginReader -> CommandLineState -> IO String+showDerivationTree r s = do+    let k = pr_kernel r+        cursor = cl_cursor s+    all_asts <- listK k     let graph = [ (a,[fromMaybe "-- command missing!" b],c) | (c,b,Just a) <- all_asts ]-    return $ unlines $ showRefactorTrail graph firstAST (cl_cursor st)+    return $ unlines $ showRefactorTrail graph firstAST cursor  showRefactorTrail :: (Eq a, Show a) => [(a,[String],a)] -> a -> a -> [String] showRefactorTrail db a me =@@ -250,7 +268,7 @@ -------------------------------------------------------------------------------  displayScripts :: QueryFun-displayScripts = Inquiry (return . showScripts . cl_scripts)+displayScripts = Inquiry (const (return . showScripts . cl_scripts))  showScripts :: [(ScriptName,Script)] -> String showScripts = concatMap (\ (name,script) -> name ++ ": " ++ unparseScript script ++ "\n\n")

@@ -9,6 +9,7 @@     ) where  import Control.Arrow+import Control.Monad.Reader import Control.Monad.State  import qualified Data.Map as M@@ -22,6 +23,7 @@ import HERMIT.Kure import HERMIT.Lemma import HERMIT.Parser+import HERMIT.Plugin.Types  import HERMIT.Shell.Types @@ -54,11 +56,12 @@     let str = unparseExprH expr     case ps of         todo@(Unproven {}) : todos -> do-            q' <- queryInFocus (inProofFocusR todo (promoteR rr) >>> (contextfreeT (applyT lintQuantifiedT (ptContext todo)) >> idR) :: TransformH Core Quantified) (Always str)-            let todo' = todo { ptLemma = (ptLemma todo) { lemmaQ = q' } }+            cl' <- queryInFocus (inProofFocusR todo (promoteR rr) >>> (contextfreeT (applyT lintClauseT (ptContext todo)) >> idR) :: TransformH Core Clause) (Always str)+            let todo' = todo { ptLemma = (ptLemma todo) { lemmaC = cl' } }             modify $ \ st -> st { cl_proofstack = M.insert (cl_cursor st) (todo':todos) (cl_proofstack st) }         _ -> do-            (k,(kEnv,(ast,cl))) <- gets (cl_kernel &&& cl_kernel_env &&& cl_cursor &&& cl_corelint)+            k <- asks pr_kernel+            (kEnv,(ast,cl)) <- gets (cl_kernel_env &&& cl_cursor &&& cl_corelint)              rr' <- addFocusR (extractR rr :: RewriteH CoreTC)             ast' <- prefixFailMsg "Rewrite failed:" $ applyK k rr' (Always str) kEnv ast@@ -69,46 +72,50 @@                 putStrToConsole warns              addAST ast'-    ifM isRunningScript (return ()) (showWindow Nothing)+    showWindow 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-    ifM isRunningScript (return ()) (showWindow Nothing)+    showWindow Nothing  goUp :: (MonadCatch m, CLMonad m) => Direction -> ExprH -> m () goUp T expr = modifyLocalPath (const mempty) expr goUp U expr = do-    (_,rel) <- getPathStack+    ps <- getProofStackEmpty+    (_,rel) <- case ps of+                [] -> getPathStack+                todo:_ -> return $ ptPath todo     case rel of         SnocPath [] -> fail "cannot move up, at root of scope."         SnocPath (_:cs) -> modifyLocalPath (const $ SnocPath cs) expr-    ifM isRunningScript (return ()) (showWindow Nothing)+    showWindow Nothing  beginScope :: (MonadCatch m, CLMonad m) => ExprH -> m () beginScope expr = do     ps <- getProofStackEmpty     let logExpr = do-            (k,ast) <- gets (cl_kernel &&& cl_cursor)+            k <- asks pr_kernel+            ast <- gets cl_cursor             tellK k (unparseExprH expr) ast     case ps of         [] -> do             (base, rel) <- getPathStack             addAST =<< logExpr             modify $ \ st -> st { cl_foci = M.insert (cl_cursor st) (rel : base, mempty) (cl_foci st) }-        Unproven nm l c ls (base,p) : todos -> do+        Unproven nm l c (base,p) : todos -> do             addAST =<< logExpr-            let todos' = Unproven nm l c ls (p : base, mempty) : todos+            let todos' = Unproven nm l c (p : base, mempty) : todos             modify $ \ st -> st { cl_proofstack = M.insert (cl_cursor st) todos' (cl_proofstack st) }-        _ -> fail "beginScope: impossible case!"-    ifM isRunningScript (return ()) (showWindow Nothing)+    showWindow Nothing  endScope :: (MonadCatch m, CLMonad m) => ExprH -> m () endScope expr = do     ps <- getProofStackEmpty     let logExpr = do-            (k,ast) <- gets (cl_kernel &&& cl_cursor)+            k <- asks pr_kernel+            ast <- gets cl_cursor             tellK k (unparseExprH expr) ast     case ps of         [] -> do@@ -118,17 +125,16 @@                 (rel:base') -> do                     addAST =<< logExpr                     modify $ \ st -> st { cl_foci = M.insert (cl_cursor st) (base', rel) (cl_foci st) }-        Unproven nm l c ls (base,_) : todos -> do+        Unproven nm l c (base,_) : todos -> do             case base of                 [] -> fail "no scope to end."                 (p:base') -> do                     addAST =<< logExpr-                    let todos' = Unproven nm l c ls (base', p) : todos+                    let todos' = Unproven nm l c (base', p) : todos                     modify $ \ st -> st { cl_proofstack = M.insert (cl_cursor st) todos' (cl_proofstack st) }-        _ -> fail "endScope: impossible case!"-    ifM isRunningScript (return ()) (showWindow Nothing)+    showWindow Nothing  deleteAST :: (MonadCatch m, CLMonad m) => AST -> m ()-deleteAST ast = gets cl_kernel >>= flip deleteK ast+deleteAST ast = asks pr_kernel >>= flip deleteK ast  -------------------------------------------------------------------------------

@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -22,70 +23,47 @@     ) where  import Control.Arrow hiding (loop, (<+>))-import Control.Monad (forM, forM_, liftM)+import Control.Concurrent.STM+import Control.Monad (forM_,unless) import Control.Monad.Error.Class (MonadError(..))-import Control.Monad.State (MonadState, modify, gets)+import Control.Monad.IO.Class+import Control.Monad.Reader (asks)+import Control.Monad.State (MonadState(get), modify, gets)  import Data.Dynamic-import Data.List (delete, zipWith4)-import qualified Data.Map as M-import Data.Monoid-import Data.String (fromString)+import Data.Function (on)+import Data.List (nubBy)  import HERMIT.Context-import HERMIT.Core import HERMIT.External-import HERMIT.GHC hiding (settings, (<>), text, sep, (<+>), ($+$), nest)+import HERMIT.GHC import HERMIT.Kernel import HERMIT.Kure import HERMIT.Lemma-import HERMIT.Monad-import HERMIT.Name import HERMIT.Parser import HERMIT.Syntax-import HERMIT.Utilities -import HERMIT.Dictionary.Induction-import HERMIT.Dictionary.Local.Case hiding (externals) import HERMIT.Dictionary.Reasoning hiding (externals)-import HERMIT.Dictionary.Undefined hiding (externals) +import HERMIT.Plugin.Types 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" (CLSModifyAndShow . interactiveProofIO)+    [ external "prove-lemma" (\nm -> CLSModify $ interactiveProof nm >> showWindow Nothing)         [ "Proof a lemma interactively." ]     ]  -- | Externals that are added to the dictionary only when in interactive proof mode. proof_externals :: [External] proof_externals = map (.+ Proof)-    [ external "lemma" (PCEnd . LemmaProof Obligation)-        [ "Prove lemma by asserting it is alpha-equivalent to an already proven lemma." ]-    , external "lemma-unsafe" (PCEnd . LemmaProof UnsafeUsed)-        [ "Prove lemma by asserting it is alpha-equivalent to an already proven lemma." ] .+ Unsafe-    , external "induction" (PCInduction . cmpString2Var :: String -> ProofShellCommand)-        [ "Perform induction on given universally quantified variable."-        , "Each constructor case will generate a new lemma to be proven."-        ]-    , external "prove-by-cases" (PCByCases . cmpString2Var :: String -> ProofShellCommand)-        [ "Case split on given universally quantified variable."-        , "Each constructor case will generate a new lemma to be proven."-        ]-    , external "prove-consequent" PCConsequent-        [ "Prove the consequent of an implication by assuming the antecedent." ]-    , external "prove-conjunction" PCConjunction-        [ "Prove a conjunction by proving both sides of it." ]-    , external "inst-assumed" (\ i nm cs -> PCInstAssumed i (cmpHN2Var nm) cs)-        [ "Split an assumed lemma which is a conjunction/disjunction." ]-    , external "split-assumed" PCSplitAssumed-        [ "Split an assumed lemma which is a conjunction/disjunction." ]-    , external "end-proof" (PCEnd Reflexivity)+    [ external "end-proof" (PCEnd Reflexivity)         [ "check for alpha-equality, marking the lemma as proven" ]     , external "end-case" (PCEnd Reflexivity)         [ "check for alpha-equality, marking the proof case as proven" ]@@ -96,18 +74,16 @@ --------------------------------------------------------------------------------------------------------  -- | Top level entry point!-interactiveProofIO :: LemmaName -> CommandLineState -> IO (Either CLException CommandLineState)-interactiveProofIO nm s = do-    (r,st) <- runCLT s $ do-                ps <- getProofStackEmpty-                let t :: TransformH x (HermitC,Lemma)-                    t = contextT &&& getLemmaByNameT nm-                (c,l) <- case ps of-                            [] -> queryInFocus (t :: TransformH Core (HermitC,Lemma))-                                               (Always $ "prove-lemma " ++ quoteShow nm)-                            todo : _ -> queryInFocus (inProofFocusT todo t) Never-                pushProofStack $ Unproven nm l c [] mempty-    return $ fmap (const st) r+interactiveProof :: LemmaName -> CLT IO ()+interactiveProof nm = do+    ps <- getProofStackEmpty+    let t :: TransformH x (HermitC,Lemma)+        t = contextT &&& getLemmaByNameT nm+    (c,l) <- case ps of+                [] -> queryInFocus (t :: TransformH Core (HermitC,Lemma))+                                   (Always $ "prove-lemma " ++ quoteShow nm)+                todo : _ -> queryInFocus (inProofFocusT todo t) Never+    pushProofStack $ Unproven nm l c mempty  withProofExternals :: (MonadError CLException m, MonadState CommandLineState m) => m a -> m a withProofExternals comp = do@@ -124,31 +100,36 @@  forceProofs :: (MonadCatch m, CLMonad m) => m () forceProofs = do-    (c,nls) <- queryInFocus (contextT &&& getObligationNotProvenT :: TransformH Core (HermitC, [NamedLemma])) Never-    todos <- getProofStackEmpty-    let already = map ptName todos-        nls' = [ nl | nl@(nm,_) <- nls, not (nm `elem` already) ]-    if null nls'-    then return ()-    else do-        c' <- case todos of-                todo : _ -> queryInFocus (inProofFocusT todo contextT) Never-                _        -> return c-        forM_ nls' $ \ (nm,l) -> pushProofStack (Unproven nm l c' [] mempty)+    k <- asks pr_kernel+    st <- get+    ls <- liftIO $ atomically $ swapTVar (cl_templemmas st) []+    let snd3 (_,y,_) = y+        nls = nubBy ((==) `on` snd3) ls+    unless (null nls) $ do+        (_,topc) <- queryK k (arr topLevelHermitC) Never (cl_kernel_env st) (cl_cursor st)+        let chooseC c cl = if all (inScope topc) (varSetElems (freeVarsClause cl)) then (True,topc) else (False,c)+            nls' = [ (chooseC c (lemmaC l), nm, l) | (c,nm,l) <- nls ]+            nonTemp = [ (nm,l) | ((True,_),nm,l) <- nls' ]+        unless (null nonTemp) $+            queryInFocus (insertLemmasT nonTemp :: TransformH LCore ())+                         (Always $ "-- recording obligations as lemmas : " ++ unwords (map (show.fst) (reverse nonTemp)))+        forM_ nls' $ \ ((_,c),nm,l) -> do+            cl_putStrLn $ "Forcing obligation: " ++ show nm+            pushProofStack (Unproven nm l c mempty)+        showWindow Nothing  -- | Verify that the lemma has been proven. Throws an exception if it has not. endProof :: (MonadCatch m, CLMonad m) => ProofReason -> ExprH -> m () endProof reason expr = do-    Unproven nm (Lemma q _ _ temp) c ls _ : _ <- getProofStack+    Unproven nm (Lemma q _ _) c _ : _ <- getProofStack     let msg = "The two sides of " ++ quoteShow nm ++ " are not alpha-equivalent."-        deleteOr tr = if temp then constT (deleteLemma nm) else tr         t = case reason of-                UserAssume -> deleteOr (markLemmaProvenT nm Assumed)-                Reflexivity -> setFailMsg msg verifyQuantifiedT >> deleteOr (markLemmaProvenT nm Proven)-                LemmaProof u nm' -> verifyEquivalentT u nm' >> deleteOr (markLemmaProvenT nm Proven)+                UserAssume -> markLemmaProvenT nm Assumed+                Reflexivity -> setFailMsg msg (do tryR (extractR simplifyClauseR) >>> verifyClauseT+                                                  markLemmaProvenT nm Proven)                 UserProof up -> let UserProofTechnique tr = up-                                in extractT tr >> deleteOr (markLemmaProvenT nm Proven)-    queryInFocus (constT (withLemmas (M.fromList ls) $ applyT t c q) :: TransformH Core ())+                                in extractT tr >> markLemmaProvenT nm Proven+    queryInFocus (constT (applyT t c q) :: TransformH Core ())                  (Always $ unparseExprH expr ++ " -- proven " ++ quoteShow nm)     _ <- popProofStack     cl_putStrLn $ "Successfully proven: " ++ show nm@@ -159,153 +140,16 @@ -- can generate additional lemmas, and add to the version history. performProofShellCommand :: (MonadCatch m, CLMonad m)                          => ProofShellCommand -> ExprH -> m ()-performProofShellCommand cmd expr = go cmd-    where str = unparseExprH expr-          go (PCInduction idPred) = performInduction (Always str) idPred-          go (PCByCases idPred)   = proveByCases (Always str) idPred-          go PCConsequent         = proveConsequent str-          go PCConjunction        = proveConjunction str-          go (PCInstAssumed i v cs) = instAssumed i v cs str-          go (PCSplitAssumed i)   = splitAssumed i str-          go (PCEnd why)          = endProof why expr--proveConsequent :: (MonadCatch m, CLMonad m) => String -> m ()-proveConsequent expr = do-    todo : _ <- getProofStack-    (c, Impl ante con) <- setFailMsg "not an implication" $-                          queryInFocus (inProofFocusT todo (contextT &&& projectT)) Never-    let nm = ptName todo-        ls = (nm <> "-antecedent", Lemma ante BuiltIn NotUsed True) : ptAssumed todo-    (k,ast) <- gets (cl_kernel &&& cl_cursor)-    addAST =<< tellK k expr ast-    _ <- popProofStack-    pushProofStack $ MarkProven nm (lemmaT (ptLemma todo)) -- proving the consequent proves the lemma-    pushProofStack $ Unproven (nm <> "-consequent") (Lemma con NotProven Obligation True) c ls mempty--proveConjunction :: (MonadCatch m, CLMonad m) => String -> m ()-proveConjunction expr = do-    Unproven nm (Lemma (Quantified bs cl) p u t) c ls _ : _ <- getProofStack-    case cl of-        Conj (Quantified lbs lcl) (Quantified rbs rcl) -> do-            (k,ast) <- gets (cl_kernel &&& cl_cursor)-            addAST =<< tellK k expr ast-            _ <- popProofStack-            pushProofStack $ MarkProven nm t-            pushProofStack $ Unproven (nm <> "-r") (Lemma (Quantified (bs++rbs) rcl) p u True) c ls mempty-            pushProofStack $ Unproven (nm <> "-l") (Lemma (Quantified (bs++lbs) lcl) p u True) c ls mempty-        _ -> fail "not a conjunction."--splitAssumed :: (MonadCatch m, CLMonad m) => Int -> String -> m ()-splitAssumed i expr = do-    Unproven nm lem c ls ps : _ <- getProofStack-    (b, (n, Lemma q p u t):a) <- getIth i ls-    qs <- splitQuantified q-    let nls = [ (n <> fromString (show j), Lemma q' p u t) | (j::Int,q') <- zip [0..] qs ]-    (k,ast) <- gets (cl_kernel &&& cl_cursor)-    addAST =<< tellK k expr ast-    _ <- popProofStack-    pushProofStack $ Unproven nm lem c (b ++ nls ++ a) ps--instAssumed :: (MonadCatch m, CLMonad m) => Int -> (Var -> Bool) -> CoreString -> String -> m ()-instAssumed i pr cs expr = do-    todo : _ <- getProofStack-    (b, orig@(n, Lemma q p u t):a) <- getIth i $ ptAssumed todo-    q' <- queryInFocus (inProofFocusT todo $ return q >>> instantiateQuantifiedVarR pr cs) Never-    (k,ast) <- gets (cl_kernel &&& cl_cursor)-    addAST =<< tellK k expr ast-    _ <- popProofStack-    pushProofStack $ todo { ptAssumed = b ++ orig:(n <> "'", Lemma q' p u t):a }--getIth :: MonadCatch m => Int -> [a] -> m ([a],[a])-getIth _ [] = fail "getIth: out of range"-getIth n (x:xs) = go n x xs []-    where go 0 y ys zs = return (reverse zs, y:ys)-          go _ _ [] _  = fail "getIth: out of range"-          go i z (y:ys) zs = go (i-1) y ys (z:zs)---- | Always returns non-empty list, or fails.-splitQuantified :: MonadCatch m => Quantified -> m [Quantified]-splitQuantified (Quantified bs cl) = do-    case cl of-        Conj (Quantified lbs lcl) (Quantified rbs rcl) ->-            return [Quantified (bs++lbs) lcl, Quantified (bs++rbs) rcl]-        Disj (Quantified lbs lcl) (Quantified rbs rcl) ->-            return [Quantified (bs++lbs) lcl, Quantified (bs++rbs) rcl]-        Impl (Quantified lbs lcl) (Quantified rbs rcl) ->-            return [Quantified (bs++lbs) lcl, Quantified (bs++rbs) rcl]-        _ -> fail "equalities cannot be split!"--performInduction :: (MonadCatch m, CLMonad m)-                 => CommitMsg -> (Id -> Bool) -> m ()-performInduction cm idPred = do-    (nm, Lemma q@(Quantified bs (Equiv lhs rhs)) _ _ temp, ctxt, ls, _) <- currentLemma-    i <- setFailMsg "specified identifier is not universally quantified in this equality lemma." $-         soleElement (filter idPred bs)--    -- Why do a query? We want to do our proof in the current context of the shell, whatever that is.-    cases <- queryInContext-                (inductionCaseSplit bs i lhs rhs :: TransformH LCoreTC [(Maybe DataCon, [Var], CoreExpr, CoreExpr)])-                cm--    -- replace the current lemma with the three subcases-    -- proving them will prove this case automatically-    _ <- popProofStack-    pushProofStack $ MarkProven nm temp-    forM_ (reverse cases) $ \ (mdc,vs,lhsE,rhsE) -> do--        let vs_matching_i_type = filter (typeAlphaEq (varType i) . varType) vs-            caseName = maybe "undefined" unqualifiedName mdc--        -- Generate list of specialized induction hypotheses for the recursive cases.-        qs <- forM vs_matching_i_type $ \ i' -> do-                liftM discardUniVars $ instQuantified (boundVars ctxt) (==i) (Var i') q-                -- TODO rethink the discardUniVars--        let nms = [ fromString ("ind-hyp-" ++ show n) | n :: Int <- [0..] ]-            hypLemmas = zip nms $ zipWith4 Lemma qs (repeat BuiltIn) (repeat NotUsed) (repeat True)-            lemmaName = fromString $ show nm ++ "-induction-case-" ++ caseName-            caseLemma = Lemma (mkQuantified (delete i bs ++ vs) lhsE rhsE) NotProven Obligation True--        pushProofStack $ Unproven lemmaName caseLemma ctxt (hypLemmas ++ ls) mempty--proveByCases :: (MonadCatch m, CLMonad m)-             => CommitMsg -> (Id -> Bool) -> m ()-proveByCases cm idPred = do-    (nm, Lemma (Quantified bs cl) _ _ temp, ctxt, ls, _) <- currentLemma-    guardMsg (any idPred bs) "specified identifier is not universally quantified in this lemma."-    let (as,b:bs') = break idPred bs -- safe because above guard-    guardMsg (not (any idPred bs')) "multiple matching quantifiers."--    cases <- queryInContext (do ue <- mkUndefinedValT (varType b)-                                liftM (ue:) (constT (caseExprsForM (varToCoreExpr b)))) cm--    -- replace the current lemma with the three subcases-    -- proving them will prove the overall lemma automatically-    _ <- popProofStack-    pushProofStack $ MarkProven nm temp-    forM_ (zip [(0::Int)..] $ reverse cases) $ \ (i,e) -> do--        let lemmaName = fromString $ show nm ++ "-case-" ++ show i-            Quantified bs'' cl' = substQuantified b e $ Quantified bs' cl-            fvs = varSetElems $ localFreeVarsExpr e-            caseLemma = Lemma (Quantified (as++fvs++bs'') cl') NotProven Obligation True--        pushProofStack $ Unproven lemmaName caseLemma ctxt ls mempty+performProofShellCommand cmd expr = go cmd >> showWindow Nothing+    where go (PCEnd why)          = endProof why expr  data ProofShellCommand-    = PCInduction (Id -> Bool)-    | PCByCases (Id -> Bool)-    | PCConsequent-    | PCConjunction-    | PCSplitAssumed Int-    | PCInstAssumed Int (Var -> Bool) CoreString-    | PCEnd ProofReason+    = PCEnd ProofReason     deriving Typeable  data ProofReason = UserProof UserProofTechnique -- ^ Run the technique, mark Proven if succeeds                  | UserAssume                   -- ^ Assume                  | Reflexivity                  -- ^ Check for alpha-equivalence first-                 | LemmaProof Used LemmaName    -- ^ Used should be 'UnsafeUsed' or 'Obligation'  -- keep abstract to avoid breaking things if we modify this later newtype UserProofTechnique = UserProofTechnique (TransformH LCoreTC ())

@@ -1,5 +1,11 @@-{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts, LambdaCase,-             MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}  module HERMIT.Shell.ScriptToRewrite     ( -- * Converting Scripts to Rewrites@@ -17,21 +23,23 @@     ) where  import Control.Arrow-import Control.Monad+import Control.Monad (forM) import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (asks) 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)+import HERMIT.Context (LocalPathH, getAntecedents) import HERMIT.External import HERMIT.Kernel import HERMIT.Kure import HERMIT.Lemma import HERMIT.Parser(Script, ExprH, unparseExprH, parseScript, unparseScript) import HERMIT.Dictionary.Reasoning+import HERMIT.Plugin.Types import HERMIT.PrettyPrinter.Common import qualified HERMIT.PrettyPrinter.Clean as Clean @@ -40,6 +48,8 @@ import HERMIT.Shell.ShellEffect import HERMIT.Shell.Types +import Prelude.Compat hiding ((<$>))+ import qualified Text.PrettyPrint.MarkedHughesPJ as PP ------------------------------------ @@ -82,18 +92,16 @@     (now,opts) <- gets (cl_cursor &&& cl_pretty_opts)     modify $ setCursor ast     ps <- getProofStackEmpty-    let discardProvens [] = []-        discardProvens r@(Unproven{} : _) = r-        discardProvens (_:r) = discardProvens r-    doc <- case discardProvens ps of-            Unproven _ (Lemma q _ _ _) _ ls p : _ -> do-                as <- case ls of-                        [] -> return []-                        _  -> liftM (PP.text "Assumed lemmas: " :) $-                                queryInFocus ((liftPrettyH opts $-                                                forM ls $ \(n',l') ->-                                                    return l' >>> ppLemmaT Clean.pretty n'-                                              ) :: TransformH Core [DocH]) Never+    doc <- case ps of+            Unproven _ (Lemma q _ _) _ p : _ -> do+                as <- queryInContext ((liftPrettyH opts $ do+                                        m <- getAntecedents <$> contextT+                                        ds <- forM (M.toList m) $ \(n',l') ->+                                                return l' >>> ppLemmaT Clean.pretty n'+                                        if M.null m+                                        then return []+                                        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 $ PP.vcat $ as ++ [PP.text "Goal:", d]@@ -121,7 +129,8 @@            go (SaveFile verb fileName) = do             putStrToConsole $ "[saving " ++ fileName ++ "]"-            (k,cur) <- gets (cl_kernel &&& cl_cursor)+            k <- asks pr_kernel+            cur <- gets cl_cursor             all_asts <- listK k             let m = M.fromList [ (ast,(msg,p)) | (ast,msg,p) <- all_asts ]                 follow ast

@@ -18,6 +18,7 @@  import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Reader (ask) import Control.Monad.State (MonadState(..), gets)  import Data.Typeable@@ -37,8 +38,7 @@  data ShellEffect :: * where     Abort             :: ShellEffect-    CLSModify         :: (CommandLineState -> IO (Either CLException CommandLineState)) -> ShellEffect-    CLSModifyAndShow  :: (CommandLineState -> IO (Either CLException CommandLineState)) -> ShellEffect+    CLSModify         :: CLT IO () -> ShellEffect     PluginComp        :: PluginM () -> ShellEffect     Continue          :: ShellEffect     Resume            :: ShellEffect@@ -56,11 +56,7 @@ performShellEffect Resume = announceUnprovens >> gets cl_cursor >>= resume performShellEffect Continue = announceUnprovens >> get >>= continue -performShellEffect (CLSModify f) = get >>= liftAndCatchIO . f >>= either throwError put--performShellEffect (CLSModifyAndShow f) = do-    get >>= liftAndCatchIO . f >>= either throwError put-    ifM isRunningScript (return ()) (showWindow Nothing)+performShellEffect (CLSModify m) = clm2clt m  performShellEffect (PluginComp m) = pluginM m @@ -73,13 +69,15 @@                                hClose h       _ -> fail "dump: bad renderer option" -dump :: FilePath -> PrettyPrinter -> String -> Int -> CommandLineState -> IO (Either CLException CommandLineState)-dump fileName pp renderer width st = do+dump :: FilePath -> PrettyPrinter -> String -> Int -> CLT IO ()+dump fileName pp renderer width = do+    st <- get+    env <- ask     let st' = setPrettyOpts (setPretty st pp) $ (cl_pretty_opts st) { po_width = width }-    (r, _st'') <- runCLT st' $ do+    (er, _st'') <- runCLT env st' $ do         pluginM (changeRenderer renderer)         h <- liftIO $ openFile fileName WriteMode-        showWindow (Just h)+        showWindowAlways (Just h)         liftIO $ hClose h-    return $ fmap (const st) r+    either throwError return er 

@@ -8,28 +8,28 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+ module HERMIT.Shell.Types where -import Control.Applicative import Control.Arrow import Control.Concurrent.STM-import Control.Monad (liftM, unless, when, forM_)+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 Data.Dynamic-import Data.List (intercalate) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust)-import Data.Monoid (mempty, (<>))-import Data.String (fromString)  import HERMIT.Context import HERMIT.Core@@ -42,12 +42,13 @@ import HERMIT.Monad import HERMIT.Parser import HERMIT.PrettyPrinter.Common-import HERMIT.Syntax  import HERMIT.Plugin.Display import HERMIT.Plugin.Renderer import HERMIT.Plugin.Types +import Prelude.Compat hiding ((<$>))+ import System.Console.Haskeline hiding (catch, display) import System.IO (Handle, stdout) @@ -66,12 +67,12 @@    QueryDocH    :: Injection a LCoreTC => TransformH a DocH         -> QueryFun    QueryPrettyH :: Injection a LCoreTC => PrettyH a                 -> QueryFun    Diff         :: AST -> AST                                       -> QueryFun-   Inquiry      :: (CommandLineState -> IO String)                  -> QueryFun+   Inquiry      :: (PluginReader -> CommandLineState -> IO String)  -> QueryFun    QueryUnit    :: Injection a LCoreTC => TransformH a ()           -> QueryFun    deriving Typeable  message :: String -> QueryFun-message str = Inquiry (const $ return str)+message = Inquiry . const . const . return  instance Extern QueryFun where    type Box QueryFun = QueryFun@@ -94,11 +95,12 @@             doc <- prefixFailMsg "Query failed: " $ queryInContext (liftPrettyH (pOptions (cl_pretty st)) $ promoteT q) cm             liftIO $ cl_render st stdout (cl_pretty_opts st) (Right doc) -          go (Inquiry f) = get >>= liftIO . f >>= putStrToConsole+          go (Inquiry f) = ask >>= \env -> get >>= liftIO . f env >>= putStrToConsole            go (Diff ast1 ast2) = do+            k <- asks pr_kernel             st <- get-            all_asts <- listK (cl_kernel st)+            all_asts <- listK k              let getCmds ast                     | ast == ast1 = []@@ -128,7 +130,8 @@ ppWholeProgram :: (CLMonad m, MonadCatch m) => AST -> m DocH ppWholeProgram ast = do     st <- get-    d <- queryK (cl_kernel st)+    k <- asks pr_kernel+    d <- queryK k                 (extractT $ pathT [ModGuts_Prog] $ liftPrettyH (cl_pretty_opts st) $ pCoreTC $ cl_pretty st)                 Never                 (cl_kernel_env st) ast@@ -181,8 +184,8 @@ -- management in the command line code. -- -- NB: an alternative to monad transformers, like Oleg's Extensible Effects, might be useful here.-newtype CLT m a = CLT { unCLT :: ExceptT CLException (StateT CommandLineState m) a }-    deriving (Functor, Applicative, MonadIO, MonadError CLException, MonadState CommandLineState)+newtype CLT m a = CLT { unCLT :: ExceptT CLException (ReaderT PluginReader (StateT CommandLineState m)) a }+    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@@ -201,11 +204,11 @@                     run' = RunIO (fmap (StateT . const) . run . flip runStateT s)                     in fmap (flip runStateT s) $ f run' -type CLMonad m = (MonadIO m, MonadState CommandLineState m, MonadError CLException m)+type CLMonad m = (MonadIO m, MonadState CommandLineState m, MonadReader PluginReader m, MonadError CLException m)  instance MonadTrans CLT where     -- lift :: Monad m => m a -> CLT m a-    lift = CLT . lift . lift+    lift = CLT . lift . lift . lift  -- TODO: type CLM = CLT IO @@ -217,41 +220,45 @@     fail = CLT . throwError . CLError  -- | Run a CLT computation.-runCLT :: CommandLineState -> CLT m a -> m (Either CLException a, CommandLineState)-runCLT s = flip runStateT s . runExceptT . unCLT+runCLT :: PluginReader -> CommandLineState -> CLT m a -> m (Either CLException a, CommandLineState)+runCLT r s = flip runStateT s . flip runReaderT r . runExceptT . unCLT --- | Lift a CLT IO computation into a CLT computation over an arbitrary MonadIO.-clm2clt :: MonadIO m => CLT IO a -> CLT m a+-- | Lift a CLT IO computation into a computation in an arbitrary CLMonad.+clm2clt :: CLMonad m => CLT IO a -> m a clm2clt m = do     st <- get-    (ea, st') <- liftIO (runCLT st m)+    env <- ask+    (ea, st') <- liftIO (runCLT env st m)     either throwError (\r -> put st' >> return r) ea  -- | Lift a CLM computation into the PluginM monad. clm :: CLT IO a -> PluginM a clm m = do     s <- mkCLS-    (r,s') <- liftIO $ runCLT s m-    case r of+    env <- ask+    (er,s') <- liftIO $ runCLT env s m+    case er of         Left err -> rethrowCLE err-        Right r' -> put (cl_pstate s') >> return r'+        Right r  -> put (cl_pstate s') >> return r  -- | Lift a PluginM computation into the CLM monad. pluginM :: CLMonad m => PluginM a -> m a pluginM m = do     s <- get-    (r,ps) <- liftIO $ runPluginT (cl_pstate s) m-    case r of+    env <- ask+    (er,ps) <- liftIO $ runPluginT env (cl_pstate s) m+    case er of         Left err -> rethrowPE err-        Right r' -> put (s { cl_pstate = ps }) >> return r'+        Right r -> put (s { cl_pstate = ps }) >> return r  instance Monad m => MonadCatch (CLT m) where     -- law: fail msg `catchM` f == f msg     -- catchM :: m a -> (String -> m a) -> m a     catchM m f = do         st <- get-        (r,st') <- lift $ runCLT st m-        case r of+        env <- ask+        (er,st') <- lift $ runCLT env st m+        case er of             Left err -> case err of                             CLError msg -> f msg                             other -> throwError other -- rethrow abort/resume/continue@@ -274,6 +281,9 @@     , cl_externals      :: [External]             -- ^ Currently visible externals     , cl_running_script :: Maybe Script           -- ^ Nothing = no script running, otherwise the remaining script commands     , cl_safety         :: Safety                 -- ^ which level of safety we are running in+    , 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)@@ -282,12 +292,11 @@                     { ptName    :: LemmaName    -- ^ lemma we are proving                     , ptLemma   :: Lemma                     , ptContext :: HermitC      -- ^ context in which lemma is being proved-                    , ptAssumed :: [NamedLemma] -- ^ temporary lemmas in scope                     , ptPath    :: PathStack    -- ^ path into lemma to focus on                     }-               | MarkProven { ptName :: LemmaName, ptTemp :: Bool } -- ^ lemma successfully proven, temporary status  data Safety = StrictSafety | NormalSafety | NoSafety+    deriving (Read, Show, Eq, Typeable)  filterSafety :: Safety -> [External] -> [External] filterSafety NoSafety     = id@@ -311,23 +320,14 @@ setCursor :: AST -> CommandLineState -> CommandLineState setCursor sast st = st { cl_pstate = (cl_pstate st) { ps_cursor = sast } } -cl_diffonly :: CommandLineState -> Bool-cl_diffonly = ps_diffonly . cl_pstate--setDiffOnly :: CommandLineState -> Bool -> CommandLineState-setDiffOnly st b = st { cl_pstate = (cl_pstate st) { ps_diffonly = b } }--cl_failhard :: CommandLineState -> Bool-cl_failhard = ps_failhard . cl_pstate--setFailHard :: CommandLineState -> Bool -> CommandLineState-setFailHard st b = st { cl_pstate = (cl_pstate st) { ps_failhard = b } }--cl_kernel :: CommandLineState -> Kernel-cl_kernel = ps_kernel . cl_pstate- cl_kernel_env :: CommandLineState -> KernelEnv-cl_kernel_env = mkKernelEnv . cl_pstate+cl_kernel_env s = do+    let KernelEnv f = mkKernelEnv (cl_pstate s)+    KernelEnv $ \ msg ->+        case msg of+            AddObligation c nm l@(Lemma _ NotProven Obligation) | cl_safety s /= NoSafety ->+                liftIO $ atomically $ modifyTVar' (cl_templemmas s) ((c,nm,l):)+            _ -> f msg  cl_pretty :: CommandLineState -> PrettyPrinter cl_pretty = ps_pretty . cl_pstate@@ -350,6 +350,7 @@ mkCLS = do     ps <- get     (w,h) <- liftIO getTermDimensions+    tlv <- liftIO (newTVarIO [])     let st = CommandLineState { cl_pstate         = ps                               , cl_height         = h                               , cl_scripts        = []@@ -361,6 +362,9 @@                               , cl_externals      = [] -- Note, empty dictionary.                               , cl_running_script = Nothing                               , cl_safety         = NormalSafety+                              , cl_templemmas     = tlv+                              , cl_failhard       = False+                              , cl_diffonly       = False                               }     return $ setPrettyOpts st $ (cl_pretty_opts st) { po_width = w } @@ -452,16 +456,17 @@ modifyLocalPath :: (MonadCatch m, CLMonad m) => (LocalPathH -> LocalPathH) -> ExprH -> m () modifyLocalPath f expr = do     ps <- getProofStackEmpty-    (k,(kEnv,ast)) <- gets (cl_kernel &&& cl_kernel_env &&& cl_cursor)+    k <- asks pr_kernel+    (kEnv,ast) <- gets (cl_kernel_env &&& cl_cursor)     case ps of-        todo@(Unproven _ (Lemma q _ _ _) c _ _) : todos -> do+        todo@(Unproven _ (Lemma q _ _) c _) : todos -> do             let (base, rel) = ptPath todo                 rel' = f rel             requireDifferent rel rel'             (ast',()) <- queryK k (constT                                     (applyT                                       (setFailMsg "invalid path."-                                        (focusT (pathStackToLens base rel' :: LensH Quantified LCoreTC) successT))+                                        (focusT (pathStackToLens base rel' :: LensH Clause LCoreTC) successT))                                       c q))                                   (Always $ unparseExprH expr) kEnv ast             addAST ast'@@ -499,48 +504,24 @@     modify $ \ st -> st { cl_proofstack = M.insert (cl_cursor st) ts (cl_proofstack st) }     return t -currentLemma :: CLMonad m => m (LemmaName, Lemma, HermitC, [NamedLemma], PathStack)-currentLemma = do-    todo : _ <- getProofStack--    case todo of-        Unproven nm l c ls p -> return (nm, l, c, ls, p)-        _ -> fail "currentLemma: unproven lemma not on top of stack!"--announceProven :: (MonadCatch m, CLMonad m) => m ()-announceProven = getProofStackEmpty >>= go []-    where go ps (MarkProven nm temp : r) = do-            let t = if temp then constT (deleteLemma nm) else modifyLemmaT nm id idR (const Proven) id-            go ((nm,t):ps) r-          go ps r = case ps of-                        [] -> return ()-                        _  -> do -- adjust the stack for the existing AST, because we don't want-                                 -- to replay these after a 'goto'!-                                 let (nms, ts) = unzip $ reverse ps-                                     commaNames f = intercalate ", " (map f nms)-                                 modify $ \ st -> st { cl_proofstack = M.insert (cl_cursor st) r (cl_proofstack st) }-                                 queryInFocus (sequence_ ts :: TransformH Core ())-                                              (Always $ "-- proven " ++ commaNames quoteShow)-                                 cl_putStrLn ("Successfully proven: " ++ commaNames show)- announceUnprovens :: (MonadCatch m, CLMonad m) => m () announceUnprovens = do     (c,m) <- queryInFocus (contextT &&& getLemmasT :: TransformH LCore (HermitC,Lemmas)) Never     sf <- gets cl_safety     case sf of         StrictSafety -> do-            let ls = [ nl | nl@(_,Lemma _ p u _) <- M.toList m, p `elem` [NotProven, Assumed], u /= NotUsed ]+            let ls = [ nl | nl@(_,Lemma _ p u) <- M.toList m, p `elem` [NotProven, Assumed], u /= NotUsed ]             forM_ ls $ \ nl@(nm,_) -> do                 cl_putStrLn $ "Fatal: Lemma " ++ show nm ++ " has not been proven, but was used."                 printLemma stdout c mempty nl             unless (null ls) abort -- don't finish if this happens         NormalSafety -> do-            let np = [ nl | nl@(_,Lemma _ NotProven u _) <- M.toList m, u /= NotUsed ]+            let np = [ nl | nl@(_,Lemma _ NotProven u) <- M.toList m, u /= NotUsed ]             forM_ np $ \ nl@(nm,_) -> do                 cl_putStrLn $ "Fatal: Lemma " ++ show nm ++ " has not been proven, but was used."                 printLemma stdout c mempty nl             unless (null np) abort -- don't finish if this happens-            let as = [ nl | nl@(_,Lemma _ Assumed u _) <- M.toList m, u /= NotUsed ]+            let as = [ nl | nl@(_,Lemma _ Assumed u) <- M.toList m, u /= NotUsed ]             forM_ as $ \ nl@(nm,_) -> do                 cl_putStrLn $ "Warning: Lemma " ++ show nm ++ " was assumed but not proven."                 printLemma stdout c mempty nl@@ -573,23 +554,22 @@        $ 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 mbh = do+showWindow = ifM isRunningScript (return ()) . showWindowAlways++-- always prints the current view+showWindowAlways :: (MonadCatch m, CLMonad m) => Maybe Handle -> m ()+showWindowAlways 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     case M.lookup ast ps of-        Just (Unproven _ l c ls p : _)  -> do-            unless (null ls) $ do-                liftIO $ pStr "Assumed lemmas:\n"-                mapM_ (printLemma h c mempty)-                      [ (fromString (show i) <> ": " <> n, lem)-                      | (i::Int,(n,lem)) <- zip [0..] ls ]-            printLemma h c p ("Goal:",l)+        Just (Unproven _ l c p : _)  -> printLemma h c p ("Goal:",l)         _ -> do st <- get                 if cl_diffonly st                 then do-                    let k = cl_kernel st+                    k <- asks pr_kernel                      all_asts <- listK k @@ -603,12 +583,19 @@                     diffDocH pp doc1 doc2 >>= liftIO . pStr -- TODO                 else fixWindow >> gets cl_window >>= pluginM . display mbh . Just --TODO -printLemma :: (MonadCatch m, MonadError CLException m, MonadIO m, MonadState CommandLineState m)+printLemma :: (MonadCatch m, CLMonad m)            => Handle -> HermitC -> PathStack -> (LemmaName,Lemma) -> m ()-printLemma h c p (nm,Lemma q _ _ _) = do -- TODO-    pp <- gets cl_pretty+printLemma h c p (nm,Lemma q _ _) = do -- TODO+    (pp,opts) <- gets (cl_pretty &&& cl_pretty_opts)+    as <- queryInContext ((liftPrettyH opts $ do+                            m <- getAntecedents <$> contextT+                            ds <- forM (M.toList m) $ \(n',l') -> return l' >>> ppLemmaT pp n'+                            if M.null m+                            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.text (show nm) PP.$+$ PP.nest 2 doc+    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') @@ -619,23 +606,19 @@ queryInFocus t msg = do     q <- addFocusT t     st <- get-    (ast', r) <- queryK (cl_kernel st) q msg (cl_kernel_env st) (cl_cursor st)+    k <- asks pr_kernel+    (ast', r) <- queryK k q msg (cl_kernel_env st) (cl_cursor st)     addAST ast'     return r  -- meant to be used inside queryInFocus inProofFocusT :: ProofTodo -> TransformH LCoreTC b -> TransformH Core b-inProofFocusT (Unproven _ (Lemma q _ _ _) c ls ps) t =-    contextfreeT $ withLemmas (M.fromList ls) . applyT (return q >>> extractT (pathT (pathStack2Path ps) t)) c-inProofFocusT _ _ = fail "no proof in progress."--inProofFocusR :: ProofTodo -> RewriteH LCoreTC -> TransformH Core Quantified-inProofFocusR (Unproven _ (Lemma q _ _ _) c ls ps) rr =-    contextfreeT $ withLemmas (M.fromList ls) . applyT (return q >>> extractR (pathR (pathStack2Path ps) rr)) c-inProofFocusR _ _ = fail "no proof in progress."+inProofFocusT (Unproven _ (Lemma q _ _) c ps) t =+    contextfreeT $ applyT (return q >>> extractT (pathT (pathStack2Path ps) t)) c -withLemmasInScope :: HasLemmas m => [(LemmaName,Lemma)] -> Transform c m a b -> Transform c m a b-withLemmasInScope ls t = transform $ \ c -> withLemmas (M.fromList ls) . applyT t c+inProofFocusR :: ProofTodo -> RewriteH LCoreTC -> TransformH Core Clause+inProofFocusR (Unproven _ (Lemma q _ _) c ps) rr =+    contextfreeT $ applyT (return q >>> extractR (pathR (pathStack2Path ps) rr)) c  -- TODO: better name queryInContext :: forall b m. (MonadCatch m, CLMonad m) => TransformH LCoreTC b -> CommitMsg -> m b

@@ -1,5 +1,5 @@ -- | Adapted from circular-ruin's StackOverflow answer at <http://stackoverflow.com/a/10779150>-{-# LANGUAGE ForeignFunctionInterface, CPP, NoImplicitPrelude #-}+{-# LANGUAGE ForeignFunctionInterface #-} module HERMIT.Win32.IO (     HERMIT.Win32.IO.putChar   , HERMIT.Win32.IO.putStr