From 3212e0decee6cd5457003675486721565202c5d2 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Sat, 25 Apr 2020 16:38:04 -0500 Subject: [PATCH 01/79] hie-bios.sh: Do not override GHC_PACKAGE_PATH, if set --- hie-bios.sh | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/hie-bios.sh b/hie-bios.sh index 57ec7b84be..5fcd8d87c2 100755 --- a/hie-bios.sh +++ b/hie-bios.sh @@ -18,11 +18,15 @@ out -ikore/src/ out -ikore/test/ out -ikore/app/share/ out -ikore/bench/ -out -ikore/$(stack path --dist-dir)/build/autogen/ -out -clear-package-db -out -package-db $(stack path --local-pkg-db) -out -package-db $(stack path --snapshot-pkg-db) -out -package-db $(stack path --global-pkg-db) + +# Set -package-db options, unless GHC_PACKAGE_PATH is set already. +if [[ -z "${GHC_PACKAGE_PATH}" ]] && [[ -z "${IN_NIX_SHELL}" ]] +then + out -clear-package-db + out -package-db $(stack path --local-pkg-db) + out -package-db $(stack path --snapshot-pkg-db) + out -package-db $(stack path --global-pkg-db) +fi yq -r '. "ghc-options" []' < ./kore/package.yaml | while read opt do From a3533be0c389e983602f3ab035a97661a1573eda Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Sat, 25 Apr 2020 16:40:12 -0500 Subject: [PATCH 02/79] ghcid.sh --- ghcid.sh | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100755 ghcid.sh diff --git a/ghcid.sh b/ghcid.sh new file mode 100755 index 0000000000..d4c8b9f5cd --- /dev/null +++ b/ghcid.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash +# Load the entire project in GHCi. +# Usage: ghcid.sh [⟨ghcid arguments⟩] -- ⟨ghci arguments⟩ +# Example: Load the kore-test test suite in GHCi: +# $ ghcid.sh -- Driver + +ghcid_args=() +while [[ "$#" -gt 0 ]] +do + arg="$1" + shift + if [[ "$arg" == "--" ]] + then + break + else + ghcid_args+=("$arg") + fi +done + +ghci_args=( $(./hie-bios.sh) ) +while [[ "$#" -gt 0 ]] +do + ghci_args+=("$1") + shift +done + +ghci="ghci ${ghci_args[@]}" +exec ghcid -c "$ghci" "${ghcid_args[@]}" From c420e3b2825e2b04a64db2fcac0cb926b9b76a0c Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Sun, 26 Apr 2020 07:35:32 -0500 Subject: [PATCH 03/79] shell.nix: exactDeps = true --- shell.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/shell.nix b/shell.nix index 933af7ba49..52e73615b4 100644 --- a/shell.nix +++ b/shell.nix @@ -10,4 +10,5 @@ project.shellFor { [ ghcid ghcide gnumake hlint stylish-haskell yq z3 ]; + exactDeps = true; } From 7a923f79fae52405cd9a6d0e20ad54fad32f3171 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Sun, 26 Apr 2020 11:38:01 -0500 Subject: [PATCH 04/79] nix: ghc-tags-plugin --- default.nix | 12 ++++++++++++ shell.nix | 5 +++++ 2 files changed, 17 insertions(+) diff --git a/default.nix b/default.nix index 55e8270aa8..3af2dea5d7 100644 --- a/default.nix +++ b/default.nix @@ -26,6 +26,9 @@ let src = pkgs.haskell-nix.haskellLib.cleanGit { name = "kore"; src = ./.; }; modules = [ { + packages.ghc.flags.ghci = pkgs.lib.mkForce true; + packages.ghci.flags.ghci = pkgs.lib.mkForce true; + reinstallableLibGhc = true; # package * enableLibraryProfiling = true; profilingDetail = "none"; @@ -40,6 +43,15 @@ let }; } ]; + pkg-def-extras = [ + (hackage: { + packages = { + ghc-tags-plugin = hackage.ghc-tags-plugin."0.1.6.0".revisions.default; + ghc-tags-core = hackage.ghc-tags-core."0.1.0.0".revisions.default; + pipes-text = hackage.pipes-text."0.0.2.5".revisions.default; + }; + }) + ]; }; shell = import ./shell.nix { inherit default; }; default = diff --git a/shell.nix b/shell.nix index 52e73615b4..4248f4a9e1 100644 --- a/shell.nix +++ b/shell.nix @@ -5,6 +5,11 @@ let in project.shellFor { + additional = hspkgs: + [ + hspkgs.ghc-tags-plugin + hspkgs.terminfo + ]; buildInputs = with pkgs; [ From 27fa3f63dd7c789c790262d57b545d05843fbe50 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 10:57:07 -0500 Subject: [PATCH 05/79] Kore.Exec: Remove ToRulePattern --- kore/src/Kore/Exec.hs | 38 ++++++++++++++++++++++---------------- 1 file changed, 22 insertions(+), 16 deletions(-) diff --git a/kore/src/Kore/Exec.hs b/kore/src/Kore/Exec.hs index 3bb99869c6..0deedbe3a2 100644 --- a/kore/src/Kore/Exec.hs +++ b/kore/src/Kore/Exec.hs @@ -120,7 +120,10 @@ import Kore.Step.Rule.Simplify ( SimplifyRuleLHS (..) ) import Kore.Step.RulePattern - ( ReachabilityRule (..) + ( AllPathRule (..) + , ImplicationRule (..) + , OnePathRule (..) + , ReachabilityRule (..) , RewriteRule (RewriteRule) , RulePattern (RulePattern) , getRewriteRule @@ -420,7 +423,7 @@ boundedModelCheck breadthLimit depthLimit definitionModule specModule searchOrde assertSomeClaims specClaims assertSingleClaim specClaims let axioms = fmap Bounded.Axiom rewriteRules - claims = fmap makeClaim specClaims + claims = fmap makeImplicationRule specClaims Bounded.checkClaim breadthLimit @@ -568,18 +571,21 @@ assertSomeClaims claims = ++ "Possible explanation: the frontend and the backend don't agree " ++ "on the representation of claims." -makeClaim - :: Goal.FromRulePattern claim - => Goal.ToRulePattern claim - => (Attribute.Axiom Symbol Variable, claim) -> claim -makeClaim (attributes, ruleType@(Goal.toRulePattern -> rule)) = - Goal.fromRulePattern ruleType RulePattern - { attributes = attributes - , left = left rule - , antiLeft = antiLeft rule - , requires = requires rule - , rhs = rhs rule - } +makeReachabilityRule + :: (Attribute.Axiom Symbol Variable, ReachabilityRule Variable) + -> ReachabilityRule Variable +makeReachabilityRule (attributes, reachabilityRule) = + case reachabilityRule of + OnePath (OnePathRule rulePattern) -> + OnePath (OnePathRule rulePattern { attributes }) + AllPath (AllPathRule rulePattern) -> + AllPath (AllPathRule rulePattern { attributes }) + +makeImplicationRule + :: (Attribute.Axiom Symbol Variable, ImplicationRule Variable) + -> ImplicationRule Variable +makeImplicationRule (attributes, ImplicationRule rulePattern) = + ImplicationRule rulePattern { attributes } simplifyRuleOnSecond :: (MonadSimplify simplifier, Claim claim) @@ -729,9 +735,9 @@ initializeProver definitionModule specModule maybeAlreadyProvenModule within = mapM (mapMSecond simplifyToList) specClaims specAxioms <- Profiler.initialization "simplifyRuleOnSecond" $ traverse simplifyRuleOnSecond (concat simplifiedSpecClaims) - let claims = fmap makeClaim specAxioms + let claims = fmap makeReachabilityRule specAxioms axioms = coerce rewriteRules - alreadyProven = fmap makeClaim claimsAlreadyProven + alreadyProven = fmap makeReachabilityRule claimsAlreadyProven initializedProver = InitializedProver {axioms, claims, alreadyProven} within initializedProver From 95c87c6066b5227c9882ae6406d7254c4bb56889 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 27 Apr 2020 15:33:19 -0500 Subject: [PATCH 06/79] Kore.HasPriority --- kore/src/Kore/HasPriority.hs | 8 ++++++++ kore/src/Kore/Step.hs | 16 +++++----------- kore/src/Kore/Step/RulePattern.hs | 11 +++++++---- kore/src/Kore/Strategies/Goal.hs | 11 +++-------- kore/src/Kore/Strategies/Rule.hs | 10 ++++++++++ 5 files changed, 33 insertions(+), 23 deletions(-) create mode 100644 kore/src/Kore/HasPriority.hs diff --git a/kore/src/Kore/HasPriority.hs b/kore/src/Kore/HasPriority.hs new file mode 100644 index 0000000000..5bd914b90b --- /dev/null +++ b/kore/src/Kore/HasPriority.hs @@ -0,0 +1,8 @@ +module Kore.HasPriority + ( HasPriority (..) + ) where + +import Prelude.Kore + +class HasPriority has where + getPriority :: has -> Integer diff --git a/kore/src/Kore/Step.hs b/kore/src/Kore/Step.hs index 8a7cf831c1..d313df94a1 100644 --- a/kore/src/Kore/Step.hs +++ b/kore/src/Kore/Step.hs @@ -40,6 +40,7 @@ import Numeric.Natural ( Natural ) +import Kore.HasPriority import Kore.Internal.Pattern ( Pattern ) @@ -48,7 +49,6 @@ import Kore.Step.RulePattern ( RewriteRule (..) , RulePattern , ToRulePattern (..) - , getPriorityOfRule , isCoolingRule , isHeatingRule , isNormalRule @@ -167,28 +167,22 @@ anyRewrite rewrites = Strategy.any (rewriteStep <$> rewrites) priorityAllStrategy - :: ToRulePattern rewrite + :: HasPriority rewrite => [rewrite] -> Strategy (Prim rewrite) priorityAllStrategy rewrites = Strategy.first (fmap allRewrites priorityGroups) where - priorityGroups = - groupSortOn - (getPriorityOfRule . toRulePattern) - rewrites + priorityGroups = groupSortOn getPriority rewrites priorityAnyStrategy - :: ToRulePattern rewrite + :: HasPriority rewrite => [rewrite] -> Strategy (Prim rewrite) priorityAnyStrategy rewrites = anyRewrite sortedRewrites where - sortedRewrites = - sortOn - (getPriorityOfRule . toRulePattern) - rewrites + sortedRewrites = sortOn getPriority rewrites {- | Heat the configuration, apply a normal rewrite, and cool the result. -} diff --git a/kore/src/Kore/Step/RulePattern.hs b/kore/src/Kore/Step/RulePattern.hs index 64851f9c7e..a98208f6e1 100644 --- a/kore/src/Kore/Step/RulePattern.hs +++ b/kore/src/Kore/Step/RulePattern.hs @@ -21,7 +21,6 @@ module Kore.Step.RulePattern , isHeatingRule , isCoolingRule , isNormalRule - , getPriorityOfRule , applySubstitution , topExistsToImplicitForall , isFreeOf @@ -79,6 +78,7 @@ import Kore.Attribute.Pattern.FreeVariables ) import qualified Kore.Attribute.Pattern.FreeVariables as FreeVariables import Kore.Debug +import Kore.HasPriority import Kore.Internal.Alias ( Alias (..) ) @@ -243,6 +243,9 @@ instance TopBottom (RulePattern variable) where isTop _ = False isBottom _ = False +instance HasPriority (RulePattern variable) where + getPriority = Attribute.getPriorityOfAxiom . attributes + -- | Creates a basic, unconstrained, Equality pattern rulePattern :: InternalVariable variable @@ -303,9 +306,6 @@ isNormalRule RulePattern { attributes } = Attribute.Normal -> True _ -> False -getPriorityOfRule :: RulePattern variable -> Integer -getPriorityOfRule = Attribute.getPriorityOfAxiom . attributes - -- | Converts the 'RHS' back to the term form. rhsToTerm :: InternalVariable variable @@ -478,6 +478,9 @@ instance freeVariables (RewriteRule rule) = freeVariables rule {-# INLINE freeVariables #-} +instance HasPriority (RewriteRule variable) where + getPriority = getPriority . getRewriteRule + {- | Implication-based pattern. -} newtype ImplicationRule variable = diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index e45ccc1b01..19d00ab58f 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -64,6 +64,7 @@ import Kore.Attribute.Pattern.FreeVariables ) import qualified Kore.Attribute.Pattern.FreeVariables as Attribute.FreeVariables import qualified Kore.Attribute.Trusted as Attribute.Trusted +import Kore.HasPriority import Kore.IndexedModule.IndexedModule ( IndexedModule (indexedModuleClaims) , VerifiedModule @@ -321,10 +322,7 @@ instance Goal (OnePathRule Variable) where rewrites ) where - rewrites = - sortOn - (RulePattern.getPriorityOfRule . toRulePattern) - rules + rewrites = sortOn getPriority rules coinductiveRewrites = OnePathRewriteRule . RewriteRule @@ -370,10 +368,7 @@ instance Goal (AllPathRule Variable) where priorityGroups ) where - priorityGroups = - groupSortOn - (RulePattern.getPriorityOfRule . toRulePattern) - rules + priorityGroups = groupSortOn getPriority rules coinductiveRewrites = AllPathRewriteRule . RewriteRule diff --git a/kore/src/Kore/Strategies/Rule.hs b/kore/src/Kore/Strategies/Rule.hs index 71e785760b..c3f353d7f3 100644 --- a/kore/src/Kore/Strategies/Rule.hs +++ b/kore/src/Kore/Strategies/Rule.hs @@ -18,6 +18,7 @@ import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC import Debug +import Kore.HasPriority import Kore.Internal.Variable ( Variable ) @@ -55,6 +56,9 @@ instance ToRulePattern (Rule (OnePathRule Variable)) instance FromRulePattern (Rule (OnePathRule Variable)) +instance HasPriority (Rule (OnePathRule Variable)) where + getPriority = getPriority . unRuleOnePath + -- * All-path reachability newtype instance Rule (AllPathRule Variable) = @@ -73,6 +77,9 @@ instance ToRulePattern (Rule (AllPathRule Variable)) instance FromRulePattern (Rule (AllPathRule Variable)) +instance HasPriority (Rule (AllPathRule Variable)) where + getPriority = getPriority . unRuleAllPath + -- * Reachability newtype instance Rule (ReachabilityRule Variable) = @@ -91,3 +98,6 @@ instance Diff (Rule (ReachabilityRule Variable)) instance ToRulePattern (Rule (ReachabilityRule Variable)) instance FromRulePattern (Rule (ReachabilityRule Variable)) + +instance HasPriority (Rule (ReachabilityRule Variable)) where + getPriority = getPriority . unReachabilityRewriteRule From 7d738c2e342ec234edea61ecd9eb5b9ef926ef54 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 11:06:26 -0500 Subject: [PATCH 07/79] Kore.Step: Remove ToRulePattern --- kore/src/Kore/Step.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/kore/src/Kore/Step.hs b/kore/src/Kore/Step.hs index d313df94a1..3a2641e5ac 100644 --- a/kore/src/Kore/Step.hs +++ b/kore/src/Kore/Step.hs @@ -48,7 +48,6 @@ import qualified Kore.Step.RewriteStep as Step import Kore.Step.RulePattern ( RewriteRule (..) , RulePattern - , ToRulePattern (..) , isCoolingRule , isHeatingRule , isNormalRule @@ -190,10 +189,7 @@ priorityAnyStrategy rewrites = -- rules must have side conditions if encoded as \rewrites, or they must be -- \equals rules, which are not handled by this strategy. heatingCooling - :: ( forall rewrite - . ToRulePattern rewrite - => [rewrite] -> Strategy (Prim rewrite) - ) + :: (forall rewrite. [rewrite] -> Strategy (Prim rewrite)) -- ^ 'allRewrites' or 'anyRewrite' -> [RewriteRule Variable] -> Strategy (Prim (RewriteRule Variable)) From 91474c1c05f250ef88787250c3a6d5dca5f1991e Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 11:08:45 -0500 Subject: [PATCH 08/79] HasAttributes --- kore/src/Kore/Step/RulePattern.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/kore/src/Kore/Step/RulePattern.hs b/kore/src/Kore/Step/RulePattern.hs index a98208f6e1..479dd35d02 100644 --- a/kore/src/Kore/Step/RulePattern.hs +++ b/kore/src/Kore/Step/RulePattern.hs @@ -13,6 +13,7 @@ module Kore.Step.RulePattern , ReachabilityRule (..) , ImplicationRule (..) , RHS (..) + , HasAttributes (..) , ToRulePattern (..) , FromRulePattern (..) , UnifyingRule (..) @@ -428,6 +429,12 @@ applySubstitution substitution rule = finalRule = substitute subst rule substitutedVariables = Substitution.variables substitution +class HasAttributes rule where + getAttributes :: rule variable -> Attribute.Axiom Symbol variable + +instance HasAttributes RulePattern where + getAttributes = attributes + -- | The typeclasses 'ToRulePattern' and 'FromRulePattern' are intended to -- be implemented by types which contain more (or the same amount of) -- information as 'RulePattern Variable'. From 60ec5d66bfcd59d9d1d75d199689ce33c7421192 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 13:39:04 -0500 Subject: [PATCH 09/79] Kore.Repl: Remove type parameters --- kore/src/Kore/Repl.hs | 55 +++++++++++++++++++++---------------------- 1 file changed, 27 insertions(+), 28 deletions(-) diff --git a/kore/src/Kore/Repl.hs b/kore/src/Kore/Repl.hs index 8b4991286e..7bbe5aa0ae 100644 --- a/kore/src/Kore/Repl.hs +++ b/kore/src/Kore/Repl.hs @@ -87,20 +87,19 @@ import Kore.Unparser ( unparseToString ) +type Axiom = Rule (ReachabilityRule Variable) + -- | Runs the repl for proof mode. It requires all the tooling and simplifiers -- that would otherwise be required in the proof and allows for step-by-step -- execution of proofs. Currently works via stdin/stdout interaction. runRepl - :: forall claim axiom m + :: forall m . MonadSimplify m => MonadIO m => MonadCatch m - => Claim claim - => From claim (TermLike Variable) - => axiom ~ Rule claim - => [axiom] + => [Axiom] -- ^ list of axioms to used in the proof - -> [claim] + -> [ReachabilityRule Variable] -- ^ list of claims to be proven -> MVar (Log.LogAction IO Log.ActualEntry) -> ReplScript @@ -133,24 +132,24 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d where - runReplCommand :: ReplCommand -> ReplState claim -> m () + runReplCommand :: ReplCommand -> ReplState (ReachabilityRule Variable) -> m () runReplCommand cmd st = void $ flip evalStateT st $ flip runReaderT config $ replInterpreter printIfNotEmpty cmd - evaluateScript :: ReplScript -> RWST (Config claim m) String (ReplState claim) m () + evaluateScript :: ReplScript -> RWST (Config (ReachabilityRule Variable) m) String (ReplState (ReachabilityRule Variable)) m () evaluateScript = maybe (pure ()) parseEvalScript . unReplScript - repl0 :: ReaderT (Config claim m) (StateT (ReplState claim) m) () + repl0 :: ReaderT (Config (ReachabilityRule Variable) m) (StateT (ReplState (ReachabilityRule Variable)) m) () repl0 = do str <- prompt let command = fromMaybe ShowUsage $ parseMaybe commandParser str when (shouldStore command) $ field @"commands" Lens.%= (Seq.|> str) void $ replInterpreter printIfNotEmpty command - state :: ReplState claim + state :: ReplState (ReachabilityRule Variable) state = ReplState { axioms = addIndexesToAxioms axioms' @@ -170,7 +169,7 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d { Log.exeName = Log.ExeName "kore-repl" } } - config :: Config claim m + config :: Config (ReachabilityRule Variable) m config = Config { stepper = stepper0 @@ -187,15 +186,15 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d $ findIndex (not . isTrusted) claims' addIndexesToAxioms - :: [axiom] - -> [axiom] + :: [Axiom] + -> [Axiom] addIndexesToAxioms axs = fmap addIndex (zip axs [0..]) addIndexesToClaims :: Int - -> [claim] - -> [claim] + -> [ReachabilityRule Variable] + -> [ReachabilityRule Variable] addIndexesToClaims len claims'' = let toAxiomAndBack claim' index = ruleToGoal @@ -204,24 +203,24 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d in zipWith toAxiomAndBack claims'' [len..] addIndex - :: (axiom, Int) - -> axiom + :: (Axiom, Int) + -> Axiom addIndex (rw, n) = modifyAttribute (mapAttribute n (getAttribute rw)) rw modifyAttribute :: Attribute.Axiom Symbol Variable - -> axiom - -> axiom + -> Axiom + -> Axiom modifyAttribute att rule = let rp = axiomToRulePatt rule in fromRulePattern rule $ rp { Rule.attributes = att } - axiomToRulePatt :: axiom -> Rule.RulePattern Variable + axiomToRulePatt :: Axiom -> Rule.RulePattern Variable axiomToRulePatt = toRulePattern - getAttribute :: axiom -> Attribute.Axiom Symbol Variable + getAttribute :: Axiom -> Attribute.Axiom Symbol Variable getAttribute = Rule.attributes . axiomToRulePatt mapAttribute @@ -234,19 +233,19 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d makeRuleIndex :: Int -> RuleIndex -> RuleIndex makeRuleIndex n _ = RuleIndex (Just n) - firstClaim :: claim + firstClaim :: ReachabilityRule Variable firstClaim = claims' !! unClaimIndex firstClaimIndex - firstClaimExecutionGraph :: ExecutionGraph axiom + firstClaimExecutionGraph :: ExecutionGraph Axiom firstClaimExecutionGraph = emptyExecutionGraph firstClaim stepper0 - :: claim - -> [claim] - -> [axiom] - -> ExecutionGraph axiom + :: ReachabilityRule Variable + -> [ReachabilityRule Variable] + -> [Axiom] + -> ExecutionGraph Axiom -> ReplNode - -> m (ExecutionGraph axiom) + -> m (ExecutionGraph Axiom) stepper0 claim claims axioms graph rnode = do let node = unReplNode rnode if Graph.outdeg (Strategy.graph graph) node == 0 From abf40559099b5096e55dcc4180819e74470cdb0a Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 14:07:16 -0500 Subject: [PATCH 10/79] Kore.Repl: Remove ReplState type parameter --- kore/src/Kore/Repl.hs | 12 +- kore/src/Kore/Repl/Data.hs | 16 +- kore/src/Kore/Repl/Interpreter.hs | 282 ++++++++++-------------- kore/src/Kore/Repl/State.hs | 141 +++++------- kore/test/Test/Kore/Repl/Interpreter.hs | 21 +- 5 files changed, 190 insertions(+), 282 deletions(-) diff --git a/kore/src/Kore/Repl.hs b/kore/src/Kore/Repl.hs index 7bbe5aa0ae..e56b32321e 100644 --- a/kore/src/Kore/Repl.hs +++ b/kore/src/Kore/Repl.hs @@ -87,8 +87,6 @@ import Kore.Unparser ( unparseToString ) -type Axiom = Rule (ReachabilityRule Variable) - -- | Runs the repl for proof mode. It requires all the tooling and simplifiers -- that would otherwise be required in the proof and allows for step-by-step -- execution of proofs. Currently works via stdin/stdout interaction. @@ -132,24 +130,24 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d where - runReplCommand :: ReplCommand -> ReplState (ReachabilityRule Variable) -> m () + runReplCommand :: ReplCommand -> ReplState -> m () runReplCommand cmd st = void $ flip evalStateT st $ flip runReaderT config $ replInterpreter printIfNotEmpty cmd - evaluateScript :: ReplScript -> RWST (Config (ReachabilityRule Variable) m) String (ReplState (ReachabilityRule Variable)) m () + evaluateScript :: ReplScript -> RWST (Config (ReachabilityRule Variable) m) String ReplState m () evaluateScript = maybe (pure ()) parseEvalScript . unReplScript - repl0 :: ReaderT (Config (ReachabilityRule Variable) m) (StateT (ReplState (ReachabilityRule Variable)) m) () + repl0 :: ReaderT (Config (ReachabilityRule Variable) m) (StateT ReplState m) () repl0 = do str <- prompt let command = fromMaybe ShowUsage $ parseMaybe commandParser str when (shouldStore command) $ field @"commands" Lens.%= (Seq.|> str) void $ replInterpreter printIfNotEmpty command - state :: ReplState (ReachabilityRule Variable) + state :: ReplState state = ReplState { axioms = addIndexesToAxioms axioms' @@ -275,7 +273,7 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d liftIO $ putStrLn "Welcome to the Kore Repl! Use 'help' to get started.\n" - prompt :: MonadIO n => MonadState (ReplState claim) n => n String + prompt :: MonadIO n => MonadState ReplState n => n String prompt = do node <- Lens.use (field @"node") liftIO $ do diff --git a/kore/src/Kore/Repl/Data.hs b/kore/src/Kore/Repl/Data.hs index 825243e418..52b2ddf91b 100644 --- a/kore/src/Kore/Repl/Data.hs +++ b/kore/src/Kore/Repl/Data.hs @@ -13,6 +13,7 @@ module Kore.Repl.Data , AxiomIndex (..), ClaimIndex (..) , RuleName (..), RuleReference(..) , ReplNode (..) + , Axiom , ReplState (..) , ReplOutput (..) , ReplOut (..) @@ -428,17 +429,19 @@ type ExecutionGraph rule = type InnerGraph rule = Gr CommonProofState (Seq rule) +type Axiom = Rule (ReachabilityRule Variable) + -- | State for the repl. -data ReplState claim = ReplState - { axioms :: [Rule claim] +data ReplState = ReplState + { axioms :: [Axiom] -- ^ List of available axioms - , claims :: [claim] + , claims :: [ReachabilityRule Variable] -- ^ List of claims to be proven - , claim :: claim + , claim :: ReachabilityRule Variable -- ^ Currently focused claim in the repl , claimIndex :: ClaimIndex -- ^ Index of the currently focused claim in the repl - , graphs :: Map ClaimIndex (ExecutionGraph (Rule claim)) + , graphs :: Map ClaimIndex (ExecutionGraph Axiom) -- ^ Execution graph for the current proof; initialized with root = claim , node :: ReplNode -- ^ Currently selected node in the graph; initialized with node = root @@ -451,7 +454,8 @@ data ReplState claim = ReplState , aliases :: Map String AliasDefinition -- ^ Map of command aliases , koreLogOptions :: !KoreLogOptions - -- ^ The log level, log scopes and log type decide what gets logged and where. + -- ^ The log level, log scopes and log type decide what gets logged and + -- where. } deriving (GHC.Generic) diff --git a/kore/src/Kore/Repl/Interpreter.hs b/kore/src/Kore/Repl/Interpreter.hs index 9fbd966ba3..da6f1bc780 100644 --- a/kore/src/Kore/Repl/Interpreter.hs +++ b/kore/src/Kore/Repl/Interpreter.hs @@ -197,8 +197,7 @@ import Kore.Strategies.ProofState ) import qualified Kore.Strategies.ProofState as ProofState.DoNotUse import Kore.Strategies.Verification - ( Claim - , CommonProofState + ( CommonProofState , commonProofStateTransformer ) import Kore.Syntax.Application @@ -219,21 +218,19 @@ import Kore.Unparser -- rid of the WriterT part of the stack. This happens in the implementation of -- 'replInterpreter'. type ReplM claim m a = - RWST (Config claim m) ReplOutput (ReplState claim) m a + RWST (Config claim m) ReplOutput ReplState m a data ReplStatus = Continue | SuccessStop | FailStop deriving (Eq, Show) -- | Interprets a REPL command in a stateful Simplifier context. replInterpreter - :: forall claim m - . Claim claim - => From claim (TermLike Variable) - => MonadSimplify m + :: forall m + . MonadSimplify m => MonadIO m => (String -> IO ()) -> ReplCommand - -> ReaderT (Config claim m) (StateT (ReplState claim) m) ReplStatus + -> ReaderT (Config (ReachabilityRule Variable) m) (StateT ReplState m) ReplStatus replInterpreter fn cmd = replInterpreter0 (PrintAuxOutput fn) @@ -241,15 +238,13 @@ replInterpreter fn cmd = cmd replInterpreter0 - :: forall claim m - . Claim claim - => From claim (TermLike Variable) - => MonadSimplify m + :: forall m + . MonadSimplify m => MonadIO m => PrintAuxOutput -> PrintKoreOutput -> ReplCommand - -> ReaderT (Config claim m) (StateT (ReplState claim) m) ReplStatus + -> ReaderT (Config (ReachabilityRule Variable) m) (StateT ReplState m) ReplStatus replInterpreter0 printAux printKore replCmd = do let command = case replCmd of ShowUsage -> showUsage $> Continue @@ -301,7 +296,7 @@ replInterpreter0 printAux printKore replCmd = do -- monadic result. evaluateCommand :: ReplM claim m ReplStatus - -> ReaderT (Config claim m) (StateT (ReplState claim) m) (ReplOutput, ReplStatus) + -> ReaderT (Config claim m) (StateT ReplState m) (ReplOutput, ReplStatus) evaluateCommand c = do st <- get config <- Reader.ask @@ -332,10 +327,8 @@ showUsage :: MonadWriter ReplOutput m => m () showUsage = putStrLn' showUsageMessage exit - :: Claim claim - => From claim (TermLike Variable) - => MonadIO m - => ReplM claim m ReplStatus + :: MonadIO m + => ReplM (ReachabilityRule Variable) m ReplStatus exit = do proofs <- allProofs ofile <- Lens.view (field @"outputFile") @@ -356,8 +349,7 @@ help = putStrLn' helpText -- | Prints a claim using an index in the claims list. showClaim - :: Claim claim - => MonadState (ReplState claim) m + :: MonadState ReplState m => MonadWriter ReplOutput m => Maybe (Either ClaimIndex RuleName) -> m () @@ -377,10 +369,7 @@ showClaim = -- | Prints an axiom using an index in the axioms list. showAxiom - :: MonadState (ReplState claim) m - => axiom ~ Rule claim - => ToRulePattern axiom - => Unparse axiom + :: MonadState ReplState m => MonadWriter ReplOutput m => Either AxiomIndex RuleName -- ^ index in the axioms list @@ -394,9 +383,8 @@ showAxiom indexOrName = do -- | Changes the currently focused proof, using an index in the claims list. prove - :: forall claim m - . Claim claim - => MonadState (ReplState claim) m + :: forall m + . MonadState ReplState m => MonadWriter ReplOutput m => Either ClaimIndex RuleName -- ^ index in the claims list @@ -411,9 +399,7 @@ prove indexOrName = do startProving claim' where - startProving - :: claim - -> m () + startProving :: ReachabilityRule Variable -> m () startProving claim | isTrusted claim = putStrLn' @@ -445,10 +431,9 @@ showIndexOrName = showGraph :: MonadIO m => MonadWriter ReplOutput m - => Claim claim => Maybe FilePath -> Maybe Graph.GraphvizOutput - -> MonadState (ReplState claim) m + -> MonadState ReplState m => m () showGraph mfile out = do let format = fromMaybe Graph.Svg out @@ -472,12 +457,11 @@ showGraph mfile out = do -- | Executes 'n' prove steps, or until branching occurs. proveSteps - :: Claim claim - => MonadSimplify m + :: MonadSimplify m => MonadIO m => Natural -- ^ maximum number of steps to perform - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () proveSteps n = do let node = ReplNode . fromEnum $ n result <- loopM performStepNoBranching (n, SingleResult node) @@ -489,38 +473,34 @@ proveSteps n = do -- | Executes 'n' prove steps, distributing over branches. It will perform less -- than 'n' steps if the proof is stuck or completed in less than 'n' steps. proveStepsF - :: Claim claim - => MonadSimplify m + :: MonadSimplify m => MonadIO m => Natural -- ^ maximum number of steps to perform - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () proveStepsF n = do node <- Lens.use (field @"node") recursiveForcedStep n node -- | Loads a script from a file. loadScript - :: forall claim m - . Claim claim - => From claim (TermLike Variable) - => MonadSimplify m + :: forall m + . MonadSimplify m => MonadIO m => FilePath -- ^ path to file - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () loadScript file = parseEvalScript file handleLog - :: MonadState (ReplState claim) m + :: MonadState ReplState m => Log.KoreLogOptions -> m () handleLog t = field @"koreLogOptions" .= t -- | Focuses the node with id equals to 'n'. selectNode - :: MonadState (ReplState claim) m - => Claim claim + :: MonadState ReplState m => MonadWriter ReplOutput m => ReplNode -- ^ node identifier @@ -534,8 +514,7 @@ selectNode rnode = do -- | Shows configuration at node 'n', or current node if 'Nothing' is passed. showConfig - :: Claim claim - => Monad m + :: Monad m => Maybe ReplNode -- ^ 'Nothing' for current node, or @Just n@ for a specific node identifier -> ReplM claim m () @@ -578,11 +557,7 @@ omitCell = -- | Shows all leaf nodes identifiers which are either stuck or can be -- evaluated further. -showLeafs - :: forall claim m - . Claim claim - => Monad m - => ReplM claim m () +showLeafs :: forall claim m. Monad m => ReplM claim m () showLeafs = do leafsByType <- sortLeafsByType <$> getInnerGraph case Map.foldMapWithKey showPair leafsByType of @@ -592,21 +567,15 @@ showLeafs = do showPair :: NodeState -> [Graph.Node] -> String showPair ns xs = show ns <> ": " <> show xs -proofStatus - :: forall claim m - . Claim claim - => Monad m - => ReplM claim m () +proofStatus :: forall m. Monad m => ReplM (ReachabilityRule Variable) m () proofStatus = do proofs <- allProofs putStrLn' . showProofStatus $ proofs allProofs - :: forall claim axiom m - . Claim claim - => axiom ~ Rule claim - => Monad m - => ReplM claim m (Map.Map ClaimIndex GraphProofStatus) + :: forall m + . Monad m + => ReplM (ReachabilityRule Variable) m (Map.Map ClaimIndex GraphProofStatus) allProofs = do graphs <- Lens.use (field @"graphs") claims <- Lens.use (field @"claims") @@ -617,7 +586,7 @@ allProofs = do (notStartedProofs graphs (Map.fromList $ zip cindexes claims)) where inProgressProofs - :: ExecutionGraph axiom + :: ExecutionGraph Axiom -> GraphProofStatus inProgressProofs = findProofStatus @@ -625,13 +594,13 @@ allProofs = do . Strategy.graph notStartedProofs - :: Map.Map ClaimIndex (ExecutionGraph axiom) - -> Map.Map ClaimIndex claim + :: Map.Map ClaimIndex (ExecutionGraph Axiom) + -> Map.Map ClaimIndex (ReachabilityRule Variable) -> Map.Map ClaimIndex GraphProofStatus notStartedProofs gphs cls = notStartedOrTrusted <$> cls `Map.difference` gphs - notStartedOrTrusted :: claim -> GraphProofStatus + notStartedOrTrusted :: ReachabilityRule Variable -> GraphProofStatus notStartedOrTrusted cl = if isTrusted cl then TrustedClaim @@ -647,9 +616,8 @@ allProofs = do Just ns -> StuckProof ns showRule - :: MonadState (ReplState claim) m + :: MonadState ReplState m => MonadWriter ReplOutput m - => Claim claim => Maybe ReplNode -> m () showRule configNode = do @@ -669,8 +637,7 @@ showRule configNode = do -- | Shows the previous branching point. showPrecBranch - :: Claim claim - => Monad m + :: Monad m => Maybe ReplNode -- ^ 'Nothing' for current node, or @Just n@ for a specific node identifier -> ReplM claim m () @@ -692,8 +659,7 @@ showPrecBranch maybeNode = do -- | Shows the next node(s) for the selected node. showChildren - :: Claim claim - => Monad m + :: Monad m => Maybe ReplNode -- ^ 'Nothing' for current node, or @Just n@ for a specific node identifier -> ReplM claim m () @@ -706,10 +672,9 @@ showChildren maybeNode = do -- | Shows existing labels or go to an existing label. label - :: forall m claim - . MonadState (ReplState claim) m + :: forall m + . MonadState ReplState m => MonadWriter ReplOutput m - => Claim claim => Maybe String -- ^ 'Nothing' for show labels, @Just str@ for jumping to the string label. -> m () @@ -734,9 +699,8 @@ label = -- | Adds label for selected node. labelAdd - :: MonadState (ReplState claim) m + :: MonadState ReplState m => MonadWriter ReplOutput m - => Claim claim => String -- ^ label -> Maybe ReplNode @@ -757,7 +721,7 @@ labelAdd lbl maybeNode = do -- | Removes a label. labelDel - :: MonadState (ReplState claim) m + :: MonadState ReplState m => MonadWriter ReplOutput m => String -- ^ label @@ -773,31 +737,27 @@ labelDel lbl = do -- | Redirect command to specified file. redirect - :: forall claim m - . Claim claim - => From claim (TermLike Variable) - => MonadSimplify m + :: forall m + . MonadSimplify m => MonadIO m => ReplCommand -- ^ command to redirect -> FilePath -- ^ file path - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () redirect cmd file = do liftIO $ withExistingDirectory file (`writeFile` "") appendCommand cmd file runInterpreterWithOutput - :: forall claim m - . Claim claim - => From claim (TermLike Variable) - => MonadSimplify m + :: forall m + . MonadSimplify m => MonadIO m => PrintAuxOutput -> PrintKoreOutput -> ReplCommand - -> Config claim m - -> ReplM claim m () + -> Config (ReachabilityRule Variable) m + -> ReplM (ReachabilityRule Variable) m () runInterpreterWithOutput printAux printKore cmd config = get >>= (\st -> lift $ execStateReader config st @@ -810,36 +770,32 @@ data AlsoApplyRule = Never | IfPossible -- | Attempt to use a specific axiom or claim to see if it unifies with the -- current node. tryAxiomClaim - :: forall claim m - . Claim claim - => MonadSimplify m + :: forall m + . MonadSimplify m => MonadIO m => RuleReference -- ^ tagged index in the axioms or claims list - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () tryAxiomClaim = tryAxiomClaimWorker Never -- | Attempt to use a specific axiom or claim to progress the current proof. tryFAxiomClaim - :: forall claim m - . Claim claim - => MonadSimplify m + :: forall m + . MonadSimplify m => MonadIO m => RuleReference -- ^ tagged index in the axioms or claims list - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () tryFAxiomClaim = tryAxiomClaimWorker IfPossible tryAxiomClaimWorker - :: forall claim axiom m - . Claim claim - => axiom ~ Rule claim - => MonadSimplify m + :: forall m + . MonadSimplify m => MonadIO m => AlsoApplyRule -> RuleReference -- ^ tagged index in the axioms or claims list - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () tryAxiomClaimWorker mode ref = do maybeAxiomOrClaim <- ruleReference @@ -862,18 +818,18 @@ tryAxiomClaimWorker mode ref = do IfPossible -> tryForceAxiomOrClaim axiomOrClaim node where - notEqualClaimTypes :: Either axiom claim -> claim -> Bool + notEqualClaimTypes :: Either Axiom (ReachabilityRule Variable) -> ReachabilityRule Variable -> Bool notEqualClaimTypes axiomOrClaim' claim' = not (either (const True) (equalClaimTypes claim') axiomOrClaim') - equalClaimTypes :: claim -> claim -> Bool + equalClaimTypes :: ReachabilityRule Variable -> ReachabilityRule Variable -> Bool equalClaimTypes = isSameType `on` castToReachability - castToReachability :: claim -> Maybe (ReachabilityRule Variable) + castToReachability :: ReachabilityRule Variable -> Maybe (ReachabilityRule Variable) castToReachability = Typeable.cast - isReachabilityRule :: claim -> Bool + isReachabilityRule :: ReachabilityRule Variable -> Bool isReachabilityRule = isJust . castToReachability isSameType @@ -885,9 +841,9 @@ tryAxiomClaimWorker mode ref = do isSameType _ _ = False showUnificationFailure - :: Either axiom claim + :: Either Axiom (ReachabilityRule Variable) -> ReplNode - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () showUnificationFailure axiomOrClaim' node = do let first = extractLeftPattern axiomOrClaim' maybeSecond <- getConfigAt (Just node) @@ -904,7 +860,7 @@ tryAxiomClaimWorker mode ref = do } second where - patternUnifier :: Pattern Variable -> ReplM claim m () + patternUnifier :: Pattern Variable -> ReplM (ReachabilityRule Variable) m () patternUnifier (Pattern.splitTerm -> (secondTerm, secondCondition)) = @@ -914,9 +870,9 @@ tryAxiomClaimWorker mode ref = do SideCondition.assumeTrueCondition secondCondition tryForceAxiomOrClaim - :: Either axiom claim + :: Either Axiom (ReachabilityRule Variable) -> ReplNode - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () tryForceAxiomOrClaim axiomOrClaim node = do (graph, result) <- runStepper' @@ -936,22 +892,20 @@ tryAxiomClaimWorker mode ref = do :: SideCondition Variable -> TermLike Variable -> TermLike Variable - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () runUnifier' sideCondition first second = runUnifier sideCondition first' second >>= tell . formatUnificationMessage where first' = TermLike.refreshVariables (freeVariables second) first - extractLeftPattern :: Either axiom claim -> TermLike Variable + extractLeftPattern :: Either Axiom (ReachabilityRule Variable) -> TermLike Variable extractLeftPattern = left . either toRulePattern toRulePattern -- | Removes specified node and all its child nodes. clear - :: forall m claim axiom - . MonadState (ReplState claim) m - => Claim claim - => axiom ~ Rule claim + :: forall m + . MonadState ReplState m => MonadWriter ReplOutput m => Maybe ReplNode -- ^ 'Nothing' for current node, or @Just n@ for a specific node identifier @@ -985,8 +939,8 @@ clear = -- | Save this sessions' commands to the specified file. saveSession - :: forall m claim - . MonadState (ReplState claim) m + :: forall m + . MonadState ReplState m => MonadWriter ReplOutput m => MonadIO m => FilePath @@ -1004,13 +958,11 @@ saveSession path = seqUnlines = unlines . toList savePartialProof - :: forall m claim - . Claim claim - => MonadIO m - => From claim (TermLike Variable) + :: forall m + . MonadIO m => Maybe Natural -> FilePath - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () savePartialProof maybeNatural file = do currentClaim <- Lens.use (field @"claim") currentIndex <- Lens.use (field @"claimIndex") @@ -1050,7 +1002,7 @@ savePartialProof maybeNatural file = do maybeNode = ReplNode . naturalToInt <$> maybeNatural - makeTrusted :: claim -> claim + makeTrusted :: ReachabilityRule Variable -> ReachabilityRule Variable makeTrusted goal@(toRulePattern -> rule) = fromRulePattern goal $ rule @@ -1063,8 +1015,8 @@ savePartialProof maybeNatural file = do removeIfRoot :: ReplNode -> ClaimIndex - -> [claim] - -> [claim] + -> [ReachabilityRule Variable] + -> [ReachabilityRule Variable] removeIfRoot (ReplNode node) (ClaimIndex index) claims | index >= 0 && index < length claims , node == 0 = @@ -1075,14 +1027,16 @@ savePartialProof maybeNatural file = do makeModuleName :: FilePath -> String makeModuleName name = upper name <> "-SPEC" --- | Pipe result of the command to the specified program. This function will start --- one process for each KoreOut in the command's output. AuxOut will not be piped, --- instead it will be sent directly to the repl's output. +{- | Pipe result of the command to the specified program. + +This function will start one process for each KoreOut in the command's +output. AuxOut will not be piped, instead it will be sent directly to the repl's +output. + + -} pipe - :: forall claim m - . Claim claim - => From claim (TermLike Variable) - => MonadIO m + :: forall m + . MonadIO m => MonadSimplify m => ReplCommand -- ^ command to pipe @@ -1090,7 +1044,7 @@ pipe -- ^ path to the program that will receive the command's output -> [String] -- ^ additional arguments to be passed to the program - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () pipe cmd file args = do exists <- liftIO $ findExecutable file case exists of @@ -1125,28 +1079,24 @@ pipe cmd file args = do -- | Appends output of a command to a file. appendTo - :: forall claim m - . Claim claim - => From claim (TermLike Variable) - => MonadSimplify m + :: forall m + . MonadSimplify m => MonadIO m => ReplCommand -- ^ command -> FilePath -- ^ file to append to - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () appendTo cmd file = withExistingDirectory file (appendCommand cmd) appendCommand - :: forall claim m - . Claim claim - => From claim (TermLike Variable) - => MonadSimplify m + :: forall m + . MonadSimplify m => MonadIO m => ReplCommand -> FilePath - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () appendCommand cmd file = do config <- ask runInterpreterWithOutput @@ -1157,8 +1107,8 @@ appendCommand cmd file = do putStrLn' $ "Redirected output to \"" <> file <> "\"." alias - :: forall m claim - . MonadState (ReplState claim) m + :: forall m + . MonadState ReplState m => MonadWriter ReplOutput m => AliasDefinition -> m () @@ -1169,15 +1119,13 @@ alias a = do Right _ -> pure () tryAlias - :: forall claim m - . Claim claim - => From claim (TermLike Variable) - => MonadSimplify m + :: forall m + . MonadSimplify m => MonadIO m => ReplAlias -> PrintAuxOutput -> PrintKoreOutput - -> ReplM claim m ReplStatus + -> ReplM (ReachabilityRule Variable) m ReplStatus tryAlias replAlias@ReplAlias { name } printAux printKore = do res <- findAlias name case res of @@ -1194,9 +1142,9 @@ tryAlias replAlias@ReplAlias { name } printAux printKore = do where runInterpreter :: ReplCommand - -> Config claim m - -> ReplState claim - -> ReplM claim m (ReplStatus, ReplState claim) + -> Config (ReachabilityRule Variable) m + -> ReplState + -> ReplM (ReachabilityRule Variable) m (ReplStatus, ReplState) runInterpreter cmd config st = lift $ (`runStateT` st) @@ -1208,13 +1156,12 @@ tryAlias replAlias@ReplAlias { name } printAux printKore = do -- -- See 'loopM' for details. performStepNoBranching - :: forall claim m - . Claim claim - => MonadSimplify m + :: forall m + . MonadSimplify m => MonadIO m => (Natural, StepResult) -- ^ (current step, last result) - -> ReplM claim m (Either (Natural, StepResult) (Natural, StepResult)) + -> ReplM (ReachabilityRule Variable) m (Either (Natural, StepResult) (Natural, StepResult)) performStepNoBranching = \case -- Termination branch @@ -1229,12 +1176,11 @@ performStepNoBranching = -- TODO(Vladimir): It would be ideal for this to be implemented in terms of -- 'performStepNoBranching'. recursiveForcedStep - :: Claim claim - => MonadSimplify m + :: MonadSimplify m => MonadIO m => Natural -> ReplNode - -> ReplM claim m () + -> ReplM (ReachabilityRule Variable) m () recursiveForcedStep n node | n == 0 = pure () | otherwise = do @@ -1421,13 +1367,11 @@ showAxiomOrClaimName | otherwise = Just $ "Claim " <> ruleName parseEvalScript - :: forall claim t m - . Claim claim - => From claim (TermLike Variable) - => MonadSimplify m + :: forall t m + . MonadSimplify m => MonadIO m - => MonadState (ReplState claim) (t m) - => MonadReader (Config claim m) (t m) + => MonadState ReplState (t m) + => MonadReader (Config (ReachabilityRule Variable) m) (t m) => Monad.Trans.MonadTrans t => FilePath -> t m () diff --git a/kore/src/Kore/Repl/State.hs b/kore/src/Kore/Repl/State.hs index 8e9c56cd57..9cc8c41cfc 100644 --- a/kore/src/Kore/Repl/State.hs +++ b/kore/src/Kore/Repl/State.hs @@ -133,9 +133,6 @@ import Kore.Step.Simplification.Data ( MonadSimplify ) import qualified Kore.Step.Strategy as Strategy -import Kore.Strategies.Goal - ( Rule (..) - ) import qualified Kore.Strategies.Goal as Goal import Kore.Strategies.ProofState ( ProofState (Goal) @@ -180,46 +177,42 @@ ruleReference f g ref = -- | Get nth claim from the claims list. getClaimByIndex - :: MonadState (ReplState claim) m + :: MonadState ReplState m => Int -- ^ index in the claims list - -> m (Maybe claim) + -> m (Maybe (ReachabilityRule Variable)) getClaimByIndex index = Lens.preuse $ field @"claims" . Lens.element index -- | Get nth axiom from the axioms list. getAxiomByIndex - :: MonadState (ReplState claim) m + :: MonadState ReplState m => Int -- ^ index in the axioms list - -> m (Maybe (Rule claim)) + -> m (Maybe Axiom) getAxiomByIndex index = Lens.preuse $ field @"axioms" . Lens.element index -- | Get the leftmost axiom with a specific name from the axioms list. getAxiomByName - :: MonadState (ReplState claim) m - => axiom ~ Rule claim - => ToRulePattern axiom + :: MonadState ReplState m => String -- ^ label attribute - -> m (Maybe axiom) + -> m (Maybe Axiom) getAxiomByName name = do axioms <- Lens.use (field @"axioms") return $ find (isNameEqual name) axioms -- | Get the leftmost claim with a specific name from the claim list. getClaimByName - :: MonadState (ReplState claim) m - => Claim claim + :: MonadState ReplState m => String -- ^ label attribute - -> m (Maybe claim) + -> m (Maybe (ReachabilityRule Variable)) getClaimByName name = do claims <- Lens.use (field @"claims") return $ find (isNameEqual name) claims getClaimIndexByName - :: MonadState (ReplState claim) m - => Claim claim + :: MonadState ReplState m => String -- ^ label attribute -> m (Maybe ClaimIndex) @@ -228,11 +221,9 @@ getClaimIndexByName name= do return $ ClaimIndex <$> findIndex (isNameEqual name) claims getAxiomOrClaimByName - :: MonadState (ReplState claim) m - => Claim claim - => axiom ~ Rule claim + :: MonadState ReplState m => RuleName - -> m (Maybe (Either axiom claim)) + -> m (Maybe (Either Axiom (ReachabilityRule Variable))) getAxiomOrClaimByName (RuleName name) = do mAxiom <- getAxiomByName name case mAxiom of @@ -268,10 +259,9 @@ getNameText = -- | Transforms an axiom or claim index into an axiom or claim if they could be -- found. getAxiomOrClaimByIndex - :: MonadState (ReplState claim) m - => axiom ~ Rule claim + :: MonadState ReplState m => Either AxiomIndex ClaimIndex - -> m (Maybe (Either axiom claim)) + -> m (Maybe (Either Axiom (ReachabilityRule Variable))) getAxiomOrClaimByIndex = fmap bisequence . bitraverse @@ -287,7 +277,9 @@ getInternalIdentifier = . toRulePattern -- | Update the currently selected claim to prove. -switchToProof :: MonadState (ReplState claim) m => claim -> ClaimIndex -> m () +switchToProof + :: MonadState ReplState m + => ReachabilityRule Variable -> ClaimIndex -> m () switchToProof claim cindex = modify (\st -> st { claim = claim @@ -296,50 +288,33 @@ switchToProof claim cindex = }) -- | Get the internal representation of the execution graph. -getInnerGraph - :: MonadState (ReplState claim) m - => axiom ~ Rule claim - => Claim claim - => m (InnerGraph axiom) +getInnerGraph :: MonadState ReplState m => m (InnerGraph Axiom) getInnerGraph = fmap Strategy.graph getExecutionGraph -- | Get the current execution graph -getExecutionGraph - :: MonadState (ReplState claim) m - => axiom ~ Rule claim - => Claim claim - => m (ExecutionGraph axiom) +getExecutionGraph :: MonadState ReplState m => m (ExecutionGraph Axiom) getExecutionGraph = do ReplState { claimIndex, graphs, claim } <- get let mgraph = Map.lookup claimIndex graphs return $ fromMaybe (emptyExecutionGraph claim) mgraph -- | Update the internal representation of the current execution graph. -updateInnerGraph - :: forall claim axiom m - . MonadState (ReplState claim) m - => axiom ~ Rule claim - => InnerGraph axiom - -> m () +updateInnerGraph :: forall m. MonadState ReplState m => InnerGraph Axiom -> m () updateInnerGraph ig = do ReplState { claimIndex, graphs } <- get field @"graphs" Lens..= Map.adjust (updateInnerGraph0 ig) claimIndex graphs where updateInnerGraph0 - :: InnerGraph axiom - -> ExecutionGraph axiom - -> ExecutionGraph axiom + :: InnerGraph Axiom + -> ExecutionGraph Axiom + -> ExecutionGraph Axiom updateInnerGraph0 graph Strategy.ExecutionGraph { root } = Strategy.ExecutionGraph { root, graph } -- | Update the current execution graph. -updateExecutionGraph - :: MonadState (ReplState claim) m - => axiom ~ Rule claim - => ExecutionGraph axiom - -> m () +updateExecutionGraph :: MonadState ReplState m => ExecutionGraph Axiom -> m () updateExecutionGraph gph = do ReplState { claimIndex, graphs } <- get field @"graphs" Lens..= Map.insert claimIndex gph graphs @@ -396,7 +371,7 @@ smoothOutGraph graph = do -- | Get the node labels for the current claim. getLabels - :: MonadState (ReplState claim) m + :: MonadState ReplState m => m (Map String ReplNode) getLabels = do ReplState { claimIndex, labels } <- get @@ -405,7 +380,7 @@ getLabels = do -- | Update the node labels for the current claim. setLabels - :: MonadState (ReplState claim) m + :: MonadState ReplState m => Map String ReplNode -> m () setLabels lbls = do @@ -416,8 +391,7 @@ setLabels lbls = do -- | Get selected node (or current node for 'Nothing') and validate that it's -- part of the execution graph. getTargetNode - :: MonadState (ReplState claim) m - => Claim claim + :: MonadState ReplState m => Maybe ReplNode -- ^ node index -> m (Maybe ReplNode) @@ -431,8 +405,7 @@ getTargetNode maybeNode = do -- | Get the configuration at selected node (or current node for 'Nothing'). getConfigAt - :: MonadState (ReplState claim) m - => Claim claim + :: MonadState ReplState m => Maybe ReplNode -> m (Maybe (ReplNode, CommonProofState)) getConfigAt maybeNode = do @@ -447,12 +420,10 @@ getConfigAt maybeNode = do -- | Get the rule used to reach selected node. getRuleFor - :: MonadState (ReplState claim) m - => axiom ~ Rule claim - => Claim claim + :: MonadState ReplState m => Maybe ReplNode -- ^ node index - -> m (Maybe axiom) + -> m (Maybe Axiom) getRuleFor maybeNode = do targetNode <- getTargetNode maybeNode graph' <- getInnerGraph @@ -468,8 +439,8 @@ getRuleFor maybeNode = do -- | Lifting function that takes logging into account. liftSimplifierWithLogger - :: forall a t m claim - . MonadState (ReplState claim) (t m) + :: forall a t m + . MonadState ReplState (t m) => MonadSimplify m => MonadIO m => Monad.Trans.MonadTrans t @@ -506,12 +477,11 @@ liftSimplifierWithLogger mLogger simplifier = do -- | Run a single step for the data in state -- (claim, axioms, claims, current node and execution graph). runStepper - :: MonadState (ReplState claim) (t m) - => MonadReader (Config claim m) (t m) + :: MonadState ReplState (t m) + => MonadReader (Config (ReachabilityRule Variable) m) (t m) => Monad.Trans.MonadTrans t => MonadSimplify m => MonadIO m - => Claim claim => t m StepResult runStepper = do ReplState { claims, axioms, node } <- get @@ -526,17 +496,15 @@ runStepper = do -- | Run a single step for the current claim with the selected claims, axioms -- starting at the selected node. runStepper' - :: MonadState (ReplState claim) (t m) - => MonadReader (Config claim m) (t m) - => axiom ~ Rule claim + :: MonadState ReplState (t m) + => MonadReader (Config (ReachabilityRule Variable) m) (t m) => Monad.Trans.MonadTrans t => MonadSimplify m => MonadIO m - => Claim claim - => [claim] - -> [axiom] + => [ReachabilityRule Variable] + -> [Axiom] -> ReplNode - -> t m (ExecutionGraph axiom, StepResult) + -> t m (ExecutionGraph Axiom, StepResult) runStepper' claims axioms node = do ReplState { claim } <- get stepper <- asks stepper @@ -555,7 +523,7 @@ runStepper' claims axioms node = do nodes -> BranchResult $ fmap ReplNode nodes runUnifier - :: MonadState (ReplState claim) (t m) + :: MonadState ReplState (t m) => MonadReader (Config claim m) (t m) => Monad.Trans.MonadTrans t => MonadSimplify m @@ -603,8 +571,8 @@ nodeToPattern graph node = -- | Adds or updates the provided alias. addOrUpdateAlias - :: forall m claim - . MonadState (ReplState claim) m + :: forall m + . MonadState ReplState m => MonadError AliasError m => AliasDefinition -> m () @@ -642,7 +610,7 @@ addOrUpdateAlias alias@AliasDefinition { name, command } = do findAlias - :: MonadState (ReplState claim) m + :: MonadState ReplState m => String -> m (Maybe AliasDefinition) findAlias name = Map.lookup name <$> Lens.use (field @"aliases") @@ -704,11 +672,9 @@ conjOfClaims claims sort = $ fmap from claims generateInProgressClaims - :: forall claim m axiom - . Claim claim - => axiom ~ Rule claim - => MonadState (ReplState claim) m - => m [claim] + :: forall m + . MonadState ReplState m + => m [ReachabilityRule Variable] generateInProgressClaims = do graphs <- Lens.use (field @"graphs") claims <- Lens.use (field @"claims") @@ -717,17 +683,17 @@ generateInProgressClaims = do return $ started <> notStarted where startedClaims - :: Map.Map ClaimIndex (ExecutionGraph axiom) - -> [claim] - -> [claim] + :: Map.Map ClaimIndex (ExecutionGraph Axiom) + -> [ReachabilityRule Variable] + -> [ReachabilityRule Variable] startedClaims graphs claims = fmap (uncurry createClaim) $ claimsWithPatterns graphs claims >>= sequence notStartedClaims - :: Map.Map ClaimIndex (ExecutionGraph axiom) - -> [claim] - -> [claim] + :: Map.Map ClaimIndex (ExecutionGraph Axiom) + -> [ReachabilityRule Variable] + -> [ReachabilityRule Variable] notStartedClaims graphs claims = filter (not . Goal.isTrusted) ( (claims !!) @@ -761,10 +727,7 @@ findTerminalPatterns graph = . findLeafNodes $ graph -currentClaimSort - :: Claim claim - => MonadState (ReplState claim) m - => m Sort +currentClaimSort :: MonadState ReplState m => m Sort currentClaimSort = do claims <- Lens.use (field @"claim") return . TermLike.termLikeSort diff --git a/kore/test/Test/Kore/Repl/Interpreter.hs b/kore/test/Test/Kore/Repl/Interpreter.hs index 0840943b88..61b052dac0 100644 --- a/kore/test/Test/Kore/Repl/Interpreter.hs +++ b/kore/test/Test/Kore/Repl/Interpreter.hs @@ -94,8 +94,7 @@ import Test.Kore.Builtin.Builtin import Test.Kore.Builtin.Definition import Test.Kore.Step.Simplification -type Claim = OnePathRule Variable -type Axiom = Rule (OnePathRule Variable) +type Claim = ReachabilityRule Variable test_replInterpreter :: [TestTree] test_replInterpreter = @@ -564,14 +563,14 @@ add1 = zeroToTen :: Claim zeroToTen = - coerce $ rulePatternWithName zero (mkAnd mkTop_ ten) "0to10Claim" + OnePath $ coerce $ rulePatternWithName zero (mkAnd mkTop_ ten) "0to10Claim" where zero = Int.asInternal intSort 0 ten = Int.asInternal intSort 10 emptyClaim :: Claim emptyClaim = - coerce + OnePath . coerce $ rulePatternWithName mkBottom_ (mkAnd mkTop_ mkBottom_) "emptyClaim" rulePatternWithName @@ -595,7 +594,7 @@ runWithState -> [Axiom] -> [Claim] -> Claim - -> (ReplState Claim -> ReplState Claim) + -> (ReplState -> ReplState) -> IO Result runWithState command axioms claims claim stateTransformer = do let logger = mempty @@ -626,7 +625,7 @@ runWithState command axioms claims claim stateTransformer = do data Result = Result { output :: ReplOutput , continue :: ReplStatus - , state :: ReplState Claim + , state :: ReplState } equals :: (Eq a, Show a) => a -> a -> Assertion @@ -636,7 +635,7 @@ equalsOutput :: ReplOutput -> ReplOutput -> Assertion equalsOutput actual expected = actual @?= expected -hasCurrentNode :: ReplState Claim -> ReplNode -> IO () +hasCurrentNode :: ReplState -> ReplNode -> IO () hasCurrentNode st n = do node st `equals` n graphNode <- evalStateT (getTargetNode justNode) st @@ -644,7 +643,7 @@ hasCurrentNode st n = do where justNode = Just n -hasAlias :: ReplState Claim -> AliasDefinition -> IO () +hasAlias :: ReplState -> AliasDefinition -> IO () hasAlias st alias@AliasDefinition { name } = let aliasMap = aliases st @@ -653,7 +652,7 @@ hasAlias st alias@AliasDefinition { name } = actual `equals` Just alias hasLogging - :: ReplState Claim + :: ReplState -> Log.KoreLogOptions -> IO () hasLogging st expectedLogging = @@ -662,7 +661,7 @@ hasLogging st expectedLogging = in actualLogging `equals` expectedLogging -hasCurrentClaimIndex :: ReplState Claim -> ClaimIndex -> IO () +hasCurrentClaimIndex :: ReplState -> ClaimIndex -> IO () hasCurrentClaimIndex st expectedClaimIndex = let actualClaimIndex = claimIndex st @@ -676,7 +675,7 @@ mkState :: [Axiom] -> [Claim] -> Claim - -> ReplState Claim + -> ReplState mkState axioms claims claim = ReplState { axioms = axioms From 680c896ec750a31b29608a4a6852c300b6625bd7 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 14:20:39 -0500 Subject: [PATCH 11/79] Kore.Repl: Remove Config type parameter --- kore/src/Kore/Repl.hs | 6 +- kore/src/Kore/Repl/Data.hs | 12 ++-- kore/src/Kore/Repl/Interpreter.hs | 81 ++++++++++++------------- kore/src/Kore/Repl/State.hs | 8 +-- kore/test/Test/Kore/Repl/Interpreter.hs | 2 +- 5 files changed, 54 insertions(+), 55 deletions(-) diff --git a/kore/src/Kore/Repl.hs b/kore/src/Kore/Repl.hs index e56b32321e..3369d1b3ea 100644 --- a/kore/src/Kore/Repl.hs +++ b/kore/src/Kore/Repl.hs @@ -137,10 +137,10 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d $ flip runReaderT config $ replInterpreter printIfNotEmpty cmd - evaluateScript :: ReplScript -> RWST (Config (ReachabilityRule Variable) m) String ReplState m () + evaluateScript :: ReplScript -> RWST (Config m) String ReplState m () evaluateScript = maybe (pure ()) parseEvalScript . unReplScript - repl0 :: ReaderT (Config (ReachabilityRule Variable) m) (StateT ReplState m) () + repl0 :: ReaderT (Config m) (StateT ReplState m) () repl0 = do str <- prompt let command = fromMaybe ShowUsage $ parseMaybe commandParser str @@ -167,7 +167,7 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d { Log.exeName = Log.ExeName "kore-repl" } } - config :: Config (ReachabilityRule Variable) m + config :: Config m config = Config { stepper = stepper0 diff --git a/kore/src/Kore/Repl/Data.hs b/kore/src/Kore/Repl/Data.hs index 52b2ddf91b..0dc9739116 100644 --- a/kore/src/Kore/Repl/Data.hs +++ b/kore/src/Kore/Repl/Data.hs @@ -460,14 +460,14 @@ data ReplState = ReplState deriving (GHC.Generic) -- | Configuration environment for the repl. -data Config claim m = Config +data Config m = Config { stepper - :: claim - -> [claim] - -> [Rule claim] - -> ExecutionGraph (Rule claim) + :: ReachabilityRule Variable + -> [ReachabilityRule Variable] + -> [Axiom] + -> ExecutionGraph Axiom -> ReplNode - -> m (ExecutionGraph (Rule claim)) + -> m (ExecutionGraph Axiom) -- ^ Stepper function, it is a partially applied 'verifyClaimStep' , unifier :: SideCondition Variable diff --git a/kore/src/Kore/Repl/Interpreter.hs b/kore/src/Kore/Repl/Interpreter.hs index da6f1bc780..4ef1e6d3a7 100644 --- a/kore/src/Kore/Repl/Interpreter.hs +++ b/kore/src/Kore/Repl/Interpreter.hs @@ -217,8 +217,7 @@ import Kore.Unparser -- _great care_ of evaluating the RWST to a StateT immediatly, and thus getting -- rid of the WriterT part of the stack. This happens in the implementation of -- 'replInterpreter'. -type ReplM claim m a = - RWST (Config claim m) ReplOutput ReplState m a +type ReplM m a = RWST (Config m) ReplOutput ReplState m a data ReplStatus = Continue | SuccessStop | FailStop deriving (Eq, Show) @@ -230,7 +229,7 @@ replInterpreter => MonadIO m => (String -> IO ()) -> ReplCommand - -> ReaderT (Config (ReachabilityRule Variable) m) (StateT ReplState m) ReplStatus + -> ReaderT (Config m) (StateT ReplState m) ReplStatus replInterpreter fn cmd = replInterpreter0 (PrintAuxOutput fn) @@ -244,7 +243,7 @@ replInterpreter0 => PrintAuxOutput -> PrintKoreOutput -> ReplCommand - -> ReaderT (Config (ReachabilityRule Variable) m) (StateT ReplState m) ReplStatus + -> ReaderT (Config m) (StateT ReplState m) ReplStatus replInterpreter0 printAux printKore replCmd = do let command = case replCmd of ShowUsage -> showUsage $> Continue @@ -295,8 +294,8 @@ replInterpreter0 printAux printKore replCmd = do -- and updates the state, returning the writer output along with the -- monadic result. evaluateCommand - :: ReplM claim m ReplStatus - -> ReaderT (Config claim m) (StateT ReplState m) (ReplOutput, ReplStatus) + :: ReplM m ReplStatus + -> ReaderT (Config m) (StateT ReplState m) (ReplOutput, ReplStatus) evaluateCommand c = do st <- get config <- Reader.ask @@ -328,7 +327,7 @@ showUsage = putStrLn' showUsageMessage exit :: MonadIO m - => ReplM (ReachabilityRule Variable) m ReplStatus + => ReplM m ReplStatus exit = do proofs <- allProofs ofile <- Lens.view (field @"outputFile") @@ -461,7 +460,7 @@ proveSteps => MonadIO m => Natural -- ^ maximum number of steps to perform - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () proveSteps n = do let node = ReplNode . fromEnum $ n result <- loopM performStepNoBranching (n, SingleResult node) @@ -477,7 +476,7 @@ proveStepsF => MonadIO m => Natural -- ^ maximum number of steps to perform - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () proveStepsF n = do node <- Lens.use (field @"node") recursiveForcedStep n node @@ -489,7 +488,7 @@ loadScript => MonadIO m => FilePath -- ^ path to file - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () loadScript file = parseEvalScript file handleLog @@ -517,7 +516,7 @@ showConfig :: Monad m => Maybe ReplNode -- ^ 'Nothing' for current node, or @Just n@ for a specific node identifier - -> ReplM claim m () + -> ReplM m () showConfig configNode = do maybeConfig <- getConfigAt configNode case maybeConfig of @@ -530,24 +529,24 @@ showConfig configNode = do -- | Shows current omit list if passed 'Nothing'. Adds/removes from the list -- depending on whether the string already exists in the list or not. omitCell - :: forall claim m + :: forall m . Monad m => Maybe String -- ^ Nothing to show current list, @Just str@ to add/remove to list - -> ReplM claim m () + -> ReplM m () omitCell = \case Nothing -> showCells Just str -> addOrRemove str where - showCells :: ReplM claim m () + showCells :: ReplM m () showCells = do omit <- Lens.use (field @"omit") if Set.null omit then putStrLn' "Omit list is currently empty." else Foldable.traverse_ putStrLn' omit - addOrRemove :: String -> ReplM claim m () + addOrRemove :: String -> ReplM m () addOrRemove str = field @"omit" %= toggle str toggle :: String -> Set String -> Set String @@ -557,7 +556,7 @@ omitCell = -- | Shows all leaf nodes identifiers which are either stuck or can be -- evaluated further. -showLeafs :: forall claim m. Monad m => ReplM claim m () +showLeafs :: forall m. Monad m => ReplM m () showLeafs = do leafsByType <- sortLeafsByType <$> getInnerGraph case Map.foldMapWithKey showPair leafsByType of @@ -567,7 +566,7 @@ showLeafs = do showPair :: NodeState -> [Graph.Node] -> String showPair ns xs = show ns <> ": " <> show xs -proofStatus :: forall m. Monad m => ReplM (ReachabilityRule Variable) m () +proofStatus :: forall m. Monad m => ReplM m () proofStatus = do proofs <- allProofs putStrLn' . showProofStatus $ proofs @@ -575,7 +574,7 @@ proofStatus = do allProofs :: forall m . Monad m - => ReplM (ReachabilityRule Variable) m (Map.Map ClaimIndex GraphProofStatus) + => ReplM m (Map.Map ClaimIndex GraphProofStatus) allProofs = do graphs <- Lens.use (field @"graphs") claims <- Lens.use (field @"claims") @@ -640,7 +639,7 @@ showPrecBranch :: Monad m => Maybe ReplNode -- ^ 'Nothing' for current node, or @Just n@ for a specific node identifier - -> ReplM claim m () + -> ReplM m () showPrecBranch maybeNode = do graph <- getInnerGraph node' <- getTargetNode maybeNode @@ -662,7 +661,7 @@ showChildren :: Monad m => Maybe ReplNode -- ^ 'Nothing' for current node, or @Just n@ for a specific node identifier - -> ReplM claim m () + -> ReplM m () showChildren maybeNode = do graph <- getInnerGraph node' <- getTargetNode maybeNode @@ -744,7 +743,7 @@ redirect -- ^ command to redirect -> FilePath -- ^ file path - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () redirect cmd file = do liftIO $ withExistingDirectory file (`writeFile` "") appendCommand cmd file @@ -756,8 +755,8 @@ runInterpreterWithOutput => PrintAuxOutput -> PrintKoreOutput -> ReplCommand - -> Config (ReachabilityRule Variable) m - -> ReplM (ReachabilityRule Variable) m () + -> Config m + -> ReplM m () runInterpreterWithOutput printAux printKore cmd config = get >>= (\st -> lift $ execStateReader config st @@ -775,7 +774,7 @@ tryAxiomClaim => MonadIO m => RuleReference -- ^ tagged index in the axioms or claims list - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () tryAxiomClaim = tryAxiomClaimWorker Never -- | Attempt to use a specific axiom or claim to progress the current proof. @@ -785,7 +784,7 @@ tryFAxiomClaim => MonadIO m => RuleReference -- ^ tagged index in the axioms or claims list - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () tryFAxiomClaim = tryAxiomClaimWorker IfPossible tryAxiomClaimWorker @@ -795,7 +794,7 @@ tryAxiomClaimWorker => AlsoApplyRule -> RuleReference -- ^ tagged index in the axioms or claims list - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () tryAxiomClaimWorker mode ref = do maybeAxiomOrClaim <- ruleReference @@ -843,7 +842,7 @@ tryAxiomClaimWorker mode ref = do showUnificationFailure :: Either Axiom (ReachabilityRule Variable) -> ReplNode - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () showUnificationFailure axiomOrClaim' node = do let first = extractLeftPattern axiomOrClaim' maybeSecond <- getConfigAt (Just node) @@ -860,7 +859,7 @@ tryAxiomClaimWorker mode ref = do } second where - patternUnifier :: Pattern Variable -> ReplM (ReachabilityRule Variable) m () + patternUnifier :: Pattern Variable -> ReplM m () patternUnifier (Pattern.splitTerm -> (secondTerm, secondCondition)) = @@ -872,7 +871,7 @@ tryAxiomClaimWorker mode ref = do tryForceAxiomOrClaim :: Either Axiom (ReachabilityRule Variable) -> ReplNode - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () tryForceAxiomOrClaim axiomOrClaim node = do (graph, result) <- runStepper' @@ -892,7 +891,7 @@ tryAxiomClaimWorker mode ref = do :: SideCondition Variable -> TermLike Variable -> TermLike Variable - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () runUnifier' sideCondition first second = runUnifier sideCondition first' second >>= tell . formatUnificationMessage @@ -962,7 +961,7 @@ savePartialProof . MonadIO m => Maybe Natural -> FilePath - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () savePartialProof maybeNatural file = do currentClaim <- Lens.use (field @"claim") currentIndex <- Lens.use (field @"claimIndex") @@ -990,7 +989,7 @@ savePartialProof maybeNatural file = do saveUnparsedDefinitionToFile :: Pretty.Doc ann - -> ReplM claim m () + -> ReplM m () saveUnparsedDefinitionToFile definition = liftIO $ withFile @@ -1044,7 +1043,7 @@ pipe -- ^ path to the program that will receive the command's output -> [String] -- ^ additional arguments to be passed to the program - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () pipe cmd file args = do exists <- liftIO $ findExecutable file case exists of @@ -1086,7 +1085,7 @@ appendTo -- ^ command -> FilePath -- ^ file to append to - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () appendTo cmd file = withExistingDirectory file (appendCommand cmd) @@ -1096,7 +1095,7 @@ appendCommand => MonadIO m => ReplCommand -> FilePath - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () appendCommand cmd file = do config <- ask runInterpreterWithOutput @@ -1125,7 +1124,7 @@ tryAlias => ReplAlias -> PrintAuxOutput -> PrintKoreOutput - -> ReplM (ReachabilityRule Variable) m ReplStatus + -> ReplM m ReplStatus tryAlias replAlias@ReplAlias { name } printAux printKore = do res <- findAlias name case res of @@ -1142,9 +1141,9 @@ tryAlias replAlias@ReplAlias { name } printAux printKore = do where runInterpreter :: ReplCommand - -> Config (ReachabilityRule Variable) m + -> Config m -> ReplState - -> ReplM (ReachabilityRule Variable) m (ReplStatus, ReplState) + -> ReplM m (ReplStatus, ReplState) runInterpreter cmd config st = lift $ (`runStateT` st) @@ -1161,7 +1160,7 @@ performStepNoBranching => MonadIO m => (Natural, StepResult) -- ^ (current step, last result) - -> ReplM (ReachabilityRule Variable) m (Either (Natural, StepResult) (Natural, StepResult)) + -> ReplM m (Either (Natural, StepResult) (Natural, StepResult)) performStepNoBranching = \case -- Termination branch @@ -1180,7 +1179,7 @@ recursiveForcedStep => MonadIO m => Natural -> ReplNode - -> ReplM (ReachabilityRule Variable) m () + -> ReplM m () recursiveForcedStep n node | n == 0 = pure () | otherwise = do @@ -1371,7 +1370,7 @@ parseEvalScript . MonadSimplify m => MonadIO m => MonadState ReplState (t m) - => MonadReader (Config (ReachabilityRule Variable) m) (t m) + => MonadReader (Config m) (t m) => Monad.Trans.MonadTrans t => FilePath -> t m () diff --git a/kore/src/Kore/Repl/State.hs b/kore/src/Kore/Repl/State.hs index 9cc8c41cfc..27a9f51bb6 100644 --- a/kore/src/Kore/Repl/State.hs +++ b/kore/src/Kore/Repl/State.hs @@ -155,7 +155,7 @@ import Kore.Syntax.Variable ) -- | Creates a fresh execution graph for the given claim. -emptyExecutionGraph :: Claim claim => claim -> ExecutionGraph axiom +emptyExecutionGraph :: ReachabilityRule Variable -> ExecutionGraph Axiom emptyExecutionGraph = Strategy.emptyExecutionGraph . extractConfig . RewriteRule . toRulePattern where @@ -478,7 +478,7 @@ liftSimplifierWithLogger mLogger simplifier = do -- (claim, axioms, claims, current node and execution graph). runStepper :: MonadState ReplState (t m) - => MonadReader (Config (ReachabilityRule Variable) m) (t m) + => MonadReader (Config m) (t m) => Monad.Trans.MonadTrans t => MonadSimplify m => MonadIO m @@ -497,7 +497,7 @@ runStepper = do -- starting at the selected node. runStepper' :: MonadState ReplState (t m) - => MonadReader (Config (ReachabilityRule Variable) m) (t m) + => MonadReader (Config m) (t m) => Monad.Trans.MonadTrans t => MonadSimplify m => MonadIO m @@ -524,7 +524,7 @@ runStepper' claims axioms node = do runUnifier :: MonadState ReplState (t m) - => MonadReader (Config claim m) (t m) + => MonadReader (Config m) (t m) => Monad.Trans.MonadTrans t => MonadSimplify m => MonadIO m diff --git a/kore/test/Test/Kore/Repl/Interpreter.hs b/kore/test/Test/Kore/Repl/Interpreter.hs index 61b052dac0..d3c7611dbb 100644 --- a/kore/test/Test/Kore/Repl/Interpreter.hs +++ b/kore/test/Test/Kore/Repl/Interpreter.hs @@ -695,7 +695,7 @@ mkState axioms claims claim = mkConfig :: MVar (Log.LogAction IO Log.ActualEntry) - -> Config Claim Simplifier + -> Config Simplifier mkConfig logger = Config { stepper = stepper0 From 4de90e194af314c1ec8c54c4ef0337dadabd8401 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 14:43:07 -0500 Subject: [PATCH 12/79] instance From _ SourceLocation --- kore/src/Kore/Repl/Data.hs | 12 +++++++----- kore/src/Kore/Repl/Interpreter.hs | 16 +++------------- kore/src/Kore/Repl/State.hs | 23 +++++++++-------------- kore/src/Kore/Step/RulePattern.hs | 16 ++++++++++++++++ kore/src/Kore/Strategies/Rule.hs | 6 ++++++ kore/test/Test/Kore/Repl/Interpreter.hs | 2 -- 6 files changed, 41 insertions(+), 34 deletions(-) diff --git a/kore/src/Kore/Repl/Data.hs b/kore/src/Kore/Repl/Data.hs index 0dc9739116..0c7334d066 100644 --- a/kore/src/Kore/Repl/Data.hs +++ b/kore/src/Kore/Repl/Data.hs @@ -13,6 +13,7 @@ module Kore.Repl.Data , AxiomIndex (..), ClaimIndex (..) , RuleName (..), RuleReference(..) , ReplNode (..) + , Claim , Axiom , ReplState (..) , ReplOutput (..) @@ -429,15 +430,16 @@ type ExecutionGraph rule = type InnerGraph rule = Gr CommonProofState (Seq rule) -type Axiom = Rule (ReachabilityRule Variable) +type Claim = ReachabilityRule Variable +type Axiom = Rule Claim -- | State for the repl. data ReplState = ReplState { axioms :: [Axiom] -- ^ List of available axioms - , claims :: [ReachabilityRule Variable] + , claims :: [Claim] -- ^ List of claims to be proven - , claim :: ReachabilityRule Variable + , claim :: Claim -- ^ Currently focused claim in the repl , claimIndex :: ClaimIndex -- ^ Index of the currently focused claim in the repl @@ -462,8 +464,8 @@ data ReplState = ReplState -- | Configuration environment for the repl. data Config m = Config { stepper - :: ReachabilityRule Variable - -> [ReachabilityRule Variable] + :: Claim + -> [Claim] -> [Axiom] -> ExecutionGraph Axiom -> ReplNode diff --git a/kore/src/Kore/Repl/Interpreter.hs b/kore/src/Kore/Repl/Interpreter.hs index 4ef1e6d3a7..2c373eae17 100644 --- a/kore/src/Kore/Repl/Interpreter.hs +++ b/kore/src/Kore/Repl/Interpreter.hs @@ -183,9 +183,6 @@ import Kore.Step.RulePattern , RulePattern (..) ) import qualified Kore.Step.RulePattern as Rule -import qualified Kore.Step.RulePattern as Axiom - ( attributes - ) import Kore.Step.Simplification.Data ( MonadSimplify ) @@ -1193,20 +1190,13 @@ recursiveForcedStep n node -- | Display a rule as a String. showRewriteRule - :: ToRulePattern rule - => Unparse rule + :: Unparse rule + => From rule SourceLocation => rule -> ReplOutput showRewriteRule rule = makeKoreReplOutput (unparseToString rule) - <> makeAuxReplOutput - (show . Pretty.pretty . extractSourceAndLocation $ rule') - where - rule' = toRulePattern rule - - extractSourceAndLocation :: RulePattern Variable -> SourceLocation - extractSourceAndLocation RulePattern { Axiom.attributes } = - Attribute.sourceLocation attributes + <> makeAuxReplOutput (show . Pretty.pretty . from @_ @SourceLocation $ rule) -- | Unparses a strategy node, using an omit list to hide specified children. unparseStrategy diff --git a/kore/src/Kore/Repl/State.hs b/kore/src/Kore/Repl/State.hs index 27a9f51bb6..15f0f7f8c5 100644 --- a/kore/src/Kore/Repl/State.hs +++ b/kore/src/Kore/Repl/State.hs @@ -140,7 +140,9 @@ import Kore.Strategies.ProofState , proofState ) import qualified Kore.Strategies.ProofState as ProofState.DoNotUse -import Kore.Strategies.Verification +import Kore.Strategies.Verification hiding + ( Claim + ) import Kore.Syntax.Definition ( Definition (..) , Module (..) @@ -641,11 +643,7 @@ substituteAlias SimpleArgument str -> str QuotedArgument str -> "\"" <> str <> "\"" -createClaim - :: Claim claim - => claim - -> Pattern Variable - -> claim +createClaim :: Claim -> Pattern Variable -> Claim createClaim claim cpattern = fromRulePattern claim @@ -767,12 +765,9 @@ replOutputToString (ReplOutput out) = out >>= replOut id id createNewDefinition - :: forall claim - . Claim claim - => From claim (TermLike Variable) - => ModuleName + :: ModuleName -> String - -> [claim] + -> [Claim] -> Definition (Sentence (TermLike Variable)) createNewDefinition mainModuleName name claims = Definition @@ -798,7 +793,7 @@ createNewDefinition mainModuleName name claims = , sentenceImportAttributes = mempty } - claimToSentence :: claim -> Sentence (TermLike Variable) + claimToSentence :: Claim -> Sentence (TermLike Variable) claimToSentence claim = SentenceClaimSentence . SentenceClaim @@ -808,10 +803,10 @@ createNewDefinition mainModuleName name claims = , sentenceAxiomAttributes = trustedToAttribute claim } - claimToTerm :: claim -> TermLike Variable + claimToTerm :: Claim -> TermLike Variable claimToTerm = from - trustedToAttribute :: claim -> Syntax.Attributes + trustedToAttribute :: Claim -> Syntax.Attributes trustedToAttribute ( Attribute.trusted . attributes diff --git a/kore/src/Kore/Step/RulePattern.hs b/kore/src/Kore/Step/RulePattern.hs index 479dd35d02..5f286ef806 100644 --- a/kore/src/Kore/Step/RulePattern.hs +++ b/kore/src/Kore/Step/RulePattern.hs @@ -219,6 +219,9 @@ instance Debug variable => Debug (RulePattern variable) instance (Debug variable, Diff variable) => Diff (RulePattern variable) +instance From (RulePattern variable) Attribute.SourceLocation where + from = Attribute.sourceLocation . attributes + instance InternalVariable variable => Pretty (RulePattern variable) where pretty rulePattern'@(RulePattern _ _ _ _ _ ) = Pretty.vsep @@ -471,6 +474,9 @@ instance Debug variable => Debug (RewriteRule variable) instance (Debug variable, Diff variable) => Diff (RewriteRule variable) +instance From (RewriteRule variable) Attribute.SourceLocation where + from = Attribute.sourceLocation . attributes . getRewriteRule + instance InternalVariable variable => Unparse (RewriteRule variable) @@ -547,6 +553,9 @@ instance TopBottom (OnePathRule variable) where isTop _ = False isBottom _ = False +instance From (OnePathRule variable) Attribute.SourceLocation where + from = Attribute.sourceLocation . attributes . getOnePathRule + {- | Unified One-Path and All-Path Claim rule pattern. -} data ReachabilityRule variable @@ -580,6 +589,10 @@ instance Pretty (ReachabilityRule Variable) where pretty (AllPath (AllPathRule rule)) = Pretty.vsep ["All-Path reachability rule:", Pretty.pretty rule] +instance From (ReachabilityRule variable) Attribute.SourceLocation where + from (OnePath onePathRule) = from onePathRule + from (AllPath allPathRule) = from allPathRule + toSentence :: ReachabilityRule Variable -> Verified.Sentence toSentence rule = Syntax.SentenceClaimSentence $ Syntax.SentenceClaim Syntax.SentenceAxiom @@ -626,6 +639,9 @@ instance TopBottom (AllPathRule variable) where isTop _ = False isBottom _ = False +instance From (AllPathRule variable) Attribute.SourceLocation where + from = Attribute.sourceLocation . attributes . getAllPathRule + instance ToRulePattern (RewriteRule Variable) instance ToRulePattern (OnePathRule Variable) diff --git a/kore/src/Kore/Strategies/Rule.hs b/kore/src/Kore/Strategies/Rule.hs index c3f353d7f3..9497307a06 100644 --- a/kore/src/Kore/Strategies/Rule.hs +++ b/kore/src/Kore/Strategies/Rule.hs @@ -18,6 +18,9 @@ import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC import Debug +import Kore.Attribute.SourceLocation + ( SourceLocation + ) import Kore.HasPriority import Kore.Internal.Variable ( Variable @@ -101,3 +104,6 @@ instance FromRulePattern (Rule (ReachabilityRule Variable)) instance HasPriority (Rule (ReachabilityRule Variable)) where getPriority = getPriority . unReachabilityRewriteRule + +instance From (Rule (ReachabilityRule Variable)) SourceLocation where + from = from @(RewriteRule Variable) . unReachabilityRewriteRule diff --git a/kore/test/Test/Kore/Repl/Interpreter.hs b/kore/test/Test/Kore/Repl/Interpreter.hs index d3c7611dbb..53e600d98b 100644 --- a/kore/test/Test/Kore/Repl/Interpreter.hs +++ b/kore/test/Test/Kore/Repl/Interpreter.hs @@ -94,8 +94,6 @@ import Test.Kore.Builtin.Builtin import Test.Kore.Builtin.Definition import Test.Kore.Step.Simplification -type Claim = ReachabilityRule Variable - test_replInterpreter :: [TestTree] test_replInterpreter = [ showUsage `tests` "Showing the usage message" From c35e44821502352e280a1e8b75fdd3b09077a2e9 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 14:51:14 -0500 Subject: [PATCH 13/79] instance From _ Label, instance From _ RuleIndex --- kore/src/Kore/Repl/Interpreter.hs | 9 ++++++--- kore/src/Kore/Repl/State.hs | 16 +++++----------- kore/src/Kore/Step/RulePattern.hs | 32 +++++++++++++++++++++++++++++++ kore/src/Kore/Strategies/Rule.hs | 16 ++++++++++++++-- 4 files changed, 57 insertions(+), 16 deletions(-) diff --git a/kore/src/Kore/Repl/Interpreter.hs b/kore/src/Kore/Repl/Interpreter.hs index 2c373eae17..b526c783de 100644 --- a/kore/src/Kore/Repl/Interpreter.hs +++ b/kore/src/Kore/Repl/Interpreter.hs @@ -1253,14 +1253,16 @@ printNotFound = putStrLn' "Variable or index not found" -- parameter is needed in order to distinguish between axioms and claims and -- represents the number of available axioms. showDotGraph - :: ToRulePattern axiom + :: From axiom AttrLabel.Label + => From axiom RuleIndex => Int -> Gr CommonProofState (Maybe (Seq axiom)) -> IO () showDotGraph len = flip Graph.runGraphvizCanvas' Graph.Xlib . Graph.graphToDot (graphParams len) saveDotGraph - :: ToRulePattern axiom + :: From axiom AttrLabel.Label + => From axiom RuleIndex => Int -> Gr CommonProofState (Maybe (Seq axiom)) -> Graph.GraphvizOutput @@ -1280,7 +1282,8 @@ saveDotGraph len gr format file = path graphParams - :: ToRulePattern axiom + :: From axiom AttrLabel.Label + => From axiom RuleIndex => Int -> Graph.GraphvizParams Graph.Node diff --git a/kore/src/Kore/Repl/State.hs b/kore/src/Kore/Repl/State.hs index 15f0f7f8c5..0e64023d8a 100644 --- a/kore/src/Kore/Repl/State.hs +++ b/kore/src/Kore/Repl/State.hs @@ -239,7 +239,7 @@ getAxiomOrClaimByName (RuleName name) = do return . Just . Left $ axiom isNameEqual - :: ToRulePattern rule + :: From rule AttrLabel.Label => String -> rule -> Bool isNameEqual name rule = maybe @@ -251,12 +251,9 @@ isNameEqual name rule = ) getNameText - :: ToRulePattern rule + :: From rule AttrLabel.Label => rule -> AttrLabel.Label -getNameText = - Attribute.label - . attributes - . toRulePattern +getNameText = from -- | Transforms an axiom or claim index into an axiom or claim if they could be -- found. @@ -271,12 +268,9 @@ getAxiomOrClaimByIndex = (getClaimByIndex . coerce) getInternalIdentifier - :: ToRulePattern rule + :: From rule Attribute.RuleIndex => rule -> Attribute.RuleIndex -getInternalIdentifier = - Attribute.identifier - . Rule.attributes - . toRulePattern +getInternalIdentifier = from -- | Update the currently selected claim to prove. switchToProof diff --git a/kore/src/Kore/Step/RulePattern.hs b/kore/src/Kore/Step/RulePattern.hs index 5f286ef806..ee89f9ea58 100644 --- a/kore/src/Kore/Step/RulePattern.hs +++ b/kore/src/Kore/Step/RulePattern.hs @@ -222,6 +222,12 @@ instance (Debug variable, Diff variable) => Diff (RulePattern variable) instance From (RulePattern variable) Attribute.SourceLocation where from = Attribute.sourceLocation . attributes +instance From (RulePattern variable) Attribute.Label where + from = Attribute.label . attributes + +instance From (RulePattern variable) Attribute.RuleIndex where + from = Attribute.identifier . attributes + instance InternalVariable variable => Pretty (RulePattern variable) where pretty rulePattern'@(RulePattern _ _ _ _ _ ) = Pretty.vsep @@ -477,6 +483,12 @@ instance (Debug variable, Diff variable) => Diff (RewriteRule variable) instance From (RewriteRule variable) Attribute.SourceLocation where from = Attribute.sourceLocation . attributes . getRewriteRule +instance From (RewriteRule variable) Attribute.Label where + from = Attribute.label . attributes . getRewriteRule + +instance From (RewriteRule variable) Attribute.RuleIndex where + from = Attribute.identifier . attributes . getRewriteRule + instance InternalVariable variable => Unparse (RewriteRule variable) @@ -556,6 +568,12 @@ instance TopBottom (OnePathRule variable) where instance From (OnePathRule variable) Attribute.SourceLocation where from = Attribute.sourceLocation . attributes . getOnePathRule +instance From (OnePathRule variable) Attribute.Label where + from = Attribute.label . attributes . getOnePathRule + +instance From (OnePathRule variable) Attribute.RuleIndex where + from = Attribute.identifier . attributes . getOnePathRule + {- | Unified One-Path and All-Path Claim rule pattern. -} data ReachabilityRule variable @@ -593,6 +611,14 @@ instance From (ReachabilityRule variable) Attribute.SourceLocation where from (OnePath onePathRule) = from onePathRule from (AllPath allPathRule) = from allPathRule +instance From (ReachabilityRule variable) Attribute.Label where + from (OnePath onePathRule) = from onePathRule + from (AllPath allPathRule) = from allPathRule + +instance From (ReachabilityRule variable) Attribute.RuleIndex where + from (OnePath onePathRule) = from onePathRule + from (AllPath allPathRule) = from allPathRule + toSentence :: ReachabilityRule Variable -> Verified.Sentence toSentence rule = Syntax.SentenceClaimSentence $ Syntax.SentenceClaim Syntax.SentenceAxiom @@ -642,6 +668,12 @@ instance TopBottom (AllPathRule variable) where instance From (AllPathRule variable) Attribute.SourceLocation where from = Attribute.sourceLocation . attributes . getAllPathRule +instance From (AllPathRule variable) Attribute.Label where + from = Attribute.label . attributes . getAllPathRule + +instance From (AllPathRule variable) Attribute.RuleIndex where + from = Attribute.identifier . attributes . getAllPathRule + instance ToRulePattern (RewriteRule Variable) instance ToRulePattern (OnePathRule Variable) diff --git a/kore/src/Kore/Strategies/Rule.hs b/kore/src/Kore/Strategies/Rule.hs index 9497307a06..bf4f0c2187 100644 --- a/kore/src/Kore/Strategies/Rule.hs +++ b/kore/src/Kore/Strategies/Rule.hs @@ -18,7 +18,13 @@ import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC import Debug -import Kore.Attribute.SourceLocation +import Kore.Attribute.Label as Attribute + ( Label + ) +import Kore.Attribute.RuleIndex as Attribute + ( RuleIndex + ) +import Kore.Attribute.SourceLocation as Attribute ( SourceLocation ) import Kore.HasPriority @@ -105,5 +111,11 @@ instance FromRulePattern (Rule (ReachabilityRule Variable)) instance HasPriority (Rule (ReachabilityRule Variable)) where getPriority = getPriority . unReachabilityRewriteRule -instance From (Rule (ReachabilityRule Variable)) SourceLocation where +instance From (Rule (ReachabilityRule Variable)) Attribute.SourceLocation where + from = from @(RewriteRule Variable) . unReachabilityRewriteRule + +instance From (Rule (ReachabilityRule Variable)) Attribute.Label where + from = from @(RewriteRule Variable) . unReachabilityRewriteRule + +instance From (Rule (ReachabilityRule Variable)) Attribute.RuleIndex where from = from @(RewriteRule Variable) . unReachabilityRewriteRule From 7de02ccf22ffca8e5837d24b8c2f06fb786bf022 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 14:59:36 -0500 Subject: [PATCH 14/79] ReachabilityRule: Remove type parameter --- kore/app/exec/Main.hs | 2 +- kore/src/Kore/Exec.hs | 30 +++++----- kore/src/Kore/Log/DebugProofState.hs | 4 +- kore/src/Kore/Log/InfoReachability.hs | 27 ++++----- kore/src/Kore/Repl.hs | 12 ++-- kore/src/Kore/Repl/Data.hs | 2 +- kore/src/Kore/Repl/Interpreter.hs | 30 +++++----- kore/src/Kore/Repl/State.hs | 24 ++++---- kore/src/Kore/Step/Rule/Expand.hs | 2 +- kore/src/Kore/Step/Rule/Simplify.hs | 2 +- kore/src/Kore/Step/RulePattern.hs | 39 ++++++------ kore/src/Kore/Strategies/Goal.hs | 60 +++++++++---------- kore/src/Kore/Strategies/Rule.hs | 22 +++---- .../test/Test/Kore/Strategies/OnePath/Step.hs | 13 ++-- .../Strategies/Reachability/Verification.hs | 10 ++-- 15 files changed, 134 insertions(+), 145 deletions(-) diff --git a/kore/app/exec/Main.hs b/kore/app/exec/Main.hs index a1b6411fb8..1ead9cffb9 100644 --- a/kore/app/exec/Main.hs +++ b/kore/app/exec/Main.hs @@ -541,7 +541,7 @@ koreProve execOptions proveOptions = do saveProven :: VerifiedModule StepperAttributes - -> [ReachabilityRule Variable] + -> [ReachabilityRule] -> FilePath -> IO () saveProven specModule provenClaims outputFile = diff --git a/kore/src/Kore/Exec.hs b/kore/src/Kore/Exec.hs index 0deedbe3a2..13aba0d4c7 100644 --- a/kore/src/Kore/Exec.hs +++ b/kore/src/Kore/Exec.hs @@ -320,7 +320,7 @@ prove -- ^ The module containing the claims that were proven in a previous run. -> smt (Either - (StuckVerification (TermLike Variable) (ReachabilityRule Variable)) + (StuckVerification (TermLike Variable) ReachabilityRule) () ) prove @@ -350,8 +350,8 @@ prove return $ Bifunctor.first stuckVerificationPatternToTerm result where extractUntrustedClaims' - :: [ReachabilityRule Variable] - -> [ReachabilityRule Variable] + :: [ReachabilityRule] + -> [ReachabilityRule] extractUntrustedClaims' = filter (not . Goal.isTrusted) @@ -572,8 +572,8 @@ assertSomeClaims claims = ++ "on the representation of claims." makeReachabilityRule - :: (Attribute.Axiom Symbol Variable, ReachabilityRule Variable) - -> ReachabilityRule Variable + :: (Attribute.Axiom Symbol Variable, ReachabilityRule) + -> ReachabilityRule makeReachabilityRule (attributes, reachabilityRule) = case reachabilityRule of OnePath (OnePathRule rulePattern) -> @@ -655,9 +655,9 @@ initialize verifiedModule within = do data InitializedProver = InitializedProver - { axioms :: ![Goal.Rule (ReachabilityRule Variable)] - , claims :: ![ReachabilityRule Variable] - , alreadyProven :: ![ReachabilityRule Variable] + { axioms :: ![Goal.Rule ReachabilityRule] + , claims :: ![ReachabilityRule] + , alreadyProven :: ![ReachabilityRule] } data MaybeChanged a = Changed !a | Unchanged !a @@ -682,7 +682,7 @@ initializeProver definitionModule specModule maybeAlreadyProvenModule within = let Initialized { rewriteRules } = initialized changedSpecClaims :: [ ( Attribute.Axiom Symbol Variable - , MaybeChanged (ReachabilityRule Variable) + , MaybeChanged ReachabilityRule ) ] changedSpecClaims = @@ -707,14 +707,14 @@ initializeProver definitionModule specModule maybeAlreadyProvenModule within = maybeClaimsAlreadyProven :: Maybe [ ( Attribute.Axiom Symbol Variable - , ReachabilityRule Variable + , ReachabilityRule ) ] maybeClaimsAlreadyProven = Goal.extractClaims <$> maybeAlreadyProvenModule claimsAlreadyProven :: [ (Attribute.Axiom Symbol Variable - , ReachabilityRule Variable + , ReachabilityRule ) ] claimsAlreadyProven = fromMaybe [] maybeClaimsAlreadyProven @@ -723,7 +723,7 @@ initializeProver definitionModule specModule maybeAlreadyProvenModule within = let specClaims :: [ ( Attribute.Axiom Symbol Variable - , ReachabilityRule Variable + , ReachabilityRule ) ] specClaims = @@ -744,8 +744,8 @@ initializeProver definitionModule specModule maybeAlreadyProvenModule within = where expandClaim :: SmtMetadataTools attributes - -> ReachabilityRule Variable - -> MaybeChanged (ReachabilityRule Variable) + -> ReachabilityRule + -> MaybeChanged ReachabilityRule expandClaim tools claim = if claim /= expanded then Changed expanded @@ -754,7 +754,7 @@ initializeProver definitionModule specModule maybeAlreadyProvenModule within = expanded = expandSingleConstructors tools claim logChangedClaim - :: MaybeChanged (ReachabilityRule Variable) + :: MaybeChanged ReachabilityRule -> simplifier () logChangedClaim (Changed claim) = Log.logInfo ("Claim variables were expanded:\n" <> unparseToText claim) diff --git a/kore/src/Kore/Log/DebugProofState.hs b/kore/src/Kore/Log/DebugProofState.hs index fbf077692e..c0999ff0c4 100644 --- a/kore/src/Kore/Log/DebugProofState.hs +++ b/kore/src/Kore/Log/DebugProofState.hs @@ -29,9 +29,9 @@ import Log data DebugProofState = DebugProofState - { proofState :: ProofState (ReachabilityRule Variable) + { proofState :: ProofState ReachabilityRule , transition :: Prim (RewriteRule Variable) - , result :: Maybe (ProofState (ReachabilityRule Variable)) + , result :: Maybe (ProofState ReachabilityRule) } instance Pretty DebugProofState where diff --git a/kore/src/Kore/Log/InfoReachability.hs b/kore/src/Kore/Log/InfoReachability.hs index 73be049c73..3cffe6a259 100644 --- a/kore/src/Kore/Log/InfoReachability.hs +++ b/kore/src/Kore/Log/InfoReachability.hs @@ -13,22 +13,15 @@ module Kore.Log.InfoReachability import Prelude.Kore -import Kore.Internal.Variable - ( Variable - ) import Kore.Strategies.Rule import Log import qualified Pretty data InfoReachability - = InfoSimplify !(ReachabilityRule Variable) - | InfoRemoveDestination !(ReachabilityRule Variable) - | InfoDeriveSeq - ![Rule (ReachabilityRule Variable)] - !(ReachabilityRule Variable) - | InfoDerivePar - ![Rule (ReachabilityRule Variable)] - !(ReachabilityRule Variable) + = InfoSimplify !ReachabilityRule + | InfoRemoveDestination !ReachabilityRule + | InfoDeriveSeq ![Rule ReachabilityRule] !ReachabilityRule + | InfoDerivePar ![Rule ReachabilityRule] !ReachabilityRule prettyInfoReachabilityGoal :: Pretty.Pretty goal @@ -89,30 +82,30 @@ instance Entry InfoReachability where whileSimplify :: MonadLog log - => ReachabilityRule Variable + => ReachabilityRule -> log a -> log a whileSimplify goal = logWhile (InfoSimplify goal) whileRemoveDestination :: MonadLog log - => ReachabilityRule Variable + => ReachabilityRule -> log a -> log a whileRemoveDestination goal = logWhile (InfoRemoveDestination goal) whileDeriveSeq :: MonadLog log - => [Rule (ReachabilityRule Variable)] - -> ReachabilityRule Variable + => [Rule ReachabilityRule] + -> ReachabilityRule -> log a -> log a whileDeriveSeq rules goal = logWhile (InfoDeriveSeq rules goal) whileDerivePar :: MonadLog log - => [Rule (ReachabilityRule Variable)] - -> ReachabilityRule Variable + => [Rule ReachabilityRule] + -> ReachabilityRule -> log a -> log a whileDerivePar rules goal = logWhile (InfoDerivePar rules goal) diff --git a/kore/src/Kore/Repl.hs b/kore/src/Kore/Repl.hs index 3369d1b3ea..7b1af55a1a 100644 --- a/kore/src/Kore/Repl.hs +++ b/kore/src/Kore/Repl.hs @@ -97,7 +97,7 @@ runRepl => MonadCatch m => [Axiom] -- ^ list of axioms to used in the proof - -> [ReachabilityRule Variable] + -> [ReachabilityRule] -- ^ list of claims to be proven -> MVar (Log.LogAction IO Log.ActualEntry) -> ReplScript @@ -191,8 +191,8 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d addIndexesToClaims :: Int - -> [ReachabilityRule Variable] - -> [ReachabilityRule Variable] + -> [ReachabilityRule] + -> [ReachabilityRule] addIndexesToClaims len claims'' = let toAxiomAndBack claim' index = ruleToGoal @@ -231,15 +231,15 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d makeRuleIndex :: Int -> RuleIndex -> RuleIndex makeRuleIndex n _ = RuleIndex (Just n) - firstClaim :: ReachabilityRule Variable + firstClaim :: ReachabilityRule firstClaim = claims' !! unClaimIndex firstClaimIndex firstClaimExecutionGraph :: ExecutionGraph Axiom firstClaimExecutionGraph = emptyExecutionGraph firstClaim stepper0 - :: ReachabilityRule Variable - -> [ReachabilityRule Variable] + :: ReachabilityRule + -> [ReachabilityRule] -> [Axiom] -> ExecutionGraph Axiom -> ReplNode diff --git a/kore/src/Kore/Repl/Data.hs b/kore/src/Kore/Repl/Data.hs index 0c7334d066..e12aa4bce7 100644 --- a/kore/src/Kore/Repl/Data.hs +++ b/kore/src/Kore/Repl/Data.hs @@ -430,7 +430,7 @@ type ExecutionGraph rule = type InnerGraph rule = Gr CommonProofState (Seq rule) -type Claim = ReachabilityRule Variable +type Claim = ReachabilityRule type Axiom = Rule Claim -- | State for the repl. diff --git a/kore/src/Kore/Repl/Interpreter.hs b/kore/src/Kore/Repl/Interpreter.hs index b526c783de..9905f57bee 100644 --- a/kore/src/Kore/Repl/Interpreter.hs +++ b/kore/src/Kore/Repl/Interpreter.hs @@ -395,7 +395,7 @@ prove indexOrName = do startProving claim' where - startProving :: ReachabilityRule Variable -> m () + startProving :: ReachabilityRule -> m () startProving claim | isTrusted claim = putStrLn' @@ -591,12 +591,12 @@ allProofs = do notStartedProofs :: Map.Map ClaimIndex (ExecutionGraph Axiom) - -> Map.Map ClaimIndex (ReachabilityRule Variable) + -> Map.Map ClaimIndex ReachabilityRule -> Map.Map ClaimIndex GraphProofStatus notStartedProofs gphs cls = notStartedOrTrusted <$> cls `Map.difference` gphs - notStartedOrTrusted :: ReachabilityRule Variable -> GraphProofStatus + notStartedOrTrusted :: ReachabilityRule -> GraphProofStatus notStartedOrTrusted cl = if isTrusted cl then TrustedClaim @@ -814,30 +814,30 @@ tryAxiomClaimWorker mode ref = do IfPossible -> tryForceAxiomOrClaim axiomOrClaim node where - notEqualClaimTypes :: Either Axiom (ReachabilityRule Variable) -> ReachabilityRule Variable -> Bool + notEqualClaimTypes :: Either Axiom ReachabilityRule -> ReachabilityRule -> Bool notEqualClaimTypes axiomOrClaim' claim' = not (either (const True) (equalClaimTypes claim') axiomOrClaim') - equalClaimTypes :: ReachabilityRule Variable -> ReachabilityRule Variable -> Bool + equalClaimTypes :: ReachabilityRule -> ReachabilityRule -> Bool equalClaimTypes = isSameType `on` castToReachability - castToReachability :: ReachabilityRule Variable -> Maybe (ReachabilityRule Variable) + castToReachability :: ReachabilityRule -> Maybe ReachabilityRule castToReachability = Typeable.cast - isReachabilityRule :: ReachabilityRule Variable -> Bool + isReachabilityRule :: ReachabilityRule -> Bool isReachabilityRule = isJust . castToReachability isSameType - :: Maybe (ReachabilityRule Variable) - -> Maybe (ReachabilityRule Variable) + :: Maybe ReachabilityRule + -> Maybe ReachabilityRule -> Bool isSameType (Just (OnePath _)) (Just (OnePath _)) = True isSameType (Just (AllPath _)) (Just (AllPath _)) = True isSameType _ _ = False showUnificationFailure - :: Either Axiom (ReachabilityRule Variable) + :: Either Axiom ReachabilityRule -> ReplNode -> ReplM m () showUnificationFailure axiomOrClaim' node = do @@ -866,7 +866,7 @@ tryAxiomClaimWorker mode ref = do SideCondition.assumeTrueCondition secondCondition tryForceAxiomOrClaim - :: Either Axiom (ReachabilityRule Variable) + :: Either Axiom ReachabilityRule -> ReplNode -> ReplM m () tryForceAxiomOrClaim axiomOrClaim node = do @@ -895,7 +895,7 @@ tryAxiomClaimWorker mode ref = do where first' = TermLike.refreshVariables (freeVariables second) first - extractLeftPattern :: Either Axiom (ReachabilityRule Variable) -> TermLike Variable + extractLeftPattern :: Either Axiom ReachabilityRule -> TermLike Variable extractLeftPattern = left . either toRulePattern toRulePattern -- | Removes specified node and all its child nodes. @@ -998,7 +998,7 @@ savePartialProof maybeNatural file = do maybeNode = ReplNode . naturalToInt <$> maybeNatural - makeTrusted :: ReachabilityRule Variable -> ReachabilityRule Variable + makeTrusted :: ReachabilityRule -> ReachabilityRule makeTrusted goal@(toRulePattern -> rule) = fromRulePattern goal $ rule @@ -1011,8 +1011,8 @@ savePartialProof maybeNatural file = do removeIfRoot :: ReplNode -> ClaimIndex - -> [ReachabilityRule Variable] - -> [ReachabilityRule Variable] + -> [ReachabilityRule] + -> [ReachabilityRule] removeIfRoot (ReplNode node) (ClaimIndex index) claims | index >= 0 && index < length claims , node == 0 = diff --git a/kore/src/Kore/Repl/State.hs b/kore/src/Kore/Repl/State.hs index 0e64023d8a..c90fbc4dc0 100644 --- a/kore/src/Kore/Repl/State.hs +++ b/kore/src/Kore/Repl/State.hs @@ -157,7 +157,7 @@ import Kore.Syntax.Variable ) -- | Creates a fresh execution graph for the given claim. -emptyExecutionGraph :: ReachabilityRule Variable -> ExecutionGraph Axiom +emptyExecutionGraph :: ReachabilityRule -> ExecutionGraph Axiom emptyExecutionGraph = Strategy.emptyExecutionGraph . extractConfig . RewriteRule . toRulePattern where @@ -182,7 +182,7 @@ getClaimByIndex :: MonadState ReplState m => Int -- ^ index in the claims list - -> m (Maybe (ReachabilityRule Variable)) + -> m (Maybe ReachabilityRule) getClaimByIndex index = Lens.preuse $ field @"claims" . Lens.element index -- | Get nth axiom from the axioms list. @@ -208,7 +208,7 @@ getClaimByName :: MonadState ReplState m => String -- ^ label attribute - -> m (Maybe (ReachabilityRule Variable)) + -> m (Maybe ReachabilityRule) getClaimByName name = do claims <- Lens.use (field @"claims") return $ find (isNameEqual name) claims @@ -225,7 +225,7 @@ getClaimIndexByName name= do getAxiomOrClaimByName :: MonadState ReplState m => RuleName - -> m (Maybe (Either Axiom (ReachabilityRule Variable))) + -> m (Maybe (Either Axiom ReachabilityRule)) getAxiomOrClaimByName (RuleName name) = do mAxiom <- getAxiomByName name case mAxiom of @@ -260,7 +260,7 @@ getNameText = from getAxiomOrClaimByIndex :: MonadState ReplState m => Either AxiomIndex ClaimIndex - -> m (Maybe (Either Axiom (ReachabilityRule Variable))) + -> m (Maybe (Either Axiom ReachabilityRule)) getAxiomOrClaimByIndex = fmap bisequence . bitraverse @@ -275,7 +275,7 @@ getInternalIdentifier = from -- | Update the currently selected claim to prove. switchToProof :: MonadState ReplState m - => ReachabilityRule Variable -> ClaimIndex -> m () + => ReachabilityRule -> ClaimIndex -> m () switchToProof claim cindex = modify (\st -> st { claim = claim @@ -497,7 +497,7 @@ runStepper' => Monad.Trans.MonadTrans t => MonadSimplify m => MonadIO m - => [ReachabilityRule Variable] + => [ReachabilityRule] -> [Axiom] -> ReplNode -> t m (ExecutionGraph Axiom, StepResult) @@ -666,7 +666,7 @@ conjOfClaims claims sort = generateInProgressClaims :: forall m . MonadState ReplState m - => m [ReachabilityRule Variable] + => m [ReachabilityRule] generateInProgressClaims = do graphs <- Lens.use (field @"graphs") claims <- Lens.use (field @"claims") @@ -676,16 +676,16 @@ generateInProgressClaims = do where startedClaims :: Map.Map ClaimIndex (ExecutionGraph Axiom) - -> [ReachabilityRule Variable] - -> [ReachabilityRule Variable] + -> [ReachabilityRule] + -> [ReachabilityRule] startedClaims graphs claims = fmap (uncurry createClaim) $ claimsWithPatterns graphs claims >>= sequence notStartedClaims :: Map.Map ClaimIndex (ExecutionGraph Axiom) - -> [ReachabilityRule Variable] - -> [ReachabilityRule Variable] + -> [ReachabilityRule] + -> [ReachabilityRule] notStartedClaims graphs claims = filter (not . Goal.isTrusted) ( (claims !!) diff --git a/kore/src/Kore/Step/Rule/Expand.hs b/kore/src/Kore/Step/Rule/Expand.hs index 9f71fe545b..91db74a691 100644 --- a/kore/src/Kore/Step/Rule/Expand.hs +++ b/kore/src/Kore/Step/Rule/Expand.hs @@ -143,7 +143,7 @@ instance ExpandSingleConstructors (AllPathRule Variable) where expandSingleConstructors tools = AllPathRule . expandSingleConstructors tools . getAllPathRule -instance ExpandSingleConstructors (ReachabilityRule Variable) where +instance ExpandSingleConstructors ReachabilityRule where expandSingleConstructors tools (OnePath rule) = OnePath . OnePathRule diff --git a/kore/src/Kore/Step/Rule/Simplify.hs b/kore/src/Kore/Step/Rule/Simplify.hs index efaf59b3cd..def600252f 100644 --- a/kore/src/Kore/Step/Rule/Simplify.hs +++ b/kore/src/Kore/Step/Rule/Simplify.hs @@ -116,7 +116,7 @@ instance SimplifyRuleLHS (AllPathRule Variable) where simplifyRuleLhs = fmap (fmap AllPathRule) . simplifyClaimRule . getAllPathRule -instance SimplifyRuleLHS (ReachabilityRule Variable) where +instance SimplifyRuleLHS ReachabilityRule where simplifyRuleLhs (OnePath rule) = (fmap . fmap) OnePath $ simplifyRuleLhs rule simplifyRuleLhs (AllPath rule) = diff --git a/kore/src/Kore/Step/RulePattern.hs b/kore/src/Kore/Step/RulePattern.hs index ee89f9ea58..ed9039a69f 100644 --- a/kore/src/Kore/Step/RulePattern.hs +++ b/kore/src/Kore/Step/RulePattern.hs @@ -576,50 +576,50 @@ instance From (OnePathRule variable) Attribute.RuleIndex where {- | Unified One-Path and All-Path Claim rule pattern. -} -data ReachabilityRule variable - = OnePath !(OnePathRule variable) - | AllPath !(AllPathRule variable) +data ReachabilityRule + = OnePath !(OnePathRule Variable) + | AllPath !(AllPathRule Variable) deriving (Eq, GHC.Generic, Ord, Show) -instance NFData variable => NFData (ReachabilityRule variable) +instance NFData ReachabilityRule -instance SOP.Generic (ReachabilityRule variable) +instance SOP.Generic ReachabilityRule -instance SOP.HasDatatypeInfo (ReachabilityRule variable) +instance SOP.HasDatatypeInfo ReachabilityRule -instance Debug variable => Debug (ReachabilityRule variable) +instance Debug ReachabilityRule -instance (Debug variable, Diff variable) => Diff (ReachabilityRule variable) +instance Diff ReachabilityRule -instance InternalVariable variable => Unparse (ReachabilityRule variable) where +instance Unparse ReachabilityRule where unparse (OnePath rule) = unparse rule unparse (AllPath rule) = unparse rule unparse2 (AllPath rule) = unparse2 rule unparse2 (OnePath rule) = unparse2 rule -instance TopBottom (ReachabilityRule variable) where +instance TopBottom ReachabilityRule where isTop _ = False isBottom _ = False -instance Pretty (ReachabilityRule Variable) where +instance Pretty ReachabilityRule where pretty (OnePath (OnePathRule rule)) = Pretty.vsep ["One-Path reachability rule:", Pretty.pretty rule] pretty (AllPath (AllPathRule rule)) = Pretty.vsep ["All-Path reachability rule:", Pretty.pretty rule] -instance From (ReachabilityRule variable) Attribute.SourceLocation where +instance From ReachabilityRule Attribute.SourceLocation where from (OnePath onePathRule) = from onePathRule from (AllPath allPathRule) = from allPathRule -instance From (ReachabilityRule variable) Attribute.Label where +instance From ReachabilityRule Attribute.Label where from (OnePath onePathRule) = from onePathRule from (AllPath allPathRule) = from allPathRule -instance From (ReachabilityRule variable) Attribute.RuleIndex where +instance From ReachabilityRule Attribute.RuleIndex where from (OnePath onePathRule) = from onePathRule from (AllPath allPathRule) = from allPathRule -toSentence :: ReachabilityRule Variable -> Verified.Sentence +toSentence :: ReachabilityRule -> Verified.Sentence toSentence rule = Syntax.SentenceClaimSentence $ Syntax.SentenceClaim Syntax.SentenceAxiom { sentenceAxiomParameters = [] @@ -682,7 +682,7 @@ instance ToRulePattern (AllPathRule Variable) instance ToRulePattern (ImplicationRule Variable) -instance ToRulePattern (ReachabilityRule Variable) where +instance ToRulePattern ReachabilityRule where toRulePattern (OnePath rule) = toRulePattern rule toRulePattern (AllPath rule) = toRulePattern rule @@ -692,7 +692,7 @@ instance FromRulePattern (AllPathRule Variable) instance FromRulePattern (ImplicationRule Variable) -instance FromRulePattern (ReachabilityRule Variable) where +instance FromRulePattern ReachabilityRule where fromRulePattern (OnePath _) rulePat = OnePath $ coerce rulePat fromRulePattern (AllPath _) rulePat = @@ -739,10 +739,7 @@ instance where from = allPathRuleToTerm -instance - InternalVariable variable - => From (ReachabilityRule variable) (TermLike variable) - where +instance From ReachabilityRule (TermLike Variable) where from (OnePath claim) = from claim from (AllPath claim) = from claim diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 19d00ab58f..f65b3170a0 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -381,12 +381,12 @@ instance ClaimExtractor (AllPathRule Variable) where Right (AllPathClaimPattern claim) -> Just (attrs, claim) _ -> Nothing -instance Goal (ReachabilityRule Variable) where +instance Goal ReachabilityRule where - type Prim (ReachabilityRule Variable) = - ProofState.Prim (Rule (ReachabilityRule Variable)) + type Prim ReachabilityRule = + ProofState.Prim (Rule ReachabilityRule) - type ProofState (ReachabilityRule Variable) a = + type ProofState ReachabilityRule a = ProofState.ProofState a goalToRule (OnePath rule) = coerce rule @@ -397,16 +397,16 @@ instance Goal (ReachabilityRule Variable) where transitionRule :: (MonadCatch m, MonadSimplify m) - => Prim (ReachabilityRule Variable) + => Prim ReachabilityRule -> ProofState - (ReachabilityRule Variable) - (ReachabilityRule Variable) + ReachabilityRule + ReachabilityRule -> Strategy.TransitionT - (Rule (ReachabilityRule Variable)) + (Rule ReachabilityRule) m ( ProofState - (ReachabilityRule Variable) - (ReachabilityRule Variable) + ReachabilityRule + ReachabilityRule ) transitionRule = logTransitionRule $ \prim proofstate -> case proofstate of @@ -450,10 +450,10 @@ instance Goal (ReachabilityRule Variable) where _ -> return proofstate strategy - :: ReachabilityRule Variable - -> [ReachabilityRule Variable] - -> [Rule (ReachabilityRule Variable)] - -> Stream (Strategy (Prim (ReachabilityRule Variable))) + :: ReachabilityRule + -> [ReachabilityRule] + -> [Rule ReachabilityRule] + -> Stream (Strategy (Prim ReachabilityRule)) strategy goal claims axioms = case goal of OnePath rule -> @@ -469,25 +469,25 @@ instance Goal (ReachabilityRule Variable) where (mapMaybe maybeAllPath claims) (fmap ruleReachabilityToRuleAllPath axioms) -instance ClaimExtractor (ReachabilityRule Variable) where +instance ClaimExtractor ReachabilityRule where extractClaim (attrs, sentence) = case fromSentenceAxiom (attrs, Syntax.getSentenceClaim sentence) of Right (OnePathClaimPattern claim) -> Just (attrs, OnePath claim) Right (AllPathClaimPattern claim) -> Just (attrs, AllPath claim) _ -> Nothing -maybeOnePath :: ReachabilityRule Variable -> Maybe (OnePathRule Variable) +maybeOnePath :: ReachabilityRule -> Maybe (OnePathRule Variable) maybeOnePath (OnePath rule) = Just rule maybeOnePath _ = Nothing -maybeAllPath :: ReachabilityRule Variable -> Maybe (AllPathRule Variable) +maybeAllPath :: ReachabilityRule -> Maybe (AllPathRule Variable) maybeAllPath (AllPath rule) = Just rule maybeAllPath _ = Nothing reachabilityOnePathStrategy :: Functor t => t (Strategy (Prim (OnePathRule Variable))) - -> t (Strategy (Prim (ReachabilityRule Variable))) + -> t (Strategy (Prim ReachabilityRule)) reachabilityOnePathStrategy strategy' = (fmap . fmap . fmap) ruleOnePathToRuleReachability @@ -496,7 +496,7 @@ reachabilityOnePathStrategy strategy' = reachabilityAllPathStrategy :: Functor t => t (Strategy (Prim (AllPathRule Variable))) - -> t (Strategy (Prim (ReachabilityRule Variable))) + -> t (Strategy (Prim ReachabilityRule)) reachabilityAllPathStrategy strategy' = (fmap . fmap . fmap) ruleAllPathToRuleReachability @@ -504,21 +504,21 @@ reachabilityAllPathStrategy strategy' = allPathProofState :: ProofState (AllPathRule Variable) (AllPathRule Variable) - -> ProofState (ReachabilityRule Variable) (ReachabilityRule Variable) + -> ProofState ReachabilityRule ReachabilityRule allPathProofState = fmap AllPath onePathProofState :: ProofState (OnePathRule Variable) (OnePathRule Variable) - -> ProofState (ReachabilityRule Variable) (ReachabilityRule Variable) + -> ProofState ReachabilityRule ReachabilityRule onePathProofState = fmap OnePath primRuleOnePath - :: ProofState.Prim (Rule (ReachabilityRule Variable)) + :: ProofState.Prim (Rule ReachabilityRule) -> ProofState.Prim (Rule (OnePathRule Variable)) primRuleOnePath = fmap ruleReachabilityToRuleOnePath primRuleAllPath - :: ProofState.Prim (Rule (ReachabilityRule Variable)) + :: ProofState.Prim (Rule ReachabilityRule) -> ProofState.Prim (Rule (AllPathRule Variable)) primRuleAllPath = fmap ruleReachabilityToRuleAllPath @@ -526,23 +526,23 @@ primRuleAllPath = fmap ruleReachabilityToRuleAllPath -- the newtypes over 'RewriteRule Variable' defined in the -- instances of 'Goal' as 'Rule's. ruleReachabilityToRuleAllPath - :: Rule (ReachabilityRule Variable) + :: Rule ReachabilityRule -> Rule (AllPathRule Variable) ruleReachabilityToRuleAllPath = coerce ruleReachabilityToRuleOnePath - :: Rule (ReachabilityRule Variable) + :: Rule ReachabilityRule -> Rule (OnePathRule Variable) ruleReachabilityToRuleOnePath = coerce ruleAllPathToRuleReachability :: Rule (AllPathRule Variable) - -> Rule (ReachabilityRule Variable) + -> Rule ReachabilityRule ruleAllPathToRuleReachability = coerce ruleOnePathToRuleReachability :: Rule (OnePathRule Variable) - -> Rule (ReachabilityRule Variable) + -> Rule ReachabilityRule ruleOnePathToRuleReachability = coerce data TransitionRuleTemplate monad goal = @@ -567,7 +567,7 @@ data TransitionRuleTemplate monad goal = logTransitionRule :: forall m goal . MonadSimplify m - => goal ~ ReachabilityRule Variable + => goal ~ ReachabilityRule => ( Prim goal -> ProofState goal goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) @@ -1093,7 +1093,7 @@ configurationDestinationToRule ruleType configuration rhs = } class ToReachabilityRule rule where - toReachabilityRule :: rule -> ReachabilityRule Variable + toReachabilityRule :: rule -> ReachabilityRule instance ToReachabilityRule (OnePathRule Variable) where toReachabilityRule = OnePath @@ -1101,7 +1101,7 @@ instance ToReachabilityRule (OnePathRule Variable) where instance ToReachabilityRule (AllPathRule Variable) where toReachabilityRule = AllPath -instance ToReachabilityRule (ReachabilityRule Variable) where +instance ToReachabilityRule ReachabilityRule where toReachabilityRule = id debugProofStateBracket diff --git a/kore/src/Kore/Strategies/Rule.hs b/kore/src/Kore/Strategies/Rule.hs index bf4f0c2187..b8e092a486 100644 --- a/kore/src/Kore/Strategies/Rule.hs +++ b/kore/src/Kore/Strategies/Rule.hs @@ -91,31 +91,31 @@ instance HasPriority (Rule (AllPathRule Variable)) where -- * Reachability -newtype instance Rule (ReachabilityRule Variable) = +newtype instance Rule ReachabilityRule = ReachabilityRewriteRule { unReachabilityRewriteRule :: RewriteRule Variable } deriving (GHC.Generic, Show, Unparse) -instance SOP.Generic (Rule (ReachabilityRule Variable)) +instance SOP.Generic (Rule ReachabilityRule) -instance SOP.HasDatatypeInfo (Rule (ReachabilityRule Variable)) +instance SOP.HasDatatypeInfo (Rule ReachabilityRule) -instance Debug (Rule (ReachabilityRule Variable)) +instance Debug (Rule ReachabilityRule) -instance Diff (Rule (ReachabilityRule Variable)) +instance Diff (Rule ReachabilityRule) -instance ToRulePattern (Rule (ReachabilityRule Variable)) +instance ToRulePattern (Rule ReachabilityRule) -instance FromRulePattern (Rule (ReachabilityRule Variable)) +instance FromRulePattern (Rule ReachabilityRule) -instance HasPriority (Rule (ReachabilityRule Variable)) where +instance HasPriority (Rule ReachabilityRule) where getPriority = getPriority . unReachabilityRewriteRule -instance From (Rule (ReachabilityRule Variable)) Attribute.SourceLocation where +instance From (Rule ReachabilityRule) Attribute.SourceLocation where from = from @(RewriteRule Variable) . unReachabilityRewriteRule -instance From (Rule (ReachabilityRule Variable)) Attribute.Label where +instance From (Rule ReachabilityRule) Attribute.Label where from = from @(RewriteRule Variable) . unReachabilityRewriteRule -instance From (Rule (ReachabilityRule Variable)) Attribute.RuleIndex where +instance From (Rule ReachabilityRule) Attribute.RuleIndex where from = from @(RewriteRule Variable) . unReachabilityRewriteRule diff --git a/kore/test/Test/Kore/Strategies/OnePath/Step.hs b/kore/test/Test/Kore/Strategies/OnePath/Step.hs index 8b4cdf6313..272efc095a 100644 --- a/kore/test/Test/Kore/Strategies/OnePath/Step.hs +++ b/kore/test/Test/Kore/Strategies/OnePath/Step.hs @@ -142,7 +142,7 @@ makeOnePathRuleFromPatternsWithCond makeReachabilityOnePathRule :: TermLike Variable -> TermLike Variable - -> ReachabilityRule Variable + -> ReachabilityRule makeReachabilityOnePathRule term dest = OnePath (makeOnePathRule term dest) @@ -815,7 +815,7 @@ simpleRewrite left right = simpleReachabilityRewrite :: TermLike Variable -> TermLike Variable - -> Rule (ReachabilityRule Variable) + -> Rule ReachabilityRule simpleReachabilityRewrite left right = coerce (simpleRewrite left right) @@ -838,7 +838,7 @@ rewriteReachabilityWithPredicate :: TermLike Variable -> TermLike Variable -> Predicate Variable - -> Rule (ReachabilityRule Variable) + -> Rule ReachabilityRule rewriteReachabilityWithPredicate left right predicate = coerce (rewriteWithPredicate left right predicate) @@ -903,10 +903,9 @@ runOnePathSteps return (sort $ nub result) assertStuck - :: (Debug variable, Diff variable) - => OnePathRule variable - -> [ProofState.ProofState (OnePathRule variable)] - -> [ProofState.ProofState (ReachabilityRule variable)] + :: OnePathRule Variable + -> [ProofState.ProofState (OnePathRule Variable)] + -> [ProofState.ProofState ReachabilityRule] -> IO () assertStuck expectedGoal actual actualReach = do assertEqual "as one-path claim" [ ProofState.GoalStuck expectedGoal ] actual diff --git a/kore/test/Test/Kore/Strategies/Reachability/Verification.hs b/kore/test/Test/Kore/Strategies/Reachability/Verification.hs index b839bef5a6..a72dbe1a30 100644 --- a/kore/test/Test/Kore/Strategies/Reachability/Verification.hs +++ b/kore/test/Test/Kore/Strategies/Reachability/Verification.hs @@ -1112,14 +1112,14 @@ test_reachabilityVerification = simpleAxiom :: TermLike Variable -> TermLike Variable - -> Rule (ReachabilityRule Variable) + -> Rule ReachabilityRule simpleAxiom left right = ReachabilityRewriteRule $ simpleRewrite left right simpleOnePathClaim :: TermLike Variable -> TermLike Variable - -> ReachabilityRule Variable + -> ReachabilityRule simpleOnePathClaim left right = OnePath . OnePathRule $ RulePattern @@ -1133,7 +1133,7 @@ simpleOnePathClaim left right = simpleAllPathClaim :: TermLike Variable -> TermLike Variable - -> ReachabilityRule Variable + -> ReachabilityRule simpleAllPathClaim left right = AllPath . AllPathRule $ RulePattern @@ -1147,7 +1147,7 @@ simpleAllPathClaim left right = simpleOnePathTrustedClaim :: TermLike Variable -> TermLike Variable - -> ReachabilityRule Variable + -> ReachabilityRule simpleOnePathTrustedClaim left right = OnePath . OnePathRule @@ -1163,7 +1163,7 @@ simpleOnePathTrustedClaim left right = simpleAllPathTrustedClaim :: TermLike Variable -> TermLike Variable - -> ReachabilityRule Variable + -> ReachabilityRule simpleAllPathTrustedClaim left right = AllPath . AllPathRule From a3601bac9ecde7079f59c588db19e273d6507571 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 15:02:18 -0500 Subject: [PATCH 15/79] OnePathRule: Remove type parameter --- kore/src/Kore/Step/Rule.hs | 16 ++++---- kore/src/Kore/Step/Rule/Expand.hs | 2 +- kore/src/Kore/Step/Rule/Simplify.hs | 2 +- kore/src/Kore/Step/RulePattern.hs | 40 ++++++++----------- kore/src/Kore/Strategies/Goal.hs | 24 +++++------ kore/src/Kore/Strategies/Rule.hs | 16 ++++---- kore/test/Test/Kore/Step/Rule/Expand.hs | 2 +- kore/test/Test/Kore/Step/Rule/Simplify.hs | 6 +-- .../test/Test/Kore/Strategies/OnePath/Step.hs | 14 +++---- .../Kore/Strategies/OnePath/Verification.hs | 8 ++-- 10 files changed, 61 insertions(+), 69 deletions(-) diff --git a/kore/src/Kore/Step/Rule.hs b/kore/src/Kore/Step/Rule.hs index 01f832dd82..fb4eabc6e0 100644 --- a/kore/src/Kore/Step/Rule.hs +++ b/kore/src/Kore/Step/Rule.hs @@ -101,7 +101,7 @@ instance NFData AxiomPatternError qualifiedAxiomOpToConstructor :: Alias (TermLike.TermLike Variable) - -> Maybe (RulePattern variable -> QualifiedAxiomPattern variable) + -> Maybe (RulePattern Variable -> QualifiedAxiomPattern Variable) qualifiedAxiomOpToConstructor patternHead | headName == weakExistsFinally = Just $ OnePathClaimPattern . OnePathRule | headName == weakAlwaysFinally = Just $ AllPathClaimPattern . AllPathRule @@ -114,7 +114,7 @@ from function axioms (used for functional simplification). --} data QualifiedAxiomPattern variable = RewriteAxiomPattern (RewriteRule variable) - | OnePathClaimPattern (OnePathRule variable) + | OnePathClaimPattern OnePathRule | AllPathClaimPattern (AllPathRule variable) | ImplicationAxiomPattern (ImplicationRule variable) deriving (Eq, GHC.Generic, Ord, Show) @@ -285,10 +285,9 @@ complexRewriteTermToRule attributes pat = not encode a normal rewrite or function axiom. -} termToAxiomPattern - :: InternalVariable variable - => Attribute.Axiom Internal.Symbol.Symbol variable - -> TermLike.TermLike variable - -> Either (Error AxiomPatternError) (QualifiedAxiomPattern variable) + :: Attribute.Axiom Internal.Symbol.Symbol Variable + -> TermLike.TermLike Variable + -> Either (Error AxiomPatternError) (QualifiedAxiomPattern Variable) termToAxiomPattern attributes pat = case pat of -- Reachability claims @@ -338,9 +337,8 @@ termToAxiomPattern attributes pat = -} axiomPatternToTerm - :: InternalVariable variable - => QualifiedAxiomPattern variable - -> TermLike.TermLike variable + :: QualifiedAxiomPattern Variable + -> TermLike.TermLike Variable axiomPatternToTerm = \case RewriteAxiomPattern rule -> rewriteRuleToTerm rule OnePathClaimPattern rule -> onePathRuleToTerm rule diff --git a/kore/src/Kore/Step/Rule/Expand.hs b/kore/src/Kore/Step/Rule/Expand.hs index 91db74a691..50197a1987 100644 --- a/kore/src/Kore/Step/Rule/Expand.hs +++ b/kore/src/Kore/Step/Rule/Expand.hs @@ -135,7 +135,7 @@ instance ExpandSingleConstructors (RulePattern Variable) where } } -instance ExpandSingleConstructors (OnePathRule Variable) where +instance ExpandSingleConstructors OnePathRule where expandSingleConstructors tools = OnePathRule . expandSingleConstructors tools . getOnePathRule diff --git a/kore/src/Kore/Step/Rule/Simplify.hs b/kore/src/Kore/Step/Rule/Simplify.hs index def600252f..eb29d74ab4 100644 --- a/kore/src/Kore/Step/Rule/Simplify.hs +++ b/kore/src/Kore/Step/Rule/Simplify.hs @@ -108,7 +108,7 @@ instance SimplifyRuleLHS (RewriteRule Variable) where simplifyRuleLhs = fmap (fmap RewriteRule) . simplifyRuleLhs . getRewriteRule -instance SimplifyRuleLHS (OnePathRule Variable) where +instance SimplifyRuleLHS OnePathRule where simplifyRuleLhs = fmap (fmap OnePathRule) . simplifyClaimRule . getOnePathRule diff --git a/kore/src/Kore/Step/RulePattern.hs b/kore/src/Kore/Step/RulePattern.hs index ed9039a69f..61e5eed037 100644 --- a/kore/src/Kore/Step/RulePattern.hs +++ b/kore/src/Kore/Step/RulePattern.hs @@ -532,21 +532,21 @@ instance {- | One-Path-Claim rule pattern. -} -newtype OnePathRule variable = - OnePathRule { getOnePathRule :: RulePattern variable } +newtype OnePathRule = + OnePathRule { getOnePathRule :: RulePattern Variable } deriving (Eq, GHC.Generic, Ord, Show) -instance NFData variable => NFData (OnePathRule variable) +instance NFData OnePathRule -instance SOP.Generic (OnePathRule variable) +instance SOP.Generic OnePathRule -instance SOP.HasDatatypeInfo (OnePathRule variable) +instance SOP.HasDatatypeInfo OnePathRule -instance Debug variable => Debug (OnePathRule variable) +instance Debug OnePathRule -instance (Debug variable, Diff variable) => Diff (OnePathRule variable) +instance Diff OnePathRule -instance InternalVariable variable => Unparse (OnePathRule variable) where +instance Unparse OnePathRule where unparse claimPattern = "claim {}" <> Pretty.line' @@ -561,23 +561,23 @@ instance InternalVariable variable => Unparse (OnePathRule variable) where unparse2 (onePathRuleToTerm claimPattern) Pretty.<+> "[]" -instance TopBottom (OnePathRule variable) where +instance TopBottom OnePathRule where isTop _ = False isBottom _ = False -instance From (OnePathRule variable) Attribute.SourceLocation where +instance From OnePathRule Attribute.SourceLocation where from = Attribute.sourceLocation . attributes . getOnePathRule -instance From (OnePathRule variable) Attribute.Label where +instance From OnePathRule Attribute.Label where from = Attribute.label . attributes . getOnePathRule -instance From (OnePathRule variable) Attribute.RuleIndex where +instance From OnePathRule Attribute.RuleIndex where from = Attribute.identifier . attributes . getOnePathRule {- | Unified One-Path and All-Path Claim rule pattern. -} data ReachabilityRule - = OnePath !(OnePathRule Variable) + = OnePath !OnePathRule | AllPath !(AllPathRule Variable) deriving (Eq, GHC.Generic, Ord, Show) @@ -676,7 +676,7 @@ instance From (AllPathRule variable) Attribute.RuleIndex where instance ToRulePattern (RewriteRule Variable) -instance ToRulePattern (OnePathRule Variable) +instance ToRulePattern OnePathRule instance ToRulePattern (AllPathRule Variable) @@ -686,7 +686,7 @@ instance ToRulePattern ReachabilityRule where toRulePattern (OnePath rule) = toRulePattern rule toRulePattern (AllPath rule) = toRulePattern rule -instance FromRulePattern (OnePathRule Variable) +instance FromRulePattern OnePathRule instance FromRulePattern (AllPathRule Variable) @@ -727,10 +727,7 @@ rewriteRuleToTerm (TermLike.mkAnd (Predicate.unwrapPredicate requires) left) (rhsToTerm rhs) -instance - InternalVariable variable - => From (OnePathRule variable) (TermLike variable) - where +instance From OnePathRule (TermLike Variable) where from = onePathRuleToTerm instance @@ -744,10 +741,7 @@ instance From ReachabilityRule (TermLike Variable) where from (AllPath claim) = from claim -- | Converts a 'OnePathRule' into its term representation -onePathRuleToTerm - :: InternalVariable variable - => OnePathRule variable - -> TermLike.TermLike variable +onePathRuleToTerm :: OnePathRule -> TermLike.TermLike Variable onePathRuleToTerm (OnePathRule (RulePattern left _ requires rhs _)) = mkImpliesRule left requires (Just wEF) rhs diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index f65b3170a0..72bbfe40f0 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -289,12 +289,12 @@ Things to note when implementing your own: 2. You can return an infinite list. -} -instance Goal (OnePathRule Variable) where +instance Goal OnePathRule where - type Prim (OnePathRule Variable) = - ProofState.Prim (Rule (OnePathRule Variable)) + type Prim OnePathRule = + ProofState.Prim (Rule OnePathRule) - type ProofState (OnePathRule Variable) a = + type ProofState OnePathRule a = ProofState.ProofState a transitionRule = @@ -329,7 +329,7 @@ instance Goal (OnePathRule Variable) where . getOnePathRule <$> goals -instance ClaimExtractor (OnePathRule Variable) where +instance ClaimExtractor OnePathRule where extractClaim (attrs, sentence) = case fromSentenceAxiom (attrs, Syntax.getSentenceClaim sentence) of Right (OnePathClaimPattern claim) -> Just (attrs, claim) @@ -476,7 +476,7 @@ instance ClaimExtractor ReachabilityRule where Right (AllPathClaimPattern claim) -> Just (attrs, AllPath claim) _ -> Nothing -maybeOnePath :: ReachabilityRule -> Maybe (OnePathRule Variable) +maybeOnePath :: ReachabilityRule -> Maybe OnePathRule maybeOnePath (OnePath rule) = Just rule maybeOnePath _ = Nothing @@ -486,7 +486,7 @@ maybeAllPath _ = Nothing reachabilityOnePathStrategy :: Functor t - => t (Strategy (Prim (OnePathRule Variable))) + => t (Strategy (Prim OnePathRule)) -> t (Strategy (Prim ReachabilityRule)) reachabilityOnePathStrategy strategy' = (fmap . fmap . fmap) @@ -508,13 +508,13 @@ allPathProofState allPathProofState = fmap AllPath onePathProofState - :: ProofState (OnePathRule Variable) (OnePathRule Variable) + :: ProofState OnePathRule OnePathRule -> ProofState ReachabilityRule ReachabilityRule onePathProofState = fmap OnePath primRuleOnePath :: ProofState.Prim (Rule ReachabilityRule) - -> ProofState.Prim (Rule (OnePathRule Variable)) + -> ProofState.Prim (Rule OnePathRule) primRuleOnePath = fmap ruleReachabilityToRuleOnePath primRuleAllPath @@ -532,7 +532,7 @@ ruleReachabilityToRuleAllPath = coerce ruleReachabilityToRuleOnePath :: Rule ReachabilityRule - -> Rule (OnePathRule Variable) + -> Rule OnePathRule ruleReachabilityToRuleOnePath = coerce ruleAllPathToRuleReachability @@ -541,7 +541,7 @@ ruleAllPathToRuleReachability ruleAllPathToRuleReachability = coerce ruleOnePathToRuleReachability - :: Rule (OnePathRule Variable) + :: Rule OnePathRule -> Rule ReachabilityRule ruleOnePathToRuleReachability = coerce @@ -1095,7 +1095,7 @@ configurationDestinationToRule ruleType configuration rhs = class ToReachabilityRule rule where toReachabilityRule :: rule -> ReachabilityRule -instance ToReachabilityRule (OnePathRule Variable) where +instance ToReachabilityRule OnePathRule where toReachabilityRule = OnePath instance ToReachabilityRule (AllPathRule Variable) where diff --git a/kore/src/Kore/Strategies/Rule.hs b/kore/src/Kore/Strategies/Rule.hs index b8e092a486..f2ee119f1c 100644 --- a/kore/src/Kore/Strategies/Rule.hs +++ b/kore/src/Kore/Strategies/Rule.hs @@ -49,23 +49,23 @@ data family Rule goal -- * One-path reachability -newtype instance Rule (OnePathRule Variable) = +newtype instance Rule OnePathRule = OnePathRewriteRule { unRuleOnePath :: RewriteRule Variable } deriving (GHC.Generic, Show, Unparse) -instance SOP.Generic (Rule (OnePathRule Variable)) +instance SOP.Generic (Rule OnePathRule) -instance SOP.HasDatatypeInfo (Rule (OnePathRule Variable)) +instance SOP.HasDatatypeInfo (Rule OnePathRule) -instance Debug (Rule (OnePathRule Variable)) +instance Debug (Rule OnePathRule) -instance Diff (Rule (OnePathRule Variable)) +instance Diff (Rule OnePathRule) -instance ToRulePattern (Rule (OnePathRule Variable)) +instance ToRulePattern (Rule OnePathRule) -instance FromRulePattern (Rule (OnePathRule Variable)) +instance FromRulePattern (Rule OnePathRule) -instance HasPriority (Rule (OnePathRule Variable)) where +instance HasPriority (Rule OnePathRule) where getPriority = getPriority . unRuleOnePath -- * All-path reachability diff --git a/kore/test/Test/Kore/Step/Rule/Expand.hs b/kore/test/Test/Kore/Step/Rule/Expand.hs index c8f4a7cc98..ad9178e02e 100644 --- a/kore/test/Test/Kore/Step/Rule/Expand.hs +++ b/kore/test/Test/Kore/Step/Rule/Expand.hs @@ -73,7 +73,7 @@ import Test.Kore.With import Test.Tasty.HUnit.Ext class OnePathRuleBase base where - rewritesTo :: base Variable -> base Variable -> OnePathRule Variable + rewritesTo :: base Variable -> base Variable -> OnePathRule newtype Pair variable = Pair (TermLike variable, Predicate variable) diff --git a/kore/test/Test/Kore/Step/Rule/Simplify.hs b/kore/test/Test/Kore/Step/Rule/Simplify.hs index 8c19b52fa4..4c2c07bd98 100644 --- a/kore/test/Test/Kore/Step/Rule/Simplify.hs +++ b/kore/test/Test/Kore/Step/Rule/Simplify.hs @@ -76,7 +76,7 @@ import Test.SMT import Test.Tasty.HUnit.Ext class OnePathRuleBase base where - rewritesTo :: base Variable -> base Variable -> OnePathRule Variable + rewritesTo :: base Variable -> base Variable -> OnePathRule newtype Pair variable = Pair (TermLike variable, Predicate variable) @@ -238,8 +238,8 @@ test_simplifyRule = x = mkElemVar Mock.x runSimplifyRule - :: OnePathRule Variable - -> IO [OnePathRule Variable] + :: OnePathRule + -> IO [OnePathRule] runSimplifyRule rule = fmap MultiAnd.extractPatterns $ runNoSMT diff --git a/kore/test/Test/Kore/Strategies/OnePath/Step.hs b/kore/test/Test/Kore/Strategies/OnePath/Step.hs index 272efc095a..94fe930619 100644 --- a/kore/test/Test/Kore/Strategies/OnePath/Step.hs +++ b/kore/test/Test/Kore/Strategies/OnePath/Step.hs @@ -87,14 +87,14 @@ import Test.Tasty.HUnit.Ext makeOnePathRule :: TermLike Variable -> TermLike Variable - -> OnePathRule Variable + -> OnePathRule makeOnePathRule term dest = OnePathRule $ rulePattern term dest makeOnePathRuleFromPatterns :: Pattern Variable -> Pattern Variable - -> OnePathRule Variable + -> OnePathRule makeOnePathRuleFromPatterns configuration destination @@ -118,7 +118,7 @@ makeOnePathRuleFromPatterns makeOnePathRuleFromPatternsWithCond :: Pattern Variable -> Pattern Variable - -> OnePathRule Variable + -> OnePathRule makeOnePathRuleFromPatternsWithCond configuration destination @@ -801,7 +801,7 @@ test_onePathStrategy = simpleRewrite :: TermLike Variable -> TermLike Variable - -> Rule (OnePathRule Variable) + -> Rule OnePathRule simpleRewrite left right = OnePathRewriteRule $ RewriteRule RulePattern @@ -823,7 +823,7 @@ rewriteWithPredicate :: TermLike Variable -> TermLike Variable -> Predicate Variable - -> Rule (OnePathRule Variable) + -> Rule OnePathRule rewriteWithPredicate left right predicate = OnePathRewriteRule $ RewriteRule RulePattern @@ -903,8 +903,8 @@ runOnePathSteps return (sort $ nub result) assertStuck - :: OnePathRule Variable - -> [ProofState.ProofState (OnePathRule Variable)] + :: OnePathRule + -> [ProofState.ProofState OnePathRule] -> [ProofState.ProofState ReachabilityRule] -> IO () assertStuck expectedGoal actual actualReach = do diff --git a/kore/test/Test/Kore/Strategies/OnePath/Verification.hs b/kore/test/Test/Kore/Strategies/OnePath/Verification.hs index 4e5be53464..df2f201a2b 100644 --- a/kore/test/Test/Kore/Strategies/OnePath/Verification.hs +++ b/kore/test/Test/Kore/Strategies/OnePath/Verification.hs @@ -468,14 +468,14 @@ test_onePathVerification = simpleAxiom :: TermLike Variable -> TermLike Variable - -> Rule (OnePathRule Variable) + -> Rule OnePathRule simpleAxiom left right = OnePathRewriteRule $ simpleRewrite left right simpleClaim :: TermLike Variable -> TermLike Variable - -> OnePathRule Variable + -> OnePathRule simpleClaim left right = OnePathRule RulePattern @@ -489,7 +489,7 @@ simpleClaim left right = simpleTrustedClaim :: TermLike Variable -> TermLike Variable - -> OnePathRule Variable + -> OnePathRule simpleTrustedClaim left right = OnePathRule RulePattern @@ -505,7 +505,7 @@ simplePriorityAxiom :: TermLike Variable -> TermLike Variable -> Integer - -> Rule (OnePathRule Variable) + -> Rule OnePathRule simplePriorityAxiom left right priority = OnePathRewriteRule . RewriteRule $ RulePattern From 24be08a38d1c0fb771d3b47d56a33f4013cc703d Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 15:05:40 -0500 Subject: [PATCH 16/79] AllPathRule: Remove type parameter --- kore/src/Kore/Step/Rule.hs | 2 +- kore/src/Kore/Step/Rule/Expand.hs | 2 +- kore/src/Kore/Step/Rule/Simplify.hs | 2 +- kore/src/Kore/Step/RulePattern.hs | 40 ++++++++----------- kore/src/Kore/Strategies/Goal.hs | 38 +++++++++--------- kore/src/Kore/Strategies/Rule.hs | 16 ++++---- .../Kore/Strategies/AllPath/Verification.hs | 8 ++-- 7 files changed, 51 insertions(+), 57 deletions(-) diff --git a/kore/src/Kore/Step/Rule.hs b/kore/src/Kore/Step/Rule.hs index fb4eabc6e0..24b2271fa5 100644 --- a/kore/src/Kore/Step/Rule.hs +++ b/kore/src/Kore/Step/Rule.hs @@ -115,7 +115,7 @@ from function axioms (used for functional simplification). data QualifiedAxiomPattern variable = RewriteAxiomPattern (RewriteRule variable) | OnePathClaimPattern OnePathRule - | AllPathClaimPattern (AllPathRule variable) + | AllPathClaimPattern AllPathRule | ImplicationAxiomPattern (ImplicationRule variable) deriving (Eq, GHC.Generic, Ord, Show) -- TODO(virgil): Rename the above since it applies to all sorts of axioms, diff --git a/kore/src/Kore/Step/Rule/Expand.hs b/kore/src/Kore/Step/Rule/Expand.hs index 50197a1987..0d7b6cced2 100644 --- a/kore/src/Kore/Step/Rule/Expand.hs +++ b/kore/src/Kore/Step/Rule/Expand.hs @@ -139,7 +139,7 @@ instance ExpandSingleConstructors OnePathRule where expandSingleConstructors tools = OnePathRule . expandSingleConstructors tools . getOnePathRule -instance ExpandSingleConstructors (AllPathRule Variable) where +instance ExpandSingleConstructors AllPathRule where expandSingleConstructors tools = AllPathRule . expandSingleConstructors tools . getAllPathRule diff --git a/kore/src/Kore/Step/Rule/Simplify.hs b/kore/src/Kore/Step/Rule/Simplify.hs index eb29d74ab4..5be3576876 100644 --- a/kore/src/Kore/Step/Rule/Simplify.hs +++ b/kore/src/Kore/Step/Rule/Simplify.hs @@ -112,7 +112,7 @@ instance SimplifyRuleLHS OnePathRule where simplifyRuleLhs = fmap (fmap OnePathRule) . simplifyClaimRule . getOnePathRule -instance SimplifyRuleLHS (AllPathRule Variable) where +instance SimplifyRuleLHS AllPathRule where simplifyRuleLhs = fmap (fmap AllPathRule) . simplifyClaimRule . getAllPathRule diff --git a/kore/src/Kore/Step/RulePattern.hs b/kore/src/Kore/Step/RulePattern.hs index 61e5eed037..37cb7c483b 100644 --- a/kore/src/Kore/Step/RulePattern.hs +++ b/kore/src/Kore/Step/RulePattern.hs @@ -578,7 +578,7 @@ instance From OnePathRule Attribute.RuleIndex where -} data ReachabilityRule = OnePath !OnePathRule - | AllPath !(AllPathRule Variable) + | AllPath !AllPathRule deriving (Eq, GHC.Generic, Ord, Show) instance NFData ReachabilityRule @@ -633,21 +633,21 @@ toSentence rule = {- | All-Path-Claim rule pattern. -} -newtype AllPathRule variable = - AllPathRule { getAllPathRule :: RulePattern variable } +newtype AllPathRule = + AllPathRule { getAllPathRule :: RulePattern Variable } deriving (Eq, GHC.Generic, Ord, Show) -instance NFData variable => NFData (AllPathRule variable) +instance NFData AllPathRule -instance SOP.Generic (AllPathRule variable) +instance SOP.Generic AllPathRule -instance SOP.HasDatatypeInfo (AllPathRule variable) +instance SOP.HasDatatypeInfo AllPathRule -instance Debug variable => Debug (AllPathRule variable) +instance Debug AllPathRule -instance (Debug variable, Diff variable) => Diff (AllPathRule variable) +instance Diff AllPathRule -instance InternalVariable variable => Unparse (AllPathRule variable) where +instance Unparse AllPathRule where unparse claimPattern = "claim {}" <> Pretty.line' @@ -661,24 +661,24 @@ instance InternalVariable variable => Unparse (AllPathRule variable) where unparse2 (allPathRuleToTerm claimPattern) Pretty.<+> "[]" -instance TopBottom (AllPathRule variable) where +instance TopBottom AllPathRule where isTop _ = False isBottom _ = False -instance From (AllPathRule variable) Attribute.SourceLocation where +instance From AllPathRule Attribute.SourceLocation where from = Attribute.sourceLocation . attributes . getAllPathRule -instance From (AllPathRule variable) Attribute.Label where +instance From AllPathRule Attribute.Label where from = Attribute.label . attributes . getAllPathRule -instance From (AllPathRule variable) Attribute.RuleIndex where +instance From AllPathRule Attribute.RuleIndex where from = Attribute.identifier . attributes . getAllPathRule instance ToRulePattern (RewriteRule Variable) instance ToRulePattern OnePathRule -instance ToRulePattern (AllPathRule Variable) +instance ToRulePattern AllPathRule instance ToRulePattern (ImplicationRule Variable) @@ -688,7 +688,7 @@ instance ToRulePattern ReachabilityRule where instance FromRulePattern OnePathRule -instance FromRulePattern (AllPathRule Variable) +instance FromRulePattern AllPathRule instance FromRulePattern (ImplicationRule Variable) @@ -730,10 +730,7 @@ rewriteRuleToTerm instance From OnePathRule (TermLike Variable) where from = onePathRuleToTerm -instance - InternalVariable variable - => From (AllPathRule variable) (TermLike variable) - where +instance From AllPathRule (TermLike Variable) where from = allPathRuleToTerm instance From ReachabilityRule (TermLike Variable) where @@ -779,10 +776,7 @@ mkImpliesRule left requires alias right = rhsTerm = rhsToTerm right -- | Converts an 'AllPathRule' into its term representation -allPathRuleToTerm - :: InternalVariable variable - => AllPathRule variable - -> TermLike.TermLike variable +allPathRuleToTerm :: AllPathRule -> TermLike.TermLike Variable allPathRuleToTerm (AllPathRule (RulePattern left _ requires rhs _)) = mkImpliesRule left requires (Just wAF) rhs diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 72bbfe40f0..f55b0492b5 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -335,12 +335,12 @@ instance ClaimExtractor OnePathRule where Right (OnePathClaimPattern claim) -> Just (attrs, claim) _ -> Nothing -instance Goal (AllPathRule Variable) where +instance Goal AllPathRule where - type Prim (AllPathRule Variable) = - ProofState.Prim (Rule (AllPathRule Variable)) + type Prim AllPathRule = + ProofState.Prim (Rule AllPathRule) - type ProofState (AllPathRule Variable) a = + type ProofState AllPathRule a = ProofState.ProofState a transitionRule = @@ -375,7 +375,7 @@ instance Goal (AllPathRule Variable) where . getAllPathRule <$> goals -instance ClaimExtractor (AllPathRule Variable) where +instance ClaimExtractor AllPathRule where extractClaim (attrs, sentence) = case fromSentenceAxiom (attrs, Syntax.getSentenceClaim sentence) of Right (AllPathClaimPattern claim) -> Just (attrs, claim) @@ -480,7 +480,7 @@ maybeOnePath :: ReachabilityRule -> Maybe OnePathRule maybeOnePath (OnePath rule) = Just rule maybeOnePath _ = Nothing -maybeAllPath :: ReachabilityRule -> Maybe (AllPathRule Variable) +maybeAllPath :: ReachabilityRule -> Maybe AllPathRule maybeAllPath (AllPath rule) = Just rule maybeAllPath _ = Nothing @@ -495,7 +495,7 @@ reachabilityOnePathStrategy strategy' = reachabilityAllPathStrategy :: Functor t - => t (Strategy (Prim (AllPathRule Variable))) + => t (Strategy (Prim AllPathRule)) -> t (Strategy (Prim ReachabilityRule)) reachabilityAllPathStrategy strategy' = (fmap . fmap . fmap) @@ -503,7 +503,7 @@ reachabilityAllPathStrategy strategy' = strategy' allPathProofState - :: ProofState (AllPathRule Variable) (AllPathRule Variable) + :: ProofState AllPathRule AllPathRule -> ProofState ReachabilityRule ReachabilityRule allPathProofState = fmap AllPath @@ -519,7 +519,7 @@ primRuleOnePath = fmap ruleReachabilityToRuleOnePath primRuleAllPath :: ProofState.Prim (Rule ReachabilityRule) - -> ProofState.Prim (Rule (AllPathRule Variable)) + -> ProofState.Prim (Rule AllPathRule) primRuleAllPath = fmap ruleReachabilityToRuleAllPath -- The functions below are easier to read coercions between @@ -527,7 +527,7 @@ primRuleAllPath = fmap ruleReachabilityToRuleAllPath -- instances of 'Goal' as 'Rule's. ruleReachabilityToRuleAllPath :: Rule ReachabilityRule - -> Rule (AllPathRule Variable) + -> Rule AllPathRule ruleReachabilityToRuleAllPath = coerce ruleReachabilityToRuleOnePath @@ -536,7 +536,7 @@ ruleReachabilityToRuleOnePath ruleReachabilityToRuleOnePath = coerce ruleAllPathToRuleReachability - :: Rule (AllPathRule Variable) + :: Rule AllPathRule -> Rule ReachabilityRule ruleAllPathToRuleReachability = coerce @@ -728,8 +728,8 @@ onePathFollowupStep claims axioms = ] groupStrategy - :: [[Rule (AllPathRule Variable)]] - -> [Prim (AllPathRule Variable)] + :: [[Rule AllPathRule]] + -> [Prim AllPathRule] groupStrategy [] = [DerivePar [], Simplify, TriviallyValid] groupStrategy axiomGroups = do @@ -737,8 +737,8 @@ groupStrategy axiomGroups = do [DerivePar group, Simplify, TriviallyValid] allPathFirstStep - :: [[Rule (AllPathRule Variable)]] - -> Strategy (Prim (AllPathRule Variable)) + :: [[Rule AllPathRule]] + -> Strategy (Prim AllPathRule) allPathFirstStep axiomGroups = (Strategy.sequence . map Strategy.apply) $ [ CheckProven @@ -755,9 +755,9 @@ allPathFirstStep axiomGroups = ] allPathFollowupStep - :: [Rule (AllPathRule Variable)] - -> [[Rule (AllPathRule Variable)]] - -> Strategy (Prim (AllPathRule Variable)) + :: [Rule AllPathRule] + -> [[Rule AllPathRule]] + -> Strategy (Prim AllPathRule) allPathFollowupStep claims axiomGroups = (Strategy.sequence . map Strategy.apply) $ [ CheckProven @@ -1098,7 +1098,7 @@ class ToReachabilityRule rule where instance ToReachabilityRule OnePathRule where toReachabilityRule = OnePath -instance ToReachabilityRule (AllPathRule Variable) where +instance ToReachabilityRule AllPathRule where toReachabilityRule = AllPath instance ToReachabilityRule ReachabilityRule where diff --git a/kore/src/Kore/Strategies/Rule.hs b/kore/src/Kore/Strategies/Rule.hs index f2ee119f1c..ed4f871e7f 100644 --- a/kore/src/Kore/Strategies/Rule.hs +++ b/kore/src/Kore/Strategies/Rule.hs @@ -70,23 +70,23 @@ instance HasPriority (Rule OnePathRule) where -- * All-path reachability -newtype instance Rule (AllPathRule Variable) = +newtype instance Rule AllPathRule = AllPathRewriteRule { unRuleAllPath :: RewriteRule Variable } deriving (GHC.Generic, Show, Unparse) -instance SOP.Generic (Rule (AllPathRule Variable)) +instance SOP.Generic (Rule AllPathRule) -instance SOP.HasDatatypeInfo (Rule (AllPathRule Variable)) +instance SOP.HasDatatypeInfo (Rule AllPathRule) -instance Debug (Rule (AllPathRule Variable)) +instance Debug (Rule AllPathRule) -instance Diff (Rule (AllPathRule Variable)) +instance Diff (Rule AllPathRule) -instance ToRulePattern (Rule (AllPathRule Variable)) +instance ToRulePattern (Rule AllPathRule) -instance FromRulePattern (Rule (AllPathRule Variable)) +instance FromRulePattern (Rule AllPathRule) -instance HasPriority (Rule (AllPathRule Variable)) where +instance HasPriority (Rule AllPathRule) where getPriority = getPriority . unRuleAllPath -- * Reachability diff --git a/kore/test/Test/Kore/Strategies/AllPath/Verification.hs b/kore/test/Test/Kore/Strategies/AllPath/Verification.hs index 1224ae3f2e..58636421c1 100644 --- a/kore/test/Test/Kore/Strategies/AllPath/Verification.hs +++ b/kore/test/Test/Kore/Strategies/AllPath/Verification.hs @@ -368,14 +368,14 @@ test_allPathVerification = simpleAxiom :: TermLike Variable -> TermLike Variable - -> Rule (AllPathRule Variable) + -> Rule AllPathRule simpleAxiom left right = AllPathRewriteRule $ simpleRewrite left right simpleClaim :: TermLike Variable -> TermLike Variable - -> AllPathRule Variable + -> AllPathRule simpleClaim left right = AllPathRule RulePattern @@ -389,7 +389,7 @@ simpleClaim left right = simpleTrustedClaim :: TermLike Variable -> TermLike Variable - -> AllPathRule Variable + -> AllPathRule simpleTrustedClaim left right = AllPathRule RulePattern @@ -405,7 +405,7 @@ simplePriorityAxiom :: TermLike Variable -> TermLike Variable -> Integer - -> Rule (AllPathRule Variable) + -> Rule AllPathRule simplePriorityAxiom left right priority = AllPathRewriteRule . RewriteRule $ RulePattern From e98caf8ed6005b8005ce95820317e83541bafdc5 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 16:54:28 -0500 Subject: [PATCH 17/79] Kore.Strategies.Goal: Formatting --- kore/src/Kore/Strategies/Goal.hs | 44 ++++++++++++-------------------- 1 file changed, 16 insertions(+), 28 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index f55b0492b5..f9751823aa 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -298,20 +298,14 @@ instance Goal OnePathRule where ProofState.ProofState a transitionRule = - withDebugProofState - $ transitionRuleTemplate - TransitionRuleTemplate - { simplifyTemplate = - simplify - , removeDestinationTemplate = - removeDestination - , isTriviallyValidTemplate = - isTriviallyValid - , deriveParTemplate = - derivePar - , deriveSeqTemplate = - deriveSeq - } + (withDebugProofState . transitionRuleTemplate) + TransitionRuleTemplate + { simplifyTemplate = simplify + , removeDestinationTemplate = removeDestination + , isTriviallyValidTemplate = isTriviallyValid + , deriveParTemplate = derivePar + , deriveSeqTemplate = deriveSeq + } strategy _ goals rules = onePathFirstStep rewrites @@ -344,20 +338,14 @@ instance Goal AllPathRule where ProofState.ProofState a transitionRule = - withDebugProofState - $ transitionRuleTemplate - TransitionRuleTemplate - { simplifyTemplate = - simplify - , removeDestinationTemplate = - removeDestination - , isTriviallyValidTemplate = - isTriviallyValid - , deriveParTemplate = - derivePar - , deriveSeqTemplate = - deriveSeq - } + (withDebugProofState . transitionRuleTemplate) + TransitionRuleTemplate + { simplifyTemplate = simplify + , removeDestinationTemplate = removeDestination + , isTriviallyValidTemplate = isTriviallyValid + , deriveParTemplate = derivePar + , deriveSeqTemplate = deriveSeq + } strategy _ goals rules = allPathFirstStep priorityGroups From d34fdfc8a771ab0ab91da4024a20ee636e6133c8 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 28 Apr 2020 17:20:36 -0500 Subject: [PATCH 18/79] Kore.Strategies.Goal.ProofState: Require fewer type parameters --- kore/src/Kore/Strategies/Goal.hs | 29 +++++++------------ .../Test/Kore/Strategies/AllPath/AllPath.hs | 2 +- 2 files changed, 11 insertions(+), 20 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index f9751823aa..765be464a1 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -47,6 +47,9 @@ import Data.Coerce ) import qualified Data.Default as Default import qualified Data.Foldable as Foldable +import Data.Kind + ( Type + ) import Data.List.Extra ( groupSortOn , sortOn @@ -200,7 +203,7 @@ proven = Foldable.null . unprovenNodes class Goal goal where type Prim goal - type ProofState goal a + type ProofState goal :: Type -> Type goalToRule :: goal -> Rule goal default goalToRule @@ -290,12 +293,8 @@ Things to note when implementing your own: -} instance Goal OnePathRule where - - type Prim OnePathRule = - ProofState.Prim (Rule OnePathRule) - - type ProofState OnePathRule a = - ProofState.ProofState a + type Prim OnePathRule = ProofState.Prim (Rule OnePathRule) + type ProofState OnePathRule = ProofState.ProofState transitionRule = (withDebugProofState . transitionRuleTemplate) @@ -330,12 +329,8 @@ instance ClaimExtractor OnePathRule where _ -> Nothing instance Goal AllPathRule where - - type Prim AllPathRule = - ProofState.Prim (Rule AllPathRule) - - type ProofState AllPathRule a = - ProofState.ProofState a + type Prim AllPathRule = ProofState.Prim (Rule AllPathRule) + type ProofState AllPathRule = ProofState.ProofState transitionRule = (withDebugProofState . transitionRuleTemplate) @@ -370,12 +365,8 @@ instance ClaimExtractor AllPathRule where _ -> Nothing instance Goal ReachabilityRule where - - type Prim ReachabilityRule = - ProofState.Prim (Rule ReachabilityRule) - - type ProofState ReachabilityRule a = - ProofState.ProofState a + type Prim ReachabilityRule = ProofState.Prim (Rule ReachabilityRule) + type ProofState ReachabilityRule = ProofState.ProofState goalToRule (OnePath rule) = coerce rule goalToRule (AllPath rule) = coerce rule diff --git a/kore/test/Test/Kore/Strategies/AllPath/AllPath.hs b/kore/test/Test/Kore/Strategies/AllPath/AllPath.hs index 292a1d76fa..cfb76d95e3 100644 --- a/kore/test/Test/Kore/Strategies/AllPath/AllPath.hs +++ b/kore/test/Test/Kore/Strategies/AllPath/AllPath.hs @@ -320,7 +320,7 @@ newtype instance Goal.Rule Goal = instance Goal.Goal Goal where type Prim Goal = ProofState.Prim (Goal.Rule Goal) - type ProofState Goal a = ProofState.ProofState a + type ProofState Goal = ProofState.ProofState strategy _ goals rules = firstStep :> Stream.iterate id nextStep From a5ea50da3b166384e3db11dd7b48ff280218aa87 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Wed, 29 Apr 2020 11:02:02 -0500 Subject: [PATCH 19/79] Generalize signature of getPriorityOfAxiom --- kore/src/Kore/Attribute/Axiom.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/kore/src/Kore/Attribute/Axiom.hs b/kore/src/Kore/Attribute/Axiom.hs index 27e938fa39..a5da892360 100644 --- a/kore/src/Kore/Attribute/Axiom.hs +++ b/kore/src/Kore/Attribute/Axiom.hs @@ -205,6 +205,9 @@ instance From symbol SymbolOrAlias => From (Axiom symbol Variable) Attributes wh , from . owise ] +instance From (Axiom symbol variable) (Priority, Owise) where + from Axiom { priority, owise } = (priority, owise) + instance SQL.Column (Axiom SymbolOrAlias Variable) where -- TODO (thomas.tuegel): Use a foreign key. defineColumn tableName _ = @@ -272,11 +275,10 @@ mapAxiomVariables e s axiom@Axiom { concrete, symbolic } = , symbolic = mapSymbolicVariables e s symbolic } -getPriorityOfAxiom :: Axiom symbol variable -> Integer getPriorityOfAxiom - Axiom - { priority = Priority { getPriority } - , owise = Owise { isOwise } - } + :: forall attrs. From attrs (Priority, Owise) => attrs -> Integer +getPriorityOfAxiom attrs | isOwise = owisePriority | otherwise = fromMaybe defaultPriority getPriority + where + (Priority { getPriority }, Owise { isOwise }) = from @attrs attrs From 271dc8adcad467e9e0b2654c89ee62d6abe5c9e9 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Wed, 29 Apr 2020 13:01:47 -0500 Subject: [PATCH 20/79] Kore.Strategies.Goal.removeDestination: Specify signature --- kore/src/Kore/Strategies/Goal.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 765be464a1..155b46b940 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -529,7 +529,7 @@ data TransitionRuleTemplate monad goal = { simplifyTemplate :: goal -> Strategy.TransitionT (Rule goal) monad goal , removeDestinationTemplate - :: (goal -> ProofState goal goal) + :: (forall x. x -> ProofState goal x) -> goal -> Strategy.TransitionT (Rule goal) monad (ProofState goal goal) , isTriviallyValidTemplate :: goal -> Bool @@ -762,7 +762,7 @@ removeDestination => ProofState.ProofState goal ~ ProofState goal goal => ToRulePattern goal => FromRulePattern goal - => (goal -> ProofState goal goal) + => (forall x. x -> ProofState goal x) -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) removeDestination stateConstructor goal = From 33f7dbe23412ffd6edf4aaea167270e8dae22ca5 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Wed, 29 Apr 2020 13:16:28 -0500 Subject: [PATCH 21/79] Kore.Strategies.Goal.removeDestination: Remove ToRulePattern --- kore/src/Kore/Strategies/Goal.hs | 86 ++++++++++++++++++-------------- 1 file changed, 49 insertions(+), 37 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 155b46b940..ada260307d 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -35,6 +35,10 @@ import Control.Error import Control.Exception ( throw ) +import Control.Lens + ( Lens' + ) +import qualified Control.Lens as Lens import Control.Monad.Catch ( Exception (..) , MonadCatch @@ -47,6 +51,13 @@ import Data.Coerce ) import qualified Data.Default as Default import qualified Data.Foldable as Foldable +import Data.Functor.Compose +import Data.Generics.Product + ( field + ) +import Data.Generics.Wrapped + ( _Unwrapped + ) import Data.Kind ( Type ) @@ -300,7 +311,7 @@ instance Goal OnePathRule where (withDebugProofState . transitionRuleTemplate) TransitionRuleTemplate { simplifyTemplate = simplify - , removeDestinationTemplate = removeDestination + , removeDestinationTemplate = removeDestination _Unwrapped , isTriviallyValidTemplate = isTriviallyValid , deriveParTemplate = derivePar , deriveSeqTemplate = deriveSeq @@ -336,7 +347,7 @@ instance Goal AllPathRule where (withDebugProofState . transitionRuleTemplate) TransitionRuleTemplate { simplifyTemplate = simplify - , removeDestinationTemplate = removeDestination + , removeDestinationTemplate = removeDestination _Unwrapped , isTriviallyValidTemplate = isTriviallyValid , deriveParTemplate = derivePar , deriveSeqTemplate = deriveSeq @@ -757,46 +768,43 @@ allPathFollowupStep claims axiomGroups = -- | Remove the destination of the goal. removeDestination - :: MonadSimplify m + :: forall goal m + . MonadSimplify m => MonadCatch m => ProofState.ProofState goal ~ ProofState goal goal - => ToRulePattern goal - => FromRulePattern goal - => (forall x. x -> ProofState goal x) + => Lens' goal (RulePattern Variable) + -> (forall x. x -> ProofState goal x) -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) -removeDestination stateConstructor goal = - withConfiguration goal $ lift $ do - removal <- removalPredicate destination configuration - if isTop removal - then return . stateConstructor $ goal - else do - simplifiedRemoval <- - SMT.Evaluator.filterMultiOr - =<< simplifyTopConfiguration - (Conditional.andPredicate configuration removal) - if not (isBottom simplifiedRemoval) - then - let stuckConfiguration = OrPattern.toPattern simplifiedRemoval - (left, requiresCondition) = Conditional.splitTerm stuckConfiguration - in return . GoalStuck $ stuckGoal left requiresCondition - else return Proven +removeDestination lensRulePattern mkState goal = + Lens.traverseOf lensRulePattern removeDestinationWorker goal + & getCompose + & lift where - configuration = getConfiguration goal - configFreeVars = freeVariables configuration - - RulePattern { rhs } = toRulePattern goal - - destination = topExistsToImplicitForall configFreeVars rhs - - stuckGoal left requiresCondition = - fromRulePattern goal RulePattern - { left - , antiLeft = Nothing - , requires = Condition.toPredicate requiresCondition - , rhs = rhs - , attributes = attributes . toRulePattern $ goal - } + removeDestinationWorker + :: RulePattern Variable + -> Compose m (ProofState goal) (RulePattern Variable) + removeDestinationWorker rulePattern = + let configuration = Lens.view RulePattern.leftPattern rulePattern + configFreeVars = freeVariables configuration + destination = + Lens.view (field @"rhs") rulePattern + & topExistsToImplicitForall configFreeVars + in Compose $ withConfiguration' configuration $ do + removal <- removalPredicate destination configuration + if isTop removal + then pure . mkState $ rulePattern + else do + simplifiedRemoval <- + Conditional.andPredicate configuration removal + & simplifyTopConfiguration + & (>>= SMT.Evaluator.filterMultiOr) + if not (isBottom simplifiedRemoval) + then + let stuckConfiguration = OrPattern.toPattern simplifiedRemoval + rulePattern' = rulePattern & Lens.set RulePattern.leftPattern stuckConfiguration + in pure . GoalStuck $ rulePattern' + else pure Proven simplify :: (MonadCatch m, MonadSimplify m) @@ -942,6 +950,10 @@ withConfiguration goal = handle (throw . WithConfiguration configuration) where configuration = getConfiguration goal +withConfiguration' :: MonadCatch m => Pattern Variable -> m a -> m a +withConfiguration' configuration = + handle (throw . WithConfiguration configuration) + {- | The predicate to remove the destination from the present configuration. -} removalPredicate From 94d09d0ef4572f183d9dbba547009fa2ff308569 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Thu, 30 Apr 2020 14:39:03 -0500 Subject: [PATCH 22/79] leftPattern: Obey Lens laws --- kore/src/Kore/Step/RulePattern.hs | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/kore/src/Kore/Step/RulePattern.hs b/kore/src/Kore/Step/RulePattern.hs index 735616cbd4..7d47b5f564 100644 --- a/kore/src/Kore/Step/RulePattern.hs +++ b/kore/src/Kore/Step/RulePattern.hs @@ -84,6 +84,7 @@ import Kore.Internal.Alias ( Alias (..) ) import Kore.Internal.ApplicationSorts +import qualified Kore.Internal.Condition as Condition import Kore.Internal.Pattern ( Conditional (..) , Pattern @@ -282,15 +283,9 @@ leftPattern = get RulePattern { left, requires } = Pattern.withCondition left $ from @(Predicate _) requires set rule@(RulePattern _ _ _ _ _) pattern' = - applySubstitution - (Pattern.substitution pattern') - rule - { left = Pattern.term pattern' - , requires = coerceSort (Pattern.predicate pattern') - } + rule { left, requires = Condition.toPredicate condition } where - sort = TermLike.termLikeSort (Pattern.term pattern') - coerceSort = Predicate.coerceSort sort + (left, condition) = Pattern.splitTerm pattern' {- | Does the axiom pattern represent a heating rule? -} From 9d1101d9217b4ce2e2a2f24408c12badcb19b87d Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Thu, 30 Apr 2020 14:46:22 -0500 Subject: [PATCH 23/79] Kore.Step.RulePattern: Initialize predicate sorts correctly --- kore/src/Kore/Step/RulePattern.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/kore/src/Kore/Step/RulePattern.hs b/kore/src/Kore/Step/RulePattern.hs index 7d47b5f564..889d6103c4 100644 --- a/kore/src/Kore/Step/RulePattern.hs +++ b/kore/src/Kore/Step/RulePattern.hs @@ -267,7 +267,7 @@ rulePattern left right = RulePattern { left , antiLeft = Nothing - , requires = Predicate.makeTruePredicate_ + , requires = Predicate.makeTruePredicate (TermLike.termLikeSort left) , rhs = termToRHS right , attributes = Default.def } @@ -330,7 +330,11 @@ injectTermIntoRHS => TermLike.TermLike variable -> RHS variable injectTermIntoRHS right = - RHS { existentials = [], right, ensures = Predicate.makeTruePredicate_ } + RHS + { existentials = [] + , right + , ensures = Predicate.makeTruePredicate (TermLike.termLikeSort right) + } -- | Parses a term representing a RHS into a RHS termToRHS From 6658e78a42de6175c0fe67af85b9411587aade21 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Thu, 30 Apr 2020 15:11:36 -0500 Subject: [PATCH 24/79] Test.Kore.Strategies.OnePath.Step: Initialize rule sorts correctly --- .../test/Test/Kore/Strategies/OnePath/Step.hs | 42 +++++-------------- 1 file changed, 11 insertions(+), 31 deletions(-) diff --git a/kore/test/Test/Kore/Strategies/OnePath/Step.hs b/kore/test/Test/Kore/Strategies/OnePath/Step.hs index 94fe930619..2f3038c928 100644 --- a/kore/test/Test/Kore/Strategies/OnePath/Step.hs +++ b/kore/test/Test/Kore/Strategies/OnePath/Step.hs @@ -45,6 +45,7 @@ import Kore.Internal.Predicate , makeNotPredicate , makeTruePredicate_ ) +import qualified Kore.Internal.Predicate as Predicate import Kore.Internal.TermLike ( TermLike ) @@ -99,42 +100,19 @@ makeOnePathRuleFromPatterns configuration destination = - let (left, Condition.toPredicate -> requires) = + let (left, Condition.toPredicate -> requires') = Pattern.splitTerm configuration - (right, Condition.toPredicate -> ensures) = + (right, Condition.toPredicate -> ensures') = Pattern.splitTerm destination in coerce RulePattern { left , antiLeft = Nothing - , requires + , requires = Predicate.coerceSort (TermLike.termLikeSort left) requires' , rhs = RHS { existentials = [] , right - , ensures - } - , attributes = Default.def - } - -makeOnePathRuleFromPatternsWithCond - :: Pattern Variable - -> Pattern Variable - -> OnePathRule -makeOnePathRuleFromPatternsWithCond - configuration - destination - = - let (left, Condition.toPredicate -> requires) = - Pattern.splitTerm configuration - (right, Condition.toPredicate -> ensures) = - Pattern.splitTerm destination - in coerce RulePattern - { left - , antiLeft = Nothing - , requires - , rhs = RHS - { existentials = [] - , right - , ensures + , ensures = + Predicate.coerceSort (TermLike.termLikeSort right) ensures' } , attributes = Default.def } @@ -771,11 +749,13 @@ test_onePathStrategy = -- Normal axiom: - -- Expected: stuck, since the terms unify but the conditions do not let goal = - makeOnePathRuleFromPatternsWithCond + makeOnePathRuleFromPatterns ( Conditional { term = TermLike.mkElemVar Mock.x , predicate = - makeEqualsPredicate_ (TermLike.mkElemVar Mock.x) Mock.a + makeEqualsPredicate Mock.testSort + (TermLike.mkElemVar Mock.x) + Mock.a , substitution = mempty } ) @@ -783,7 +763,7 @@ test_onePathStrategy = { term = TermLike.mkElemVar Mock.x , predicate = makeNotPredicate - $ makeEqualsPredicate_ + $ makeEqualsPredicate Mock.testSort (TermLike.mkElemVar Mock.x) Mock.a , substitution = mempty From f2d98789042b01faf690dd8afe7d54a407d0164e Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Thu, 30 Apr 2020 15:16:25 -0500 Subject: [PATCH 25/79] Kore.Strategies.Goal: Preserve proof goal sorts --- kore/src/Kore/Strategies/Goal.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index b436ece847..6763eb587b 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -95,6 +95,7 @@ import Kore.Internal.Symbol import Kore.Internal.TermLike ( isFunctionPattern , mkAnd + , termLikeSort ) import Kore.Log.DebugProofState import Kore.Log.ErrorRewritesInstantiation @@ -793,7 +794,9 @@ removeDestination stateConstructor goal = fromRulePattern goal RulePattern { left , antiLeft = Nothing - , requires = Condition.toPredicate requiresCondition + , requires = + Condition.toPredicate requiresCondition + & Predicate.coerceSort (termLikeSort left) , rhs = rhs , attributes = attributes . toRulePattern $ goal } @@ -1061,12 +1064,12 @@ configurationDestinationToRule -> RHS Variable -> rule configurationDestinationToRule ruleType configuration rhs = - let (left, Condition.toPredicate -> requires) = + let (left, Condition.toPredicate -> requires') = Pattern.splitTerm configuration in fromRulePattern ruleType $ RulePattern { left , antiLeft = Nothing - , requires + , requires = Predicate.coerceSort (termLikeSort left) requires' , rhs , attributes = Default.def } From a628c7b2c499e12ffd5a62a19404e5a4630c706f Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Thu, 30 Apr 2020 15:36:56 -0500 Subject: [PATCH 26/79] Test.Kore.Step.Rule.Simplify: Preserve sorts --- kore/test/Test/Kore/Step/Rule/Simplify.hs | 38 +++++++++++------------ 1 file changed, 18 insertions(+), 20 deletions(-) diff --git a/kore/test/Test/Kore/Step/Rule/Simplify.hs b/kore/test/Test/Kore/Step/Rule/Simplify.hs index 4c2c07bd98..fa81df3095 100644 --- a/kore/test/Test/Kore/Step/Rule/Simplify.hs +++ b/kore/test/Test/Kore/Step/Rule/Simplify.hs @@ -27,10 +27,8 @@ import Kore.Internal.Predicate , makeAndPredicate , makeCeilPredicate , makeEqualsPredicate - , makeEqualsPredicate_ , makeNotPredicate , makeTruePredicate - , makeTruePredicate_ ) import qualified Kore.Internal.Predicate as Predicate import qualified Kore.Internal.SideCondition as SideCondition @@ -39,7 +37,7 @@ import Kore.Internal.TermLike , TermLike , mkAnd , mkElemVar - , mkEquals_ + , mkEquals , mkOr , termLikeSort ) @@ -97,7 +95,7 @@ instance OnePathRuleBase Pair where instance OnePathRuleBase TermLike where t1 `rewritesTo` t2 = Pair (t1, makeTruePredicate (termLikeSort t1)) - `rewritesTo` Pair (t2, makeTruePredicate_) + `rewritesTo` Pair (t2, makeTruePredicate (termLikeSort t2)) test_simplifyRule :: [TestTree] test_simplifyRule = @@ -113,7 +111,7 @@ test_simplifyRule = let expected = [Mock.a `rewritesTo` Mock.cf] actual <- runSimplifyRule - ( mkAnd Mock.a (mkEquals_ Mock.a Mock.a) + ( mkAnd Mock.a (mkEquals Mock.testSort Mock.a Mock.a) `rewritesTo` Mock.cf ) @@ -124,7 +122,7 @@ test_simplifyRule = let rule = Mock.a `rewritesTo` - mkAnd Mock.cf (mkEquals_ Mock.a Mock.a) + mkAnd Mock.cf (mkEquals Mock.testSort Mock.a Mock.a) expected = [rule] actual <- runSimplifyRule rule @@ -135,7 +133,7 @@ test_simplifyRule = let expected = [Mock.a `rewritesTo` Mock.f Mock.b] actual <- runSimplifyRule - ( mkAnd Mock.a (mkEquals_ Mock.b x) + ( mkAnd Mock.a (mkEquals Mock.testSort Mock.b x) `rewritesTo` Mock.f x ) @@ -145,9 +143,9 @@ test_simplifyRule = let expected = [Mock.a `rewritesTo` Mock.cf] actual <- runSimplifyRule - ( Pair (Mock.a, makeEqualsPredicate_ Mock.b Mock.b) + ( Pair (Mock.a, makeEqualsPredicate Mock.testSort Mock.b Mock.b) `rewritesTo` - Pair (Mock.cf, makeTruePredicate_) + Pair (Mock.cf, makeTruePredicate Mock.testSort) ) assertEqual "" expected actual @@ -156,7 +154,7 @@ test_simplifyRule = let rule = Pair (Mock.a, makeTruePredicate Mock.testSort) `rewritesTo` - Pair (Mock.cf, makeEqualsPredicate_ Mock.b Mock.b) + Pair (Mock.cf, makeEqualsPredicate Mock.testSort Mock.b Mock.b) expected = [rule] actual <- runSimplifyRule rule @@ -167,9 +165,9 @@ test_simplifyRule = let expected = [Mock.a `rewritesTo` Mock.f Mock.b] actual <- runSimplifyRule - ( Pair (Mock.a, makeEqualsPredicate_ Mock.b x) + ( Pair (Mock.a, makeEqualsPredicate Mock.testSort Mock.b x) `rewritesTo` - Pair (Mock.f x, makeTruePredicate_) + Pair (Mock.f x, makeTruePredicate Mock.testSort) ) assertEqual "" expected actual @@ -192,13 +190,13 @@ test_simplifyRule = let expected = [ Pair (Mock.f x, makeCeilPredicate Mock.testSort (Mock.f x)) `rewritesTo` - Pair (Mock.a, makeTruePredicate_) + Pair (Mock.a, makeTruePredicate Mock.testSort) ] actual <- runSimplifyRule - ( Pair (Mock.f x, makeTruePredicate_) + ( Pair (Mock.f x, makeTruePredicate Mock.testSort) `rewritesTo` - Pair (Mock.a, makeTruePredicate_) + Pair (Mock.a, makeTruePredicate Mock.testSort) ) assertEqual "" expected actual @@ -208,9 +206,9 @@ test_simplifyRule = ] actual <- runSimplifyRule - ( Pair (Mock.functional10 x, makeTruePredicate_) + ( Pair (Mock.functional10 x, makeTruePredicate Mock.testSort) `rewritesTo` - Pair (Mock.a, makeTruePredicate_) + Pair (Mock.a, makeTruePredicate Mock.testSort) ) assertEqual "" expected actual @@ -221,16 +219,16 @@ test_simplifyRule = ( Mock.b , makeAndPredicate (makeNotPredicate - (makeEqualsPredicate_ x Mock.b) + (makeEqualsPredicate Mock.testSort x Mock.b) ) (makeNotPredicate (makeNotPredicate - (makeEqualsPredicate_ x Mock.b) + (makeEqualsPredicate Mock.testSort x Mock.b) ) ) ) `rewritesTo` - Pair (Mock.a, makeTruePredicate_) + Pair (Mock.a, makeTruePredicate Mock.testSort) ) assertEqual "" expected actual ] From dd1cb41ed7fb5bc0df31c38c329b77f02ae4b15b Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Thu, 30 Apr 2020 15:51:08 -0500 Subject: [PATCH 27/79] simplifyClaimRule: Apply simplification substitution --- kore/src/Kore/Step/Rule/Simplify.hs | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/kore/src/Kore/Step/Rule/Simplify.hs b/kore/src/Kore/Step/Rule/Simplify.hs index 5be3576876..507c15e77f 100644 --- a/kore/src/Kore/Step/Rule/Simplify.hs +++ b/kore/src/Kore/Step/Rule/Simplify.hs @@ -129,16 +129,25 @@ simplifyClaimRule => RulePattern variable -> simplifier (MultiAnd (RulePattern variable)) simplifyClaimRule = - fmap MultiAnd.make - . Branch.gather - . Lens.traverseOf RulePattern.leftPattern worker + fmap MultiAnd.make . Branch.gather . worker where - worker, simplify, filterWithSolver + simplify, filterWithSolver :: Pattern variable -> BranchT simplifier (Pattern variable) - worker = + simplify = (return . Pattern.requireDefined) - >=> simplify + >=> Pattern.simplifyTopConfiguration + >=> Branch.scatter >=> filterWithSolver - simplify = Pattern.simplifyTopConfiguration >=> Branch.scatter filterWithSolver = SMT.Evaluator.filterBranch + + worker :: RulePattern variable -> BranchT simplifier (RulePattern variable) + worker rulePattern = do + let lhs = Lens.view RulePattern.leftPattern rulePattern + simplified <- simplify lhs + let substitution = Pattern.substitution simplified + lhs' = simplified { Pattern.substitution = mempty } + rulePattern + & Lens.set RulePattern.leftPattern lhs' + & RulePattern.applySubstitution substitution + & return From 162af9f1ddf18bfdf604d6c9ca4f4747ab6d04af Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Thu, 30 Apr 2020 16:12:41 -0500 Subject: [PATCH 28/79] instance From (Conditional _ _) (Predicate _): Preserve predicate sort --- kore/src/Kore/Internal/Conditional.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/kore/src/Kore/Internal/Conditional.hs b/kore/src/Kore/Internal/Conditional.hs index 99e83bcfbe..bd59a097e4 100644 --- a/kore/src/Kore/Internal/Conditional.hs +++ b/kore/src/Kore/Internal/Conditional.hs @@ -203,7 +203,11 @@ instance => From (Conditional variable ()) (Predicate variable) where from Conditional { predicate, substitution } = - Predicate.makeAndPredicate predicate (from substitution) + Predicate.makeAndPredicate predicate + $ Predicate.coerceSort sort + $ from substitution + where + sort = (termLikeSort . Predicate.unwrapPredicate) predicate instance InternalVariable variable From 014ba520702a34360afd6adf283deff1298ff8c7 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Thu, 30 Apr 2020 16:28:17 -0500 Subject: [PATCH 29/79] removeDestination: Remove nested if statements --- kore/src/Kore/Strategies/Goal.hs | 51 +++++++++++++++++++------------- 1 file changed, 30 insertions(+), 21 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 9e1b4417af..2d08544125 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -31,6 +31,7 @@ import Prelude.Kore import Control.Error ( ExceptT , runExceptT + , throwE ) import Control.Exception ( throw @@ -778,34 +779,42 @@ removeDestination -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) removeDestination lensRulePattern mkState goal = - Lens.traverseOf lensRulePattern removeDestinationWorker goal + goal + & Lens.traverseOf lensRulePattern (Compose . removeDestinationWorker) & getCompose & lift where removeDestinationWorker :: RulePattern Variable - -> Compose m (ProofState goal) (RulePattern Variable) + -> m (ProofState goal (RulePattern Variable)) removeDestinationWorker rulePattern = - let configuration = Lens.view RulePattern.leftPattern rulePattern - configFreeVars = freeVariables configuration - destination = - Lens.view (field @"rhs") rulePattern - & topExistsToImplicitForall configFreeVars - in Compose $ withConfiguration' configuration $ do + do removal <- removalPredicate destination configuration - if isTop removal - then pure . mkState $ rulePattern - else do - simplifiedRemoval <- - Conditional.andPredicate configuration removal - & simplifyTopConfiguration - & (>>= SMT.Evaluator.filterMultiOr) - if not (isBottom simplifiedRemoval) - then - let stuckConfiguration = OrPattern.toPattern simplifiedRemoval - rulePattern' = rulePattern & Lens.set RulePattern.leftPattern stuckConfiguration - in pure . GoalStuck $ rulePattern' - else pure Proven + when (isTop removal) (succeed . mkState $ rulePattern) + simplifiedRemoval <- + return (Conditional.andPredicate configuration removal) + >>= simplifyTopConfiguration + >>= SMT.Evaluator.filterMultiOr + when (isBottom simplifiedRemoval) (succeed Proven) + let stuckConfiguration = OrPattern.toPattern simplifiedRemoval + rulePattern + & Lens.set RulePattern.leftPattern stuckConfiguration + & GoalStuck + & pure + & run + & withConfiguration' configuration + where + configuration = Lens.view RulePattern.leftPattern rulePattern + configFreeVars = freeVariables configuration + destination = + Lens.view (field @"rhs") rulePattern + & topExistsToImplicitForall configFreeVars + + succeed :: r -> ExceptT r m a + succeed = throwE + + run :: ExceptT r m r -> m r + run acts = runExceptT acts >>= either pure pure simplify :: (MonadCatch m, MonadSimplify m) From 1b569cb307fa001291be8fbe27b415103faf3a26 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Sun, 3 May 2020 11:17:27 -0500 Subject: [PATCH 30/79] Kore.Strategies.Goal.simplify: Remove ToRulePattern --- kore/src/Kore/Strategies/Goal.hs | 39 +++++++++++++++++--------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 2d08544125..f67c9862b2 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -312,7 +312,7 @@ instance Goal OnePathRule where transitionRule = (withDebugProofState . transitionRuleTemplate) TransitionRuleTemplate - { simplifyTemplate = simplify + { simplifyTemplate = simplify _Unwrapped , removeDestinationTemplate = removeDestination _Unwrapped , isTriviallyValidTemplate = isTriviallyValid , deriveParTemplate = derivePar @@ -348,7 +348,7 @@ instance Goal AllPathRule where transitionRule = (withDebugProofState . transitionRuleTemplate) TransitionRuleTemplate - { simplifyTemplate = simplify + { simplifyTemplate = simplify _Unwrapped , removeDestinationTemplate = removeDestination _Unwrapped , isTriviallyValidTemplate = isTriviallyValid , deriveParTemplate = derivePar @@ -818,23 +818,26 @@ removeDestination lensRulePattern mkState goal = simplify :: (MonadCatch m, MonadSimplify m) - => ToRulePattern goal - => FromRulePattern goal - => goal + => Lens' goal (RulePattern Variable) + -> goal -> Strategy.TransitionT (Rule goal) m goal -simplify goal = withConfiguration goal $ do - configs <- lift $ - simplifyTopConfiguration configuration - filteredConfigs <- SMT.Evaluator.filterMultiOr configs - if null filteredConfigs - then pure $ configurationDestinationToRule goal Pattern.bottom destination - else do - let simplifiedRules = - fmap (flip (configurationDestinationToRule goal) destination) filteredConfigs - Foldable.asum (pure <$> simplifiedRules) - where - destination = getDestination goal - configuration = getConfiguration goal +simplify lensRulePattern goal = + Lens.forOf lensRulePattern goal $ \rulePattern -> + let configuration = Lens.view RulePattern.leftPattern rulePattern in + withConfiguration' configuration $ do + configs <- + simplifyTopConfiguration configuration + >>= SMT.Evaluator.filterMultiOr + & lift + if isBottom configs + then + Lens.set RulePattern.leftPattern Pattern.bottom rulePattern + & pure + else do + let simplified = + flip (Lens.set RulePattern.leftPattern) rulePattern + <$> configs + Foldable.asum (pure <$> simplified) isTriviallyValid :: ToRulePattern goal From 1bf35d0c83511892ce777036d8f8700ca2570a8f Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Sun, 3 May 2020 11:20:55 -0500 Subject: [PATCH 31/79] Refactor Kore.Strategies.Goal.simplify --- kore/src/Kore/Strategies/Goal.hs | 26 +++++++++----------------- 1 file changed, 9 insertions(+), 17 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index f67c9862b2..d3268e7c73 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -821,23 +821,15 @@ simplify => Lens' goal (RulePattern Variable) -> goal -> Strategy.TransitionT (Rule goal) m goal -simplify lensRulePattern goal = - Lens.forOf lensRulePattern goal $ \rulePattern -> - let configuration = Lens.view RulePattern.leftPattern rulePattern in - withConfiguration' configuration $ do - configs <- - simplifyTopConfiguration configuration - >>= SMT.Evaluator.filterMultiOr - & lift - if isBottom configs - then - Lens.set RulePattern.leftPattern Pattern.bottom rulePattern - & pure - else do - let simplified = - flip (Lens.set RulePattern.leftPattern) rulePattern - <$> configs - Foldable.asum (pure <$> simplified) +simplify lensRulePattern = + Lens.traverseOf (lensRulePattern . RulePattern.leftPattern) $ \config -> + withConfiguration' config $ do + configs <- + simplifyTopConfiguration config >>= SMT.Evaluator.filterMultiOr + & lift + if isBottom configs + then pure Pattern.bottom + else Foldable.asum (pure <$> configs) isTriviallyValid :: ToRulePattern goal From fb608a1219b9bab8d5b6ae59a0f2ecc97acd442e Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Sun, 3 May 2020 17:19:03 -0500 Subject: [PATCH 32/79] Kore.Strategies.Goal.isTriviallyValid: Remove ToRulePattern --- kore/src/Kore/Strategies/Goal.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index d3268e7c73..7fdba82377 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -314,7 +314,7 @@ instance Goal OnePathRule where TransitionRuleTemplate { simplifyTemplate = simplify _Unwrapped , removeDestinationTemplate = removeDestination _Unwrapped - , isTriviallyValidTemplate = isTriviallyValid + , isTriviallyValidTemplate = isTriviallyValid _Unwrapped , deriveParTemplate = derivePar , deriveSeqTemplate = deriveSeq } @@ -350,7 +350,7 @@ instance Goal AllPathRule where TransitionRuleTemplate { simplifyTemplate = simplify _Unwrapped , removeDestinationTemplate = removeDestination _Unwrapped - , isTriviallyValidTemplate = isTriviallyValid + , isTriviallyValidTemplate = isTriviallyValid _Unwrapped , deriveParTemplate = derivePar , deriveSeqTemplate = deriveSeq } @@ -831,10 +831,9 @@ simplify lensRulePattern = then pure Pattern.bottom else Foldable.asum (pure <$> configs) -isTriviallyValid - :: ToRulePattern goal - => goal -> Bool -isTriviallyValid = isBottom . RulePattern.left . toRulePattern +isTriviallyValid :: Lens' goal (RulePattern variable) -> goal -> Bool +isTriviallyValid lensRulePattern = + isBottom . RulePattern.left . Lens.view lensRulePattern isTrusted :: forall goal From 11142e285a3a49d94c663b65b68a8dc9a016240c Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 06:24:54 -0500 Subject: [PATCH 33/79] Kore.Strategies.Goal.isTrusted: Remove ToRulePattern --- kore/src/Kore/Step/RulePattern.hs | 10 ++++++++++ kore/src/Kore/Strategies/Goal.hs | 11 ++--------- kore/test/Test/Kore/Strategies/Common.hs | 5 +++++ 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/kore/src/Kore/Step/RulePattern.hs b/kore/src/Kore/Step/RulePattern.hs index 889d6103c4..9e7dbcea6f 100644 --- a/kore/src/Kore/Step/RulePattern.hs +++ b/kore/src/Kore/Step/RulePattern.hs @@ -573,6 +573,9 @@ instance From OnePathRule Attribute.Label where instance From OnePathRule Attribute.RuleIndex where from = Attribute.identifier . attributes . getOnePathRule +instance From OnePathRule Attribute.Trusted where + from = Attribute.trusted . attributes . getOnePathRule + {- | Unified One-Path and All-Path Claim rule pattern. -} data ReachabilityRule @@ -618,6 +621,10 @@ instance From ReachabilityRule Attribute.RuleIndex where from (OnePath onePathRule) = from onePathRule from (AllPath allPathRule) = from allPathRule +instance From ReachabilityRule Attribute.Trusted where + from (OnePath onePathRule) = from onePathRule + from (AllPath allPathRule) = from allPathRule + toSentence :: ReachabilityRule -> Verified.Sentence toSentence rule = Syntax.SentenceClaimSentence $ Syntax.SentenceClaim Syntax.SentenceAxiom @@ -673,6 +680,9 @@ instance From AllPathRule Attribute.Label where instance From AllPathRule Attribute.RuleIndex where from = Attribute.identifier . attributes . getAllPathRule +instance From AllPathRule Attribute.Trusted where + from = Attribute.trusted . attributes . getAllPathRule + instance ToRulePattern (RewriteRule Variable) instance ToRulePattern OnePathRule diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 7fdba82377..21abfff733 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -835,15 +835,8 @@ isTriviallyValid :: Lens' goal (RulePattern variable) -> goal -> Bool isTriviallyValid lensRulePattern = isBottom . RulePattern.left . Lens.view lensRulePattern -isTrusted - :: forall goal - . ToRulePattern goal - => goal -> Bool -isTrusted = - Attribute.Trusted.isTrusted - . Attribute.Axiom.trusted - . RulePattern.attributes - . toRulePattern +isTrusted :: From goal Attribute.Axiom.Trusted => goal -> Bool +isTrusted = Attribute.Trusted.isTrusted . from @_ @Attribute.Axiom.Trusted -- | Exception that contains the last configuration before the error. data WithConfiguration = WithConfiguration (Pattern Variable) SomeException diff --git a/kore/test/Test/Kore/Strategies/Common.hs b/kore/test/Test/Kore/Strategies/Common.hs index 329dcb48dd..a614c89609 100644 --- a/kore/test/Test/Kore/Strategies/Common.hs +++ b/kore/test/Test/Kore/Strategies/Common.hs @@ -16,6 +16,9 @@ import Numeric.Natural ( Natural ) +import qualified Kore.Attribute.Trusted as Attribute + ( Trusted + ) import Kore.Internal.Pattern ( Pattern ) @@ -56,6 +59,7 @@ runVerificationToPattern => ProofState claim (Pattern Variable) ~ Verification.CommonProofState => Show claim => Show (Rule claim) + => From claim Attribute.Trusted => Limit Natural -> Limit Natural -> [Rule claim] @@ -82,6 +86,7 @@ runVerification => ProofState claim (Pattern Variable) ~ Verification.CommonProofState => Show claim => Show (Rule claim) + => From claim Attribute.Trusted => Limit Natural -> Limit Natural -> [Rule claim] From 7c090963ed78fb455457b4e177f3d717f2b227d1 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 06:49:11 -0500 Subject: [PATCH 34/79] Kore.Strategies.Goal.deriveWith: Remove constraint ToRulePattern --- kore/src/Kore/Strategies/Goal.hs | 67 ++++++++++++++------------------ 1 file changed, 30 insertions(+), 37 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 21abfff733..e1a4973638 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -315,8 +315,8 @@ instance Goal OnePathRule where { simplifyTemplate = simplify _Unwrapped , removeDestinationTemplate = removeDestination _Unwrapped , isTriviallyValidTemplate = isTriviallyValid _Unwrapped - , deriveParTemplate = derivePar - , deriveSeqTemplate = deriveSeq + , deriveParTemplate = derivePar _Unwrapped + , deriveSeqTemplate = deriveSeq _Unwrapped } strategy _ goals rules = @@ -351,8 +351,8 @@ instance Goal AllPathRule where { simplifyTemplate = simplify _Unwrapped , removeDestinationTemplate = removeDestination _Unwrapped , isTriviallyValidTemplate = isTriviallyValid _Unwrapped - , deriveParTemplate = derivePar - , deriveSeqTemplate = deriveSeq + , deriveParTemplate = derivePar _Unwrapped + , deriveSeqTemplate = deriveSeq _Unwrapped } strategy _ goals rules = @@ -850,15 +850,15 @@ derivePar . (MonadCatch m, MonadSimplify m) => Goal goal => ProofState.ProofState goal ~ ProofState goal goal - => ToRulePattern goal - => FromRulePattern goal => ToRulePattern (Rule goal) => FromRulePattern (Rule goal) - => [Rule goal] + => Lens' goal (RulePattern Variable) + -> [Rule goal] -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) -derivePar = - deriveWith $ Step.applyRewriteRulesParallel Unification.unificationProcedure +derivePar lensRulePattern = + deriveWith lensRulePattern + $ Step.applyRewriteRulesParallel Unification.unificationProcedure type Deriver monad = [RewriteRule RewritingVariable] @@ -871,24 +871,24 @@ deriveWith . (MonadCatch m, MonadSimplify m) => Goal goal => ProofState.ProofState goal ~ ProofState goal goal - => ToRulePattern goal - => FromRulePattern goal => ToRulePattern (Rule goal) => FromRulePattern (Rule goal) - => Deriver m + => Lens' goal (RulePattern Variable) + -> Deriver m -> [Rule goal] -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) -deriveWith takeStep rules goal = - withConfiguration goal - $ (lift . runExceptT) (takeStep rewrites configuration) - >>= either - (errorRewritesInstantiation configuration) - (deriveResults goal) +deriveWith lensRulePattern takeStep rules goal = + (\x -> getCompose $ x goal) + $ Lens.traverseOf (lensRulePattern . RulePattern.leftPattern) + $ \config -> Compose $ withConfiguration' config $ do + results <- takeStep rewrites config & assertInstantiated config + deriveResults goal results where - configuration :: Pattern Variable - configuration = getConfiguration goal rewrites = mkRewritingRule . RewriteRule . toRulePattern <$> rules + assertInstantiated config act = + (lift . runExceptT) act + >>= either (errorRewritesInstantiation config) return -- | Apply 'Rule's to the goal in sequence. deriveSeq @@ -896,30 +896,28 @@ deriveSeq . (MonadCatch m, MonadSimplify m) => Goal goal => ProofState.ProofState goal ~ ProofState goal goal - => ToRulePattern goal - => FromRulePattern goal => ToRulePattern (Rule goal) => FromRulePattern (Rule goal) - => [Rule goal] + => Lens' goal (RulePattern Variable) + -> [Rule goal] -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) -deriveSeq = - deriveWith . flip +deriveSeq lensRulePattern = + deriveWith lensRulePattern . flip $ Step.applyRewriteRulesSequence Unification.unificationProcedure deriveResults :: MonadSimplify simplifier - => (Goal goal, FromRulePattern goal, ToRulePattern goal) + => Goal goal => FromRulePattern (Rule goal) => goal -> Step.Results RulePattern Variable - -> Strategy.TransitionT (Rule goal) simplifier (ProofState.ProofState goal) + -> Strategy.TransitionT (Rule goal) simplifier + (ProofState.ProofState (Pattern Variable)) +-- TODO (thomas.tuegel): Remove goal argument. deriveResults goal Results { results, remainders } = addResults <|> addRemainders where - destination = getDestination goal - toGoal config = configurationDestinationToRule goal config destination - addResults = Foldable.asum (addResult <$> results) addRemainders = Foldable.asum (addRemainder <$> Foldable.toList remainders) @@ -932,8 +930,8 @@ deriveResults goal Results { results, remainders } = pure Proven configs -> Foldable.asum (addRewritten <$> configs) - addRewritten = pure . GoalRewritten . toGoal - addRemainder = pure . GoalRemainder . toGoal + addRewritten = pure . GoalRewritten + addRemainder = pure . GoalRemainder addRule = Transition.addRule . fromAppliedRule @@ -942,11 +940,6 @@ deriveResults goal Results { results, remainders } = . Step.unRewritingRule . Step.withoutUnification -withConfiguration :: MonadCatch m => ToRulePattern goal => goal -> m a -> m a -withConfiguration goal = handle (throw . WithConfiguration configuration) - where - configuration = getConfiguration goal - withConfiguration' :: MonadCatch m => Pattern Variable -> m a -> m a withConfiguration' configuration = handle (throw . WithConfiguration configuration) From 592e07cea7d8cee4e00deee3e5718842e7d636c0 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 10:28:52 -0500 Subject: [PATCH 35/79] Kore.Strategies.Goal.deriveResults: Remove constraint FromRulePattern --- kore/src/Kore/Strategies/Goal.hs | 39 +++++++++++++------------------- 1 file changed, 16 insertions(+), 23 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index e1a4973638..59eb109476 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -315,8 +315,8 @@ instance Goal OnePathRule where { simplifyTemplate = simplify _Unwrapped , removeDestinationTemplate = removeDestination _Unwrapped , isTriviallyValidTemplate = isTriviallyValid _Unwrapped - , deriveParTemplate = derivePar _Unwrapped - , deriveSeqTemplate = deriveSeq _Unwrapped + , deriveParTemplate = derivePar _Unwrapped OnePathRewriteRule + , deriveSeqTemplate = deriveSeq _Unwrapped OnePathRewriteRule } strategy _ goals rules = @@ -351,8 +351,8 @@ instance Goal AllPathRule where { simplifyTemplate = simplify _Unwrapped , removeDestinationTemplate = removeDestination _Unwrapped , isTriviallyValidTemplate = isTriviallyValid _Unwrapped - , deriveParTemplate = derivePar _Unwrapped - , deriveSeqTemplate = deriveSeq _Unwrapped + , deriveParTemplate = derivePar _Unwrapped AllPathRewriteRule + , deriveSeqTemplate = deriveSeq _Unwrapped AllPathRewriteRule } strategy _ goals rules = @@ -848,16 +848,15 @@ instance Exception WithConfiguration derivePar :: forall m goal . (MonadCatch m, MonadSimplify m) - => Goal goal => ProofState.ProofState goal ~ ProofState goal goal => ToRulePattern (Rule goal) - => FromRulePattern (Rule goal) => Lens' goal (RulePattern Variable) + -> (RewriteRule Variable -> Rule goal) -> [Rule goal] -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) -derivePar lensRulePattern = - deriveWith lensRulePattern +derivePar lensRulePattern mkRule = + deriveWith lensRulePattern mkRule $ Step.applyRewriteRulesParallel Unification.unificationProcedure type Deriver monad = @@ -869,21 +868,20 @@ type Deriver monad = deriveWith :: forall m goal . (MonadCatch m, MonadSimplify m) - => Goal goal => ProofState.ProofState goal ~ ProofState goal goal => ToRulePattern (Rule goal) - => FromRulePattern (Rule goal) => Lens' goal (RulePattern Variable) + -> (RewriteRule Variable -> Rule goal) -> Deriver m -> [Rule goal] -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) -deriveWith lensRulePattern takeStep rules goal = +deriveWith lensRulePattern mkRule takeStep rules goal = (\x -> getCompose $ x goal) $ Lens.traverseOf (lensRulePattern . RulePattern.leftPattern) $ \config -> Compose $ withConfiguration' config $ do results <- takeStep rewrites config & assertInstantiated config - deriveResults goal results + deriveResults mkRule results where rewrites = mkRewritingRule . RewriteRule . toRulePattern <$> rules assertInstantiated config act = @@ -894,28 +892,25 @@ deriveWith lensRulePattern takeStep rules goal = deriveSeq :: forall m goal . (MonadCatch m, MonadSimplify m) - => Goal goal => ProofState.ProofState goal ~ ProofState goal goal => ToRulePattern (Rule goal) - => FromRulePattern (Rule goal) => Lens' goal (RulePattern Variable) + -> (RewriteRule Variable -> Rule goal) -> [Rule goal] -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) -deriveSeq lensRulePattern = - deriveWith lensRulePattern . flip +deriveSeq lensRulePattern mkRule = + deriveWith lensRulePattern mkRule . flip $ Step.applyRewriteRulesSequence Unification.unificationProcedure deriveResults :: MonadSimplify simplifier - => Goal goal - => FromRulePattern (Rule goal) - => goal + => (RewriteRule Variable -> Rule goal) -> Step.Results RulePattern Variable -> Strategy.TransitionT (Rule goal) simplifier (ProofState.ProofState (Pattern Variable)) -- TODO (thomas.tuegel): Remove goal argument. -deriveResults goal Results { results, remainders } = +deriveResults mkRule Results { results, remainders } = addResults <|> addRemainders where addResults = Foldable.asum (addResult <$> results) @@ -936,9 +931,7 @@ deriveResults goal Results { results, remainders } = addRule = Transition.addRule . fromAppliedRule fromAppliedRule = - (fromRulePattern . goalToRule $ goal) - . Step.unRewritingRule - . Step.withoutUnification + mkRule . RewriteRule . Step.unRewritingRule . Step.withoutUnification withConfiguration' :: MonadCatch m => Pattern Variable -> m a -> m a withConfiguration' configuration = From 24996a04afbea7690d88ca81afd4083238c92e3e Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 11:24:31 -0500 Subject: [PATCH 36/79] Kore.Strategies.Goal: Remove constraints ToRulePattern, FromRulePattern --- kore/src/Kore/Strategies/Goal.hs | 64 ++++++++++++++++++++++++++------ 1 file changed, 52 insertions(+), 12 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 59eb109476..1dab0a4f32 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -315,8 +315,8 @@ instance Goal OnePathRule where { simplifyTemplate = simplify _Unwrapped , removeDestinationTemplate = removeDestination _Unwrapped , isTriviallyValidTemplate = isTriviallyValid _Unwrapped - , deriveParTemplate = derivePar _Unwrapped OnePathRewriteRule - , deriveSeqTemplate = deriveSeq _Unwrapped OnePathRewriteRule + , deriveParTemplate = deriveParOnePath + , deriveSeqTemplate = deriveSeqOnePath } strategy _ goals rules = @@ -335,6 +335,28 @@ instance Goal OnePathRule where . getOnePathRule <$> goals +deriveParOnePath + :: (MonadCatch simplifier, MonadSimplify simplifier) + => [Rule OnePathRule] + -> OnePathRule + -> Strategy.TransitionT (Rule OnePathRule) simplifier + (ProofState OnePathRule OnePathRule) +deriveParOnePath rules = + derivePar _Unwrapped OnePathRewriteRule rewrites + where + rewrites = mkRewritingRule . unRuleOnePath <$> rules + +deriveSeqOnePath + :: (MonadCatch simplifier, MonadSimplify simplifier) + => [Rule OnePathRule] + -> OnePathRule + -> Strategy.TransitionT (Rule OnePathRule) simplifier + (ProofState OnePathRule OnePathRule) +deriveSeqOnePath rules = + deriveSeq _Unwrapped OnePathRewriteRule rewrites + where + rewrites = mkRewritingRule . unRuleOnePath <$> rules + instance ClaimExtractor OnePathRule where extractClaim (attrs, sentence) = case fromSentenceAxiom (attrs, Syntax.getSentenceClaim sentence) of @@ -351,8 +373,8 @@ instance Goal AllPathRule where { simplifyTemplate = simplify _Unwrapped , removeDestinationTemplate = removeDestination _Unwrapped , isTriviallyValidTemplate = isTriviallyValid _Unwrapped - , deriveParTemplate = derivePar _Unwrapped AllPathRewriteRule - , deriveSeqTemplate = deriveSeq _Unwrapped AllPathRewriteRule + , deriveParTemplate = deriveParAllPath + , deriveSeqTemplate = deriveSeqAllPath } strategy _ goals rules = @@ -371,6 +393,28 @@ instance Goal AllPathRule where . getAllPathRule <$> goals +deriveParAllPath + :: (MonadCatch simplifier, MonadSimplify simplifier) + => [Rule AllPathRule] + -> AllPathRule + -> Strategy.TransitionT (Rule AllPathRule) simplifier + (ProofState AllPathRule AllPathRule) +deriveParAllPath rules = + derivePar _Unwrapped AllPathRewriteRule rewrites + where + rewrites = mkRewritingRule . unRuleAllPath <$> rules + +deriveSeqAllPath + :: (MonadCatch simplifier, MonadSimplify simplifier) + => [Rule AllPathRule] + -> AllPathRule + -> Strategy.TransitionT (Rule AllPathRule) simplifier + (ProofState AllPathRule AllPathRule) +deriveSeqAllPath rules = + deriveSeq _Unwrapped AllPathRewriteRule rewrites + where + rewrites = mkRewritingRule . unRuleAllPath <$> rules + instance ClaimExtractor AllPathRule where extractClaim (attrs, sentence) = case fromSentenceAxiom (attrs, Syntax.getSentenceClaim sentence) of @@ -849,10 +893,9 @@ derivePar :: forall m goal . (MonadCatch m, MonadSimplify m) => ProofState.ProofState goal ~ ProofState goal goal - => ToRulePattern (Rule goal) => Lens' goal (RulePattern Variable) -> (RewriteRule Variable -> Rule goal) - -> [Rule goal] + -> [RewriteRule RewritingVariable] -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) derivePar lensRulePattern mkRule = @@ -869,21 +912,19 @@ deriveWith :: forall m goal . (MonadCatch m, MonadSimplify m) => ProofState.ProofState goal ~ ProofState goal goal - => ToRulePattern (Rule goal) => Lens' goal (RulePattern Variable) -> (RewriteRule Variable -> Rule goal) -> Deriver m - -> [Rule goal] + -> [RewriteRule RewritingVariable] -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) -deriveWith lensRulePattern mkRule takeStep rules goal = +deriveWith lensRulePattern mkRule takeStep rewrites goal = (\x -> getCompose $ x goal) $ Lens.traverseOf (lensRulePattern . RulePattern.leftPattern) $ \config -> Compose $ withConfiguration' config $ do results <- takeStep rewrites config & assertInstantiated config deriveResults mkRule results where - rewrites = mkRewritingRule . RewriteRule . toRulePattern <$> rules assertInstantiated config act = (lift . runExceptT) act >>= either (errorRewritesInstantiation config) return @@ -893,10 +934,9 @@ deriveSeq :: forall m goal . (MonadCatch m, MonadSimplify m) => ProofState.ProofState goal ~ ProofState goal goal - => ToRulePattern (Rule goal) => Lens' goal (RulePattern Variable) -> (RewriteRule Variable -> Rule goal) - -> [Rule goal] + -> [RewriteRule RewritingVariable] -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) deriveSeq lensRulePattern mkRule = From 70e2df6900a1e9544b99df138531274d189e52ce Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 16:09:40 -0500 Subject: [PATCH 37/79] Kore.Strategies.Verification: Specialize to ReachabilityRule --- kore/src/Kore/Strategies/Verification.hs | 30 ++++++-------- .../Kore/Strategies/AllPath/Verification.hs | 41 ++++++++++--------- kore/test/Test/Kore/Strategies/Common.hs | 31 ++++---------- .../Kore/Strategies/OnePath/Verification.hs | 41 ++++++++++--------- 4 files changed, 64 insertions(+), 79 deletions(-) diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index fcc11bea30..eddb250f8a 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -122,7 +122,7 @@ didn't manage to verify a claim within the its maximum number of steps. If the verification succeeds, it returns (). -} - +-- TODO (thomas.tuegel): Specialize type of StuckVerification. data StuckVerification patt claim = StuckVerification { stuckDescription :: !patt @@ -145,21 +145,17 @@ newtype ToProve claim = ToProve {getToProve :: [(claim, Limit Natural)]} newtype AlreadyProven = AlreadyProven {getAlreadyProven :: [Text]} verify - :: forall claim m - . Claim claim - => ProofState claim (Pattern Variable) ~ CommonProofState - => Show claim - => (MonadCatch m, MonadSimplify m) - => Show (Rule claim) + :: forall m + . (MonadCatch m, MonadSimplify m) => Limit Natural -> GraphSearchOrder - -> AllClaims claim - -> Axioms claim + -> AllClaims ReachabilityRule + -> Axioms ReachabilityRule -> AlreadyProven - -> ToProve claim + -> ToProve ReachabilityRule -- ^ List of claims, together with a maximum number of verification steps -- for each. - -> ExceptT (StuckVerification (Pattern Variable) claim) m () + -> ExceptT (StuckVerification (Pattern Variable) ReachabilityRule) m () verify breadthLimit searchOrder @@ -171,24 +167,24 @@ verify withExceptT addStillProven $ verifyHelper breadthLimit searchOrder claims axioms unproven where - unproven :: ToProve claim - stillProven :: [claim] + unproven :: ToProve ReachabilityRule + stillProven :: [ReachabilityRule] (unproven, stillProven) = (ToProve newToProve, newAlreadyProven) where (newToProve, newAlreadyProven) = partitionEithers (map lookupEither toProve) lookupEither - :: (claim, Limit Natural) - -> Either (claim, Limit Natural) claim + :: (ReachabilityRule, Limit Natural) + -> Either (ReachabilityRule, Limit Natural) ReachabilityRule lookupEither claim@(rule, _) = if unparseToText2 rule `elem` alreadyProven then Right rule else Left claim addStillProven - :: StuckVerification (Pattern Variable) claim - -> StuckVerification (Pattern Variable) claim + :: StuckVerification (Pattern Variable) ReachabilityRule + -> StuckVerification (Pattern Variable) ReachabilityRule addStillProven StuckVerification { stuckDescription, provenClaims } = diff --git a/kore/test/Test/Kore/Strategies/AllPath/Verification.hs b/kore/test/Test/Kore/Strategies/AllPath/Verification.hs index 58636421c1..e4a24cf565 100644 --- a/kore/test/Test/Kore/Strategies/AllPath/Verification.hs +++ b/kore/test/Test/Kore/Strategies/AllPath/Verification.hs @@ -29,6 +29,7 @@ import Kore.Internal.Predicate import Kore.Internal.TermLike import Kore.Step.RulePattern ( AllPathRule (..) + , ReachabilityRule (..) , RewriteRule (..) , RulePattern (..) , injectTermIntoRHS @@ -368,52 +369,52 @@ test_allPathVerification = simpleAxiom :: TermLike Variable -> TermLike Variable - -> Rule AllPathRule + -> Rule ReachabilityRule simpleAxiom left right = - AllPathRewriteRule $ simpleRewrite left right + ReachabilityRewriteRule $ simpleRewrite left right -simpleClaim +simplePriorityAxiom :: TermLike Variable -> TermLike Variable - -> AllPathRule -simpleClaim left right = - AllPathRule - RulePattern + -> Integer + -> Rule ReachabilityRule +simplePriorityAxiom left right priority = + ReachabilityRewriteRule . RewriteRule + $ RulePattern { left = left , antiLeft = Nothing , requires = makeTruePredicate_ , rhs = injectTermIntoRHS right , attributes = def + { Attribute.priority = Attribute.Priority (Just priority) + } } -simpleTrustedClaim +simpleClaim :: TermLike Variable -> TermLike Variable - -> AllPathRule -simpleTrustedClaim left right = - AllPathRule + -> ReachabilityRule +simpleClaim left right = + (AllPath . AllPathRule) RulePattern { left = left , antiLeft = Nothing , requires = makeTruePredicate_ , rhs = injectTermIntoRHS right , attributes = def - { Attribute.trusted = Attribute.Trusted True } } -simplePriorityAxiom +simpleTrustedClaim :: TermLike Variable -> TermLike Variable - -> Integer - -> Rule AllPathRule -simplePriorityAxiom left right priority = - AllPathRewriteRule . RewriteRule - $ RulePattern + -> ReachabilityRule +simpleTrustedClaim left right = + (AllPath . AllPathRule) + RulePattern { left = left , antiLeft = Nothing , requires = makeTruePredicate_ , rhs = injectTermIntoRHS right , attributes = def - { Attribute.priority = Attribute.Priority (Just priority) - } + { Attribute.trusted = Attribute.Trusted True } } diff --git a/kore/test/Test/Kore/Strategies/Common.hs b/kore/test/Test/Kore/Strategies/Common.hs index a614c89609..ab2435e104 100644 --- a/kore/test/Test/Kore/Strategies/Common.hs +++ b/kore/test/Test/Kore/Strategies/Common.hs @@ -16,9 +16,6 @@ import Numeric.Natural ( Natural ) -import qualified Kore.Attribute.Trusted as Attribute - ( Trusted - ) import Kore.Internal.Pattern ( Pattern ) @@ -55,16 +52,11 @@ simpleRewrite left right = RewriteRule $ rulePattern left right runVerificationToPattern - :: Verification.Claim claim - => ProofState claim (Pattern Variable) ~ Verification.CommonProofState - => Show claim - => Show (Rule claim) - => From claim Attribute.Trusted - => Limit Natural + :: Limit Natural -> Limit Natural - -> [Rule claim] - -> [claim] - -> [claim] + -> [Rule ReachabilityRule] + -> [ReachabilityRule] + -> [ReachabilityRule] -> IO (Either (Pattern Variable) ()) runVerificationToPattern breadthLimit depthLimit axioms claims alreadyProven = do @@ -82,17 +74,12 @@ runVerificationToPattern breadthLimit depthLimit axioms claims alreadyProven = runVerification - :: Verification.Claim claim - => ProofState claim (Pattern Variable) ~ Verification.CommonProofState - => Show claim - => Show (Rule claim) - => From claim Attribute.Trusted - => Limit Natural + :: Limit Natural -> Limit Natural - -> [Rule claim] - -> [claim] - -> [claim] - -> IO (Either (StuckVerification (Pattern Variable) claim) ()) + -> [Rule ReachabilityRule] + -> [ReachabilityRule] + -> [ReachabilityRule] + -> IO (Either (StuckVerification (Pattern Variable) ReachabilityRule) ()) runVerification breadthLimit depthLimit axioms claims alreadyProven = runSimplifier mockEnv $ do SMT.AST.declare Mock.smtDeclarations diff --git a/kore/test/Test/Kore/Strategies/OnePath/Verification.hs b/kore/test/Test/Kore/Strategies/OnePath/Verification.hs index df2f201a2b..f54cea4506 100644 --- a/kore/test/Test/Kore/Strategies/OnePath/Verification.hs +++ b/kore/test/Test/Kore/Strategies/OnePath/Verification.hs @@ -29,6 +29,7 @@ import Kore.Internal.Predicate import Kore.Internal.TermLike import Kore.Step.RulePattern ( OnePathRule (..) + , ReachabilityRule (..) , RewriteRule (..) , RulePattern (..) , injectTermIntoRHS @@ -468,52 +469,52 @@ test_onePathVerification = simpleAxiom :: TermLike Variable -> TermLike Variable - -> Rule OnePathRule + -> Rule ReachabilityRule simpleAxiom left right = - OnePathRewriteRule $ simpleRewrite left right + ReachabilityRewriteRule $ simpleRewrite left right -simpleClaim +simplePriorityAxiom :: TermLike Variable -> TermLike Variable - -> OnePathRule -simpleClaim left right = - OnePathRule - RulePattern + -> Integer + -> Rule ReachabilityRule +simplePriorityAxiom left right priority = + ReachabilityRewriteRule . RewriteRule + $ RulePattern { left = left , antiLeft = Nothing , requires = makeTruePredicate_ , rhs = injectTermIntoRHS right , attributes = def + { Attribute.priority = Attribute.Priority (Just priority) + } } -simpleTrustedClaim +simpleClaim :: TermLike Variable -> TermLike Variable - -> OnePathRule -simpleTrustedClaim left right = - OnePathRule + -> ReachabilityRule +simpleClaim left right = + (OnePath . OnePathRule) RulePattern { left = left , antiLeft = Nothing , requires = makeTruePredicate_ , rhs = injectTermIntoRHS right , attributes = def - { Attribute.trusted = Attribute.Trusted True } } -simplePriorityAxiom +simpleTrustedClaim :: TermLike Variable -> TermLike Variable - -> Integer - -> Rule OnePathRule -simplePriorityAxiom left right priority = - OnePathRewriteRule . RewriteRule - $ RulePattern + -> ReachabilityRule +simpleTrustedClaim left right = + (OnePath . OnePathRule) + RulePattern { left = left , antiLeft = Nothing , requires = makeTruePredicate_ , rhs = injectTermIntoRHS right , attributes = def - { Attribute.priority = Attribute.Priority (Just priority) - } + { Attribute.trusted = Attribute.Trusted True } } From 17ff4554a2d798309c8f8a82f574e089fb24084a Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 16:11:09 -0500 Subject: [PATCH 38/79] Kore.Strategies.Verification.verifyHelper: Specialize to ReachabilityRule --- kore/src/Kore/Strategies/Verification.hs | 24 ++++++++++-------------- 1 file changed, 10 insertions(+), 14 deletions(-) diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index eddb250f8a..70a34d2114 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -192,20 +192,16 @@ verify { stuckDescription, provenClaims = stillProven ++ provenClaims } verifyHelper - :: forall claim m - . Claim claim - => ProofState claim (Pattern Variable) ~ CommonProofState - => Show claim - => (MonadCatch m, MonadSimplify m) - => Show (Rule claim) + :: forall m + . (MonadCatch m, MonadSimplify m) => Limit Natural -> GraphSearchOrder - -> AllClaims claim - -> Axioms claim - -> ToProve claim + -> AllClaims ReachabilityRule + -> Axioms ReachabilityRule + -> ToProve ReachabilityRule -- ^ List of claims, together with a maximum number of verification steps -- for each. - -> ExceptT (StuckVerification (Pattern Variable) claim) m () + -> ExceptT (StuckVerification (Pattern Variable) ReachabilityRule) m () verifyHelper breadthLimit searchOrder @@ -216,16 +212,16 @@ verifyHelper Monad.foldM_ verifyWorker [] toProve where verifyWorker - :: [claim] - -> (claim, Limit Natural) - -> ExceptT (StuckVerification (Pattern Variable) claim) m [claim] + :: [ReachabilityRule] + -> (ReachabilityRule, Limit Natural) + -> ExceptT (StuckVerification (Pattern Variable) ReachabilityRule) m [ReachabilityRule] verifyWorker provenClaims unprovenClaim@(claim, _) = withExceptT wrapStuckPattern $ do verifyClaim breadthLimit searchOrder claims axioms unprovenClaim return (claim : provenClaims) where wrapStuckPattern - :: Pattern Variable -> StuckVerification (Pattern Variable) claim + :: Pattern Variable -> StuckVerification (Pattern Variable) ReachabilityRule wrapStuckPattern stuckDescription = StuckVerification { stuckDescription, provenClaims } From 70c2e5bf0587f9ee22868b386b199d49c8ce0a97 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 16:27:14 -0500 Subject: [PATCH 39/79] Kore.Strategies.Verification.Stuck: Specialize type --- kore/app/exec/Main.hs | 8 +-- kore/src/Kore/Exec.hs | 35 ++---------- kore/src/Kore/Strategies/Verification.hs | 56 +++++++++---------- kore/test/Test/Kore/Strategies/Common.hs | 10 ++-- .../Kore/Strategies/OnePath/Verification.hs | 13 ++--- 5 files changed, 46 insertions(+), 76 deletions(-) diff --git a/kore/app/exec/Main.hs b/kore/app/exec/Main.hs index 1ead9cffb9..ecbabf2613 100644 --- a/kore/app/exec/Main.hs +++ b/kore/app/exec/Main.hs @@ -85,6 +85,7 @@ import Kore.Internal.Pattern ( Conditional (..) , Pattern ) +import qualified Kore.Internal.Pattern as Pattern import Kore.Internal.Predicate ( makePredicate ) @@ -134,9 +135,8 @@ import qualified Kore.Step.Search as Search import Kore.Step.SMT.Lemma import qualified Kore.Strategies.Goal as Goal import Kore.Strategies.Verification - ( StuckVerification (StuckVerification) + ( Stuck (..) ) -import qualified Kore.Strategies.Verification as Verification.DoNotUse import Kore.Syntax.Definition ( Definition (Definition) , Module (Module) @@ -508,12 +508,12 @@ koreProve execOptions proveOptions = do maybeAlreadyProvenModule (exitCode, final) <- case proveResult of - Left StuckVerification {stuckDescription, provenClaims} -> do + Left Stuck { stuckPattern, provenClaims } -> do maybe (return ()) (lift . saveProven specModule provenClaims) saveProofs - return (failure stuckDescription) + return (failure $ Pattern.toTermLike stuckPattern) Right () -> return success lift $ renderResult execOptions (unparse final) diff --git a/kore/src/Kore/Exec.hs b/kore/src/Kore/Exec.hs index 13aba0d4c7..4e756cd251 100644 --- a/kore/src/Kore/Exec.hs +++ b/kore/src/Kore/Exec.hs @@ -35,8 +35,7 @@ import Control.Monad.Trans.Except ( runExceptT ) import qualified Data.Bifunctor as Bifunctor - ( first - , second + ( second ) import Data.Coerce ( coerce @@ -153,13 +152,10 @@ import Kore.Strategies.Verification , AlreadyProven (AlreadyProven) , Axioms (Axioms) , Claim - , StuckVerification (StuckVerification) + , Stuck (..) , ToProve (ToProve) , verify ) -import qualified Kore.Strategies.Verification as StuckVerification - ( StuckVerification (..) - ) import Kore.Syntax.Module ( ModuleName ) @@ -318,11 +314,7 @@ prove -- ^ The spec module -> Maybe (VerifiedModule StepperAttributes) -- ^ The module containing the claims that were proven in a previous run. - -> smt - (Either - (StuckVerification (TermLike Variable) ReachabilityRule) - () - ) + -> smt (Either Stuck ()) prove searchOrder breadthLimit @@ -347,25 +339,10 @@ prove (extractUntrustedClaims' claims) ) ) - return $ Bifunctor.first stuckVerificationPatternToTerm result + return result where - extractUntrustedClaims' - :: [ReachabilityRule] - -> [ReachabilityRule] - extractUntrustedClaims' = - filter (not . Goal.isTrusted) - - stuckVerificationPatternToTerm - :: StuckVerification (Pattern Variable) claim - -> StuckVerification (TermLike Variable) claim - stuckVerificationPatternToTerm - stuck@StuckVerification {stuckDescription} - = - stuck - { StuckVerification.stuckDescription = - Pattern.toTermLike stuckDescription - } - + extractUntrustedClaims' :: [ReachabilityRule] -> [ReachabilityRule] + extractUntrustedClaims' = filter (not . Goal.isTrusted) -- | Initialize and run the repl with the main and spec modules. This will loop -- the repl until the user exits. diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index 70a34d2114..5dd5d1b213 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -9,7 +9,7 @@ This should be imported qualified. module Kore.Strategies.Verification ( Claim , CommonProofState - , StuckVerification (..) + , Stuck (..) , AllClaims (..) , Axioms (..) , ToProve (..) @@ -61,8 +61,15 @@ import Kore.Step.RulePattern ) import Kore.Step.Simplification.Simplify import Kore.Step.Strategy + ( ExecutionGraph (..) + , GraphSearchOrder + , Strategy + , executionHistoryStep + , runStrategyWithSearchOrder + ) import Kore.Step.Transition - ( runTransitionT + ( TransitionT + , runTransitionT ) import qualified Kore.Step.Transition as Transition import Kore.Strategies.Goal @@ -118,26 +125,24 @@ first step, it also uses the claims as axioms (i.e. it does coinductive proofs). If the verification fails, returns an error containing a pattern that could not be rewritten (either because no axiom could be applied or because we -didn't manage to verify a claim within the its maximum number of steps. +didn't manage to verify a claim within the its maximum number of steps). If the verification succeeds, it returns (). -} --- TODO (thomas.tuegel): Specialize type of StuckVerification. -data StuckVerification patt claim - = StuckVerification - { stuckDescription :: !patt - , provenClaims :: ![claim] - } +data Stuck = + Stuck + { stuckPattern :: !(Pattern Variable) + , provenClaims :: ![ReachabilityRule] + } deriving (Eq, GHC.Generic, Show) -instance SOP.Generic (StuckVerification patt claim) +instance SOP.Generic Stuck -instance SOP.HasDatatypeInfo (StuckVerification patt claim) +instance SOP.HasDatatypeInfo Stuck -instance (Debug patt, Debug claim) => Debug (StuckVerification patt claim) +instance Debug Stuck -instance (Debug patt, Debug claim, Diff patt, Diff claim) - => Diff (StuckVerification patt claim) +instance Diff Stuck newtype AllClaims claim = AllClaims {getAllClaims :: [claim]} newtype Axioms claim = Axioms {getAxioms :: [Rule claim]} @@ -155,7 +160,7 @@ verify -> ToProve ReachabilityRule -- ^ List of claims, together with a maximum number of verification steps -- for each. - -> ExceptT (StuckVerification (Pattern Variable) ReachabilityRule) m () + -> ExceptT Stuck m () verify breadthLimit searchOrder @@ -182,14 +187,9 @@ verify then Right rule else Left claim - addStillProven - :: StuckVerification (Pattern Variable) ReachabilityRule - -> StuckVerification (Pattern Variable) ReachabilityRule - addStillProven - StuckVerification { stuckDescription, provenClaims } - = - StuckVerification - { stuckDescription, provenClaims = stillProven ++ provenClaims } + addStillProven :: Stuck -> Stuck + addStillProven stuck@Stuck { provenClaims } = + stuck { provenClaims = stillProven ++ provenClaims } verifyHelper :: forall m @@ -201,7 +201,7 @@ verifyHelper -> ToProve ReachabilityRule -- ^ List of claims, together with a maximum number of verification steps -- for each. - -> ExceptT (StuckVerification (Pattern Variable) ReachabilityRule) m () + -> ExceptT Stuck m () verifyHelper breadthLimit searchOrder @@ -214,16 +214,14 @@ verifyHelper verifyWorker :: [ReachabilityRule] -> (ReachabilityRule, Limit Natural) - -> ExceptT (StuckVerification (Pattern Variable) ReachabilityRule) m [ReachabilityRule] + -> ExceptT Stuck m [ReachabilityRule] verifyWorker provenClaims unprovenClaim@(claim, _) = withExceptT wrapStuckPattern $ do verifyClaim breadthLimit searchOrder claims axioms unprovenClaim return (claim : provenClaims) where - wrapStuckPattern - :: Pattern Variable -> StuckVerification (Pattern Variable) ReachabilityRule - wrapStuckPattern stuckDescription = - StuckVerification { stuckDescription, provenClaims } + wrapStuckPattern :: Pattern Variable -> Stuck + wrapStuckPattern stuckPattern = Stuck { stuckPattern, provenClaims } verifyClaim :: forall claim m diff --git a/kore/test/Test/Kore/Strategies/Common.hs b/kore/test/Test/Kore/Strategies/Common.hs index ab2435e104..555eff3390 100644 --- a/kore/test/Test/Kore/Strategies/Common.hs +++ b/kore/test/Test/Kore/Strategies/Common.hs @@ -9,6 +9,7 @@ import Prelude.Kore import Control.Monad.Trans.Except ( runExceptT ) +import qualified Data.Bifunctor as Bifunctor import Data.Limit ( Limit (..) ) @@ -33,7 +34,7 @@ import Kore.Strategies.Verification ( AllClaims (AllClaims) , AlreadyProven (AlreadyProven) , Axioms (Axioms) - , StuckVerification (StuckVerification) + , Stuck (..) , ToProve (ToProve) ) import qualified Kore.Strategies.Verification as Verification @@ -68,10 +69,7 @@ runVerificationToPattern breadthLimit depthLimit axioms claims alreadyProven = alreadyProven return (toPattern stuck) where - toPattern (Left StuckVerification {stuckDescription}) = - Left stuckDescription - toPattern (Right a) = Right a - + toPattern = Bifunctor.first stuckPattern runVerification :: Limit Natural @@ -79,7 +77,7 @@ runVerification -> [Rule ReachabilityRule] -> [ReachabilityRule] -> [ReachabilityRule] - -> IO (Either (StuckVerification (Pattern Variable) ReachabilityRule) ()) + -> IO (Either Stuck ()) runVerification breadthLimit depthLimit axioms claims alreadyProven = runSimplifier mockEnv $ do SMT.AST.declare Mock.smtDeclarations diff --git a/kore/test/Test/Kore/Strategies/OnePath/Verification.hs b/kore/test/Test/Kore/Strategies/OnePath/Verification.hs index f54cea4506..10c0b26e1a 100644 --- a/kore/test/Test/Kore/Strategies/OnePath/Verification.hs +++ b/kore/test/Test/Kore/Strategies/OnePath/Verification.hs @@ -36,10 +36,7 @@ import Kore.Step.RulePattern ) import Kore.Strategies.Goal import Kore.Strategies.Verification - ( StuckVerification (StuckVerification) - ) -import qualified Kore.Strategies.Verification as Verification.DoNotUse - ( StuckVerification (..) + ( Stuck (..) ) import qualified Test.Kore.Step.MockSymbols as Mock @@ -237,8 +234,8 @@ test_onePathVerification = ] [] assertEqual "" - (Left StuckVerification - { stuckDescription = Pattern.fromTermLike Mock.c + (Left Stuck + { stuckPattern = Pattern.fromTermLike Mock.c , provenClaims = [] } ) @@ -262,8 +259,8 @@ test_onePathVerification = ] [] assertEqual "" - (Left StuckVerification - { stuckDescription = Pattern.fromTermLike Mock.e + (Left Stuck + { stuckPattern = Pattern.fromTermLike Mock.e , provenClaims = [simpleClaim Mock.a Mock.c] } ) From 82de42185b691bebe5283620524ddd1f28c5688a Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 16:30:16 -0500 Subject: [PATCH 40/79] Kore.Strategies.Verification.verifyClaim: Specialize type to ReachabilityRule --- kore/src/Kore/Strategies/Verification.hs | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index 5dd5d1b213..4e1ea1ae08 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -224,17 +224,13 @@ verifyHelper wrapStuckPattern stuckPattern = Stuck { stuckPattern, provenClaims } verifyClaim - :: forall claim m + :: forall m . (MonadCatch m, MonadSimplify m) - => ProofState claim (Pattern Variable) ~ CommonProofState - => Claim claim - => Show claim - => Show (Rule claim) => Limit Natural -> GraphSearchOrder - -> AllClaims claim - -> Axioms claim - -> (claim, Limit Natural) + -> AllClaims ReachabilityRule + -> Axioms ReachabilityRule + -> (ReachabilityRule, Limit Natural) -> ExceptT (Pattern Variable) m () verifyClaim breadthLimit @@ -263,9 +259,9 @@ verifyClaim where modifiedTransitionRule :: RHS Variable - -> Prim claim + -> Prim ReachabilityRule -> CommonProofState - -> TransitionT (Rule claim) (Verifier m) CommonProofState + -> TransitionT (Rule ReachabilityRule) (Verifier m) CommonProofState modifiedTransitionRule destination prim proofState' = do transitions <- lift . lift . runTransitionT From b88fa643d5538ef2c1708fa5409b618fde8899ba Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 16:31:03 -0500 Subject: [PATCH 41/79] Kore.Strategies.Verification.verifyClaimStep: Specialize type to ReachabilityRule --- kore/src/Kore/Strategies/Verification.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index 4e1ea1ae08..bbb84e20f5 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -272,20 +272,19 @@ verifyClaim -- in the execution graph designated by the provided node. Re-constructs the -- execution graph by inserting this step. verifyClaimStep - :: forall claim m + :: forall m . (MonadCatch m, MonadSimplify m) - => Claim claim - => claim + => ReachabilityRule -- ^ claim that is being proven - -> [claim] + -> [ReachabilityRule] -- ^ list of claims in the spec module - -> [Rule claim] + -> [Rule ReachabilityRule] -- ^ list of axioms in the main module - -> ExecutionGraph CommonProofState (Rule claim) + -> ExecutionGraph CommonProofState (Rule ReachabilityRule) -- ^ current execution graph -> Graph.Node -- ^ selected node in the graph - -> m (ExecutionGraph CommonProofState (Rule claim)) + -> m (ExecutionGraph CommonProofState (Rule ReachabilityRule)) verifyClaimStep target claims @@ -300,15 +299,15 @@ verifyClaimStep eg node where - strategy' :: Strategy (Prim claim) + strategy' :: Strategy (Prim ReachabilityRule) strategy' | isRoot = firstStep | otherwise = followupStep - firstStep :: Strategy (Prim claim) + firstStep :: Strategy (Prim ReachabilityRule) firstStep = strategy target claims axioms Stream.!! 0 - followupStep :: Strategy (Prim claim) + followupStep :: Strategy (Prim ReachabilityRule) followupStep = strategy target claims axioms Stream.!! 1 isRoot :: Bool From eb4b83b7bdcba59063d610df22b326bd29cf04d7 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 16:31:40 -0500 Subject: [PATCH 42/79] Kore.Strategies.Verification.transitionRule': Specialize type to ReachabilityRule --- kore/src/Kore/Strategies/Verification.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index bbb84e20f5..af3bf89718 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -314,14 +314,13 @@ verifyClaimStep isRoot = node == root transitionRule' - :: forall claim m + :: forall m . (MonadCatch m, MonadSimplify m) - => Claim claim - => claim + => ReachabilityRule -> RHS Variable - -> Prim claim + -> Prim ReachabilityRule -> CommonProofState - -> TransitionT (Rule claim) m CommonProofState + -> TransitionT (Rule ReachabilityRule) m CommonProofState transitionRule' ruleType destination prim state = do let goal = flip (configurationDestinationToRule ruleType) destination <$> state next <- transitionRule prim goal From 20c3d0cb71b92e486134ac488ba035201fd2a76b Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 16:35:11 -0500 Subject: [PATCH 43/79] Kore.Strategies.Verification: Clean up --- kore/src/Kore/Strategies/Verification.hs | 68 ++++++++++-------------- 1 file changed, 27 insertions(+), 41 deletions(-) diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index af3bf89718..03e9ead5c7 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -82,7 +82,7 @@ import Kore.Syntax.Variable ) import Kore.Unparser -type CommonProofState = ProofState.ProofState (Pattern Variable) +type CommonProofState = ProofState.ProofState (Pattern Variable) commonProofStateTransformer :: ProofStateTransformer (Pattern Variable) (Pattern Variable) commonProofStateTransformer = @@ -150,8 +150,8 @@ newtype ToProve claim = ToProve {getToProve :: [(claim, Limit Natural)]} newtype AlreadyProven = AlreadyProven {getAlreadyProven :: [Text]} verify - :: forall m - . (MonadCatch m, MonadSimplify m) + :: forall simplifier + . (MonadCatch simplifier, MonadSimplify simplifier) => Limit Natural -> GraphSearchOrder -> AllClaims ReachabilityRule @@ -160,7 +160,7 @@ verify -> ToProve ReachabilityRule -- ^ List of claims, together with a maximum number of verification steps -- for each. - -> ExceptT Stuck m () + -> ExceptT Stuck simplifier () verify breadthLimit searchOrder @@ -192,8 +192,8 @@ verify stuck { provenClaims = stillProven ++ provenClaims } verifyHelper - :: forall m - . (MonadCatch m, MonadSimplify m) + :: forall simplifier + . (MonadCatch simplifier, MonadSimplify simplifier) => Limit Natural -> GraphSearchOrder -> AllClaims ReachabilityRule @@ -201,20 +201,14 @@ verifyHelper -> ToProve ReachabilityRule -- ^ List of claims, together with a maximum number of verification steps -- for each. - -> ExceptT Stuck m () -verifyHelper - breadthLimit - searchOrder - claims - axioms - (ToProve toProve) - = + -> ExceptT Stuck simplifier () +verifyHelper breadthLimit searchOrder claims axioms (ToProve toProve) = Monad.foldM_ verifyWorker [] toProve where verifyWorker :: [ReachabilityRule] -> (ReachabilityRule, Limit Natural) - -> ExceptT Stuck m [ReachabilityRule] + -> ExceptT Stuck simplifier [ReachabilityRule] verifyWorker provenClaims unprovenClaim@(claim, _) = withExceptT wrapStuckPattern $ do verifyClaim breadthLimit searchOrder claims axioms unprovenClaim @@ -224,14 +218,14 @@ verifyHelper wrapStuckPattern stuckPattern = Stuck { stuckPattern, provenClaims } verifyClaim - :: forall m - . (MonadCatch m, MonadSimplify m) + :: forall simplifier + . (MonadCatch simplifier, MonadSimplify simplifier) => Limit Natural -> GraphSearchOrder -> AllClaims ReachabilityRule -> Axioms ReachabilityRule -> (ReachabilityRule, Limit Natural) - -> ExceptT (Pattern Variable) m () + -> ExceptT (Pattern Variable) simplifier () verifyClaim breadthLimit searchOrder @@ -258,10 +252,11 @@ verifyClaim Foldable.traverse_ Monad.Except.throwError (unprovenNodes executionGraph) where modifiedTransitionRule - :: RHS Variable - -> Prim ReachabilityRule - -> CommonProofState - -> TransitionT (Rule ReachabilityRule) (Verifier m) CommonProofState + :: RHS Variable + -> Prim ReachabilityRule + -> CommonProofState + -> TransitionT (Rule ReachabilityRule) (Verifier simplifier) + CommonProofState modifiedTransitionRule destination prim proofState' = do transitions <- lift . lift . runTransitionT @@ -272,8 +267,8 @@ verifyClaim -- in the execution graph designated by the provided node. Re-constructs the -- execution graph by inserting this step. verifyClaimStep - :: forall m - . (MonadCatch m, MonadSimplify m) + :: forall simplifier + . (MonadCatch simplifier, MonadSimplify simplifier) => ReachabilityRule -- ^ claim that is being proven -> [ReachabilityRule] @@ -284,21 +279,12 @@ verifyClaimStep -- ^ current execution graph -> Graph.Node -- ^ selected node in the graph - -> m (ExecutionGraph CommonProofState (Rule ReachabilityRule)) -verifyClaimStep - target - claims - axioms - eg@ExecutionGraph { root } - node - = do - let destination = getDestination target - executionHistoryStep - (transitionRule' target destination) - strategy' - eg - node + -> simplifier (ExecutionGraph CommonProofState (Rule ReachabilityRule)) +verifyClaimStep target claims axioms eg@ExecutionGraph { root } node = + executionHistoryStep (transitionRule' target destination) strategy' eg node where + destination = getDestination target + strategy' :: Strategy (Prim ReachabilityRule) strategy' | isRoot = firstStep @@ -314,13 +300,13 @@ verifyClaimStep isRoot = node == root transitionRule' - :: forall m - . (MonadCatch m, MonadSimplify m) + :: forall simplifier + . (MonadCatch simplifier, MonadSimplify simplifier) => ReachabilityRule -> RHS Variable -> Prim ReachabilityRule -> CommonProofState - -> TransitionT (Rule ReachabilityRule) m CommonProofState + -> TransitionT (Rule ReachabilityRule) simplifier CommonProofState transitionRule' ruleType destination prim state = do let goal = flip (configurationDestinationToRule ruleType) destination <$> state next <- transitionRule prim goal From 25356ba9676e04fed145d44201bc2d60b73fa3e1 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 16:37:25 -0500 Subject: [PATCH 44/79] Remove type Kore.Strategies.Verification.Claim --- kore/src/Kore/Exec.hs | 7 +++---- kore/src/Kore/Repl/State.hs | 4 +--- kore/src/Kore/Strategies/Verification.hs | 23 +---------------------- 3 files changed, 5 insertions(+), 29 deletions(-) diff --git a/kore/src/Kore/Exec.hs b/kore/src/Kore/Exec.hs index 4e756cd251..3967cd147c 100644 --- a/kore/src/Kore/Exec.hs +++ b/kore/src/Kore/Exec.hs @@ -151,7 +151,6 @@ import Kore.Strategies.Verification ( AllClaims (AllClaims) , AlreadyProven (AlreadyProven) , Axioms (Axioms) - , Claim , Stuck (..) , ToProve (ToProve) , verify @@ -565,9 +564,9 @@ makeImplicationRule (attributes, ImplicationRule rulePattern) = ImplicationRule rulePattern { attributes } simplifyRuleOnSecond - :: (MonadSimplify simplifier, Claim claim) - => (Attribute.Axiom Symbol variable, claim) - -> simplifier (Attribute.Axiom Symbol variable, claim) + :: MonadSimplify simplifier + => (Attribute.Axiom Symbol variable, ReachabilityRule) + -> simplifier (Attribute.Axiom Symbol variable, ReachabilityRule) simplifyRuleOnSecond (atts, rule) = do rule' <- Rule.simplifyRewriteRule (RewriteRule . Goal.toRulePattern $ rule) return (atts, Goal.fromRulePattern rule . getRewriteRule $ rule') diff --git a/kore/src/Kore/Repl/State.hs b/kore/src/Kore/Repl/State.hs index c90fbc4dc0..fe5cac392a 100644 --- a/kore/src/Kore/Repl/State.hs +++ b/kore/src/Kore/Repl/State.hs @@ -140,9 +140,7 @@ import Kore.Strategies.ProofState , proofState ) import qualified Kore.Strategies.ProofState as ProofState.DoNotUse -import Kore.Strategies.Verification hiding - ( Claim - ) +import Kore.Strategies.Verification import Kore.Syntax.Definition ( Definition (..) , Module (..) diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index 03e9ead5c7..4fab371ae5 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -7,8 +7,7 @@ This should be imported qualified. -} module Kore.Strategies.Verification - ( Claim - , CommonProofState + ( CommonProofState , Stuck (..) , AllClaims (..) , Axioms (..) @@ -54,8 +53,6 @@ import Kore.Internal.Pattern ( Pattern ) import qualified Kore.Internal.Pattern as Pattern -import Kore.Step.Rule.Expand -import Kore.Step.Rule.Simplify import Kore.Step.RulePattern ( RHS ) @@ -94,24 +91,6 @@ commonProofStateTransformer = , provenValue = Pattern.bottom } -{- | Class type for claim-like rules --} -type Claim claim = - ( ToRulePattern claim - , ToRulePattern (Rule claim) - , FromRulePattern claim - , FromRulePattern (Rule claim) - , Unparse claim - , Unparse (Rule claim) - , Goal claim - , ClaimExtractor claim - , ExpandSingleConstructors claim - , SimplifyRuleLHS claim - , Typeable claim - , Prim claim ~ ProofState.Prim (Rule claim) - , ProofState claim claim ~ ProofState.ProofState claim - ) - {- | @Verifer a@ is a 'Simplifier'-based action which returns an @a@. The action may throw an exception if the proof fails; the exception is a single From 6c508c348af3d7f45019cbdd726de40ecc5edbd7 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 4 May 2020 16:38:31 -0500 Subject: [PATCH 45/79] Kore.Strategies.Verification: TODO --- kore/src/Kore/Strategies/Verification.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index 4fab371ae5..9cc34e3852 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -79,6 +79,7 @@ import Kore.Syntax.Variable ) import Kore.Unparser +-- TODO (thomas.tuegel): (Pattern Variable) should be ReachabilityRule. type CommonProofState = ProofState.ProofState (Pattern Variable) commonProofStateTransformer :: ProofStateTransformer (Pattern Variable) (Pattern Variable) From c59d88151f1aa79e566b522bf6c2c50048d83e59 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 06:55:04 -0500 Subject: [PATCH 46/79] Kore.Strategies.Goal: Remove ToRulePattern --- kore/src/Kore/Exec.hs | 3 ++- kore/src/Kore/Repl.hs | 3 +++ kore/src/Kore/Repl/Interpreter.hs | 7 ++----- kore/src/Kore/Strategies/Goal.hs | 14 +++----------- kore/src/Kore/Strategies/Verification.hs | 1 - 5 files changed, 10 insertions(+), 18 deletions(-) diff --git a/kore/src/Kore/Exec.hs b/kore/src/Kore/Exec.hs index 3967cd147c..43cbc6eb03 100644 --- a/kore/src/Kore/Exec.hs +++ b/kore/src/Kore/Exec.hs @@ -125,6 +125,7 @@ import Kore.Step.RulePattern , ReachabilityRule (..) , RewriteRule (RewriteRule) , RulePattern (RulePattern) + , ToRulePattern (..) , getRewriteRule ) import Kore.Step.RulePattern as RulePattern @@ -568,7 +569,7 @@ simplifyRuleOnSecond => (Attribute.Axiom Symbol variable, ReachabilityRule) -> simplifier (Attribute.Axiom Symbol variable, ReachabilityRule) simplifyRuleOnSecond (atts, rule) = do - rule' <- Rule.simplifyRewriteRule (RewriteRule . Goal.toRulePattern $ rule) + rule' <- Rule.simplifyRewriteRule (RewriteRule . toRulePattern $ rule) return (atts, Goal.fromRulePattern rule . getRewriteRule $ rule') -- | Construct an execution graph for the given input pattern. diff --git a/kore/src/Kore/Repl.hs b/kore/src/Kore/Repl.hs index 7b1af55a1a..d35940215b 100644 --- a/kore/src/Kore/Repl.hs +++ b/kore/src/Kore/Repl.hs @@ -68,6 +68,9 @@ import Kore.Repl.Data import Kore.Repl.Interpreter import Kore.Repl.Parser import Kore.Repl.State +import Kore.Step.RulePattern + ( ToRulePattern (..) + ) import qualified Kore.Step.RulePattern as Rule import Kore.Step.Simplification.Data ( MonadSimplify diff --git a/kore/src/Kore/Repl/Interpreter.hs b/kore/src/Kore/Repl/Interpreter.hs index 9905f57bee..bd445310c8 100644 --- a/kore/src/Kore/Repl/Interpreter.hs +++ b/kore/src/Kore/Repl/Interpreter.hs @@ -181,8 +181,8 @@ import Kore.Repl.State import Kore.Step.RulePattern ( ReachabilityRule (..) , RulePattern (..) + , ToRulePattern (..) ) -import qualified Kore.Step.RulePattern as Rule import Kore.Step.Simplification.Data ( MonadSimplify ) @@ -623,13 +623,10 @@ showRule configNode = do Just rule -> do axioms <- Lens.use (field @"axioms") tell . showRewriteRule $ rule - let ruleIndex = getRuleIndex . toRulePattern $ rule + let ruleIndex = from @_ @Attribute.RuleIndex rule putStrLn' $ fromMaybe "Error: identifier attribute wasn't initialized." $ showAxiomOrClaim (length axioms) ruleIndex - where - getRuleIndex :: RulePattern Variable -> Attribute.RuleIndex - getRuleIndex = Attribute.identifier . Rule.attributes -- | Shows the previous branching point. showPrecBranch diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 1dab0a4f32..2d419ea14c 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -4,7 +4,6 @@ License : NCSA -} module Kore.Strategies.Goal ( Goal (..) - , ToRulePattern (..) , FromRulePattern (..) , ClaimExtractor (..) , TransitionRuleTemplate (..) @@ -136,6 +135,7 @@ import Kore.Step.RulePattern , RewriteRule (..) , RulePattern (..) , ToRulePattern (..) + , ToRulePattern (..) , topExistsToImplicitForall ) import qualified Kore.Step.RulePattern as RulePattern @@ -1070,19 +1070,11 @@ removalPredicate extractElementVariable (remainderVariables config dest) -getConfiguration - :: forall goal - . ToRulePattern goal - => goal - -> Pattern Variable +getConfiguration :: ReachabilityRule -> Pattern Variable getConfiguration (toRulePattern -> RulePattern { left, requires }) = Pattern.withCondition left (Conditional.fromPredicate requires) -getDestination - :: forall goal - . ToRulePattern goal - => goal - -> RHS Variable +getDestination :: ReachabilityRule -> RHS Variable getDestination (toRulePattern -> RulePattern { rhs }) = rhs {-| Given a rule to use as a prototype, a 'Pattern' to use as the configuration diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index 9cc34e3852..63e625f891 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -15,7 +15,6 @@ module Kore.Strategies.Verification , AlreadyProven (..) , verify , verifyClaimStep - , toRulePattern , commonProofStateTransformer ) where From 5706096678e512a0d1eb9ff2e82ea962489f7258 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 09:45:08 -0500 Subject: [PATCH 47/79] Remove function Kore.Strategies.Goal.configurationDestinationToRule --- kore/src/Kore/Strategies/Goal.hs | 24 --------------- kore/src/Kore/Strategies/Verification.hs | 37 ++++++++++++++++++------ 2 files changed, 28 insertions(+), 33 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 2d419ea14c..8bd791cf8b 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -15,7 +15,6 @@ module Kore.Strategies.Goal , onePathFollowupStep , allPathFirstStep , allPathFollowupStep - , configurationDestinationToRule , getConfiguration , getDestination , transitionRuleTemplate @@ -49,7 +48,6 @@ import Data.Coerce ( Coercible , coerce ) -import qualified Data.Default as Default import qualified Data.Foldable as Foldable import Data.Functor.Compose import Data.Generics.Product @@ -106,7 +104,6 @@ import Kore.Internal.Symbol import Kore.Internal.TermLike ( isFunctionPattern , mkAnd - , termLikeSort ) import Kore.Log.DebugProofState import Kore.Log.ErrorRewritesInstantiation @@ -1077,27 +1074,6 @@ getConfiguration (toRulePattern -> RulePattern { left, requires }) = getDestination :: ReachabilityRule -> RHS Variable getDestination (toRulePattern -> RulePattern { rhs }) = rhs -{-| Given a rule to use as a prototype, a 'Pattern' to use as the configuration -and a 'RHS' containing the destination, makes a rule out of them. --} -configurationDestinationToRule - :: forall rule - . FromRulePattern rule - => rule - -> Pattern Variable - -> RHS Variable - -> rule -configurationDestinationToRule ruleType configuration rhs = - let (left, Condition.toPredicate -> requires') = - Pattern.splitTerm configuration - in fromRulePattern ruleType $ RulePattern - { left - , antiLeft = Nothing - , requires = Predicate.coerceSort (termLikeSort left) requires' - , rhs - , attributes = Default.def - } - class ToReachabilityRule rule where toReachabilityRule :: rule -> ReachabilityRule diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index 63e625f891..ff1d7159fa 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -20,6 +20,7 @@ module Kore.Strategies.Verification import Prelude.Kore +import qualified Control.Lens as Lens import qualified Control.Monad as Monad ( foldM_ ) @@ -53,7 +54,11 @@ import Kore.Internal.Pattern ) import qualified Kore.Internal.Pattern as Pattern import Kore.Step.RulePattern - ( RHS + ( AllPathRule (..) + , OnePathRule (..) + , RHS + , ReachabilityRule (..) + , leftPattern ) import Kore.Step.Simplification.Simplify import Kore.Step.Strategy @@ -215,7 +220,6 @@ verifyClaim traceExceptT D_OnePath_verifyClaim [debugArg "rule" goal] $ do let startPattern = ProofState.Goal $ getConfiguration goal - destination = getDestination goal limitedStrategy = Limit.takeWithin depthLimit @@ -223,20 +227,20 @@ verifyClaim executionGraph <- runStrategyWithSearchOrder breadthLimit - (modifiedTransitionRule destination) + modifiedTransitionRule limitedStrategy searchOrder startPattern -- Throw the first unproven configuration as an error. Foldable.traverse_ Monad.Except.throwError (unprovenNodes executionGraph) where + destination = getDestination goal modifiedTransitionRule - :: RHS Variable - -> Prim ReachabilityRule + :: Prim ReachabilityRule -> CommonProofState -> TransitionT (Rule ReachabilityRule) (Verifier simplifier) CommonProofState - modifiedTransitionRule destination prim proofState' = do + modifiedTransitionRule prim proofState' = do transitions <- lift . lift . runTransitionT $ transitionRule' goal destination prim proofState' @@ -286,7 +290,22 @@ transitionRule' -> Prim ReachabilityRule -> CommonProofState -> TransitionT (Rule ReachabilityRule) simplifier CommonProofState -transitionRule' ruleType destination prim state = do - let goal = flip (configurationDestinationToRule ruleType) destination <$> state - next <- transitionRule prim goal +transitionRule' goal _ prim state = do + let goal' = flip (Lens.set lensReachabilityConfig) goal <$> state + next <- transitionRule prim goal' pure $ fmap getConfiguration next + where + lensReachabilityConfig = + Lens.lens + (\case + OnePath onePathRule -> + Lens.view leftPattern (getOnePathRule onePathRule) + AllPath allPathRule -> + Lens.view leftPattern (getAllPathRule allPathRule) + ) + (\case + OnePath (OnePathRule rulePattern) -> \b -> + (OnePath . OnePathRule) (Lens.set leftPattern b rulePattern) + AllPath (AllPathRule rulePattern) -> \b -> + (AllPath . AllPathRule) (Lens.set leftPattern b rulePattern) + ) From 4260645c7094322d6d83ccf02147a22c599c4e7d Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 09:47:10 -0500 Subject: [PATCH 48/79] Kore.Strategies.Rule: Remove instances of ToRulePattern and FromRulePattern --- kore/src/Kore/Strategies/Rule.hs | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/kore/src/Kore/Strategies/Rule.hs b/kore/src/Kore/Strategies/Rule.hs index 6295e5f3a1..3c20a6aaf5 100644 --- a/kore/src/Kore/Strategies/Rule.hs +++ b/kore/src/Kore/Strategies/Rule.hs @@ -38,11 +38,9 @@ import Kore.Internal.Variable ) import Kore.Step.RulePattern ( AllPathRule - , FromRulePattern , OnePathRule , ReachabilityRule , RewriteRule (..) - , ToRulePattern ) import Kore.Unparser ( Unparse @@ -66,10 +64,6 @@ instance Debug (Rule OnePathRule) instance Diff (Rule OnePathRule) -instance ToRulePattern (Rule OnePathRule) - -instance FromRulePattern (Rule OnePathRule) - instance From (Rule OnePathRule) (Attribute.Priority, Attribute.Owise) where from = from @(RewriteRule _) . unRuleOnePath @@ -87,10 +81,6 @@ instance Debug (Rule AllPathRule) instance Diff (Rule AllPathRule) -instance ToRulePattern (Rule AllPathRule) - -instance FromRulePattern (Rule AllPathRule) - instance From (Rule AllPathRule) (Attribute.Priority, Attribute.Owise) where from = from @(RewriteRule _) . unRuleAllPath @@ -109,10 +99,6 @@ instance Debug (Rule ReachabilityRule) instance Diff (Rule ReachabilityRule) -instance ToRulePattern (Rule ReachabilityRule) - -instance FromRulePattern (Rule ReachabilityRule) - instance From (Rule ReachabilityRule) (Attribute.Priority, Attribute.Owise) where from = from @(RewriteRule _) . unReachabilityRewriteRule From 318b4234eda50feeb149754ef3e5e7fff4c19eb2 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 10:03:53 -0500 Subject: [PATCH 49/79] Revert "Kore.Strategies.Rule: Remove instances of ToRulePattern and FromRulePattern" This reverts commit 4260645c7094322d6d83ccf02147a22c599c4e7d. --- kore/src/Kore/Strategies/Rule.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/kore/src/Kore/Strategies/Rule.hs b/kore/src/Kore/Strategies/Rule.hs index 3c20a6aaf5..6295e5f3a1 100644 --- a/kore/src/Kore/Strategies/Rule.hs +++ b/kore/src/Kore/Strategies/Rule.hs @@ -38,9 +38,11 @@ import Kore.Internal.Variable ) import Kore.Step.RulePattern ( AllPathRule + , FromRulePattern , OnePathRule , ReachabilityRule , RewriteRule (..) + , ToRulePattern ) import Kore.Unparser ( Unparse @@ -64,6 +66,10 @@ instance Debug (Rule OnePathRule) instance Diff (Rule OnePathRule) +instance ToRulePattern (Rule OnePathRule) + +instance FromRulePattern (Rule OnePathRule) + instance From (Rule OnePathRule) (Attribute.Priority, Attribute.Owise) where from = from @(RewriteRule _) . unRuleOnePath @@ -81,6 +87,10 @@ instance Debug (Rule AllPathRule) instance Diff (Rule AllPathRule) +instance ToRulePattern (Rule AllPathRule) + +instance FromRulePattern (Rule AllPathRule) + instance From (Rule AllPathRule) (Attribute.Priority, Attribute.Owise) where from = from @(RewriteRule _) . unRuleAllPath @@ -99,6 +109,10 @@ instance Debug (Rule ReachabilityRule) instance Diff (Rule ReachabilityRule) +instance ToRulePattern (Rule ReachabilityRule) + +instance FromRulePattern (Rule ReachabilityRule) + instance From (Rule ReachabilityRule) (Attribute.Priority, Attribute.Owise) where from = from @(RewriteRule _) . unReachabilityRewriteRule From 6e6944bbe5c3a2f7bb63d9539cb4072daade9608 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 10:30:28 -0500 Subject: [PATCH 50/79] Kore.Repl: Remove constraint ToRulePattern --- kore/src/Kore/Repl.hs | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/kore/src/Kore/Repl.hs b/kore/src/Kore/Repl.hs index d35940215b..7056419781 100644 --- a/kore/src/Kore/Repl.hs +++ b/kore/src/Kore/Repl.hs @@ -16,6 +16,9 @@ import Control.Concurrent.MVar import Control.Exception ( AsyncException (UserInterrupt) ) +import Control.Lens + ( Lens' + ) import qualified Control.Lens as Lens import Control.Monad ( forever @@ -39,6 +42,7 @@ import Control.Monad.State.Strict ) import qualified Data.Default as Default import Data.Generics.Product +import Data.Generics.Wrapped import qualified Data.Graph.Inductive.Graph as Graph import Data.List ( findIndex @@ -68,10 +72,6 @@ import Kore.Repl.Data import Kore.Repl.Interpreter import Kore.Repl.Parser import Kore.Repl.State -import Kore.Step.RulePattern - ( ToRulePattern (..) - ) -import qualified Kore.Step.RulePattern as Rule import Kore.Step.Simplification.Data ( MonadSimplify ) @@ -209,20 +209,14 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d addIndex (rw, n) = modifyAttribute (mapAttribute n (getAttribute rw)) rw - modifyAttribute - :: Attribute.Axiom Symbol Variable - -> Axiom - -> Axiom - modifyAttribute att rule = - let rp = axiomToRulePatt rule in - fromRulePattern rule - $ rp { Rule.attributes = att } + lensAttribute :: Lens' Axiom (Attribute.Axiom Symbol Variable) + lensAttribute = _Unwrapped . _Unwrapped . field @"attributes" - axiomToRulePatt :: Axiom -> Rule.RulePattern Variable - axiomToRulePatt = toRulePattern + modifyAttribute :: Attribute.Axiom Symbol Variable -> Axiom -> Axiom + modifyAttribute = Lens.set lensAttribute getAttribute :: Axiom -> Attribute.Axiom Symbol Variable - getAttribute = Rule.attributes . axiomToRulePatt + getAttribute = Lens.view lensAttribute mapAttribute :: Int From 02e320ef34748a7f3aa4b40f6a40c6272d58bafa Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 10:30:47 -0500 Subject: [PATCH 51/79] Kore.Strategies.Rule: Remove instances of FromRulePattern --- kore/src/Kore/Strategies/Rule.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/kore/src/Kore/Strategies/Rule.hs b/kore/src/Kore/Strategies/Rule.hs index 6295e5f3a1..48bce5dfb0 100644 --- a/kore/src/Kore/Strategies/Rule.hs +++ b/kore/src/Kore/Strategies/Rule.hs @@ -38,7 +38,6 @@ import Kore.Internal.Variable ) import Kore.Step.RulePattern ( AllPathRule - , FromRulePattern , OnePathRule , ReachabilityRule , RewriteRule (..) @@ -68,8 +67,6 @@ instance Diff (Rule OnePathRule) instance ToRulePattern (Rule OnePathRule) -instance FromRulePattern (Rule OnePathRule) - instance From (Rule OnePathRule) (Attribute.Priority, Attribute.Owise) where from = from @(RewriteRule _) . unRuleOnePath @@ -89,8 +86,6 @@ instance Diff (Rule AllPathRule) instance ToRulePattern (Rule AllPathRule) -instance FromRulePattern (Rule AllPathRule) - instance From (Rule AllPathRule) (Attribute.Priority, Attribute.Owise) where from = from @(RewriteRule _) . unRuleAllPath @@ -111,8 +106,6 @@ instance Diff (Rule ReachabilityRule) instance ToRulePattern (Rule ReachabilityRule) -instance FromRulePattern (Rule ReachabilityRule) - instance From (Rule ReachabilityRule) (Attribute.Priority, Attribute.Owise) where from = from @(RewriteRule _) . unReachabilityRewriteRule From e8a1a5adb430536b3f0931f17f24a954de07ddaf Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 10:50:09 -0500 Subject: [PATCH 52/79] Kore.Repl: Remove use of function ruleToGoal --- kore/src/Kore/Repl.hs | 58 +++++++++++++++++++++---------------------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/kore/src/Kore/Repl.hs b/kore/src/Kore/Repl.hs index 7056419781..8ce3900321 100644 --- a/kore/src/Kore/Repl.hs +++ b/kore/src/Kore/Repl.hs @@ -16,9 +16,6 @@ import Control.Concurrent.MVar import Control.Exception ( AsyncException (UserInterrupt) ) -import Control.Lens - ( Lens' - ) import qualified Control.Lens as Lens import Control.Monad ( forever @@ -58,10 +55,6 @@ import Text.Megaparsec ( parseMaybe ) -import qualified Kore.Attribute.Axiom as Attribute -import Kore.Internal.Symbol - ( Symbol (..) - ) import Kore.Internal.TermLike ( TermLike , mkSortVariable @@ -72,6 +65,9 @@ import Kore.Repl.Data import Kore.Repl.Interpreter import Kore.Repl.Parser import Kore.Repl.State +import Kore.Step.RulePattern + ( ReachabilityRule (..) + ) import Kore.Step.Simplification.Data ( MonadSimplify ) @@ -197,33 +193,37 @@ runRepl axioms' claims' logger replScript replMode outputFile mainModuleName = d -> [ReachabilityRule] -> [ReachabilityRule] addIndexesToClaims len claims'' = - let toAxiomAndBack claim' index = - ruleToGoal - claim' - $ addIndex (goalToRule claim', index) - in zipWith toAxiomAndBack claims'' [len..] + zipWith addIndexToClaim [len..] claims'' + where + addIndexToClaim n = + Lens.over (lensAttribute . field @"identifier") (makeRuleIndex n) + + lensAttribute = + Lens.lens + (\case + OnePath onePathRule -> + Lens.view (_Unwrapped . field @"attributes") onePathRule + AllPath allPathRule -> + Lens.view (_Unwrapped . field @"attributes") allPathRule + ) + (\case + OnePath onePathRule -> \attrs -> + onePathRule + & Lens.set (_Unwrapped . field @"attributes") attrs + & OnePath + AllPath allPathRule -> \attrs -> + allPathRule + & Lens.set (_Unwrapped . field @"attributes") attrs + & AllPath + ) addIndex :: (Axiom, Int) -> Axiom addIndex (rw, n) = - modifyAttribute (mapAttribute n (getAttribute rw)) rw - - lensAttribute :: Lens' Axiom (Attribute.Axiom Symbol Variable) - lensAttribute = _Unwrapped . _Unwrapped . field @"attributes" - - modifyAttribute :: Attribute.Axiom Symbol Variable -> Axiom -> Axiom - modifyAttribute = Lens.set lensAttribute - - getAttribute :: Axiom -> Attribute.Axiom Symbol Variable - getAttribute = Lens.view lensAttribute - - mapAttribute - :: Int - -> Attribute.Axiom Symbol variable - -> Attribute.Axiom Symbol variable - mapAttribute n attr = - Lens.over (field @"identifier") (makeRuleIndex n) attr + Lens.over (lensAttribute . field @"identifier") (makeRuleIndex n) rw + where + lensAttribute = _Unwrapped . _Unwrapped . field @"attributes" makeRuleIndex :: Int -> RuleIndex -> RuleIndex makeRuleIndex n _ = RuleIndex (Just n) From cc6056e1b082a10c2d690bf008f59348daacd6d4 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 10:51:08 -0500 Subject: [PATCH 53/79] Remove member ruleToGoal of class Goal --- kore/src/Kore/Strategies/Goal.hs | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 8bd791cf8b..37f52d3025 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -221,16 +221,6 @@ class Goal goal where => goal -> Rule goal goalToRule = coerce - -- | Since Goals usually carry more information than Rules, - -- we need to know the context when transforming a Rule into a Goal, - -- hence the first 'goal' argument. In general it can be ignored - -- when the Goal and the Rule are representationally equal. - ruleToGoal :: goal -> Rule goal -> goal - default ruleToGoal - :: Coercible (Rule goal) goal - => goal -> Rule goal -> goal - ruleToGoal _ = coerce - transitionRule :: (MonadCatch m, MonadSimplify m) => Prim goal @@ -425,9 +415,6 @@ instance Goal ReachabilityRule where goalToRule (OnePath rule) = coerce rule goalToRule (AllPath rule) = coerce rule - ruleToGoal (OnePath _) rule = OnePath (coerce rule) - ruleToGoal (AllPath _) rule = AllPath (coerce rule) - transitionRule :: (MonadCatch m, MonadSimplify m) => Prim ReachabilityRule From 5dff45698f03d442b0a1eb84e7dec32162bf76c3 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 11:19:26 -0500 Subject: [PATCH 54/79] Rename free rule variables at initialization Instead of renaming the variables of each semantic rule as it is attempted, the free variables of each rule are renamed at initialization. The former behavior exhibits poor performance: the work of renaming is substantially duplicated because every semantic rule is attempted at every step. There is a small amount of work to rename the free variables of each _applied_ semantic rule, but the number of applied rules is small, and this work is not really duplicated. --- kore/src/Kore/Exec.hs | 3 +- kore/src/Kore/Log/DebugProofState.hs | 6 +- kore/src/Kore/Strategies/Goal.hs | 77 ++++++++++--------- kore/src/Kore/Strategies/Rule.hs | 27 +++---- kore/test/Test/Kore/Repl/Interpreter.hs | 65 +++++++++++----- .../Kore/Strategies/AllPath/Verification.hs | 3 +- kore/test/Test/Kore/Strategies/Common.hs | 5 +- .../test/Test/Kore/Strategies/OnePath/Step.hs | 5 +- .../Kore/Strategies/OnePath/Verification.hs | 3 +- 9 files changed, 115 insertions(+), 79 deletions(-) diff --git a/kore/src/Kore/Exec.hs b/kore/src/Kore/Exec.hs index 43cbc6eb03..a9af6bfab2 100644 --- a/kore/src/Kore/Exec.hs +++ b/kore/src/Kore/Exec.hs @@ -103,6 +103,7 @@ import qualified Kore.Profiler.Profile as Profiler ) import qualified Kore.Repl as Repl import qualified Kore.Repl.Data as Repl.Data +import Kore.Rewriting.RewritingVariable import Kore.Step import Kore.Step.Rule ( extractImplicationClaims @@ -713,7 +714,7 @@ initializeProver definitionModule specModule maybeAlreadyProvenModule within = specAxioms <- Profiler.initialization "simplifyRuleOnSecond" $ traverse simplifyRuleOnSecond (concat simplifiedSpecClaims) let claims = fmap makeReachabilityRule specAxioms - axioms = coerce rewriteRules + axioms = coerce . mkRewritingRule <$> rewriteRules alreadyProven = fmap makeReachabilityRule claimsAlreadyProven initializedProver = InitializedProver {axioms, claims, alreadyProven} diff --git a/kore/src/Kore/Log/DebugProofState.hs b/kore/src/Kore/Log/DebugProofState.hs index 78eda5bf76..b795548101 100644 --- a/kore/src/Kore/Log/DebugProofState.hs +++ b/kore/src/Kore/Log/DebugProofState.hs @@ -14,9 +14,7 @@ import Data.Text.Prettyprint.Doc ) import qualified Data.Text.Prettyprint.Doc as Pretty -import Kore.Internal.TermLike - ( Variable - ) +import Kore.Rewriting.RewritingVariable import Kore.Step.RulePattern ( ReachabilityRule (..) , RewriteRule (..) @@ -30,7 +28,7 @@ import Log data DebugProofState = DebugProofState { proofState :: ProofState ReachabilityRule - , transition :: Prim (RewriteRule Variable) + , transition :: Prim (RewriteRule RewritingVariable) , result :: Maybe (ProofState ReachabilityRule) } diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 37f52d3025..5981f3221a 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -296,6 +296,12 @@ instance Goal OnePathRule where type Prim OnePathRule = ProofState.Prim (Rule OnePathRule) type ProofState OnePathRule = ProofState.ProofState + goalToRule = + OnePathRewriteRule + . mkRewritingRule + . RewriteRule + . getOnePathRule + transitionRule = (withDebugProofState . transitionRuleTemplate) TransitionRuleTemplate @@ -316,11 +322,7 @@ instance Goal OnePathRule where ) where rewrites = sortOn Attribute.Axiom.getPriorityOfAxiom rules - coinductiveRewrites = - OnePathRewriteRule - . RewriteRule - . getOnePathRule - <$> goals + coinductiveRewrites = goalToRule <$> goals deriveParOnePath :: (MonadCatch simplifier, MonadSimplify simplifier) @@ -331,7 +333,7 @@ deriveParOnePath deriveParOnePath rules = derivePar _Unwrapped OnePathRewriteRule rewrites where - rewrites = mkRewritingRule . unRuleOnePath <$> rules + rewrites = unRuleOnePath <$> rules deriveSeqOnePath :: (MonadCatch simplifier, MonadSimplify simplifier) @@ -342,7 +344,7 @@ deriveSeqOnePath deriveSeqOnePath rules = deriveSeq _Unwrapped OnePathRewriteRule rewrites where - rewrites = mkRewritingRule . unRuleOnePath <$> rules + rewrites = unRuleOnePath <$> rules instance ClaimExtractor OnePathRule where extractClaim (attrs, sentence) = @@ -354,6 +356,12 @@ instance Goal AllPathRule where type Prim AllPathRule = ProofState.Prim (Rule AllPathRule) type ProofState AllPathRule = ProofState.ProofState + goalToRule = + AllPathRewriteRule + . mkRewritingRule + . RewriteRule + . getAllPathRule + transitionRule = (withDebugProofState . transitionRuleTemplate) TransitionRuleTemplate @@ -374,11 +382,7 @@ instance Goal AllPathRule where ) where priorityGroups = groupSortOn Attribute.Axiom.getPriorityOfAxiom rules - coinductiveRewrites = - AllPathRewriteRule - . RewriteRule - . getAllPathRule - <$> goals + coinductiveRewrites = goalToRule <$> goals deriveParAllPath :: (MonadCatch simplifier, MonadSimplify simplifier) @@ -389,7 +393,7 @@ deriveParAllPath deriveParAllPath rules = derivePar _Unwrapped AllPathRewriteRule rewrites where - rewrites = mkRewritingRule . unRuleAllPath <$> rules + rewrites = unRuleAllPath <$> rules deriveSeqAllPath :: (MonadCatch simplifier, MonadSimplify simplifier) @@ -400,7 +404,7 @@ deriveSeqAllPath deriveSeqAllPath rules = deriveSeq _Unwrapped AllPathRewriteRule rewrites where - rewrites = mkRewritingRule . unRuleAllPath <$> rules + rewrites = unRuleAllPath <$> rules instance ClaimExtractor AllPathRule where extractClaim (attrs, sentence) = @@ -412,8 +416,16 @@ instance Goal ReachabilityRule where type Prim ReachabilityRule = ProofState.Prim (Rule ReachabilityRule) type ProofState ReachabilityRule = ProofState.ProofState - goalToRule (OnePath rule) = coerce rule - goalToRule (AllPath rule) = coerce rule + goalToRule (OnePath rule) = + ReachabilityRewriteRule + $ mkRewritingRule + $ RewriteRule + $ getOnePathRule rule + goalToRule (AllPath rule) = + ReachabilityRewriteRule + $ mkRewritingRule + $ RewriteRule + $ getAllPathRule rule transitionRule :: (MonadCatch m, MonadSimplify m) @@ -456,17 +468,11 @@ instance Goal ReachabilityRule where <$> transitionRule (primRuleAllPath prim) (GoalRemainder rule) state@(GoalStuck _) -> case prim of - CheckGoalStuck -> - debugProofStateFinal - state - CheckGoalStuck + CheckGoalStuck -> debugProofStateFinal state CheckGoalStuck _ -> return proofstate Proven -> case prim of - CheckProven -> - debugProofStateFinal - Proven - CheckProven + CheckProven -> debugProofStateFinal Proven CheckProven _ -> return proofstate strategy @@ -558,12 +564,14 @@ ruleReachabilityToRuleOnePath = coerce ruleAllPathToRuleReachability :: Rule AllPathRule -> Rule ReachabilityRule -ruleAllPathToRuleReachability = coerce +ruleAllPathToRuleReachability = + ReachabilityRewriteRule . mkRewritingRule . RewriteRule . toRulePattern ruleOnePathToRuleReachability :: Rule OnePathRule -> Rule ReachabilityRule -ruleOnePathToRuleReachability = coerce +ruleOnePathToRuleReachability = + ReachabilityRewriteRule . mkRewritingRule . RewriteRule . toRulePattern data TransitionRuleTemplate monad goal = TransitionRuleTemplate @@ -878,7 +886,7 @@ derivePar . (MonadCatch m, MonadSimplify m) => ProofState.ProofState goal ~ ProofState goal goal => Lens' goal (RulePattern Variable) - -> (RewriteRule Variable -> Rule goal) + -> (RewriteRule RewritingVariable -> Rule goal) -> [RewriteRule RewritingVariable] -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) @@ -897,7 +905,7 @@ deriveWith . (MonadCatch m, MonadSimplify m) => ProofState.ProofState goal ~ ProofState goal goal => Lens' goal (RulePattern Variable) - -> (RewriteRule Variable -> Rule goal) + -> (RewriteRule RewritingVariable -> Rule goal) -> Deriver m -> [RewriteRule RewritingVariable] -> goal @@ -919,7 +927,7 @@ deriveSeq . (MonadCatch m, MonadSimplify m) => ProofState.ProofState goal ~ ProofState goal goal => Lens' goal (RulePattern Variable) - -> (RewriteRule Variable -> Rule goal) + -> (RewriteRule RewritingVariable -> Rule goal) -> [RewriteRule RewritingVariable] -> goal -> Strategy.TransitionT (Rule goal) m (ProofState goal goal) @@ -929,7 +937,7 @@ deriveSeq lensRulePattern mkRule = deriveResults :: MonadSimplify simplifier - => (RewriteRule Variable -> Rule goal) + => (RewriteRule RewritingVariable -> Rule goal) -> Step.Results RulePattern Variable -> Strategy.TransitionT (Rule goal) simplifier (ProofState.ProofState (Pattern Variable)) @@ -954,8 +962,7 @@ deriveResults mkRule Results { results, remainders } = addRule = Transition.addRule . fromAppliedRule - fromAppliedRule = - mkRule . RewriteRule . Step.unRewritingRule . Step.withoutUnification + fromAppliedRule = mkRule . RewriteRule . Step.withoutUnification withConfiguration' :: MonadCatch m => Pattern Variable -> m a -> m a withConfiguration' configuration = @@ -1077,7 +1084,7 @@ debugProofStateBracket :: forall monad goal . MonadLog monad => ToReachabilityRule goal - => Coercible (Rule goal) (RewriteRule Variable) + => Coercible (Rule goal) (RewriteRule RewritingVariable) => ProofState goal goal ~ ProofState.ProofState goal => Prim goal ~ ProofState.Prim (Rule goal) => ProofState goal goal @@ -1105,7 +1112,7 @@ debugProofStateFinal . Alternative monad => MonadLog monad => ToReachabilityRule goal - => Coercible (Rule goal) (RewriteRule Variable) + => Coercible (Rule goal) (RewriteRule RewritingVariable) => ProofState goal goal ~ ProofState.ProofState goal => Prim goal ~ ProofState.Prim (Rule goal) => ProofState goal goal @@ -1128,7 +1135,7 @@ withDebugProofState :: forall monad goal . MonadLog monad => ToReachabilityRule goal - => Coercible (Rule goal) (RewriteRule Variable) + => Coercible (Rule goal) (RewriteRule RewritingVariable) => ProofState goal goal ~ ProofState.ProofState goal => Prim goal ~ ProofState.Prim (Rule goal) => diff --git a/kore/src/Kore/Strategies/Rule.hs b/kore/src/Kore/Strategies/Rule.hs index 48bce5dfb0..a2240b602c 100644 --- a/kore/src/Kore/Strategies/Rule.hs +++ b/kore/src/Kore/Strategies/Rule.hs @@ -33,15 +33,13 @@ import Kore.Attribute.RuleIndex as Attribute import Kore.Attribute.SourceLocation as Attribute ( SourceLocation ) -import Kore.Internal.Variable - ( Variable - ) +import Kore.Rewriting.RewritingVariable import Kore.Step.RulePattern ( AllPathRule , OnePathRule , ReachabilityRule , RewriteRule (..) - , ToRulePattern + , ToRulePattern (..) ) import Kore.Unparser ( Unparse @@ -54,7 +52,7 @@ data family Rule goal -- * One-path reachability newtype instance Rule OnePathRule = - OnePathRewriteRule { unRuleOnePath :: RewriteRule Variable } + OnePathRewriteRule { unRuleOnePath :: RewriteRule RewritingVariable } deriving (GHC.Generic, Show, Unparse) instance SOP.Generic (Rule OnePathRule) @@ -65,7 +63,8 @@ instance Debug (Rule OnePathRule) instance Diff (Rule OnePathRule) -instance ToRulePattern (Rule OnePathRule) +instance ToRulePattern (Rule OnePathRule) where + toRulePattern = getRewriteRule . unRewritingRule . unRuleOnePath instance From (Rule OnePathRule) (Attribute.Priority, Attribute.Owise) where from = from @(RewriteRule _) . unRuleOnePath @@ -73,7 +72,7 @@ instance From (Rule OnePathRule) (Attribute.Priority, Attribute.Owise) where -- * All-path reachability newtype instance Rule AllPathRule = - AllPathRewriteRule { unRuleAllPath :: RewriteRule Variable } + AllPathRewriteRule { unRuleAllPath :: RewriteRule RewritingVariable } deriving (GHC.Generic, Show, Unparse) instance SOP.Generic (Rule AllPathRule) @@ -84,7 +83,8 @@ instance Debug (Rule AllPathRule) instance Diff (Rule AllPathRule) -instance ToRulePattern (Rule AllPathRule) +instance ToRulePattern (Rule AllPathRule) where + toRulePattern = getRewriteRule . unRewritingRule . unRuleAllPath instance From (Rule AllPathRule) (Attribute.Priority, Attribute.Owise) where from = from @(RewriteRule _) . unRuleAllPath @@ -93,7 +93,7 @@ instance From (Rule AllPathRule) (Attribute.Priority, Attribute.Owise) where newtype instance Rule ReachabilityRule = ReachabilityRewriteRule - { unReachabilityRewriteRule :: RewriteRule Variable } + { unReachabilityRewriteRule :: RewriteRule RewritingVariable } deriving (GHC.Generic, Show, Unparse) instance SOP.Generic (Rule ReachabilityRule) @@ -104,17 +104,18 @@ instance Debug (Rule ReachabilityRule) instance Diff (Rule ReachabilityRule) -instance ToRulePattern (Rule ReachabilityRule) +instance ToRulePattern (Rule ReachabilityRule) where + toRulePattern = getRewriteRule . unRewritingRule . unReachabilityRewriteRule instance From (Rule ReachabilityRule) (Attribute.Priority, Attribute.Owise) where from = from @(RewriteRule _) . unReachabilityRewriteRule instance From (Rule ReachabilityRule) Attribute.SourceLocation where - from = from @(RewriteRule Variable) . unReachabilityRewriteRule + from = from @(RewriteRule _) . unReachabilityRewriteRule instance From (Rule ReachabilityRule) Attribute.Label where - from = from @(RewriteRule Variable) . unReachabilityRewriteRule + from = from @(RewriteRule _) . unReachabilityRewriteRule instance From (Rule ReachabilityRule) Attribute.RuleIndex where - from = from @(RewriteRule Variable) . unReachabilityRewriteRule + from = from @(RewriteRule _) . unReachabilityRewriteRule diff --git a/kore/test/Test/Kore/Repl/Interpreter.hs b/kore/test/Test/Kore/Repl/Interpreter.hs index 53e600d98b..6f7b3df08d 100644 --- a/kore/test/Test/Kore/Repl/Interpreter.hs +++ b/kore/test/Test/Kore/Repl/Interpreter.hs @@ -37,13 +37,13 @@ import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as StrictMap import qualified Data.Sequence as Seq import Data.Text ( pack ) import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Map.Strict as StrictMap import qualified Kore.Attribute.Axiom as Attribute import qualified Kore.Builtin.Int as Int import Kore.Internal.Condition @@ -51,8 +51,7 @@ import Kore.Internal.Condition ) import qualified Kore.Internal.Condition as Condition import Kore.Internal.TermLike - ( InternalVariable - , TermLike + ( TermLike , elemVarS , mkAnd , mkBottom_ @@ -64,6 +63,7 @@ import qualified Kore.Log.Registry as Log import Kore.Repl.Data import Kore.Repl.Interpreter import Kore.Repl.State +import Kore.Rewriting.RewritingVariable import Kore.Step.RulePattern import Kore.Step.Simplification.AndTerms ( cannotUnifyDistinctDomainValues @@ -297,7 +297,7 @@ unificationFailure = let zero = Int.asInternal intSort 0 one = Int.asInternal intSort 1 - impossibleAxiom = coerce $ rulePattern one one + impossibleAxiom = mkAxiom one one axioms = [ impossibleAxiom ] claim = zeroToTen command = Try . ByIndex . Left $ AxiomIndex 0 @@ -314,7 +314,7 @@ unificationFailureWithName = let zero = Int.asInternal intSort 0 one = Int.asInternal intSort 1 - impossibleAxiom = coerce $ rulePatternWithName one one "impossible" + impossibleAxiom = mkNamedAxiom one one "impossible" axioms = [ impossibleAxiom ] claim = zeroToTen command = Try . ByName . RuleName $ "impossible" @@ -331,7 +331,7 @@ unificationSuccess = do let zero = Int.asInternal intSort 0 one = Int.asInternal intSort 1 - axiom = coerce $ rulePattern zero one + axiom = mkAxiom zero one axioms = [ axiom ] claim = zeroToTen command = Try . ByIndex . Left $ AxiomIndex 0 @@ -347,7 +347,7 @@ unificationSuccessWithName = do let zero = Int.asInternal intSort 0 one = Int.asInternal intSort 1 - axiom = coerce $ rulePatternWithName zero one "0to1" + axiom = mkNamedAxiom zero one "0to1" axioms = [ axiom ] claim = zeroToTen command = Try . ByName . RuleName $ "0to1" @@ -363,7 +363,7 @@ forceFailure = let zero = Int.asInternal intSort 0 one = Int.asInternal intSort 1 - impossibleAxiom = coerce $ rulePattern one one + impossibleAxiom = mkAxiom one one axioms = [ impossibleAxiom ] claim = zeroToTen command = TryF . ByIndex . Left $ AxiomIndex 0 @@ -380,7 +380,7 @@ forceFailureWithName = let zero = Int.asInternal intSort 0 one = Int.asInternal intSort 1 - impossibleAxiom = coerce $ rulePatternWithName one one "impossible" + impossibleAxiom = mkNamedAxiom one one "impossible" axioms = [ impossibleAxiom ] claim = zeroToTen command = TryF . ByName . RuleName $ "impossible" @@ -397,7 +397,7 @@ forceSuccess = do let zero = Int.asInternal intSort 0 one = Int.asInternal intSort 1 - axiom = coerce $ rulePattern zero one + axiom = mkAxiom zero one axioms = [ axiom ] claim = zeroToTen command = TryF . ByIndex . Left $ AxiomIndex 0 @@ -413,7 +413,7 @@ forceSuccessWithName = do let zero = Int.asInternal intSort 0 one = Int.asInternal intSort 1 - axiom = coerce $ rulePatternWithName zero one "0to1" + axiom = mkNamedAxiom zero one "0to1" axioms = [ axiom ] claim = zeroToTen command = TryF . ByName . RuleName $ "0to1" @@ -553,7 +553,7 @@ proveSecondClaimByName = add1 :: Axiom add1 = - coerce $ rulePatternWithName n plusOne "add1Axiom" + mkNamedAxiom n plusOne "add1Axiom" where one = Int.asInternal intSort 1 n = mkElemVar $ elemVarS "x" intSort @@ -561,7 +561,8 @@ add1 = zeroToTen :: Claim zeroToTen = - OnePath $ coerce $ rulePatternWithName zero (mkAnd mkTop_ ten) "0to10Claim" + OnePath . coerce + $ claimWithName zero (mkAnd mkTop_ ten) "0to10Claim" where zero = Int.asInternal intSort 0 ten = Int.asInternal intSort 10 @@ -569,20 +570,44 @@ zeroToTen = emptyClaim :: Claim emptyClaim = OnePath . coerce - $ rulePatternWithName mkBottom_ (mkAnd mkTop_ mkBottom_) "emptyClaim" + $ claimWithName mkBottom_ (mkAnd mkTop_ mkBottom_) "emptyClaim" + +mkNamedAxiom + :: TermLike Variable + -> TermLike Variable + -> String + -> Axiom +mkNamedAxiom left right name = + rulePattern left right + & Lens.set (field @"attributes" . typed @Attribute.Label) label + & RewriteRule + & mkRewritingRule + & coerce + where + label = Attribute.Label . pure $ pack name -rulePatternWithName - :: InternalVariable variable - => TermLike variable - -> TermLike variable +claimWithName + :: TermLike Variable + -> TermLike Variable -> String - -> RulePattern variable -rulePatternWithName left right name = + -> RewriteRule Variable +claimWithName left right name = rulePattern left right & Lens.set (field @"attributes" . typed @Attribute.Label) label + & RewriteRule where label = Attribute.Label . pure $ pack name +mkAxiom + :: TermLike Variable + -> TermLike Variable + -> Axiom +mkAxiom left right = + rulePattern left right + & RewriteRule + & mkRewritingRule + & coerce + run :: ReplCommand -> [Axiom] -> [Claim] -> Claim -> IO Result run command axioms claims claim = runWithState command axioms claims claim id diff --git a/kore/test/Test/Kore/Strategies/AllPath/Verification.hs b/kore/test/Test/Kore/Strategies/AllPath/Verification.hs index e4a24cf565..ba47c8d2cc 100644 --- a/kore/test/Test/Kore/Strategies/AllPath/Verification.hs +++ b/kore/test/Test/Kore/Strategies/AllPath/Verification.hs @@ -27,6 +27,7 @@ import Kore.Internal.Predicate , makeTruePredicate_ ) import Kore.Internal.TermLike +import Kore.Rewriting.RewritingVariable import Kore.Step.RulePattern ( AllPathRule (..) , ReachabilityRule (..) @@ -379,7 +380,7 @@ simplePriorityAxiom -> Integer -> Rule ReachabilityRule simplePriorityAxiom left right priority = - ReachabilityRewriteRule . RewriteRule + ReachabilityRewriteRule . mkRewritingRule . RewriteRule $ RulePattern { left = left , antiLeft = Nothing diff --git a/kore/test/Test/Kore/Strategies/Common.hs b/kore/test/Test/Kore/Strategies/Common.hs index 555eff3390..f8846f405a 100644 --- a/kore/test/Test/Kore/Strategies/Common.hs +++ b/kore/test/Test/Kore/Strategies/Common.hs @@ -21,6 +21,7 @@ import Kore.Internal.Pattern ( Pattern ) import Kore.Internal.TermLike +import Kore.Rewriting.RewritingVariable import Kore.Step.RulePattern ( RewriteRule (..) , rulePattern @@ -48,9 +49,9 @@ import Test.Kore.Step.Simplification simpleRewrite :: TermLike Variable -> TermLike Variable - -> RewriteRule Variable + -> RewriteRule RewritingVariable simpleRewrite left right = - RewriteRule $ rulePattern left right + mkRewritingRule $ RewriteRule $ rulePattern left right runVerificationToPattern :: Limit Natural diff --git a/kore/test/Test/Kore/Strategies/OnePath/Step.hs b/kore/test/Test/Kore/Strategies/OnePath/Step.hs index 2f3038c928..d142c368db 100644 --- a/kore/test/Test/Kore/Strategies/OnePath/Step.hs +++ b/kore/test/Test/Kore/Strategies/OnePath/Step.hs @@ -29,6 +29,7 @@ import Data.Limit ( Limit (..) ) import qualified Data.Limit as Limit +import Kore.Rewriting.RewritingVariable import Kore.IndexedModule.IndexedModule ( indexedModuleWithDefaultImports @@ -783,7 +784,7 @@ simpleRewrite -> TermLike Variable -> Rule OnePathRule simpleRewrite left right = - OnePathRewriteRule + OnePathRewriteRule . mkRewritingRule $ RewriteRule RulePattern { left = left , antiLeft = Nothing @@ -805,7 +806,7 @@ rewriteWithPredicate -> Predicate Variable -> Rule OnePathRule rewriteWithPredicate left right predicate = - OnePathRewriteRule + OnePathRewriteRule . mkRewritingRule $ RewriteRule RulePattern { left = left , antiLeft = Nothing diff --git a/kore/test/Test/Kore/Strategies/OnePath/Verification.hs b/kore/test/Test/Kore/Strategies/OnePath/Verification.hs index 10c0b26e1a..7361ce7376 100644 --- a/kore/test/Test/Kore/Strategies/OnePath/Verification.hs +++ b/kore/test/Test/Kore/Strategies/OnePath/Verification.hs @@ -27,6 +27,7 @@ import Kore.Internal.Predicate , makeTruePredicate_ ) import Kore.Internal.TermLike +import Kore.Rewriting.RewritingVariable import Kore.Step.RulePattern ( OnePathRule (..) , ReachabilityRule (..) @@ -476,7 +477,7 @@ simplePriorityAxiom -> Integer -> Rule ReachabilityRule simplePriorityAxiom left right priority = - ReachabilityRewriteRule . RewriteRule + ReachabilityRewriteRule . mkRewritingRule . RewriteRule $ RulePattern { left = left , antiLeft = Nothing From 4d250098602844ef2d9a50ab0781f7141e547e3d Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 15:13:08 -0500 Subject: [PATCH 55/79] Kore.Exec: Undo CPS transformations --- kore/src/Kore/Exec.hs | 259 +++++++++++++++++++----------------------- 1 file changed, 120 insertions(+), 139 deletions(-) diff --git a/kore/src/Kore/Exec.hs b/kore/src/Kore/Exec.hs index a9af6bfab2..407d8745f2 100644 --- a/kore/src/Kore/Exec.hs +++ b/kore/src/Kore/Exec.hs @@ -322,24 +322,28 @@ prove depthLimit definitionModule specModule - maybeAlreadyProvenModule + trustedModule = - evalProver definitionModule specModule maybeAlreadyProvenModule - $ \initialized -> do + evalSimplifier definitionModule $ do + initialized <- + initializeProver + definitionModule + specModule + trustedModule let InitializedProver { axioms, claims, alreadyProven } = initialized result <- - runExceptT - $ verify + verify breadthLimit searchOrder (AllClaims claims) (Axioms axioms) (AlreadyProven (map unparseToText2 alreadyProven)) (ToProve - (map (\x -> (x,depthLimit)) + (map (\x -> (x, depthLimit)) (extractUntrustedClaims' claims) ) ) + & runExceptT return result where extractUntrustedClaims' :: [ReachabilityRule] -> [ReachabilityRule] @@ -366,17 +370,28 @@ proveWithRepl proveWithRepl definitionModule specModule - maybeAlreadyProvenModule + trustedModule mvar replScript replMode outputFile mainModuleName = - evalProver definitionModule specModule maybeAlreadyProvenModule - $ \initialized -> do + evalSimplifier definitionModule $ do + initialized <- + initializeProver + definitionModule + specModule + trustedModule let InitializedProver { axioms, claims } = initialized - Repl.runRepl axioms claims mvar replScript replMode outputFile mainModuleName + Repl.runRepl + axioms + claims + mvar + replScript + replMode + outputFile + mainModuleName -- | Bounded model check a spec given as a module containing rules to be checked boundedModelCheck @@ -394,8 +409,8 @@ boundedModelCheck -> Strategy.GraphSearchOrder -> smt (Bounded.CheckResult (TermLike Variable)) boundedModelCheck breadthLimit depthLimit definitionModule specModule searchOrder = - evalSimplifier definitionModule $ initialize definitionModule - $ \initialized -> do + evalSimplifier definitionModule $ do + initialized <- initialize definitionModule let Initialized { rewriteRules } = initialized specClaims = extractImplicationClaims specModule assertSomeClaims specClaims @@ -457,9 +472,8 @@ mergeRules -- ^ The list of rules to merge -> smt (Either Text [RewriteRule Variable]) mergeRules ruleMerger verifiedModule ruleNames = - evalSimplifier verifiedModule - $ initialize verifiedModule - $ \initialized -> do + evalSimplifier verifiedModule $ do + initialized <- initialize verifiedModule let Initialized { rewriteRules } = initialized let nonEmptyRules :: Either Text (NonEmpty (RewriteRule Variable)) @@ -584,39 +598,37 @@ execute -> TermLike Variable -- ^ The input pattern -> simplifier Execution -execute breadthLimit verifiedModule strategy inputPattern = - initialize verifiedModule $ \initialized -> do - let Initialized { rewriteRules } = initialized - simplifier <- Simplifier.askSimplifierTermLike - axiomIdToSimplifier <- Simplifier.askSimplifierAxioms - simplifiedPatterns <- - Pattern.simplify - SideCondition.top - (Pattern.fromTermLike inputPattern) - let - initialPattern = - case MultiOr.extractPatterns simplifiedPatterns of - [] -> Pattern.bottomOf patternSort - (config : _) -> config - where - patternSort = termLikeSort inputPattern - runStrategy' = - runStrategy breadthLimit transitionRule (strategy rewriteRules) - executionGraph <- runStrategy' initialPattern - return Execution - { simplifier - , axiomIdToSimplifier - , executionGraph - } +execute breadthLimit verifiedModule strategy inputPattern = do + initialized <- initialize verifiedModule + let Initialized { rewriteRules } = initialized + simplifier <- Simplifier.askSimplifierTermLike + axiomIdToSimplifier <- Simplifier.askSimplifierAxioms + simplifiedPatterns <- + Pattern.simplify SideCondition.top + $ Pattern.fromTermLike inputPattern + let + initialPattern = + case MultiOr.extractPatterns simplifiedPatterns of + [] -> Pattern.bottomOf patternSort + (config : _) -> config + where + patternSort = termLikeSort inputPattern + runStrategy' = + runStrategy breadthLimit transitionRule (strategy rewriteRules) + executionGraph <- runStrategy' initialPattern + return Execution + { simplifier + , axiomIdToSimplifier + , executionGraph + } -- | Collect various rules and simplifiers in preparation to execute. initialize - :: forall a simplifier + :: forall simplifier . MonadSimplify simplifier => VerifiedModule StepperAttributes - -> (Initialized -> simplifier a) - -> simplifier a -initialize verifiedModule within = do + -> simplifier Initialized +initialize verifiedModule = do let rewriteRules = extractRewriteAxioms verifiedModule simplifyToList :: SimplifyRuleLHS rule @@ -627,9 +639,7 @@ initialize verifiedModule within = do return (MultiAnd.extractPatterns simplified) rewriteAxioms <- Profiler.initialization "simplifyRewriteRule" $ mapM simplifyToList rewriteRules - --let axioms = coerce (concat simplifiedRewrite) - let initialized = Initialized { rewriteRules = concat rewriteAxioms } - within initialized + pure Initialized { rewriteRules = concat rewriteAxioms } data InitializedProver = InitializedProver @@ -646,79 +656,74 @@ fromMaybeChanged (Unchanged a) = a -- | Collect various rules and simplifiers in preparation to execute. initializeProver - :: forall simplifier a + :: forall simplifier . MonadSimplify simplifier => VerifiedModule StepperAttributes -> VerifiedModule StepperAttributes -> Maybe (VerifiedModule StepperAttributes) - -> (InitializedProver -> simplifier a) - -> simplifier a -initializeProver definitionModule specModule maybeAlreadyProvenModule within = - initialize definitionModule - $ \initialized -> do - tools <- Simplifier.askMetadataTools - let Initialized { rewriteRules } = initialized - changedSpecClaims - :: [ ( Attribute.Axiom Symbol Variable - , MaybeChanged ReachabilityRule - ) - ] - changedSpecClaims = - map - (Bifunctor.second $ expandClaim tools) - (Goal.extractClaims specModule) - mapMSecond - :: Monad m - => (rule -> m [rule']) - -> (attributes, rule) -> m [(attributes, rule')] - mapMSecond f (attribute, rule) = do - simplified <- f rule - return (map ((,) attribute) simplified) - simplifyToList - :: SimplifyRuleLHS rule - => rule - -> simplifier [rule] - simplifyToList rule = do - simplified <- simplifyRuleLhs rule - return (MultiAnd.extractPatterns simplified) - - maybeClaimsAlreadyProven - :: Maybe - [ ( Attribute.Axiom Symbol Variable - , ReachabilityRule - ) - ] - maybeClaimsAlreadyProven = - Goal.extractClaims <$> maybeAlreadyProvenModule - claimsAlreadyProven - :: [ (Attribute.Axiom Symbol Variable - , ReachabilityRule - ) - ] - claimsAlreadyProven = fromMaybe [] maybeClaimsAlreadyProven - - mapM_ (logChangedClaim . snd) changedSpecClaims - - let specClaims - :: [ ( Attribute.Axiom Symbol Variable - , ReachabilityRule - ) - ] - specClaims = - map (Bifunctor.second fromMaybeChanged) changedSpecClaims - -- This assertion should come before simplifying the claims, - -- since simplification should remove all trivial claims. - assertSomeClaims specClaims - simplifiedSpecClaims <- - mapM (mapMSecond simplifyToList) specClaims - specAxioms <- Profiler.initialization "simplifyRuleOnSecond" - $ traverse simplifyRuleOnSecond (concat simplifiedSpecClaims) - let claims = fmap makeReachabilityRule specAxioms - axioms = coerce . mkRewritingRule <$> rewriteRules - alreadyProven = fmap makeReachabilityRule claimsAlreadyProven - initializedProver = - InitializedProver {axioms, claims, alreadyProven} - within initializedProver + -> simplifier InitializedProver +initializeProver definitionModule specModule maybeTrustedModule = do + initialized <- initialize definitionModule + tools <- Simplifier.askMetadataTools + let Initialized { rewriteRules } = initialized + changedSpecClaims + :: [ ( Attribute.Axiom Symbol Variable + , MaybeChanged ReachabilityRule + ) + ] + changedSpecClaims = + map + (Bifunctor.second $ expandClaim tools) + (Goal.extractClaims specModule) + mapMSecond + :: Monad m + => (rule -> m [rule']) + -> (attributes, rule) -> m [(attributes, rule')] + mapMSecond f (attribute, rule) = do + simplified <- f rule + return (map ((,) attribute) simplified) + simplifyToList + :: SimplifyRuleLHS rule + => rule + -> simplifier [rule] + simplifyToList rule = do + simplified <- simplifyRuleLhs rule + return (MultiAnd.extractPatterns simplified) + + maybeClaimsAlreadyProven + :: Maybe + [ ( Attribute.Axiom Symbol Variable + , ReachabilityRule + ) + ] + maybeClaimsAlreadyProven = Goal.extractClaims <$> maybeTrustedModule + claimsAlreadyProven + :: [ (Attribute.Axiom Symbol Variable + , ReachabilityRule + ) + ] + claimsAlreadyProven = fromMaybe [] maybeClaimsAlreadyProven + + mapM_ (logChangedClaim . snd) changedSpecClaims + + let specClaims + :: [ ( Attribute.Axiom Symbol Variable + , ReachabilityRule + ) + ] + specClaims = + map (Bifunctor.second fromMaybeChanged) changedSpecClaims + -- This assertion should come before simplifying the claims, + -- since simplification should remove all trivial claims. + assertSomeClaims specClaims + simplifiedSpecClaims <- + mapM (mapMSecond simplifyToList) specClaims + specAxioms <- Profiler.initialization "simplifyRuleOnSecond" + $ traverse simplifyRuleOnSecond (concat simplifiedSpecClaims) + let claims = fmap makeReachabilityRule specAxioms + axioms = coerce . mkRewritingRule <$> rewriteRules + alreadyProven = fmap makeReachabilityRule claimsAlreadyProven + pure InitializedProver { axioms, claims, alreadyProven } where expandClaim :: SmtMetadataTools attributes @@ -737,27 +742,3 @@ initializeProver definitionModule specModule maybeAlreadyProvenModule within = logChangedClaim (Changed claim) = Log.logInfo ("Claim variables were expanded:\n" <> unparseToText claim) logChangedClaim (Unchanged _) = return () - -evalProver - :: forall smt a - . ( Log.WithLog Log.LogMessage smt - , MonadProfiler smt - , MonadIO smt - , MonadSMT smt - ) - => VerifiedModule StepperAttributes - -- ^ The main module - -> VerifiedModule StepperAttributes - -- ^ The spec module - -> Maybe (VerifiedModule StepperAttributes) - -- ^ The module containing the claims that were proven in a previous run. - -> (InitializedProver -> Simplifier.SimplifierT smt a) - -- The prover - -> smt a -evalProver definitionModule specModule maybeAlreadyProvenModule prover = - evalSimplifier definitionModule - $ initializeProver - definitionModule - specModule - maybeAlreadyProvenModule - prover From 94aaf2278b42b26be8bad884b682c60b4e7f11b1 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 15:37:19 -0500 Subject: [PATCH 56/79] Kore.Exec: Use Compose --- kore/src/Kore/Exec.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/kore/src/Kore/Exec.hs b/kore/src/Kore/Exec.hs index 407d8745f2..b97dcf229b 100644 --- a/kore/src/Kore/Exec.hs +++ b/kore/src/Kore/Exec.hs @@ -40,6 +40,7 @@ import qualified Data.Bifunctor as Bifunctor import Data.Coerce ( coerce ) +import Data.Functor.Compose import Data.List.NonEmpty ( NonEmpty ((:|)) ) @@ -676,12 +677,11 @@ initializeProver definitionModule specModule maybeTrustedModule = do (Bifunctor.second $ expandClaim tools) (Goal.extractClaims specModule) mapMSecond - :: Monad m - => (rule -> m [rule']) - -> (attributes, rule) -> m [(attributes, rule')] - mapMSecond f (attribute, rule) = do - simplified <- f rule - return (map ((,) attribute) simplified) + :: Applicative f + => (rule -> f [rule']) + -> (attributes, rule) + -> f [(attributes, rule')] + mapMSecond f = getCompose . traverse (Compose . f) simplifyToList :: SimplifyRuleLHS rule => rule From 15981b8edc3fb592a71257b24f7661244ae2196c Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 15:50:39 -0500 Subject: [PATCH 57/79] extractClaim: Do not return attributes used to construct claim The attributes can be accessed from the claim itself, there is no need to return a tuple of attributes and claim. --- kore/src/Kore/Exec.hs | 83 ++++++++------------------------ kore/src/Kore/Strategies/Goal.hs | 20 +++----- 2 files changed, 27 insertions(+), 76 deletions(-) diff --git a/kore/src/Kore/Exec.hs b/kore/src/Kore/Exec.hs index b97dcf229b..adad9a244d 100644 --- a/kore/src/Kore/Exec.hs +++ b/kore/src/Kore/Exec.hs @@ -34,13 +34,9 @@ import Control.Monad.Catch import Control.Monad.Trans.Except ( runExceptT ) -import qualified Data.Bifunctor as Bifunctor - ( second - ) import Data.Coerce ( coerce ) -import Data.Functor.Compose import Data.List.NonEmpty ( NonEmpty ((:|)) ) @@ -121,9 +117,7 @@ import Kore.Step.Rule.Simplify ( SimplifyRuleLHS (..) ) import Kore.Step.RulePattern - ( AllPathRule (..) - , ImplicationRule (..) - , OnePathRule (..) + ( ImplicationRule (..) , ReachabilityRule (..) , RewriteRule (RewriteRule) , RulePattern (RulePattern) @@ -564,29 +558,19 @@ assertSomeClaims claims = ++ "Possible explanation: the frontend and the backend don't agree " ++ "on the representation of claims." -makeReachabilityRule - :: (Attribute.Axiom Symbol Variable, ReachabilityRule) - -> ReachabilityRule -makeReachabilityRule (attributes, reachabilityRule) = - case reachabilityRule of - OnePath (OnePathRule rulePattern) -> - OnePath (OnePathRule rulePattern { attributes }) - AllPath (AllPathRule rulePattern) -> - AllPath (AllPathRule rulePattern { attributes }) - makeImplicationRule :: (Attribute.Axiom Symbol Variable, ImplicationRule Variable) -> ImplicationRule Variable makeImplicationRule (attributes, ImplicationRule rulePattern) = ImplicationRule rulePattern { attributes } -simplifyRuleOnSecond +simplifyReachabilityRule :: MonadSimplify simplifier - => (Attribute.Axiom Symbol variable, ReachabilityRule) - -> simplifier (Attribute.Axiom Symbol variable, ReachabilityRule) -simplifyRuleOnSecond (atts, rule) = do + => ReachabilityRule + -> simplifier ReachabilityRule +simplifyReachabilityRule rule = do rule' <- Rule.simplifyRewriteRule (RewriteRule . toRulePattern $ rule) - return (atts, Goal.fromRulePattern rule . getRewriteRule $ rule') + return (Goal.fromRulePattern rule . getRewriteRule $ rule') -- | Construct an execution graph for the given input pattern. execute @@ -667,21 +651,9 @@ initializeProver definitionModule specModule maybeTrustedModule = do initialized <- initialize definitionModule tools <- Simplifier.askMetadataTools let Initialized { rewriteRules } = initialized - changedSpecClaims - :: [ ( Attribute.Axiom Symbol Variable - , MaybeChanged ReachabilityRule - ) - ] + changedSpecClaims :: [MaybeChanged ReachabilityRule] changedSpecClaims = - map - (Bifunctor.second $ expandClaim tools) - (Goal.extractClaims specModule) - mapMSecond - :: Applicative f - => (rule -> f [rule']) - -> (attributes, rule) - -> f [(attributes, rule')] - mapMSecond f = getCompose . traverse (Compose . f) + expandClaim tools <$> Goal.extractClaims specModule simplifyToList :: SimplifyRuleLHS rule => rule @@ -690,39 +662,22 @@ initializeProver definitionModule specModule maybeTrustedModule = do simplified <- simplifyRuleLhs rule return (MultiAnd.extractPatterns simplified) - maybeClaimsAlreadyProven - :: Maybe - [ ( Attribute.Axiom Symbol Variable - , ReachabilityRule - ) - ] - maybeClaimsAlreadyProven = Goal.extractClaims <$> maybeTrustedModule - claimsAlreadyProven - :: [ (Attribute.Axiom Symbol Variable - , ReachabilityRule - ) - ] - claimsAlreadyProven = fromMaybe [] maybeClaimsAlreadyProven + trustedClaims :: [ReachabilityRule] + trustedClaims = + fmap Goal.extractClaims maybeTrustedModule & fromMaybe [] - mapM_ (logChangedClaim . snd) changedSpecClaims + mapM_ logChangedClaim changedSpecClaims - let specClaims - :: [ ( Attribute.Axiom Symbol Variable - , ReachabilityRule - ) - ] - specClaims = - map (Bifunctor.second fromMaybeChanged) changedSpecClaims + let specClaims :: [ReachabilityRule] + specClaims = map fromMaybeChanged changedSpecClaims -- This assertion should come before simplifying the claims, -- since simplification should remove all trivial claims. assertSomeClaims specClaims - simplifiedSpecClaims <- - mapM (mapMSecond simplifyToList) specClaims - specAxioms <- Profiler.initialization "simplifyRuleOnSecond" - $ traverse simplifyRuleOnSecond (concat simplifiedSpecClaims) - let claims = fmap makeReachabilityRule specAxioms - axioms = coerce . mkRewritingRule <$> rewriteRules - alreadyProven = fmap makeReachabilityRule claimsAlreadyProven + simplifiedSpecClaims <- mapM simplifyToList specClaims + claims <- Profiler.initialization "simplifyRuleOnSecond" + $ traverse simplifyReachabilityRule (concat simplifiedSpecClaims) + let axioms = coerce . mkRewritingRule <$> rewriteRules + alreadyProven = trustedClaims pure InitializedProver { axioms, claims, alreadyProven } where expandClaim diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 5981f3221a..7eae260521 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -236,19 +236,15 @@ class Goal goal where class ClaimExtractor claim where extractClaim :: (Attribute.Axiom.Axiom Symbol Variable, Verified.SentenceClaim) - -> Maybe (Attribute.Axiom.Axiom Symbol Variable, claim) + -> Maybe claim -- | Extracts all One-Path claims from a verified module. extractClaims :: ClaimExtractor claim => VerifiedModule declAtts - -- ^'IndexedModule' containing the definition - -> [(Attribute.Axiom.Axiom Symbol Variable, claim)] -extractClaims idxMod = - mapMaybe - -- applying on second component - extractClaim - (indexedModuleClaims idxMod) + -- ^ 'IndexedModule' containing the definition + -> [claim] +extractClaims = mapMaybe extractClaim . indexedModuleClaims {- NOTE: Non-deterministic semantics @@ -349,7 +345,7 @@ deriveSeqOnePath rules = instance ClaimExtractor OnePathRule where extractClaim (attrs, sentence) = case fromSentenceAxiom (attrs, Syntax.getSentenceClaim sentence) of - Right (OnePathClaimPattern claim) -> Just (attrs, claim) + Right (OnePathClaimPattern claim) -> Just claim _ -> Nothing instance Goal AllPathRule where @@ -409,7 +405,7 @@ deriveSeqAllPath rules = instance ClaimExtractor AllPathRule where extractClaim (attrs, sentence) = case fromSentenceAxiom (attrs, Syntax.getSentenceClaim sentence) of - Right (AllPathClaimPattern claim) -> Just (attrs, claim) + Right (AllPathClaimPattern claim) -> Just claim _ -> Nothing instance Goal ReachabilityRule where @@ -498,8 +494,8 @@ instance Goal ReachabilityRule where instance ClaimExtractor ReachabilityRule where extractClaim (attrs, sentence) = case fromSentenceAxiom (attrs, Syntax.getSentenceClaim sentence) of - Right (OnePathClaimPattern claim) -> Just (attrs, OnePath claim) - Right (AllPathClaimPattern claim) -> Just (attrs, AllPath claim) + Right (OnePathClaimPattern claim) -> Just (OnePath claim) + Right (AllPathClaimPattern claim) -> Just (AllPath claim) _ -> Nothing maybeOnePath :: ReachabilityRule -> Maybe OnePathRule From 545c625ce7171f57c3fe91bfc430474e17d9f4d2 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 5 May 2020 20:35:10 -0500 Subject: [PATCH 58/79] PROF OPTIONS_GHC -fno-prof-auto --- kore/src/Kore/Debug.hs | 1 + kore/src/Kore/Internal/Conditional.hs | 2 ++ kore/src/Kore/Profiler/Data.hs | 1 + kore/src/Kore/Profiler/Profile.hs | 2 ++ kore/src/Kore/Step/Simplification/Data.hs | 36 ++++++++++++++++++----- kore/src/Kore/Step/Transition.hs | 2 ++ kore/src/Kore/Unification/UnifierT.hs | 3 ++ kore/src/ListT.hs | 2 ++ kore/src/Log.hs | 2 ++ kore/src/SMT.hs | 1 + 10 files changed, 44 insertions(+), 8 deletions(-) diff --git a/kore/src/Kore/Debug.hs b/kore/src/Kore/Debug.hs index 2bfa2e4dda..c9cb467328 100644 --- a/kore/src/Kore/Debug.hs +++ b/kore/src/Kore/Debug.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-unused-top-binds #-} +{-# OPTIONS_GHC -fno-prof-auto #-} {- | Copyright : (c) Runtime Verification, 2018 diff --git a/kore/src/Kore/Internal/Conditional.hs b/kore/src/Kore/Internal/Conditional.hs index bd59a097e4..2a5e7406a1 100644 --- a/kore/src/Kore/Internal/Conditional.hs +++ b/kore/src/Kore/Internal/Conditional.hs @@ -6,6 +6,8 @@ Representation of conditional terms. -} +{-# OPTIONS_GHC -fno-prof-auto #-} + module Kore.Internal.Conditional ( Conditional (..) , withoutTerm diff --git a/kore/src/Kore/Profiler/Data.hs b/kore/src/Kore/Profiler/Data.hs index bc477739cc..641c57e45e 100644 --- a/kore/src/Kore/Profiler/Data.hs +++ b/kore/src/Kore/Profiler/Data.hs @@ -2,6 +2,7 @@ Copyright : (c) Runtime Verification, 2019 License : NCSA -} +{-# OPTIONS_GHC -fno-prof-auto #-} module Kore.Profiler.Data ( MonadProfiler (..) , profileEvent diff --git a/kore/src/Kore/Profiler/Profile.hs b/kore/src/Kore/Profiler/Profile.hs index 8e4e68bd0a..6e2da4531a 100644 --- a/kore/src/Kore/Profiler/Profile.hs +++ b/kore/src/Kore/Profiler/Profile.hs @@ -4,6 +4,8 @@ License : NCSA This should be imported @qualified@. -} + +{-# OPTIONS_GHC -fno-prof-auto #-} module Kore.Profiler.Profile ( axiomBranching , axiomEvaluation diff --git a/kore/src/Kore/Step/Simplification/Data.hs b/kore/src/Kore/Step/Simplification/Data.hs index 63dcd45949..e9d3d7f757 100644 --- a/kore/src/Kore/Step/Simplification/Data.hs +++ b/kore/src/Kore/Step/Simplification/Data.hs @@ -9,6 +9,7 @@ Portability : portable -} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-prof-auto #-} module Kore.Step.Simplification.Data ( MonadSimplify (..), InternalVariable @@ -187,6 +188,7 @@ evalSimplifier verifiedModule simplifier = do runReaderT (runSimplifierT simplifier) env where !earlyEnv = + {-# SCC "evalSimplifier/earlyEnv" #-} Env { metadataTools = earlyMetadataTools , simplifierTermLike @@ -196,25 +198,42 @@ evalSimplifier verifiedModule simplifier = do , injSimplifier , overloadSimplifier } - sortGraph = SortGraph.fromIndexedModule verifiedModule - injSimplifier = mkInjSimplifier sortGraph + sortGraph = + {-# SCC "evalSimplifier/sortGraph" #-} + SortGraph.fromIndexedModule verifiedModule + injSimplifier = + {-# SCC "evalSimplifier/injSimplifier" #-} + mkInjSimplifier sortGraph -- It's safe to build the MetadataTools using the external -- IndexedModule because MetadataTools doesn't retain any -- knowledge of the patterns which are internalized. earlyMetadataTools = MetadataTools.build verifiedModule - simplifierTermLike = Simplifier.create - substitutionSimplifier = SubstitutionSimplifier.substitutionSimplifier - simplifierCondition = Condition.create substitutionSimplifier + simplifierTermLike = + {-# SCC "evalSimplifier/simplifierTermLike" #-} + Simplifier.create + substitutionSimplifier = + {-# SCC "evalSimplifier/substitutionSimplifier" #-} + SubstitutionSimplifier.substitutionSimplifier + simplifierCondition = + {-# SCC "evalSimplifier/simplifierCondition" #-} + Condition.create substitutionSimplifier -- Initialize without any builtin or axiom simplifiers. earlySimplifierAxioms = Map.empty verifiedModule' = + {-# SCC "evalSimplifier/verifiedModule'" #-} IndexedModule.mapPatterns (Builtin.internalize earlyMetadataTools) verifiedModule - metadataTools = MetadataTools.build verifiedModule' - overloadGraph = OverloadGraph.fromIndexedModule verifiedModule - overloadSimplifier = mkOverloadSimplifier overloadGraph injSimplifier + metadataTools = + {-# SCC "evalSimplifier/metadataTools" #-} + MetadataTools.build verifiedModule' + overloadGraph = + {-# SCC "evalSimplifier/overloadGraph" #-} + OverloadGraph.fromIndexedModule verifiedModule + overloadSimplifier = + {-# SCC "evalSimplifier/overloadSimplifier" #-} + mkOverloadSimplifier overloadGraph injSimplifier initialize :: SimplifierT smt (Env (SimplifierT smt)) initialize = do @@ -229,6 +248,7 @@ evalSimplifier verifiedModule simplifier = do Axiom.EvaluationStrategy.builtinEvaluation <$> Builtin.koreEvaluators verifiedModule' simplifierAxioms = + {-# SCC "evalSimplifier/simplifierAxioms" #-} Map.unionWith Axiom.EvaluationStrategy.simplifierWithFallback builtinEvaluators diff --git a/kore/src/Kore/Step/Transition.hs b/kore/src/Kore/Step/Transition.hs index 943e07e325..f62b0a2cfa 100644 --- a/kore/src/Kore/Step/Transition.hs +++ b/kore/src/Kore/Step/Transition.hs @@ -6,6 +6,8 @@ License : NCSA {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-prof-auto #-} + module Kore.Step.Transition ( TransitionT (..) , runTransitionT diff --git a/kore/src/Kore/Unification/UnifierT.hs b/kore/src/Kore/Unification/UnifierT.hs index 75f69bb88a..cd1108bd6d 100644 --- a/kore/src/Kore/Unification/UnifierT.hs +++ b/kore/src/Kore/Unification/UnifierT.hs @@ -3,6 +3,9 @@ Copyright : (c) Runtime Verification, 2019 License : NCSA -} + +{-# OPTIONS_GHC -fno-prof-auto #-} + module Kore.Unification.UnifierT ( UnifierT (..) , lowerExceptT diff --git a/kore/src/ListT.hs b/kore/src/ListT.hs index 777957d6e9..fd3be1358a 100644 --- a/kore/src/ListT.hs +++ b/kore/src/ListT.hs @@ -11,6 +11,8 @@ This module implements the list monad transformer. {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-prof-auto #-} + module ListT ( ListT (..) , cons diff --git a/kore/src/Log.hs b/kore/src/Log.hs index 4713bf201e..09521dcecb 100644 --- a/kore/src/Log.hs +++ b/kore/src/Log.hs @@ -4,6 +4,8 @@ License : NCSA -} +{-# OPTIONS_GHC -fno-prof-auto #-} + module Log ( -- * Entries diff --git a/kore/src/SMT.hs b/kore/src/SMT.hs index 19e23f46eb..164f02f3ea 100644 --- a/kore/src/SMT.hs +++ b/kore/src/SMT.hs @@ -6,6 +6,7 @@ License : NCSA Maintainer : thomas.tuegel@runtimeverification.com -} +{-# OPTIONS_GHC -fno-prof-auto #-} module SMT ( SMT, getSMT From b87f200511c7f691a82ed05cbbb1161e71ff5c54 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Wed, 6 May 2020 06:25:20 -0500 Subject: [PATCH 59/79] ruleAllPathToRuleReachability: Use coerce --- kore/src/Kore/Strategies/Goal.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index 7eae260521..6ead20a111 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -560,14 +560,12 @@ ruleReachabilityToRuleOnePath = coerce ruleAllPathToRuleReachability :: Rule AllPathRule -> Rule ReachabilityRule -ruleAllPathToRuleReachability = - ReachabilityRewriteRule . mkRewritingRule . RewriteRule . toRulePattern +ruleAllPathToRuleReachability = coerce ruleOnePathToRuleReachability :: Rule OnePathRule -> Rule ReachabilityRule -ruleOnePathToRuleReachability = - ReachabilityRewriteRule . mkRewritingRule . RewriteRule . toRulePattern +ruleOnePathToRuleReachability = coerce data TransitionRuleTemplate monad goal = TransitionRuleTemplate From b3b01f3b763156f037dc32e6c1a8a048ae5843f9 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Wed, 6 May 2020 09:49:59 -0500 Subject: [PATCH 60/79] fixup! PROF OPTIONS_GHC -fno-prof-auto --- kore/src/Branch.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/kore/src/Branch.hs b/kore/src/Branch.hs index 206b8429b9..a4e5576aa2 100644 --- a/kore/src/Branch.hs +++ b/kore/src/Branch.hs @@ -6,6 +6,8 @@ License : NCSA {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-prof-auto #-} + module Branch ( BranchT (..) , mapBranchT From 3e28c0581d7404383e5d9d29367ad184e4c3deab Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Wed, 6 May 2020 10:27:31 -0500 Subject: [PATCH 61/79] Kore.Exec: Lint --- kore/src/Kore/Exec.hs | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/kore/src/Kore/Exec.hs b/kore/src/Kore/Exec.hs index dc7eb3bf47..a81e4a4c22 100644 --- a/kore/src/Kore/Exec.hs +++ b/kore/src/Kore/Exec.hs @@ -334,20 +334,18 @@ prove specModule trustedModule let InitializedProver { axioms, claims, alreadyProven } = initialized - result <- - verify - breadthLimit - searchOrder - (AllClaims claims) - (Axioms axioms) - (AlreadyProven (map unparseToText2 alreadyProven)) - (ToProve - (map (\x -> (x, depthLimit)) - (extractUntrustedClaims' claims) - ) + verify + breadthLimit + searchOrder + (AllClaims claims) + (Axioms axioms) + (AlreadyProven (map unparseToText2 alreadyProven)) + (ToProve + (map (\x -> (x, depthLimit)) + (extractUntrustedClaims' claims) ) + ) & runExceptT - return result where extractUntrustedClaims' :: [ReachabilityRule] -> [ReachabilityRule] extractUntrustedClaims' = filter (not . Goal.isTrusted) From b4ec0a543d9db5efa1c4130e0567ae8d726ed5d2 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Wed, 6 May 2020 14:08:15 -0500 Subject: [PATCH 62/79] gitignore: TAGS file --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 00dc2614cb..4e27d296e4 100644 --- a/.gitignore +++ b/.gitignore @@ -43,3 +43,5 @@ cabal.project.local *.save-proofs.kore .envrc /result* +/TAGS +/.TAGS* From b835ad43d69ed50037cf2de16087dc8f1b7d8392 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Wed, 6 May 2020 14:20:10 -0500 Subject: [PATCH 63/79] Kore.Exec: Lint --- kore/src/Kore/Exec.hs | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/kore/src/Kore/Exec.hs b/kore/src/Kore/Exec.hs index a0e9821ec8..14cb2c5fcf 100644 --- a/kore/src/Kore/Exec.hs +++ b/kore/src/Kore/Exec.hs @@ -334,20 +334,18 @@ prove evalProver definitionModule specModule maybeAlreadyProvenModule $ \initialized -> do let InitializedProver { axioms, claims, alreadyProven } = initialized - result <- - runExceptT - $ verify - breadthLimit - searchOrder - (AllClaims claims) - (Axioms axioms) - (AlreadyProven (map unparseToText2 alreadyProven)) - (ToProve - (map (\x -> (x,depthLimit)) - (extractUntrustedClaims' claims) - ) + verify + breadthLimit + searchOrder + (AllClaims claims) + (Axioms axioms) + (AlreadyProven (map unparseToText2 alreadyProven)) + (ToProve + (map (\x -> (x,depthLimit)) + (extractUntrustedClaims' claims) ) - return result + ) + & runExceptT where extractUntrustedClaims' :: [ReachabilityRule] -> [ReachabilityRule] extractUntrustedClaims' = filter (not . Goal.isTrusted) From bc44c9a0036808c9b52d80da20201619a8fa0719 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Wed, 6 May 2020 17:06:31 -0500 Subject: [PATCH 64/79] WIP Kore.Step.Strategy: unfoldM --- kore/src/Kore/Step.hs | 4 +- kore/src/Kore/Step/Strategy.hs | 30 +++++++++++ kore/src/Kore/Strategies/Verification.hs | 64 ++++++++++++++++-------- kore/test/Test/Kore/Strategies/Common.hs | 2 - 4 files changed, 77 insertions(+), 23 deletions(-) diff --git a/kore/src/Kore/Step.hs b/kore/src/Kore/Step.hs index 61371f5884..a8ba8cec0c 100644 --- a/kore/src/Kore/Step.hs +++ b/kore/src/Kore/Step.hs @@ -61,7 +61,9 @@ import qualified Kore.Step.SMT.Evaluator as SMT.Evaluator ( filterMultiOr ) import qualified Kore.Step.Step as Step -import Kore.Step.Strategy +import Kore.Step.Strategy hiding + ( transitionRule + ) import qualified Kore.Step.Strategy as Strategy import qualified Kore.Step.Transition as Transition import Kore.Syntax.Variable diff --git a/kore/src/Kore/Step/Strategy.hs b/kore/src/Kore/Step/Strategy.hs index 4156d7fe14..31126b39d7 100644 --- a/kore/src/Kore/Step/Strategy.hs +++ b/kore/src/Kore/Step/Strategy.hs @@ -30,6 +30,7 @@ module Kore.Step.Strategy , stuck , continue -- * Running strategies + , unfoldM , GraphSearchOrder(..) , constructExecutionGraph , ExecutionGraph(..) @@ -43,6 +44,7 @@ module Kore.Step.Strategy , pickStar , pickPlus , assert + , transitionRule , executionHistoryStep , emptyExecutionGraph , module Kore.Step.Transition @@ -473,6 +475,34 @@ constructExecutionGraph breadthLimit transit instrs0 searchOrder0 config0 = do , parents = [(rules, node)] } +unfoldM + :: forall m config instr + . MonadProfiler m + => Alternative m + => Limit Natural + -> GraphSearchOrder + -> (instr -> config -> m [config]) + -> [instr] + -> config + -> m config +unfoldM _ searchOrder transit instrs0 config0 = + worker (Seq.singleton (config0, instrs0)) + where + mkSeeds instrs configs = Seq.fromList (flip (,) instrs <$> configs) + worker Seq.Empty = empty + worker ((config, instrs) Seq.:<| rest) = + case instrs of + [] -> return config <|> worker rest + instr : instrs' -> do + configs' <- transit instr config + let seeds = + case searchOrder of + BreadthFirst -> rest <> mkSeeds instrs' configs' + DepthFirst -> mkSeeds instrs' configs' <> rest + if null configs' + then return config <|> worker rest + else worker seeds + {- | Transition rule for running a 'Strategy'. -} diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index fcc11bea30..c866cbec1d 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -60,7 +60,10 @@ import Kore.Step.RulePattern ( RHS ) import Kore.Step.Simplification.Simplify -import Kore.Step.Strategy +import Kore.Step.Strategy hiding + ( transitionRule + ) +import qualified Kore.Step.Strategy as Strategy import Kore.Step.Transition ( runTransitionT ) @@ -74,6 +77,9 @@ import Kore.Syntax.Variable ( Variable ) import Kore.Unparser +import ListT + ( ListT (..) + ) type CommonProofState = ProofState.ProofState (Pattern Variable) @@ -150,7 +156,6 @@ verify => ProofState claim (Pattern Variable) ~ CommonProofState => Show claim => (MonadCatch m, MonadSimplify m) - => Show (Rule claim) => Limit Natural -> GraphSearchOrder -> AllClaims claim @@ -201,7 +206,6 @@ verifyHelper => ProofState claim (Pattern Variable) ~ CommonProofState => Show claim => (MonadCatch m, MonadSimplify m) - => Show (Rule claim) => Limit Natural -> GraphSearchOrder -> AllClaims claim @@ -239,7 +243,6 @@ verifyClaim => ProofState claim (Pattern Variable) ~ CommonProofState => Claim claim => Show claim - => Show (Rule claim) => Limit Natural -> GraphSearchOrder -> AllClaims claim @@ -256,27 +259,48 @@ verifyClaim traceExceptT D_OnePath_verifyClaim [debugArg "rule" goal] $ do let startPattern = ProofState.Goal $ getConfiguration goal - destination = getDestination goal limitedStrategy = - Limit.takeWithin - depthLimit - (Foldable.toList $ strategy goal claims axioms) - executionGraph <- - runStrategyWithSearchOrder - breadthLimit - (modifiedTransitionRule destination) - limitedStrategy - searchOrder - startPattern - -- Throw the first unproven configuration as an error. - Foldable.traverse_ Monad.Except.throwError (unprovenNodes executionGraph) + strategy goal claims axioms + & Foldable.toList + & Limit.takeWithin depthLimit + unfoldM + breadthLimit + searchOrder + transit + limitedStrategy + startPattern + & throwUnproven where + destination = getDestination goal + + throwUnproven + :: ListT (ExceptT (Pattern Variable) m) (ProofState.ProofState (Pattern Variable)) + -> ExceptT (Pattern Variable) m () + throwUnproven acts = + foldListT acts throwUnprovenOrElse done + where + done = return () + + throwUnprovenOrElse + :: ProofState.ProofState (Pattern Variable) + -> ExceptT (Pattern Variable) m () + -> ExceptT (Pattern Variable) m () + throwUnprovenOrElse proofState acts = do + ProofState.extractUnproven proofState + & Foldable.traverse_ Monad.Except.throwError + acts + + transit instr config = + Strategy.transitionRule modifiedTransitionRule instr config + & runTransitionT + & fmap (fst . unzip) + & lift + modifiedTransitionRule - :: RHS Variable - -> Prim claim + :: Prim claim -> CommonProofState -> TransitionT (Rule claim) (Verifier m) CommonProofState - modifiedTransitionRule destination prim proofState' = do + modifiedTransitionRule prim proofState' = do transitions <- lift . lift . runTransitionT $ transitionRule' goal destination prim proofState' diff --git a/kore/test/Test/Kore/Strategies/Common.hs b/kore/test/Test/Kore/Strategies/Common.hs index 329dcb48dd..df3f57043e 100644 --- a/kore/test/Test/Kore/Strategies/Common.hs +++ b/kore/test/Test/Kore/Strategies/Common.hs @@ -55,7 +55,6 @@ runVerificationToPattern :: Verification.Claim claim => ProofState claim (Pattern Variable) ~ Verification.CommonProofState => Show claim - => Show (Rule claim) => Limit Natural -> Limit Natural -> [Rule claim] @@ -81,7 +80,6 @@ runVerification :: Verification.Claim claim => ProofState claim (Pattern Variable) ~ Verification.CommonProofState => Show claim - => Show (Rule claim) => Limit Natural -> Limit Natural -> [Rule claim] From 6c1bade14e37582e7584eb727fd3313bb4f7db0b Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Thu, 7 May 2020 09:22:27 -0500 Subject: [PATCH 65/79] Kore.Strategies.Goal: Remove duplicate withConfiguration' --- kore/src/Kore/Strategies/Goal.hs | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/kore/src/Kore/Strategies/Goal.hs b/kore/src/Kore/Strategies/Goal.hs index f095be5703..89a400f6cf 100644 --- a/kore/src/Kore/Strategies/Goal.hs +++ b/kore/src/Kore/Strategies/Goal.hs @@ -843,7 +843,7 @@ removeDestination lensRulePattern mkState goal = & GoalStuck & pure & run - & withConfiguration' configuration + & withConfiguration configuration where configuration = Lens.view RulePattern.leftPattern rulePattern configFreeVars = freeVariables configuration @@ -864,7 +864,7 @@ simplify -> Strategy.TransitionT (Rule goal) m goal simplify lensRulePattern = Lens.traverseOf (lensRulePattern . RulePattern.leftPattern) $ \config -> - withConfiguration' config $ do + withConfiguration config $ do configs <- simplifyTopConfiguration config >>= SMT.Evaluator.filterMultiOr & lift @@ -918,7 +918,7 @@ deriveWith deriveWith lensRulePattern mkRule takeStep rewrites goal = (\x -> getCompose $ x goal) $ Lens.traverseOf (lensRulePattern . RulePattern.leftPattern) - $ \config -> Compose $ withConfiguration' config $ do + $ \config -> Compose $ withConfiguration config $ do results <- takeStep rewrites config & assertInstantiated config deriveResults mkRule results where @@ -970,12 +970,8 @@ deriveResults mkRule Results { results, remainders } = fromAppliedRule = mkRule . RewriteRule . Step.unRewritingRule . Step.withoutUnification -withConfiguration' :: MonadCatch m => Pattern Variable -> m a -> m a -withConfiguration' configuration = - handle (throw . WithConfiguration configuration) - -withConfiguration' :: MonadCatch m => Pattern Variable -> m a -> m a -withConfiguration' configuration = +withConfiguration :: MonadCatch m => Pattern Variable -> m a -> m a +withConfiguration configuration = handle (throw . WithConfiguration configuration) {- | The predicate to remove the destination from the present configuration. From 8cdcdd78207f313d42eefd068ef9957bb9773210 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Thu, 7 May 2020 11:02:30 -0500 Subject: [PATCH 66/79] Kore.Step.Strategy: Extract unfoldTransition from leavesM --- kore/src/Kore/Step/Strategy.hs | 85 ++++++++++++++++-------- kore/src/Kore/Strategies/Verification.hs | 9 +-- kore/test/Test/Kore/Exec.hs | 23 ++++--- 3 files changed, 75 insertions(+), 42 deletions(-) diff --git a/kore/src/Kore/Step/Strategy.hs b/kore/src/Kore/Step/Strategy.hs index 31126b39d7..68ac556054 100644 --- a/kore/src/Kore/Step/Strategy.hs +++ b/kore/src/Kore/Step/Strategy.hs @@ -30,7 +30,8 @@ module Kore.Step.Strategy , stuck , continue -- * Running strategies - , unfoldM + , leavesM + , unfoldTransition , GraphSearchOrder(..) , constructExecutionGraph , ExecutionGraph(..) @@ -62,9 +63,13 @@ import Prelude.Kore hiding , some ) +import Control.Error + ( maybeT + ) import qualified Control.Exception as Exception import Control.Monad - ( when + ( guard + , when , (>=>) ) import Control.Monad.State.Strict @@ -379,11 +384,10 @@ emptyExecutionGraph config = -} data GraphSearchOrder = BreadthFirst | DepthFirst deriving Eq -newtype LimitExceeded instr = LimitExceeded (Seq (Graph.Node, [instr])) +newtype LimitExceeded a = LimitExceeded (Seq a) deriving (Show, Typeable) -instance (Show instr, Typeable instr) - => Exception.Exception (LimitExceeded instr) +instance (Show a, Typeable a) => Exception.Exception (LimitExceeded a) {- | Execute a 'Strategy'. @@ -475,33 +479,60 @@ constructExecutionGraph breadthLimit transit instrs0 searchOrder0 config0 = do , parents = [(rules, node)] } -unfoldM - :: forall m config instr - . MonadProfiler m +{- | Unfold the function from the initial vertex. + +@leavesM@ returns a disjunction of leaves (vertices without descendants) rather +than constructing the entire graph. + + -} +leavesM + :: forall m a + . Monad m => Alternative m + => (Show a, Typeable a) => Limit Natural -> GraphSearchOrder - -> (instr -> config -> m [config]) - -> [instr] - -> config - -> m config -unfoldM _ searchOrder transit instrs0 config0 = - worker (Seq.singleton (config0, instrs0)) + -> (a -> m [a]) -- ^ unfolding function + -> a -- ^ initial vertex + -> m a +leavesM breadthLimit searchOrder next a0 = + worker (Seq.singleton a0) where - mkSeeds instrs configs = Seq.fromList (flip (,) instrs <$> configs) + mk :: Seq a -> [a] -> Seq a + mk as as' = + case searchOrder of + BreadthFirst -> as <> Seq.fromList as' + DepthFirst -> Seq.fromList as' <> as + + exceedsLimit = not . withinLimit breadthLimit . fromIntegral . Seq.length + worker Seq.Empty = empty - worker ((config, instrs) Seq.:<| rest) = - case instrs of - [] -> return config <|> worker rest - instr : instrs' -> do - configs' <- transit instr config - let seeds = - case searchOrder of - BreadthFirst -> rest <> mkSeeds instrs' configs' - DepthFirst -> mkSeeds instrs' configs' <> rest - if null configs' - then return config <|> worker rest - else worker seeds + worker (a Seq.:<| as) = + do + when (exceedsLimit as) (Exception.throw $ LimitExceeded as) + as' <- lift (next a) + (guard . not) (null as') + pure (mk as as') + & maybeT (return a <|> worker as) worker + +{- | Turn a transition rule into an unfolding function. + +@unfoldTransition@ applies the transition rule to the first @instr@ and threads +the tail of the list to the results. The result is @[]@ if the @[instr]@ is +empty. + + -} +unfoldTransition + :: Monad m + => (instr -> config -> m [config]) -- ^ transition rule + -> ([instr], config) + -> m [([instr], config)] +unfoldTransition transit (instrs, config) = + case instrs of + [] -> pure [] + instr : instrs' -> do + configs' <- transit instr config + pure ((,) instrs' <$> configs') {- | Transition rule for running a 'Strategy'. diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index 41e62a8fe1..6da7581fa6 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -227,15 +227,16 @@ verifyClaim strategy goal claims axioms & Foldable.toList & Limit.takeWithin depthLimit - Strategy.unfoldM + Strategy.leavesM breadthLimit searchOrder - transit - limitedStrategy - startPattern + (Strategy.unfoldTransition transit) + (limitedStrategy, startPattern) + & fmap discardStrategy & throwUnproven where destination = getDestination goal + discardStrategy = snd throwUnproven :: ListT (Verifier simplifier) CommonProofState diff --git a/kore/test/Test/Kore/Exec.hs b/kore/test/Test/Kore/Exec.hs index 690b1efd3d..0d2039b1de 100644 --- a/kore/test/Test/Kore/Exec.hs +++ b/kore/test/Test/Kore/Exec.hs @@ -3,7 +3,7 @@ module Test.Kore.Exec , test_execPriority , test_search , test_searchPriority - , test_searchExeedingBreadthLimit + , test_searchExceedingBreadthLimit , test_execGetExitCode ) where @@ -18,10 +18,7 @@ import Control.Exception as Exception import Data.Default ( def ) -import Data.Limit - ( Limit (..) - ) -import qualified Data.Limit as Limit +import qualified Data.Graph.Inductive.Graph as Graph import qualified Data.Map.Strict as Map import Data.Set ( Set @@ -34,6 +31,10 @@ import System.Exit ( ExitCode (..) ) +import Data.Limit + ( Limit (..) + ) +import qualified Data.Limit as Limit import Kore.ASTVerifier.DefinitionVerifier ( verifyAndIndexDefinition ) @@ -273,8 +274,8 @@ test_search = PLUS -> Set.fromList [b, c, d] FINAL -> Set.fromList [b, d] -test_searchExeedingBreadthLimit :: [TestTree] -test_searchExeedingBreadthLimit = +test_searchExceedingBreadthLimit :: [TestTree] +test_searchExceedingBreadthLimit = [ makeTestCase searchType | searchType <- [ ONE, STAR, PLUS, FINAL] ] where unlimited :: Limit Integer @@ -285,11 +286,11 @@ test_searchExeedingBreadthLimit = (assertion searchType) assertion searchType = - shouldExeedBreadthLimit searchType `catch` - \(_ :: LimitExceeded (Strategy (Prim Rewrite))) -> pure () + shouldExceedBreadthLimit searchType `catch` + \(_ :: LimitExceeded (Graph.Node, [Strategy (Prim Rewrite)])) -> pure () - shouldExeedBreadthLimit :: SearchType -> IO () - shouldExeedBreadthLimit searchType = do + shouldExceedBreadthLimit :: SearchType -> IO () + shouldExceedBreadthLimit searchType = do a <- actual searchType when (a == expected searchType) $ assertFailure "Did not exceed breadth limit" From edc34233b056a6eedf4c90a1dbf07e46414859a0 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 8 May 2020 09:33:42 -0500 Subject: [PATCH 67/79] Add instance MonadProfiler (CatchT _) --- kore/src/Kore/Profiler/Data.hs | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/kore/src/Kore/Profiler/Data.hs b/kore/src/Kore/Profiler/Data.hs index 641c57e45e..135bb060c7 100644 --- a/kore/src/Kore/Profiler/Data.hs +++ b/kore/src/Kore/Profiler/Data.hs @@ -17,6 +17,10 @@ import Prelude.Kore import Control.Monad ( when ) +import Control.Monad.Catch.Pure + ( CatchT + , mapCatchT + ) import Control.Monad.Morph ( MFunctor (..) ) @@ -257,24 +261,28 @@ profileGhcEventsAnalyze event action = do liftIO $ traceEventIO ("STOP " ++ List.intercalate "/" event) return a -instance (MonadProfiler m) => MonadProfiler (ReaderT thing m ) - -instance MonadProfiler m => MonadProfiler (Strict.StateT s m) +instance (MonadProfiler m, Monoid w) => MonadProfiler (AccumT w m) + where + profile a action = AccumT (profile a . runAccumT action) + {-# INLINE profile #-} -instance MonadProfiler m => MonadProfiler (MaybeT m) +instance MonadProfiler m => MonadProfiler (CatchT m) where + profile a = mapCatchT (profile a) + {-# INLINE profile #-} -instance MonadProfiler m => MonadProfiler (IdentityT m) +instance MonadProfiler m => MonadProfiler (CounterT m) instance MonadProfiler m => MonadProfiler (ExceptT e m) +instance MonadProfiler m => MonadProfiler (IdentityT m) + instance MonadProfiler m => MonadProfiler (ListT m) where profile a action = ListT.mapListT (profile a) action {-# INLINE profile #-} -instance (MonadProfiler m, Monoid w) => MonadProfiler (AccumT w m) - where - profile a action = AccumT (profile a . runAccumT action) - {-# INLINE profile #-} +instance MonadProfiler m => MonadProfiler (MaybeT m) -instance MonadProfiler m => MonadProfiler (CounterT m) +instance MonadProfiler m => MonadProfiler (ReaderT thing m ) + +instance MonadProfiler m => MonadProfiler (Strict.StateT s m) From 9338efdd18d4886217af5aef3759aa4391074365 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 8 May 2020 09:34:56 -0500 Subject: [PATCH 68/79] Kore.Profiler.Data: Reduce some instances --- kore/src/Kore/Profiler/Data.hs | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/kore/src/Kore/Profiler/Data.hs b/kore/src/Kore/Profiler/Data.hs index 135bb060c7..8e76bfbf2c 100644 --- a/kore/src/Kore/Profiler/Data.hs +++ b/kore/src/Kore/Profiler/Data.hs @@ -29,8 +29,8 @@ import Control.Monad.Reader ) import qualified Control.Monad.State.Strict as Strict import Control.Monad.Trans.Accum - ( AccumT (AccumT) - , runAccumT + ( AccumT + , mapAccumT ) import Control.Monad.Trans.Except ( ExceptT @@ -59,12 +59,10 @@ import System.Clock import Control.Monad.Counter import ListT ( ListT (..) - ) -import qualified ListT - ( mapListT + , mapListT ) -{- Monad that can also handle profiling events. +{- | Monad that can also handle profiling events. -} class Monad profiler => MonadProfiler profiler where profile @@ -263,7 +261,7 @@ profileGhcEventsAnalyze event action = do instance (MonadProfiler m, Monoid w) => MonadProfiler (AccumT w m) where - profile a action = AccumT (profile a . runAccumT action) + profile a = mapAccumT (profile a) {-# INLINE profile #-} instance MonadProfiler m => MonadProfiler (CatchT m) where @@ -277,8 +275,7 @@ instance MonadProfiler m => MonadProfiler (ExceptT e m) instance MonadProfiler m => MonadProfiler (IdentityT m) instance MonadProfiler m => MonadProfiler (ListT m) where - profile a action = - ListT.mapListT (profile a) action + profile a = mapListT (profile a) {-# INLINE profile #-} instance MonadProfiler m => MonadProfiler (MaybeT m) From 49f435b4ba4c58be4d7e57e5a51d5d42118756e9 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 8 May 2020 09:38:26 -0500 Subject: [PATCH 69/79] Add instance MonadThrow (ListT _) --- kore/src/ListT.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/kore/src/ListT.hs b/kore/src/ListT.hs index fd3be1358a..db71d0d2ee 100644 --- a/kore/src/ListT.hs +++ b/kore/src/ListT.hs @@ -27,6 +27,7 @@ import Prelude import Control.Applicative import Control.Monad +import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Morph import Control.Monad.RWS.Class @@ -152,6 +153,10 @@ instance (Monad f, Foldable f) => Foldable (ListT f) where fold $ foldListT as (\a r -> mappend (f a) <$> r) (pure mempty) {-# INLINE foldMap #-} +instance MonadThrow m => MonadThrow (ListT m) where + throwM = lift . throwM + {-# INLINE throwM #-} + cons :: a -> ListT m a -> ListT m a cons a as = ListT $ \yield -> yield a . foldListT as yield {-# INLINE cons #-} From b03397acd4e0f731ccf70b2a8cda0f24a9a48054 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 8 May 2020 09:43:17 -0500 Subject: [PATCH 70/79] Throw LimitExceeded in MonadThrow --- kore/src/Kore/Exec.hs | 22 +++++++++++++++------- kore/src/Kore/ModelChecker/Bounded.hs | 21 ++++++++++++--------- kore/src/Kore/Step/Strategy.hs | 20 ++++++++++++-------- kore/test/Test/Kore/Step/Strategy.hs | 15 +++++++++------ 4 files changed, 48 insertions(+), 30 deletions(-) diff --git a/kore/src/Kore/Exec.hs b/kore/src/Kore/Exec.hs index d413601769..770eced3eb 100644 --- a/kore/src/Kore/Exec.hs +++ b/kore/src/Kore/Exec.hs @@ -30,6 +30,7 @@ import Control.Error.Util ) import Control.Monad.Catch ( MonadCatch + , MonadThrow ) import Control.Monad.Trans.Except ( runExceptT @@ -167,6 +168,9 @@ import Kore.Unparser ( unparseToText , unparseToText2 ) +import Log + ( MonadLog + ) import qualified Log import SMT ( MonadSMT @@ -197,10 +201,11 @@ data Execution = -- | Symbolic execution exec - :: ( Log.WithLog Log.LogMessage smt + :: ( MonadIO smt + , MonadLog smt , MonadProfiler smt , MonadSMT smt - , MonadIO smt + , MonadThrow smt ) => Limit Natural -> VerifiedModule StepperAttributes @@ -234,10 +239,11 @@ exec breadthLimit verifiedModule strategy initialTerm = -- | Project the value of the exit cell, if it is present. execGetExitCode - :: ( Log.WithLog Log.LogMessage smt + :: ( MonadIO smt + , MonadLog smt , MonadProfiler smt , MonadSMT smt - , MonadIO smt + , MonadThrow smt ) => VerifiedModule StepperAttributes -- ^ The main module @@ -262,10 +268,11 @@ execGetExitCode indexedModule strategy' finalTerm = -- | Symbolic search search - :: ( Log.WithLog Log.LogMessage smt + :: ( MonadIO smt + , MonadLog smt , MonadProfiler smt , MonadSMT smt - , MonadIO smt + , MonadThrow smt ) => Limit Natural -> VerifiedModule StepperAttributes @@ -404,6 +411,7 @@ boundedModelCheck , MonadProfiler smt , MonadSMT smt , MonadIO smt + , MonadThrow smt ) => Limit Natural -> Limit Natural @@ -584,7 +592,7 @@ simplifyReachabilityRule rule = do -- | Construct an execution graph for the given input pattern. execute - :: MonadSimplify simplifier + :: (MonadSimplify simplifier, MonadThrow simplifier) => Limit Natural -> VerifiedModule StepperAttributes -- ^ The main module diff --git a/kore/src/Kore/ModelChecker/Bounded.hs b/kore/src/Kore/ModelChecker/Bounded.hs index cfa1c3f15c..3caa164677 100644 --- a/kore/src/Kore/ModelChecker/Bounded.hs +++ b/kore/src/Kore/ModelChecker/Bounded.hs @@ -14,6 +14,9 @@ module Kore.ModelChecker.Bounded import Prelude.Kore +import Control.Monad.Catch + ( MonadThrow + ) import qualified Control.Monad.State.Strict as State import qualified Data.Foldable as Foldable import qualified Data.Graph.Inductive.Graph as Graph @@ -100,7 +103,7 @@ bmcStrategy checkClaim :: forall m - . MonadSimplify m + . (MonadSimplify m, MonadThrow m) => Limit Natural -> ( CommonModalPattern -> [Strategy (Prim CommonModalPattern (RewriteRule Variable))] @@ -133,14 +136,14 @@ checkClaim , predicate = Predicate.makeTruePredicate_ , substitution = mempty } - executionGraph <- State.evalStateT - (runStrategyWithSearchOrder - breadthLimit - transitionRule' - strategy - searchOrder - startState) - Nothing + executionGraph <- + runStrategyWithSearchOrder + breadthLimit + transitionRule' + strategy + searchOrder + startState + & flip State.evalStateT Nothing Log.logInfo . Text.pack $ ("searched states: " ++ (show . Graph.order . graph $ executionGraph)) diff --git a/kore/src/Kore/Step/Strategy.hs b/kore/src/Kore/Step/Strategy.hs index 68ac556054..e0d75e71cd 100644 --- a/kore/src/Kore/Step/Strategy.hs +++ b/kore/src/Kore/Step/Strategy.hs @@ -66,12 +66,16 @@ import Prelude.Kore hiding import Control.Error ( maybeT ) -import qualified Control.Exception as Exception import Control.Monad ( guard , when , (>=>) ) +import Control.Monad.Catch + ( Exception (..) + , MonadThrow + ) +import qualified Control.Monad.Catch as Exception import Control.Monad.State.Strict ( MonadState , StateT @@ -387,7 +391,7 @@ data GraphSearchOrder = BreadthFirst | DepthFirst deriving Eq newtype LimitExceeded a = LimitExceeded (Seq a) deriving (Show, Typeable) -instance (Show a, Typeable a) => Exception.Exception (LimitExceeded a) +instance (Show a, Typeable a) => Exception (LimitExceeded a) {- | Execute a 'Strategy'. @@ -407,7 +411,7 @@ See also: 'pickLongest', 'pickFinal', 'pickOne', 'pickStar', 'pickPlus' constructExecutionGraph :: forall m config rule instr - . MonadProfiler m + . (MonadProfiler m, MonadThrow m) => Show instr => Typeable instr => Limit Natural @@ -438,7 +442,7 @@ constructExecutionGraph breadthLimit transit instrs0 searchOrder0 config0 = do | instr : instrs' <- instrs = Profile.executionQueueLength (Seq.length rest) $ do when (exeedsLimit rest) - $ Exception.throw $ LimitExceeded rest + $ Exception.throwM $ LimitExceeded rest nodes' <- applyInstr instr node let seeds = map (withInstrs instrs') nodes' case searchOrder of @@ -487,7 +491,7 @@ than constructing the entire graph. -} leavesM :: forall m a - . Monad m + . MonadThrow m => Alternative m => (Show a, Typeable a) => Limit Natural @@ -509,7 +513,7 @@ leavesM breadthLimit searchOrder next a0 = worker Seq.Empty = empty worker (a Seq.:<| as) = do - when (exceedsLimit as) (Exception.throw $ LimitExceeded as) + when (exceedsLimit as) (Exception.throwM $ LimitExceeded as) as' <- lift (next a) (guard . not) (null as') pure (mk as as') @@ -593,7 +597,7 @@ See also: 'pickLongest', 'pickFinal', 'pickOne', 'pickStar', 'pickPlus' runStrategy :: forall m prim rule config - . MonadProfiler m + . (MonadProfiler m, MonadThrow m) => Show prim => Typeable prim => Limit Natural @@ -609,7 +613,7 @@ runStrategy breadthLimit applyPrim instrs0 config0 = runStrategyWithSearchOrder :: forall m prim rule config - . MonadProfiler m + . (MonadProfiler m, MonadThrow m) => Show prim => Typeable prim => Limit Natural diff --git a/kore/test/Test/Kore/Step/Strategy.hs b/kore/test/Test/Kore/Step/Strategy.hs index d93b7eabd3..5ab3f66d93 100644 --- a/kore/test/Test/Kore/Step/Strategy.hs +++ b/kore/test/Test/Kore/Step/Strategy.hs @@ -30,7 +30,11 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import Data.Functor.Identity +import qualified Control.Exception as Exception +import Control.Monad.Catch.Pure + ( Catch + , runCatch + ) import qualified Data.Graph.Inductive.Graph as Graph import qualified Data.Sequence as Seq import Numeric.Natural @@ -89,7 +93,7 @@ instance Arbitrary prim => Arbitrary (Strategy prim) where Strategy.Stuck -> [] Strategy.Continue -> [] -transitionPrim :: Prim -> Natural -> TransitionT Prim Identity Natural +transitionPrim :: Prim -> Natural -> TransitionT Prim Catch Natural transitionPrim rule n = do Transition.addRule rule case rule of @@ -129,10 +133,9 @@ runStrategy -> Natural -> ExecutionGraph Natural Prim runStrategy strategy z = - let - Identity rs = Strategy.runStrategy Unlimited transitionPrim strategy z - in - rs + Strategy.runStrategy Unlimited transitionPrim strategy z + & runCatch + & either Exception.throw id prop_SeqContinueIdentity :: Strategy Prim -> Natural -> Property prop_SeqContinueIdentity a n = From 5a8285e539c8df411a38ea93acd0e313c119afaa Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 8 May 2020 09:53:13 -0500 Subject: [PATCH 71/79] Factor applyBreadthLimit out of leavesM --- kore/src/Kore/Step/Strategy.hs | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/kore/src/Kore/Step/Strategy.hs b/kore/src/Kore/Step/Strategy.hs index e0d75e71cd..773645c921 100644 --- a/kore/src/Kore/Step/Strategy.hs +++ b/kore/src/Kore/Step/Strategy.hs @@ -31,6 +31,7 @@ module Kore.Step.Strategy , continue -- * Running strategies , leavesM + , applyBreadthLimit , unfoldTransition , GraphSearchOrder(..) , constructExecutionGraph @@ -500,7 +501,7 @@ leavesM -> a -- ^ initial vertex -> m a leavesM breadthLimit searchOrder next a0 = - worker (Seq.singleton a0) + worker0 (Seq.singleton a0) where mk :: Seq a -> [a] -> Seq a mk as as' = @@ -508,16 +509,28 @@ leavesM breadthLimit searchOrder next a0 = BreadthFirst -> as <> Seq.fromList as' DepthFirst -> Seq.fromList as' <> as - exceedsLimit = not . withinLimit breadthLimit . fromIntegral . Seq.length + worker0 as = applyBreadthLimit breadthLimit as >>= worker1 - worker Seq.Empty = empty - worker (a Seq.:<| as) = + worker1 Seq.Empty = empty + worker1 (a Seq.:<| as) = do - when (exceedsLimit as) (Exception.throwM $ LimitExceeded as) as' <- lift (next a) (guard . not) (null as') pure (mk as as') - & maybeT (return a <|> worker as) worker + & maybeT (return a <|> worker0 as) worker0 + +applyBreadthLimit + :: Exception (LimitExceeded a) + => MonadThrow m + => Limit Natural + -> Seq a + -> m (Seq a) +applyBreadthLimit breadthLimit as + | _ Seq.:<| as' <- as, exceedsLimit as' = + Exception.throwM (LimitExceeded as) + | otherwise = pure as + where + exceedsLimit = not . withinLimit breadthLimit . fromIntegral . Seq.length {- | Turn a transition rule into an unfolding function. From d99ee0ada257e2bc0c3b2c697633cb90a2a8a778 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 8 May 2020 10:16:42 -0500 Subject: [PATCH 72/79] Extract unfoldBreadthFirst and unfoldDepthFirst --- kore/src/Kore/Step/Strategy.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/kore/src/Kore/Step/Strategy.hs b/kore/src/Kore/Step/Strategy.hs index 773645c921..95b0c7a615 100644 --- a/kore/src/Kore/Step/Strategy.hs +++ b/kore/src/Kore/Step/Strategy.hs @@ -503,11 +503,11 @@ leavesM leavesM breadthLimit searchOrder next a0 = worker0 (Seq.singleton a0) where - mk :: Seq a -> [a] -> Seq a - mk as as' = + mk :: [a] -> Seq a -> m (Seq a) + mk = case searchOrder of - BreadthFirst -> as <> Seq.fromList as' - DepthFirst -> Seq.fromList as' <> as + BreadthFirst -> unfoldBreadthFirst + DepthFirst -> unfoldDepthFirst worker0 as = applyBreadthLimit breadthLimit as >>= worker1 @@ -516,9 +516,15 @@ leavesM breadthLimit searchOrder next a0 = do as' <- lift (next a) (guard . not) (null as') - pure (mk as as') + lift (mk as' as) & maybeT (return a <|> worker0 as) worker0 +unfoldBreadthFirst :: Applicative f => [a] -> Seq a -> f (Seq a) +unfoldBreadthFirst as' as = pure (as <> Seq.fromList as') + +unfoldDepthFirst :: Applicative f => [a] -> Seq a -> f (Seq a) +unfoldDepthFirst as' as = pure (Seq.fromList as' <> as) + applyBreadthLimit :: Exception (LimitExceeded a) => MonadThrow m From 7d356caf42e6840a18d03a965b97992639a0ea5b Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 8 May 2020 10:30:40 -0500 Subject: [PATCH 73/79] Parameterize leavesM over queue updating function --- kore/src/Kore/Step/Strategy.hs | 39 +++++++++++++----------- kore/src/Kore/Strategies/Verification.hs | 10 ++++-- 2 files changed, 29 insertions(+), 20 deletions(-) diff --git a/kore/src/Kore/Step/Strategy.hs b/kore/src/Kore/Step/Strategy.hs index 95b0c7a615..0271f5f2f5 100644 --- a/kore/src/Kore/Step/Strategy.hs +++ b/kore/src/Kore/Step/Strategy.hs @@ -32,6 +32,9 @@ module Kore.Step.Strategy -- * Running strategies , leavesM , applyBreadthLimit + , unfoldBreadthFirst + , unfoldDepthFirst + , unfoldSearchOrder , unfoldTransition , GraphSearchOrder(..) , constructExecutionGraph @@ -489,35 +492,28 @@ constructExecutionGraph breadthLimit transit instrs0 searchOrder0 config0 = do @leavesM@ returns a disjunction of leaves (vertices without descendants) rather than constructing the entire graph. +The queue updating function should be 'unfoldBreadthFirst' or +'unfoldDepthFirst', optionally composed with 'applyBreadthLimit'. + -} leavesM :: forall m a - . MonadThrow m + . Monad m => Alternative m - => (Show a, Typeable a) - => Limit Natural - -> GraphSearchOrder + => ([a] -> Seq a -> m (Seq a)) -- ^ queue updating function -> (a -> m [a]) -- ^ unfolding function -> a -- ^ initial vertex -> m a -leavesM breadthLimit searchOrder next a0 = - worker0 (Seq.singleton a0) +leavesM mkQueue next a0 = + mkQueue [a0] Seq.empty >>= worker where - mk :: [a] -> Seq a -> m (Seq a) - mk = - case searchOrder of - BreadthFirst -> unfoldBreadthFirst - DepthFirst -> unfoldDepthFirst - - worker0 as = applyBreadthLimit breadthLimit as >>= worker1 - - worker1 Seq.Empty = empty - worker1 (a Seq.:<| as) = + worker Seq.Empty = empty + worker (a Seq.:<| as) = do as' <- lift (next a) (guard . not) (null as') - lift (mk as' as) - & maybeT (return a <|> worker0 as) worker0 + lift (mkQueue as' as) + & maybeT (return a <|> worker as) worker unfoldBreadthFirst :: Applicative f => [a] -> Seq a -> f (Seq a) unfoldBreadthFirst as' as = pure (as <> Seq.fromList as') @@ -525,6 +521,13 @@ unfoldBreadthFirst as' as = pure (as <> Seq.fromList as') unfoldDepthFirst :: Applicative f => [a] -> Seq a -> f (Seq a) unfoldDepthFirst as' as = pure (Seq.fromList as' <> as) +unfoldSearchOrder + :: Applicative f + => GraphSearchOrder + -> [a] -> Seq a -> f (Seq a) +unfoldSearchOrder DepthFirst = unfoldDepthFirst +unfoldSearchOrder BreadthFirst = unfoldBreadthFirst + applyBreadthLimit :: Exception (LimitExceeded a) => MonadThrow m diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index 6da7581fa6..fbc4d26841 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -21,6 +21,9 @@ module Kore.Strategies.Verification import Prelude.Kore import qualified Control.Lens as Lens +import Control.Monad + ( (>=>) + ) import qualified Control.Monad as Monad ( foldM_ ) @@ -228,8 +231,7 @@ verifyClaim & Foldable.toList & Limit.takeWithin depthLimit Strategy.leavesM - breadthLimit - searchOrder + updateQueue (Strategy.unfoldTransition transit) (limitedStrategy, startPattern) & fmap discardStrategy @@ -238,6 +240,10 @@ verifyClaim destination = getDestination goal discardStrategy = snd + updateQueue = \as -> + Strategy.unfoldSearchOrder searchOrder as + >=> Strategy.applyBreadthLimit breadthLimit + throwUnproven :: ListT (Verifier simplifier) CommonProofState -> Verifier simplifier () From eb7b8e17d48d893b76fda5e34be77043462e536e Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 8 May 2020 10:56:15 -0500 Subject: [PATCH 74/79] Generalize type of mapTransitionT --- kore/src/Kore/Step/Transition.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/kore/src/Kore/Step/Transition.hs b/kore/src/Kore/Step/Transition.hs index f62b0a2cfa..a304090aac 100644 --- a/kore/src/Kore/Step/Transition.hs +++ b/kore/src/Kore/Step/Transition.hs @@ -133,10 +133,10 @@ tryTransitionT tryTransitionT = lift . runTransitionT mapTransitionT - :: Monad m - => (forall x. m x -> m x) - -> TransitionT rule m a + :: (Monad m, Monad n) + => (forall x. m x -> n x) -> TransitionT rule m a + -> TransitionT rule n a mapTransitionT mapping = TransitionT . mapAccumT (mapListT mapping) . getTransitionT From a206b06247d2402185d8c29284f1023ca2193d21 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 8 May 2020 11:12:59 -0500 Subject: [PATCH 75/79] Factor unfoldM_ out of constructExecutionGraph --- kore/src/Kore/Step/Strategy.hs | 146 ++++++++++++++++++--------------- kore/test/Test/Kore/Exec.hs | 7 +- 2 files changed, 83 insertions(+), 70 deletions(-) diff --git a/kore/src/Kore/Step/Strategy.hs b/kore/src/Kore/Step/Strategy.hs index 0271f5f2f5..d53a3f6475 100644 --- a/kore/src/Kore/Step/Strategy.hs +++ b/kore/src/Kore/Step/Strategy.hs @@ -31,6 +31,7 @@ module Kore.Step.Strategy , continue -- * Running strategies , leavesM + , unfoldM_ , applyBreadthLimit , unfoldBreadthFirst , unfoldDepthFirst @@ -70,9 +71,9 @@ import Prelude.Kore hiding import Control.Error ( maybeT ) +import qualified Control.Lens as Lens import Control.Monad ( guard - , when , (>=>) ) import Control.Monad.Catch @@ -82,10 +83,12 @@ import Control.Monad.Catch import qualified Control.Monad.Catch as Exception import Control.Monad.State.Strict ( MonadState - , StateT ) import qualified Control.Monad.State.Strict as State import qualified Data.Foldable as Foldable +import Data.Generics.Product + ( field + ) import qualified Data.Graph.Inductive.Graph as Graph import Data.Graph.Inductive.PatriciaTree ( Gr @@ -102,12 +105,10 @@ import Data.Sequence ( Seq ) import qualified Data.Sequence as Seq +import qualified GHC.Generics as GHC import Kore.Profiler.Data ( MonadProfiler ) -import qualified Kore.Profiler.Profile as Profile - ( executionQueueLength - ) import Kore.Step.Transition import Numeric.Natural @@ -266,7 +267,8 @@ data ExecutionGraph config rule = ExecutionGraph { root :: Graph.Node , graph :: Gr config (Seq rule) } - deriving(Eq, Show) + deriving (Eq, Show) + deriving (GHC.Generic) -- | A temporary data structure used to construct the 'ExecutionGraph'. -- Well, it was intended to be temporary, but for the purpose of making @@ -397,6 +399,39 @@ newtype LimitExceeded a = LimitExceeded (Seq a) instance (Show a, Typeable a) => Exception (LimitExceeded a) +updateGraph + :: forall instr config rule m + . MonadState (ExecutionGraph config rule) m + => (instr -> config -> TransitionT rule m config) + -> ([instr], Graph.Node) -> m [([instr], Graph.Node)] +updateGraph _ ([], _) = return [] +updateGraph transit (instr : instrs, node) = do + config <- getConfig node + transitions <- runTransitionT (transit instr config) + nodes <- traverse (insTransition node) transitions + pure ((,) instrs <$> nodes) + +getConfig + :: MonadState (ExecutionGraph config rule) m + => Graph.Node + -> m config +getConfig node = do + graph <- Lens.use (field @"graph") + pure $ fromMaybe (error "Node does not exist") (Graph.lab graph node) + +insTransition + :: MonadState (ExecutionGraph config rule) m + => Graph.Node -- ^ parent node + -> (config, Seq rule) + -> m Graph.Node +insTransition node (config, rules) = do + graph <- Lens.use (field @"graph") + let node' = (succ . snd) (Graph.nodeRange graph) + Lens.modifying (field @"graph") $ Graph.insNode (node', config) + Lens.modifying (field @"graph") $ Graph.insEdges [(node, node', rules)] + pure node' + + {- | Execute a 'Strategy'. The primitive strategy rule is used to execute the 'apply' strategy. The @@ -424,68 +459,19 @@ constructExecutionGraph -> GraphSearchOrder -> config -> m (ExecutionGraph config rule) -constructExecutionGraph breadthLimit transit instrs0 searchOrder0 config0 = do - finalGraph <- State.execStateT - (unfoldWorker initialSeed searchOrder0) - initialGraph - return exe { graph = finalGraph } +constructExecutionGraph breadthLimit transit instrs0 searchOrder0 config0 = + unfoldM_ mkQueue transit' (instrs0, root execGraph) + & flip State.execStateT execGraph where - exe@ExecutionGraph { root, graph = initialGraph } = - emptyExecutionGraph config0 - initialSeed = Seq.singleton (root, instrs0) - - transit' instr config = (lift . runTransitionT) (transit instr config) - - unfoldWorker - :: Seq (Graph.Node, [instr]) - -> GraphSearchOrder - -> StateT (Gr config (Seq rule)) m () - unfoldWorker Seq.Empty _ = return () - unfoldWorker ((node, instrs) Seq.:<| rest) searchOrder - | [] <- instrs = unfoldWorker rest searchOrder - | instr : instrs' <- instrs - = Profile.executionQueueLength (Seq.length rest) $ do - when (exeedsLimit rest) - $ Exception.throwM $ LimitExceeded rest - nodes' <- applyInstr instr node - let seeds = map (withInstrs instrs') nodes' - case searchOrder of - -- The graph is unfolded breadth-first by appending the new seeds - -- to the end of the todo list. The next seed is always taken from - -- the beginning of the sequence, so that all the pending seeds - -- are unfolded once before the new seeds are unfolded. - BreadthFirst -> unfoldWorker - (rest <> Seq.fromList seeds) - searchOrder - -- The graph is unfolded depth-first by putting the new seeds to - -- the head of the todo list. - DepthFirst -> unfoldWorker - (Seq.fromList seeds <> rest) - searchOrder - - exeedsLimit = not . withinLimit breadthLimit . fromIntegral . Seq.length - - withInstrs instrs nodes = (nodes, instrs) - - applyInstr instr node = do - config <- getNodeConfig node - configs' <- transit' instr config - traverse insChildNode (childOf node <$> configs') - - getNodeConfig node = - fromMaybe (error "Node does not exist") - <$> State.gets (`Graph.lab` node) - - childOf - :: Graph.Node - -> (config, Seq rule) - -- ^ Child node identifier and configuration - -> ChildNode config rule - childOf node (config, rules) = - ChildNode - { config - , parents = [(rules, node)] - } + execGraph = emptyExecutionGraph config0 + + mkQueue = \as -> + unfoldSearchOrder searchOrder0 as + >=> applyBreadthLimit breadthLimit + + transit' = + updateGraph $ \instr config -> + mapTransitionT lift $ transit instr config {- | Unfold the function from the initial vertex. @@ -515,6 +501,32 @@ leavesM mkQueue next a0 = lift (mkQueue as' as) & maybeT (return a <|> worker as) worker +{- | Unfold the function from the initial vertex. + +@unfoldM_@ visits every descendant in the graph, but unlike 'leavesM' does not +return any values. + +The queue updating function should be 'unfoldBreadthFirst' or +'unfoldDepthFirst', optionally composed with 'applyBreadthLimit'. + +See also: 'leavesM' + + -} +unfoldM_ + :: forall m a + . Monad m + => ([a] -> Seq a -> m (Seq a)) -- ^ queue updating function + -> (a -> m [a]) -- ^ unfolding function + -> a -- ^ initial vertex + -> m () +unfoldM_ mkQueue next = \a -> + mkQueue [a] Seq.empty >>= worker + where + worker Seq.Empty = return () + worker (a Seq.:<| as) = do + as' <- next a + mkQueue as' as >>= worker + unfoldBreadthFirst :: Applicative f => [a] -> Seq a -> f (Seq a) unfoldBreadthFirst as' as = pure (as <> Seq.fromList as') diff --git a/kore/test/Test/Kore/Exec.hs b/kore/test/Test/Kore/Exec.hs index 0d2039b1de..a3ddab1c3e 100644 --- a/kore/test/Test/Kore/Exec.hs +++ b/kore/test/Test/Kore/Exec.hs @@ -282,12 +282,13 @@ test_searchExceedingBreadthLimit = unlimited = Unlimited makeTestCase searchType = testCase - ("Exceed bredth limit: " <> show searchType) + ("Exceed breadth limit: " <> show searchType) (assertion searchType) assertion searchType = - shouldExceedBreadthLimit searchType `catch` - \(_ :: LimitExceeded (Graph.Node, [Strategy (Prim Rewrite)])) -> pure () + catch (shouldExceedBreadthLimit searchType) + $ \(_ :: LimitExceeded ([Strategy (Prim Rewrite)], Graph.Node)) -> + pure () shouldExceedBreadthLimit :: SearchType -> IO () shouldExceedBreadthLimit searchType = do From 6a3883362b168c5efc030bdacd21a4dc0f7ded2c Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 8 May 2020 11:18:57 -0500 Subject: [PATCH 76/79] constructExecutionGraph: Restore Profile.executionQueueLength --- kore/src/Kore/Profiler/Profile.hs | 12 ++++-------- kore/src/Kore/Step/Strategy.hs | 7 ++++++- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/kore/src/Kore/Profiler/Profile.hs b/kore/src/Kore/Profiler/Profile.hs index 6e2da4531a..3ef60d5a3c 100644 --- a/kore/src/Kore/Profiler/Profile.hs +++ b/kore/src/Kore/Profiler/Profile.hs @@ -237,11 +237,7 @@ smtDecision (sexpr :| _) action = do then profile ["SMT", show $ length $ show sexpr] action else action -executionQueueLength - :: MonadProfiler profiler - => Int -> profiler result -> profiler result -executionQueueLength len action = do - Configuration {logStrategy} <- profileConfiguration - when logStrategy - (profileValue ["ExecutionQueueLength"] len) - action +executionQueueLength :: MonadProfiler profiler => Int -> profiler () +executionQueueLength len = do + Configuration { logStrategy } <- profileConfiguration + when logStrategy (profileValue ["ExecutionQueueLength"] len) diff --git a/kore/src/Kore/Step/Strategy.hs b/kore/src/Kore/Step/Strategy.hs index d53a3f6475..74f50fdf13 100644 --- a/kore/src/Kore/Step/Strategy.hs +++ b/kore/src/Kore/Step/Strategy.hs @@ -109,7 +109,7 @@ import qualified GHC.Generics as GHC import Kore.Profiler.Data ( MonadProfiler ) - +import qualified Kore.Profiler.Profile as Profile import Kore.Step.Transition import Numeric.Natural @@ -468,6 +468,11 @@ constructExecutionGraph breadthLimit transit instrs0 searchOrder0 config0 = mkQueue = \as -> unfoldSearchOrder searchOrder0 as >=> applyBreadthLimit breadthLimit + >=> profileQueueLength + + profileQueueLength queue = do + Profile.executionQueueLength (Seq.length queue) + pure queue transit' = updateGraph $ \instr config -> From 17f415bcbde96bc1b249e199199d1d8b438c477a Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 8 May 2020 11:20:21 -0500 Subject: [PATCH 77/79] verifyClaim: Restore Profile.executionQueueLength --- kore/src/Kore/Strategies/Verification.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index fbc4d26841..9b0817d22b 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -56,6 +56,7 @@ import Kore.Internal.Pattern ( Pattern ) import qualified Kore.Internal.Pattern as Pattern +import qualified Kore.Profiler.Profile as Profile import Kore.Step.RulePattern ( AllPathRule (..) , OnePathRule (..) @@ -243,6 +244,11 @@ verifyClaim updateQueue = \as -> Strategy.unfoldSearchOrder searchOrder as >=> Strategy.applyBreadthLimit breadthLimit + >=> profileQueueLength + + profileQueueLength queue = do + Profile.executionQueueLength (length queue) + pure queue throwUnproven :: ListT (Verifier simplifier) CommonProofState From 7dea8c0afab0f045df871e79f35bad2a1584bfec Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 11 May 2020 15:26:47 -0500 Subject: [PATCH 78/79] Linting --- kore/src/Kore/Strategies/Verification.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kore/src/Kore/Strategies/Verification.hs b/kore/src/Kore/Strategies/Verification.hs index 9b0817d22b..d77a036b90 100644 --- a/kore/src/Kore/Strategies/Verification.hs +++ b/kore/src/Kore/Strategies/Verification.hs @@ -270,7 +270,7 @@ verifyClaim transit instr config = Strategy.transitionRule modifiedTransitionRule instr config & runTransitionT - & fmap (fst . unzip) + & fmap (map fst) & lift modifiedTransitionRule From bd4b99ce608b1caed23f8a4b00fa8cd71f5117e0 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 11 May 2020 15:32:10 -0500 Subject: [PATCH 79/79] Revert unintentional changes --- default.nix | 12 ------------ shell.nix | 1 - 2 files changed, 13 deletions(-) diff --git a/default.nix b/default.nix index c2b0651aa5..d9bf5116be 100644 --- a/default.nix +++ b/default.nix @@ -31,9 +31,6 @@ let src = pkgs.haskell-nix.haskellLib.cleanGit { name = "kore"; src = ./.; }; modules = [ { - packages.ghc.flags.ghci = pkgs.lib.mkForce true; - packages.ghci.flags.ghci = pkgs.lib.mkForce true; - reinstallableLibGhc = true; # package * enableLibraryProfiling = true; profilingDetail = "none"; @@ -48,15 +45,6 @@ let }; } ]; - pkg-def-extras = [ - (hackage: { - packages = { - ghc-tags-plugin = hackage.ghc-tags-plugin."0.1.6.0".revisions.default; - ghc-tags-core = hackage.ghc-tags-core."0.1.0.0".revisions.default; - pipes-text = hackage.pipes-text."0.0.2.5".revisions.default; - }; - }) - ]; }; shell = import ./shell.nix { inherit default; }; default = diff --git a/shell.nix b/shell.nix index 8923b1bee3..b94407b141 100644 --- a/shell.nix +++ b/shell.nix @@ -15,5 +15,4 @@ shellFor { [ ghcid ghcide gnumake hlint stylish-haskell yq z3 ]; - exactDeps = true; }