From 65018f480fdc5179918d097c18942e773eb16550 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 21 May 2021 10:33:52 -0500 Subject: [PATCH 01/86] Prelude.Kore: Export Data.Functor.(<&>) --- kore/app/exec/Main.hs | 3 --- kore/src/Kore/Step/Step.hs | 3 --- kore/src/Kore/Unification/SubstitutionNormalization.hs | 3 --- kore/src/Prelude/Kore.hs | 4 ++++ kore/test/Test/Kore.hs | 3 --- kore/test/Test/Kore/Builtin/Map.hs | 3 --- kore/test/Test/Kore/Builtin/Set.hs | 3 --- 7 files changed, 4 insertions(+), 18 deletions(-) diff --git a/kore/app/exec/Main.hs b/kore/app/exec/Main.hs index be788d9fbc..9ef4ac3ee3 100644 --- a/kore/app/exec/Main.hs +++ b/kore/app/exec/Main.hs @@ -12,9 +12,6 @@ import Control.Monad.Extra as Monad import Data.Default ( def, ) -import Data.Functor ( - (<&>), - ) import Data.Generics.Product ( field, ) diff --git a/kore/src/Kore/Step/Step.hs b/kore/src/Kore/Step/Step.hs index 1b3111c7c3..42300ee51b 100644 --- a/kore/src/Kore/Step/Step.hs +++ b/kore/src/Kore/Step/Step.hs @@ -29,9 +29,6 @@ module Kore.Step.Step ( Step.results, ) where -import Data.Functor ( - (<&>), - ) import qualified Data.Map.Strict as Map import Data.Set ( Set, diff --git a/kore/src/Kore/Unification/SubstitutionNormalization.hs b/kore/src/Kore/Unification/SubstitutionNormalization.hs index 04cd52e70b..7e14db2ac1 100644 --- a/kore/src/Kore/Unification/SubstitutionNormalization.hs +++ b/kore/src/Kore/Unification/SubstitutionNormalization.hs @@ -15,9 +15,6 @@ module Kore.Unification.SubstitutionNormalization ( import qualified Control.Comonad.Trans.Cofree as Cofree import qualified Control.Monad.State.Strict as State -import Data.Functor ( - (<&>), - ) import Data.Functor.Const import Data.Functor.Foldable ( Base, diff --git a/kore/src/Prelude/Kore.hs b/kore/src/Prelude/Kore.hs index ff8f40ab7a..11bf36a6a9 100644 --- a/kore/src/Prelude/Kore.hs +++ b/kore/src/Prelude/Kore.hs @@ -13,6 +13,7 @@ module Prelude.Kore ( -- * Functions (&), on, + (<&>), -- * Maybe isJust, @@ -139,6 +140,9 @@ import Data.Either ( partitionEithers, ) import Data.Foldable +import Data.Functor ( + (<&>) + ) import Data.Function ( on, (&), diff --git a/kore/test/Test/Kore.hs b/kore/test/Test/Kore.hs index aa29f03c6d..4e451d5bd1 100644 --- a/kore/test/Test/Kore.hs +++ b/kore/test/Test/Kore.hs @@ -44,9 +44,6 @@ import Control.Monad.Reader ( ReaderT, ) import qualified Control.Monad.Reader as Reader -import Data.Functor ( - (<&>), - ) import Data.Functor.Const import Data.Text ( Text, diff --git a/kore/test/Test/Kore/Builtin/Map.hs b/kore/test/Test/Kore/Builtin/Map.hs index 6dea687d08..d30b797a50 100644 --- a/kore/test/Test/Kore/Builtin/Map.hs +++ b/kore/test/Test/Kore/Builtin/Map.hs @@ -54,9 +54,6 @@ import Control.Monad ( ) import qualified Data.Bifunctor as Bifunctor import qualified Data.Default as Default -import Data.Functor ( - (<&>), - ) import Data.HashMap.Strict ( HashMap, ) diff --git a/kore/test/Test/Kore/Builtin/Set.hs b/kore/test/Test/Kore/Builtin/Set.hs index a068dc84fc..bed3f46d7a 100644 --- a/kore/test/Test/Kore/Builtin/Set.hs +++ b/kore/test/Test/Kore/Builtin/Set.hs @@ -64,9 +64,6 @@ import Control.Error ( runMaybeT, ) import qualified Data.Default as Default -import Data.Functor ( - (<&>), - ) import qualified Data.HashMap.Strict as HashMap import Data.HashSet ( HashSet, From 932ba491b50277bea2c8c1fd9af189d2ed5c6d61 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 21 May 2021 11:45:49 -0500 Subject: [PATCH 02/86] Prelude.Kore: Export Data.Functor.void --- kore/src/Kore/Log/KoreLogOptions.hs | 3 --- kore/src/Kore/Repl.hs | 1 - kore/src/Kore/Repl/Interpreter.hs | 1 - kore/src/Kore/Repl/Parser.hs | 3 --- kore/src/Prelude/Kore.hs | 8 +++++--- 5 files changed, 5 insertions(+), 11 deletions(-) diff --git a/kore/src/Kore/Log/KoreLogOptions.hs b/kore/src/Kore/Log/KoreLogOptions.hs index edb5b8fd3e..d3630c1f9d 100644 --- a/kore/src/Kore/Log/KoreLogOptions.hs +++ b/kore/src/Kore/Log/KoreLogOptions.hs @@ -23,9 +23,6 @@ module Kore.Log.KoreLogOptions ( import qualified Data.Char as Char import Data.Default -import Data.Functor ( - void, - ) import Data.HashSet ( HashSet, ) diff --git a/kore/src/Kore/Repl.hs b/kore/src/Kore/Repl.hs index ef7a9fe7af..abc1079493 100644 --- a/kore/src/Kore/Repl.hs +++ b/kore/src/Kore/Repl.hs @@ -13,7 +13,6 @@ import Control.Concurrent.MVar import qualified Control.Lens as Lens import Control.Monad ( forever, - void, ) import Control.Monad.Catch ( MonadMask, diff --git a/kore/src/Kore/Repl/Interpreter.hs b/kore/src/Kore/Repl/Interpreter.hs index 0ad3fc4e12..bda006fe57 100644 --- a/kore/src/Kore/Repl/Interpreter.hs +++ b/kore/src/Kore/Repl/Interpreter.hs @@ -29,7 +29,6 @@ import Control.Lens ( ) import qualified Control.Lens as Lens import Control.Monad ( - void, (<=<), ) import Control.Monad.Extra ( diff --git a/kore/src/Kore/Repl/Parser.hs b/kore/src/Kore/Repl/Parser.hs index 13a158196f..60994898bb 100644 --- a/kore/src/Kore/Repl/Parser.hs +++ b/kore/src/Kore/Repl/Parser.hs @@ -11,9 +11,6 @@ module Kore.Repl.Parser ( ReplParseError (..), ) where -import Data.Functor ( - void, - ) import Data.GraphViz ( GraphvizOutput, ) diff --git a/kore/src/Prelude/Kore.hs b/kore/src/Prelude/Kore.hs index 11bf36a6a9..8951055591 100644 --- a/kore/src/Prelude/Kore.hs +++ b/kore/src/Prelude/Kore.hs @@ -63,6 +63,7 @@ module Prelude.Kore ( MonadPlus (..), MonadIO (..), MonadTrans (..), + void, unless, when, @@ -140,13 +141,14 @@ import Data.Either ( partitionEithers, ) import Data.Foldable -import Data.Functor ( - (<&>) - ) import Data.Function ( on, (&), ) +import Data.Functor ( + void, + (<&>), + ) import Data.Hashable ( Hashable (..), ) From d9375b90dafa104e5a69d72773a34864dafef4b7 Mon Sep 17 00:00:00 2001 From: emarzion Date: Thu, 6 May 2021 09:10:36 -0500 Subject: [PATCH 03/86] initial work on substituting out old functions --- kore/src/Kore/Builtin/Bool.hs | 79 ++++-- kore/src/Kore/Builtin/Int.hs | 34 ++- kore/src/Kore/Builtin/String.hs | 37 ++- kore/src/Kore/Step/Simplification/AndTerms.hs | 244 +++++++++++++----- .../Kore/Step/Simplification/NoConfusion.hs | 43 ++- kore/test/Test/Kore/Builtin/Bool.hs | 22 +- 6 files changed, 329 insertions(+), 130 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index 27b9570757..0dab1376cd 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -16,6 +16,8 @@ module Kore.Builtin.Bool ( unifyBoolOr, unifyBoolNot, matchBool, + matchBools, + matchUnifyBoolAnd, -- * Keys orKey, @@ -55,6 +57,7 @@ import Kore.Internal.Pattern ( import qualified Kore.Internal.Pattern as Pattern import Kore.Internal.Symbol import Kore.Internal.TermLike +import Kore.Rewriting.RewritingVariable import Kore.Step.Simplification.Simplify ( BuiltinAndAxiomSimplifier, TermSimplifier, @@ -163,48 +166,68 @@ builtinFunctions = xor a b = (a && not b) || (not a && b) implies a b = not a || b +data UnifyBool = UnifyBool { + bool1, bool2 :: InternalBool +} + +matchBools + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyBool +matchBools first second + | InternalBool_ bool1 <- first + , InternalBool_ bool2 <- second + = Just $ UnifyBool bool1 bool2 + | otherwise = Nothing +{-# INLINE matchBools #-} + -- | Unification of @BOOL.Bool@ values. unifyBool :: - forall variable unifier. - InternalVariable variable => + forall unifier. MonadUnify unifier => - TermLike variable -> - TermLike variable -> - MaybeT unifier (Pattern variable) -unifyBool a b = - worker a b <|> worker b a + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + UnifyBool -> + MaybeT unifier (Pattern RewritingVariableName) +unifyBool termLike1 termLike2 unifyData = + worker bool1 bool2 <|> worker bool2 bool1 where - worker termLike1 termLike2 - | Just value1 <- matchBool termLike1 - , Just value2 <- matchBool termLike2 = - lift $ - if value1 == value2 + worker a b + = lift $ + if a == b then return (Pattern.fromTermLike termLike1) else Unify.explainAndReturnBottom "different Bool domain values" termLike1 termLike2 - worker _ _ = empty + + UnifyBool { bool1, bool2 } = unifyData + +matchUnifyBoolAnd + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe (BoolAnd (TermLike RewritingVariableName)) +matchUnifyBoolAnd first second + | Just True <- matchBool first + , Just boolAnd <- matchBoolAnd second + , isFunctionPattern second + = Just boolAnd + | otherwise + = Nothing unifyBoolAnd :: - forall variable unifier. - InternalVariable variable => + forall unifier. MonadUnify unifier => - TermSimplifier variable unifier -> - TermLike variable -> - TermLike variable -> - MaybeT unifier (Pattern variable) -unifyBoolAnd unifyChildren a b = - worker a b <|> worker b a + TermSimplifier RewritingVariableName unifier -> + TermLike RewritingVariableName -> + BoolAnd (TermLike RewritingVariableName) -> + MaybeT unifier (Pattern RewritingVariableName) +unifyBoolAnd unifyChildren term boolAnd = + unifyBothWith unifyChildren term operand1 operand2 + where - worker termLike1 termLike2 - | Just value1 <- matchBool termLike1 - , value1 - , Just BoolAnd{operand1, operand2} <- matchBoolAnd termLike2 - , isFunctionPattern termLike2 = - unifyBothWith unifyChildren termLike1 operand1 operand2 - worker _ _ = empty + BoolAnd { operand1, operand2 } = boolAnd {- |Takes a (function-like) pattern and unifies it against two other patterns. Returns the original pattern and the conditions resulting from unification. diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index 7cef679d32..707d904a65 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -29,6 +29,7 @@ module Kore.Builtin.Int ( parse, unifyIntEq, unifyInt, + matchInt, -- * keys randKey, @@ -424,24 +425,41 @@ matchIntEqual = Monad.guard (hook2 == eqKey) & isJust +data UnifyInt = UnifyInt { + int1 :: !InternalInt + , int2 :: !InternalInt +} + +matchInt + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyInt +matchInt first second + | InternalInt_ int1 <- first + , InternalInt_ int2 <- second + = Just $ UnifyInt int1 int2 + | otherwise = Nothing +{-# INLINE matchInt #-} + -- | Unification of Int values. unifyInt :: - forall unifier variable. - InternalVariable variable => + forall unifier. MonadUnify unifier => HasCallStack => - TermLike variable -> - TermLike variable -> - MaybeT unifier (Pattern variable) -unifyInt term1@(InternalInt_ int1) term2@(InternalInt_ int2) = + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + UnifyInt -> + MaybeT unifier (Pattern RewritingVariableName) +unifyInt term1 term2 unifyData = assert (on (==) internalIntSort int1 int2) $ lift worker where - worker :: unifier (Pattern variable) + worker :: unifier (Pattern RewritingVariableName) worker | on (==) internalIntValue int1 int2 = return $ Pattern.fromTermLike term1 | otherwise = explainAndReturnBottom "distinct integers" term1 term2 -unifyInt _ _ = empty + + UnifyInt{ int1, int2 } = unifyData {- | Unification of the @INT.eq@ symbol. diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index be5c748a8c..e2bbcbc227 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -26,6 +26,7 @@ module Kore.Builtin.String ( parse, unifyString, unifyStringEq, + matchString, -- * keys ltKey, @@ -471,24 +472,40 @@ matchStringEqual = Monad.guard (hook2 == eqKey) & isJust +data UnifyString = UnifyString { + string1, string2 :: InternalString +} + +matchString + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyString +matchString first second + | InternalString_ string1 <- first + , InternalString_ string2 <- second + = Just $ UnifyString string1 string2 + | otherwise = Nothing +{-# INLINE matchString #-} + -- | Unification of String values. unifyString :: - forall unifier variable. - InternalVariable variable => + forall unifier. MonadUnify unifier => HasCallStack => - TermLike variable -> - TermLike variable -> - MaybeT unifier (Pattern variable) -unifyString term1@(InternalString_ int1) term2@(InternalString_ int2) = - assert (on (==) internalStringSort int1 int2) $ lift worker + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + UnifyString -> + MaybeT unifier (Pattern RewritingVariableName) +unifyString term1 term2 unifyData = + assert (on (==) internalStringSort string1 string2) $ lift worker where - worker :: unifier (Pattern variable) + worker :: unifier (Pattern RewritingVariableName) worker - | on (==) internalStringValue int1 int2 = + | on (==) internalStringValue string1 string2 = return $ Pattern.fromTermLike term1 | otherwise = explainAndReturnBottom "distinct strings" term1 term2 -unifyString _ _ = empty + + UnifyString { string1, string2 } = unifyData {- | Unification of the @STRING.eq@ symbol diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 4d7e054603..be9b0b0f3e 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -21,6 +21,9 @@ import qualified Data.Functor.Foldable as Recursive import Data.String ( fromString, ) +import Data.Text ( + Text, + ) import qualified Kore.Builtin.Bool as Builtin.Bool import qualified Kore.Builtin.Endianness as Builtin.Endianness import qualified Kore.Builtin.Int as Builtin.Int @@ -127,6 +130,10 @@ termUnification notSimplifier = \term1 term2 -> & Pattern.fromTermLike & return +-- maybeTermEquals notSimplifier childTransformers first second = +-- asum +-- [ do { matched <- hoistMaybe $ matchInt first second; lift $ unifyInt matched } + maybeTermEquals :: MonadUnify unifier => HasCallStack => @@ -136,28 +143,46 @@ maybeTermEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) -maybeTermEquals notSimplifier childTransformers first second = +maybeTermEquals notSimplifier childTransformers first second + | Just unifyData <- Builtin.Int.matchInt first second + = Builtin.Int.unifyInt first second unifyData + | Just unifyData <- Builtin.Bool.matchBools first second + = Builtin.Bool.unifyBool first second unifyData + | Just unifyData <- Builtin.String.matchString first second + = Builtin.String.unifyString first second unifyData + | Just unifyData <- matchDomainValue first second + = unifyDomainValue first second unifyData + | Just unifyData <- matchStringLiteral first second + = unifyStringLiteral first second unifyData + | Just () <- matchEqualsAndEquals first second + = equalAndEquals first + | Just () <- matchBytesDifferent first second + = bytesDifferent + | Just () <- matchBottomTermEquals first + = bottomTermEquals SideCondition.topTODO first second + | Just () <- matchBottomTermEquals second + = bottomTermEquals SideCondition.topTODO second first + | Just var <- matchVariableFunctionEquals first second + = variableFunctionEquals first second var + | Just var <- matchVariableFunctionEquals second first + = variableFunctionEquals second first var + | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second + = equalInjectiveHeadsAndEquals childTransformers unifyData + | Just unifyData <- matchSortInjectionAndEquals first second + = sortInjectionAndEquals childTransformers first second unifyData + | otherwise + = asum - [ Builtin.Int.unifyInt first second - , Builtin.Bool.unifyBool first second - , Builtin.String.unifyString first second - , unifyDomainValue first second - , unifyStringLiteral first second - , equalAndEquals first second - , bytesDifferent first second - , bottomTermEquals SideCondition.topTODO first second - , termBottomEquals SideCondition.topTODO first second - , variableFunctionEquals first second - , variableFunctionEquals second first - , equalInjectiveHeadsAndEquals childTransformers first second - , sortInjectionAndEquals childTransformers first second - , constructorSortInjectionAndEquals first second + [ constructorSortInjectionAndEquals first second , constructorAndEqualsAssumesDifferentHeads first second , overloadedConstructorSortInjectionAndEquals childTransformers first second - , Builtin.Bool.unifyBoolAnd childTransformers first second + , do { boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd first second; + Builtin.Bool.unifyBoolAnd childTransformers first boolAndData } + , do { boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd second first; + Builtin.Bool.unifyBoolAnd childTransformers second boolAndData } , Builtin.Bool.unifyBoolOr childTransformers first second , Builtin.Bool.unifyBoolNot childTransformers first second , Builtin.Int.unifyIntEq childTransformers notSimplifier first second @@ -200,24 +225,36 @@ maybeTermAnd notSimplifier childTransformers first second = first second , boolAnd first second - , Builtin.Int.unifyInt first second - , Builtin.Bool.unifyBool first second - , Builtin.String.unifyString first second - , unifyDomainValue first second - , unifyStringLiteral first second - , equalAndEquals first second - , bytesDifferent first second + , do { unifyData <- Error.hoistMaybe $ Builtin.Int.matchInt first second; + Builtin.Int.unifyInt first second unifyData } + , do { unifyData <- Error.hoistMaybe $ Builtin.Bool.matchBools first second; + Builtin.Bool.unifyBool first second unifyData } + , do { unifyData <- Error.hoistMaybe $ Builtin.String.matchString first second; + Builtin.String.unifyString first second unifyData } + , do { unifyData <- Error.hoistMaybe $ matchDomainValue first second; + unifyDomainValue first second unifyData } + , do { unifyData <- Error.hoistMaybe $ matchStringLiteral first second; + unifyStringLiteral first second unifyData } + , do { () <- Error.hoistMaybe $ matchEqualsAndEquals first second; + equalAndEquals first } + , do { () <- Error.hoistMaybe $ matchBytesDifferent first second; + bytesDifferent } , variableFunctionAnd first second , variableFunctionAnd second first - , equalInjectiveHeadsAndEquals childTransformers first second - , sortInjectionAndEquals childTransformers first second + , do { unifyData <- Error.hoistMaybe $ matchEqualInjectiveHeadsAndEquals first second; + equalInjectiveHeadsAndEquals childTransformers unifyData } + , do { unifyData <- Error.hoistMaybe $ matchSortInjectionAndEquals first second; + sortInjectionAndEquals childTransformers first second unifyData } , constructorSortInjectionAndEquals first second , constructorAndEqualsAssumesDifferentHeads first second , overloadedConstructorSortInjectionAndEquals childTransformers first second - , Builtin.Bool.unifyBoolAnd childTransformers first second + , do { boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd first second; + Builtin.Bool.unifyBoolAnd childTransformers first boolAndData } + , do { boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd second first; + Builtin.Bool.unifyBoolAnd childTransformers second boolAndData } , Builtin.Bool.unifyBoolOr childTransformers first second , Builtin.Bool.unifyBoolNot childTransformers first second , Builtin.KEqual.unifyKequalsEq @@ -282,18 +319,33 @@ explainBoolAndBottom :: explainBoolAndBottom term1 term2 = lift $ explainBottom "Cannot unify bottom." term1 term2 +matchEqualsAndEquals + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe () +matchEqualsAndEquals first second + | first == second + = Just () + | otherwise = Nothing +{-# INLINE matchEqualsAndEquals #-} + -- | Unify two identical ('==') patterns. equalAndEquals :: - InternalVariable RewritingVariableName => Monad unifier => TermLike RewritingVariableName -> - TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) -equalAndEquals first second = - if first == second - then -- TODO (thomas.tuegel): Preserve simplified flags. - return (Pattern.fromTermLike first) - else empty +equalAndEquals first = + -- TODO (thomas.tuegel): Preserve simplified flags. + return (Pattern.fromTermLike first) + +matchBottomTermEquals + :: TermLike RewritingVariableName + -> Maybe () +matchBottomTermEquals first + | Bottom_ _ <- first + = Just () + | otherwise = Nothing +{-# INLINE matchBottomTermEquals #-} -- | Unify two patterns where the first is @\\bottom@. bottomTermEquals :: @@ -304,7 +356,7 @@ bottomTermEquals :: MaybeT unifier (Pattern RewritingVariableName) bottomTermEquals sideCondition - first@(Bottom_ _) + first second = lift $ do -- MonadUnify @@ -328,20 +380,6 @@ bottomTermEquals OrPattern.map Condition.toPredicate secondCeil , substitution = mempty } -bottomTermEquals _ _ _ = empty - -{- | Unify two patterns where the second is @\\bottom@. - -See also: 'bottomTermEquals' --} -termBottomEquals :: - MonadUnify unifier => - SideCondition RewritingVariableName -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) -termBottomEquals sideCondition first second = - bottomTermEquals sideCondition second first variableFunctionAnd :: InternalVariable variable => @@ -367,6 +405,17 @@ variableFunctionAnd (Substitution.assign (inject v) second) variableFunctionAnd _ _ = empty +matchVariableFunctionEquals :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe (ElementVariable RewritingVariableName) +matchVariableFunctionEquals first second + | ElemVar_ var <- first + , isFunctionPattern second + = Just var + | otherwise = Nothing +{-# INLINE matchVariableFunctionEquals #-} + {- | Unify a variable with a function pattern. See also: 'isFunctionPattern' @@ -375,11 +424,13 @@ variableFunctionEquals :: MonadUnify unifier => TermLike RewritingVariableName -> TermLike RewritingVariableName -> + ElementVariable RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) variableFunctionEquals - first@(ElemVar_ v) + first second - | isFunctionPattern second = lift $ do + var + = lift $ do -- MonadUnify predicate <- do resultOr <- makeEvaluateTermCeil SideCondition.topTODO second @@ -395,9 +446,23 @@ variableFunctionEquals let result = predicate <> Condition.fromSingleSubstitution - (Substitution.assign (inject v) second) + (Substitution.assign (inject var) second) return (Pattern.withCondition second result) -variableFunctionEquals _ _ = empty + +data SortInjectionAndEquals = SortInjectionAndEquals { + inj1, inj2 :: Inj (TermLike RewritingVariableName) +} + +matchSortInjectionAndEquals + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe SortInjectionAndEquals +matchSortInjectionAndEquals first second + | Inj_ inj1 <- first + , Inj_ inj2 <- second + = Just $ SortInjectionAndEquals inj1 inj2 + | otherwise = Nothing +{-# INLINE sortInjectionAndEquals #-} {- | Simplify the conjunction of two sort injections. @@ -421,8 +486,9 @@ sortInjectionAndEquals :: TermSimplifier RewritingVariableName unifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> + SortInjectionAndEquals -> MaybeT unifier (Pattern RewritingVariableName) -sortInjectionAndEquals termMerger first@(Inj_ inj1) second@(Inj_ inj2) = do +sortInjectionAndEquals termMerger first second unifyData = do InjSimplifier{unifyInj} <- Simplifier.askInjSimplifier unifyInj inj1 inj2 & either distinct merge where @@ -435,7 +501,8 @@ sortInjectionAndEquals termMerger first@(Inj_ inj1) second@(Inj_ inj2) = do let (childTerm, childCondition) = Pattern.splitTerm childPattern inj' = evaluateInj inj{injChild = childTerm} return $ Pattern.withCondition inj' childCondition -sortInjectionAndEquals _ _ _ = empty + + SortInjectionAndEquals { inj1, inj2 } = unifyData {- | Unify a constructor application pattern with a sort injection pattern. @@ -548,6 +615,24 @@ domainValueAndConstructorErrors ) domainValueAndConstructorErrors _ _ = empty +data UnifyDomainValue = UnifyDomainValue { + sort1 :: Sort + , val1 :: TermLike RewritingVariableName + , sort2 :: Sort + , val2 :: TermLike RewritingVariableName +} + +matchDomainValue + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyDomainValue +matchDomainValue first second + | DV_ sort1 val1 <- first + , DV_ sort2 val2 <- second + = Just $ UnifyDomainValue sort1 val1 sort2 val2 + | otherwise = Nothing +{-# INLINE matchDomainValue #-} + {- | Unify two domain values. The two patterns are assumed to be inequal; therefore this case always return @@ -564,16 +649,18 @@ unifyDomainValue :: MonadUnify unifier => TermLike RewritingVariableName -> TermLike RewritingVariableName -> + UnifyDomainValue -> MaybeT unifier (Pattern RewritingVariableName) -unifyDomainValue term1@(DV_ sort1 value1) term2@(DV_ sort2 value2) = +unifyDomainValue term1 term2 unifyData = assert (sort1 == sort2) $ lift worker where worker :: unifier (Pattern RewritingVariableName) worker - | value1 == value2 = + | val1 == val2 = return $ Pattern.fromTermLike term1 | otherwise = cannotUnifyDomainValues term1 term2 -unifyDomainValue _ _ = empty + + UnifyDomainValue { sort1, val1, sort2, val2 } = unifyData cannotUnifyDistinctDomainValues :: Pretty.Doc () cannotUnifyDistinctDomainValues = "distinct domain values" @@ -585,6 +672,21 @@ cannotUnifyDomainValues :: unifier a cannotUnifyDomainValues = explainAndReturnBottom cannotUnifyDistinctDomainValues +data UnifyStringLiteral = UnifyStringLiteral { + txt1, txt2 :: Text +} + +matchStringLiteral + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyStringLiteral +matchStringLiteral first second + | StringLiteral_ string1 <- first + , StringLiteral_ string2 <- second + = Just $ UnifyStringLiteral string1 string2 + | otherwise = Nothing +{-# INLINE matchStringLiteral #-} + {- | Unify two literal strings. The two patterns are assumed to be inequal; therefore this case always returns @@ -597,15 +699,17 @@ unifyStringLiteral :: MonadUnify unifier => TermLike RewritingVariableName -> TermLike RewritingVariableName -> + UnifyStringLiteral -> MaybeT unifier (Pattern RewritingVariableName) -unifyStringLiteral term1@(StringLiteral_ _) term2@(StringLiteral_ _) = lift worker +unifyStringLiteral term1 term2 unifyData = lift worker where worker :: unifier (Pattern RewritingVariableName) worker - | term1 == term2 = + | txt1 == txt2 = return $ Pattern.fromTermLike term1 | otherwise = explainAndReturnBottom "distinct string literals" term1 term2 -unifyStringLiteral _ _ = empty + + UnifyStringLiteral { txt1, txt2 } = unifyData {- | Unify any two function patterns. @@ -647,14 +751,20 @@ compareForEquals first second | isConstructorLike second = GT | otherwise = compare first second +matchBytesDifferent + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe () +matchBytesDifferent first second + | _ :< InternalBytesF (Const bytesFirst) <- Recursive.project first + , _ :< InternalBytesF (Const bytesSecond) <- Recursive.project second + , bytesFirst /= bytesSecond + = Just () + | otherwise = Nothing +{-# INLINE matchBytesDifferent #-} + bytesDifferent :: MonadUnify unifier => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) bytesDifferent - (Recursive.project -> _ :< InternalBytesF (Const bytesFirst)) - (Recursive.project -> _ :< InternalBytesF (Const bytesSecond)) - | bytesFirst /= bytesSecond = - return Pattern.bottom -bytesDifferent _ _ = empty + = return Pattern.bottom diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 3ecfd29834..bd6d54e41b 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -5,12 +5,12 @@ License : NCSA module Kore.Step.Simplification.NoConfusion ( equalInjectiveHeadsAndEquals, constructorAndEqualsAssumesDifferentHeads, + matchEqualInjectiveHeadsAndEquals, ) where import Control.Error ( MaybeT (..), ) -import qualified Control.Error as Error import qualified Control.Monad as Monad import Kore.Internal.Pattern ( Pattern, @@ -27,6 +27,30 @@ import Prelude.Kore hiding ( concat, ) +data UnifyEqualInjectiveHeadsAndEquals = UnifyEqualInjectiveHeadsAndEquals { + firstHead :: Symbol + , firstChildren :: [TermLike RewritingVariableName] + , secondChildren :: [TermLike RewritingVariableName] +} + +matchEqualInjectiveHeadsAndEquals + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyEqualInjectiveHeadsAndEquals +matchEqualInjectiveHeadsAndEquals first second + | App_ firstHead firstChildren <- first + , App_ secondHead secondChildren <- second + , Symbol.isInjective firstHead + , Symbol.isInjective secondHead + , firstHead == secondHead --is one of the above redundant in light of this? + = Just $ + UnifyEqualInjectiveHeadsAndEquals + firstHead + firstChildren + secondChildren + | otherwise = Nothing +{-# INLINE matchEqualInjectiveHeadsAndEquals #-} + {- | Unify two application patterns with equal, injective heads. This includes constructors and sort injections. @@ -39,14 +63,12 @@ equalInjectiveHeadsAndEquals :: HasCallStack => -- | Used to simplify subterm "and". TermSimplifier RewritingVariableName unifier -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> + UnifyEqualInjectiveHeadsAndEquals -> MaybeT unifier (Pattern RewritingVariableName) equalInjectiveHeadsAndEquals termMerger - (App_ firstHead firstChildren) - (App_ secondHead secondChildren) - | isFirstInjective && isSecondInjective && firstHead == secondHead = + unifyData + = lift $ do children <- Monad.zipWithM termMerger firstChildren secondChildren let merged = foldMap Pattern.withoutTerm children @@ -59,9 +81,12 @@ equalInjectiveHeadsAndEquals (Pattern.term <$> children) return (Pattern.withCondition term merged) where - isFirstInjective = Symbol.isInjective firstHead - isSecondInjective = Symbol.isInjective secondHead -equalInjectiveHeadsAndEquals _ _ _ = Error.nothing + + UnifyEqualInjectiveHeadsAndEquals + { firstHead + , firstChildren + , secondChildren + } = unifyData {- | Unify two constructor application patterns. diff --git a/kore/test/Test/Kore/Builtin/Bool.hs b/kore/test/Test/Kore/Builtin/Bool.hs index d37b1136fa..bbff023b50 100644 --- a/kore/test/Test/Kore/Builtin/Bool.hs +++ b/kore/test/Test/Kore/Builtin/Bool.hs @@ -160,11 +160,14 @@ test_unifyBoolValues = TestTree test testName term1 term2 expected = testCase testName $ do - actual <- unify term1 term2 - assertEqual "" expected actual + case Bool.matchBools term1 term2 of + Just unifyData -> do + actual <- unify term1 term2 unifyData + assertEqual "" expected actual + Nothing -> assertEqual "" expected [Nothing] - unify term1 term2 = - run (Bool.unifyBool term1 term2) + unify term1 term2 unifyData = + run (Bool.unifyBool term1 term2 unifyData) test_unifyBoolAnd :: [TestTree] test_unifyBoolAnd = @@ -190,11 +193,14 @@ test_unifyBoolAnd = TestTree test testName term1 term2 expected = testCase testName $ do - actual <- unify term1 term2 - assertEqual "" expected actual + case Bool.matchUnifyBoolAnd term1 term2 of + Just boolAnd -> do + actual <- unify term1 boolAnd + assertEqual "" expected actual + Nothing -> assertEqual "" expected [Nothing] - unify term1 term2 = - run (Bool.unifyBoolAnd termSimplifier term1 term2) + unify term boolAnd = + run (Bool.unifyBoolAnd termSimplifier term boolAnd) test_unifyBoolOr :: [TestTree] test_unifyBoolOr = From c3a7a6126052e6165b405598c8b36dceaacdec66 Mon Sep 17 00:00:00 2001 From: github-actions Date: Thu, 6 May 2021 14:13:53 +0000 Subject: [PATCH 04/86] Format with fourmolu --- kore/src/Kore/Builtin/Bool.hs | 59 ++-- kore/src/Kore/Builtin/Int.hs | 24 +- kore/src/Kore/Builtin/String.hs | 22 +- kore/src/Kore/Step/Simplification/AndTerms.hs | 296 +++++++++--------- .../Kore/Step/Simplification/NoConfusion.hs | 59 ++-- 5 files changed, 235 insertions(+), 225 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index 0dab1376cd..c904c4642e 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -166,18 +166,18 @@ builtinFunctions = xor a b = (a && not b) || (not a && b) implies a b = not a || b -data UnifyBool = UnifyBool { - bool1, bool2 :: InternalBool -} +data UnifyBool = UnifyBool + { bool1, bool2 :: InternalBool + } -matchBools - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyBool +matchBools :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyBool matchBools first second | InternalBool_ bool1 <- first - , InternalBool_ bool2 <- second - = Just $ UnifyBool bool1 bool2 + , InternalBool_ bool2 <- second = + Just $ UnifyBool bool1 bool2 | otherwise = Nothing {-# INLINE matchBools #-} @@ -192,29 +192,29 @@ unifyBool :: unifyBool termLike1 termLike2 unifyData = worker bool1 bool2 <|> worker bool2 bool1 where - worker a b - = lift $ - if a == b - then return (Pattern.fromTermLike termLike1) - else - Unify.explainAndReturnBottom - "different Bool domain values" - termLike1 - termLike2 + worker a b = + lift $ + if a == b + then return (Pattern.fromTermLike termLike1) + else + Unify.explainAndReturnBottom + "different Bool domain values" + termLike1 + termLike2 - UnifyBool { bool1, bool2 } = unifyData + UnifyBool{bool1, bool2} = unifyData -matchUnifyBoolAnd - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe (BoolAnd (TermLike RewritingVariableName)) +matchUnifyBoolAnd :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe (BoolAnd (TermLike RewritingVariableName)) matchUnifyBoolAnd first second | Just True <- matchBool first - , Just boolAnd <- matchBoolAnd second - , isFunctionPattern second - = Just boolAnd - | otherwise - = Nothing + , Just boolAnd <- matchBoolAnd second + , isFunctionPattern second = + Just boolAnd + | otherwise = + Nothing unifyBoolAnd :: forall unifier. @@ -225,9 +225,8 @@ unifyBoolAnd :: MaybeT unifier (Pattern RewritingVariableName) unifyBoolAnd unifyChildren term boolAnd = unifyBothWith unifyChildren term operand1 operand2 - where - BoolAnd { operand1, operand2 } = boolAnd + BoolAnd{operand1, operand2} = boolAnd {- |Takes a (function-like) pattern and unifies it against two other patterns. Returns the original pattern and the conditions resulting from unification. diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index 707d904a65..00343d9f37 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -425,19 +425,19 @@ matchIntEqual = Monad.guard (hook2 == eqKey) & isJust -data UnifyInt = UnifyInt { - int1 :: !InternalInt - , int2 :: !InternalInt -} - -matchInt - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyInt +data UnifyInt = UnifyInt + { int1 :: !InternalInt + , int2 :: !InternalInt + } + +matchInt :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyInt matchInt first second | InternalInt_ int1 <- first - , InternalInt_ int2 <- second - = Just $ UnifyInt int1 int2 + , InternalInt_ int2 <- second = + Just $ UnifyInt int1 int2 | otherwise = Nothing {-# INLINE matchInt #-} @@ -459,7 +459,7 @@ unifyInt term1 term2 unifyData = return $ Pattern.fromTermLike term1 | otherwise = explainAndReturnBottom "distinct integers" term1 term2 - UnifyInt{ int1, int2 } = unifyData + UnifyInt{int1, int2} = unifyData {- | Unification of the @INT.eq@ symbol. diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index e2bbcbc227..a4ecbab6c4 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -472,18 +472,18 @@ matchStringEqual = Monad.guard (hook2 == eqKey) & isJust -data UnifyString = UnifyString { - string1, string2 :: InternalString -} - -matchString - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyString +data UnifyString = UnifyString + { string1, string2 :: InternalString + } + +matchString :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyString matchString first second | InternalString_ string1 <- first - , InternalString_ string2 <- second - = Just $ UnifyString string1 string2 + , InternalString_ string2 <- second = + Just $ UnifyString string1 string2 | otherwise = Nothing {-# INLINE matchString #-} @@ -505,7 +505,7 @@ unifyString term1 term2 unifyData = return $ Pattern.fromTermLike term1 | otherwise = explainAndReturnBottom "distinct strings" term1 term2 - UnifyString { string1, string2 } = unifyData + UnifyString{string1, string2} = unifyData {- | Unification of the @STRING.eq@ symbol diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index be9b0b0f3e..9443826999 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -144,70 +144,71 @@ maybeTermEquals :: TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) maybeTermEquals notSimplifier childTransformers first second - | Just unifyData <- Builtin.Int.matchInt first second - = Builtin.Int.unifyInt first second unifyData - | Just unifyData <- Builtin.Bool.matchBools first second - = Builtin.Bool.unifyBool first second unifyData - | Just unifyData <- Builtin.String.matchString first second - = Builtin.String.unifyString first second unifyData - | Just unifyData <- matchDomainValue first second - = unifyDomainValue first second unifyData - | Just unifyData <- matchStringLiteral first second - = unifyStringLiteral first second unifyData - | Just () <- matchEqualsAndEquals first second - = equalAndEquals first - | Just () <- matchBytesDifferent first second - = bytesDifferent - | Just () <- matchBottomTermEquals first - = bottomTermEquals SideCondition.topTODO first second - | Just () <- matchBottomTermEquals second - = bottomTermEquals SideCondition.topTODO second first - | Just var <- matchVariableFunctionEquals first second - = variableFunctionEquals first second var - | Just var <- matchVariableFunctionEquals second first - = variableFunctionEquals second first var - | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second - = equalInjectiveHeadsAndEquals childTransformers unifyData - | Just unifyData <- matchSortInjectionAndEquals first second - = sortInjectionAndEquals childTransformers first second unifyData - | otherwise - = - asum - [ constructorSortInjectionAndEquals first second - , constructorAndEqualsAssumesDifferentHeads first second - , overloadedConstructorSortInjectionAndEquals - childTransformers - first - second - , do { boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd first second; - Builtin.Bool.unifyBoolAnd childTransformers first boolAndData } - , do { boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd second first; - Builtin.Bool.unifyBoolAnd childTransformers second boolAndData } - , Builtin.Bool.unifyBoolOr childTransformers first second - , Builtin.Bool.unifyBoolNot childTransformers first second - , Builtin.Int.unifyIntEq childTransformers notSimplifier first second - , Builtin.String.unifyStringEq - childTransformers - notSimplifier - first - second - , Builtin.KEqual.unifyKequalsEq - childTransformers - notSimplifier - first - second - , Builtin.Endianness.unifyEquals first second - , Builtin.Signedness.unifyEquals first second - , Builtin.Map.unifyEquals childTransformers first second - , Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second - , Builtin.Set.unifyEquals childTransformers first second - , Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - first - second - , domainValueAndConstructorErrors first second - ] + | Just unifyData <- Builtin.Int.matchInt first second = + Builtin.Int.unifyInt first second unifyData + | Just unifyData <- Builtin.Bool.matchBools first second = + Builtin.Bool.unifyBool first second unifyData + | Just unifyData <- Builtin.String.matchString first second = + Builtin.String.unifyString first second unifyData + | Just unifyData <- matchDomainValue first second = + unifyDomainValue first second unifyData + | Just unifyData <- matchStringLiteral first second = + unifyStringLiteral first second unifyData + | Just () <- matchEqualsAndEquals first second = + equalAndEquals first + | Just () <- matchBytesDifferent first second = + bytesDifferent + | Just () <- matchBottomTermEquals first = + bottomTermEquals SideCondition.topTODO first second + | Just () <- matchBottomTermEquals second = + bottomTermEquals SideCondition.topTODO second first + | Just var <- matchVariableFunctionEquals first second = + variableFunctionEquals first second var + | Just var <- matchVariableFunctionEquals second first = + variableFunctionEquals second first var + | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = + equalInjectiveHeadsAndEquals childTransformers unifyData + | Just unifyData <- matchSortInjectionAndEquals first second = + sortInjectionAndEquals childTransformers first second unifyData + | otherwise = + asum + [ constructorSortInjectionAndEquals first second + , constructorAndEqualsAssumesDifferentHeads first second + , overloadedConstructorSortInjectionAndEquals + childTransformers + first + second + , do + boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd first second + Builtin.Bool.unifyBoolAnd childTransformers first boolAndData + , do + boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd second first + Builtin.Bool.unifyBoolAnd childTransformers second boolAndData + , Builtin.Bool.unifyBoolOr childTransformers first second + , Builtin.Bool.unifyBoolNot childTransformers first second + , Builtin.Int.unifyIntEq childTransformers notSimplifier first second + , Builtin.String.unifyStringEq + childTransformers + notSimplifier + first + second + , Builtin.KEqual.unifyKequalsEq + childTransformers + notSimplifier + first + second + , Builtin.Endianness.unifyEquals first second + , Builtin.Signedness.unifyEquals first second + , Builtin.Map.unifyEquals childTransformers first second + , Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second + , Builtin.Set.unifyEquals childTransformers first second + , Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + first + second + , domainValueAndConstructorErrors first second + ] maybeTermAnd :: MonadUnify unifier => @@ -225,36 +226,47 @@ maybeTermAnd notSimplifier childTransformers first second = first second , boolAnd first second - , do { unifyData <- Error.hoistMaybe $ Builtin.Int.matchInt first second; - Builtin.Int.unifyInt first second unifyData } - , do { unifyData <- Error.hoistMaybe $ Builtin.Bool.matchBools first second; - Builtin.Bool.unifyBool first second unifyData } - , do { unifyData <- Error.hoistMaybe $ Builtin.String.matchString first second; - Builtin.String.unifyString first second unifyData } - , do { unifyData <- Error.hoistMaybe $ matchDomainValue first second; - unifyDomainValue first second unifyData } - , do { unifyData <- Error.hoistMaybe $ matchStringLiteral first second; - unifyStringLiteral first second unifyData } - , do { () <- Error.hoistMaybe $ matchEqualsAndEquals first second; - equalAndEquals first } - , do { () <- Error.hoistMaybe $ matchBytesDifferent first second; - bytesDifferent } + , do + unifyData <- Error.hoistMaybe $ Builtin.Int.matchInt first second + Builtin.Int.unifyInt first second unifyData + , do + unifyData <- Error.hoistMaybe $ Builtin.Bool.matchBools first second + Builtin.Bool.unifyBool first second unifyData + , do + unifyData <- Error.hoistMaybe $ Builtin.String.matchString first second + Builtin.String.unifyString first second unifyData + , do + unifyData <- Error.hoistMaybe $ matchDomainValue first second + unifyDomainValue first second unifyData + , do + unifyData <- Error.hoistMaybe $ matchStringLiteral first second + unifyStringLiteral first second unifyData + , do + () <- Error.hoistMaybe $ matchEqualsAndEquals first second + equalAndEquals first + , do + () <- Error.hoistMaybe $ matchBytesDifferent first second + bytesDifferent , variableFunctionAnd first second , variableFunctionAnd second first - , do { unifyData <- Error.hoistMaybe $ matchEqualInjectiveHeadsAndEquals first second; - equalInjectiveHeadsAndEquals childTransformers unifyData } - , do { unifyData <- Error.hoistMaybe $ matchSortInjectionAndEquals first second; - sortInjectionAndEquals childTransformers first second unifyData } + , do + unifyData <- Error.hoistMaybe $ matchEqualInjectiveHeadsAndEquals first second + equalInjectiveHeadsAndEquals childTransformers unifyData + , do + unifyData <- Error.hoistMaybe $ matchSortInjectionAndEquals first second + sortInjectionAndEquals childTransformers first second unifyData , constructorSortInjectionAndEquals first second , constructorAndEqualsAssumesDifferentHeads first second , overloadedConstructorSortInjectionAndEquals childTransformers first second - , do { boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd first second; - Builtin.Bool.unifyBoolAnd childTransformers first boolAndData } - , do { boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd second first; - Builtin.Bool.unifyBoolAnd childTransformers second boolAndData } + , do + boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd first second + Builtin.Bool.unifyBoolAnd childTransformers first boolAndData + , do + boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd second first + Builtin.Bool.unifyBoolAnd childTransformers second boolAndData , Builtin.Bool.unifyBoolOr childTransformers first second , Builtin.Bool.unifyBoolNot childTransformers first second , Builtin.KEqual.unifyKequalsEq @@ -319,13 +331,13 @@ explainBoolAndBottom :: explainBoolAndBottom term1 term2 = lift $ explainBottom "Cannot unify bottom." term1 term2 -matchEqualsAndEquals - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe () +matchEqualsAndEquals :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe () matchEqualsAndEquals first second - | first == second - = Just () + | first == second = + Just () | otherwise = Nothing {-# INLINE matchEqualsAndEquals #-} @@ -338,12 +350,12 @@ equalAndEquals first = -- TODO (thomas.tuegel): Preserve simplified flags. return (Pattern.fromTermLike first) -matchBottomTermEquals - :: TermLike RewritingVariableName - -> Maybe () +matchBottomTermEquals :: + TermLike RewritingVariableName -> + Maybe () matchBottomTermEquals first - | Bottom_ _ <- first - = Just () + | Bottom_ _ <- first = + Just () | otherwise = Nothing {-# INLINE matchBottomTermEquals #-} @@ -356,7 +368,7 @@ bottomTermEquals :: MaybeT unifier (Pattern RewritingVariableName) bottomTermEquals sideCondition - first + first second = lift $ do -- MonadUnify @@ -407,12 +419,12 @@ variableFunctionAnd _ _ = empty matchVariableFunctionEquals :: TermLike RewritingVariableName -> - TermLike RewritingVariableName -> + TermLike RewritingVariableName -> Maybe (ElementVariable RewritingVariableName) matchVariableFunctionEquals first second | ElemVar_ var <- first - , isFunctionPattern second - = Just var + , isFunctionPattern second = + Just var | otherwise = Nothing {-# INLINE matchVariableFunctionEquals #-} @@ -429,8 +441,8 @@ variableFunctionEquals :: variableFunctionEquals first second - var - = lift $ do + var = + lift $ do -- MonadUnify predicate <- do resultOr <- makeEvaluateTermCeil SideCondition.topTODO second @@ -449,18 +461,18 @@ variableFunctionEquals (Substitution.assign (inject var) second) return (Pattern.withCondition second result) -data SortInjectionAndEquals = SortInjectionAndEquals { - inj1, inj2 :: Inj (TermLike RewritingVariableName) -} +data SortInjectionAndEquals = SortInjectionAndEquals + { inj1, inj2 :: Inj (TermLike RewritingVariableName) + } -matchSortInjectionAndEquals - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe SortInjectionAndEquals +matchSortInjectionAndEquals :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe SortInjectionAndEquals matchSortInjectionAndEquals first second | Inj_ inj1 <- first - , Inj_ inj2 <- second - = Just $ SortInjectionAndEquals inj1 inj2 + , Inj_ inj2 <- second = + Just $ SortInjectionAndEquals inj1 inj2 | otherwise = Nothing {-# INLINE sortInjectionAndEquals #-} @@ -502,7 +514,7 @@ sortInjectionAndEquals termMerger first second unifyData = do inj' = evaluateInj inj{injChild = childTerm} return $ Pattern.withCondition inj' childCondition - SortInjectionAndEquals { inj1, inj2 } = unifyData + SortInjectionAndEquals{inj1, inj2} = unifyData {- | Unify a constructor application pattern with a sort injection pattern. @@ -615,21 +627,21 @@ domainValueAndConstructorErrors ) domainValueAndConstructorErrors _ _ = empty -data UnifyDomainValue = UnifyDomainValue { - sort1 :: Sort +data UnifyDomainValue = UnifyDomainValue + { sort1 :: Sort , val1 :: TermLike RewritingVariableName , sort2 :: Sort , val2 :: TermLike RewritingVariableName -} + } -matchDomainValue - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyDomainValue +matchDomainValue :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyDomainValue matchDomainValue first second | DV_ sort1 val1 <- first - , DV_ sort2 val2 <- second - = Just $ UnifyDomainValue sort1 val1 sort2 val2 + , DV_ sort2 val2 <- second = + Just $ UnifyDomainValue sort1 val1 sort2 val2 | otherwise = Nothing {-# INLINE matchDomainValue #-} @@ -660,7 +672,7 @@ unifyDomainValue term1 term2 unifyData = return $ Pattern.fromTermLike term1 | otherwise = cannotUnifyDomainValues term1 term2 - UnifyDomainValue { sort1, val1, sort2, val2 } = unifyData + UnifyDomainValue{sort1, val1, sort2, val2} = unifyData cannotUnifyDistinctDomainValues :: Pretty.Doc () cannotUnifyDistinctDomainValues = "distinct domain values" @@ -672,18 +684,18 @@ cannotUnifyDomainValues :: unifier a cannotUnifyDomainValues = explainAndReturnBottom cannotUnifyDistinctDomainValues -data UnifyStringLiteral = UnifyStringLiteral { - txt1, txt2 :: Text -} +data UnifyStringLiteral = UnifyStringLiteral + { txt1, txt2 :: Text + } -matchStringLiteral - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyStringLiteral +matchStringLiteral :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyStringLiteral matchStringLiteral first second | StringLiteral_ string1 <- first - , StringLiteral_ string2 <- second - = Just $ UnifyStringLiteral string1 string2 + , StringLiteral_ string2 <- second = + Just $ UnifyStringLiteral string1 string2 | otherwise = Nothing {-# INLINE matchStringLiteral #-} @@ -709,7 +721,7 @@ unifyStringLiteral term1 term2 unifyData = lift worker return $ Pattern.fromTermLike term1 | otherwise = explainAndReturnBottom "distinct string literals" term1 term2 - UnifyStringLiteral { txt1, txt2 } = unifyData + UnifyStringLiteral{txt1, txt2} = unifyData {- | Unify any two function patterns. @@ -751,20 +763,20 @@ compareForEquals first second | isConstructorLike second = GT | otherwise = compare first second -matchBytesDifferent - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe () +matchBytesDifferent :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe () matchBytesDifferent first second | _ :< InternalBytesF (Const bytesFirst) <- Recursive.project first - , _ :< InternalBytesF (Const bytesSecond) <- Recursive.project second - , bytesFirst /= bytesSecond - = Just () + , _ :< InternalBytesF (Const bytesSecond) <- Recursive.project second + , bytesFirst /= bytesSecond = + Just () | otherwise = Nothing {-# INLINE matchBytesDifferent #-} bytesDifferent :: MonadUnify unifier => MaybeT unifier (Pattern RewritingVariableName) -bytesDifferent - = return Pattern.bottom +bytesDifferent = + return Pattern.bottom diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index bd6d54e41b..7c2fa06755 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -27,27 +27,28 @@ import Prelude.Kore hiding ( concat, ) -data UnifyEqualInjectiveHeadsAndEquals = UnifyEqualInjectiveHeadsAndEquals { - firstHead :: Symbol +data UnifyEqualInjectiveHeadsAndEquals = UnifyEqualInjectiveHeadsAndEquals + { firstHead :: Symbol , firstChildren :: [TermLike RewritingVariableName] , secondChildren :: [TermLike RewritingVariableName] -} + } -matchEqualInjectiveHeadsAndEquals - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyEqualInjectiveHeadsAndEquals +matchEqualInjectiveHeadsAndEquals :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyEqualInjectiveHeadsAndEquals matchEqualInjectiveHeadsAndEquals first second | App_ firstHead firstChildren <- first - , App_ secondHead secondChildren <- second - , Symbol.isInjective firstHead - , Symbol.isInjective secondHead - , firstHead == secondHead --is one of the above redundant in light of this? - = Just $ + , App_ secondHead secondChildren <- second + , Symbol.isInjective firstHead + , Symbol.isInjective secondHead + , firstHead == secondHead --is one of the above redundant in light of this? + = + Just $ UnifyEqualInjectiveHeadsAndEquals - firstHead - firstChildren - secondChildren + firstHead + firstChildren + secondChildren | otherwise = Nothing {-# INLINE matchEqualInjectiveHeadsAndEquals #-} @@ -67,23 +68,21 @@ equalInjectiveHeadsAndEquals :: MaybeT unifier (Pattern RewritingVariableName) equalInjectiveHeadsAndEquals termMerger - unifyData - = - lift $ do - children <- Monad.zipWithM termMerger firstChildren secondChildren - let merged = foldMap Pattern.withoutTerm children - -- TODO (thomas.tuegel): This is tricky! - -- Unifying the symbol's children may have produced new patterns - -- which allow evaluating the symbol. It is possible this pattern - -- is not actually fully simplified! - term = - (markSimplified . mkApplySymbol firstHead) - (Pattern.term <$> children) - return (Pattern.withCondition term merged) + unifyData = + lift $ do + children <- Monad.zipWithM termMerger firstChildren secondChildren + let merged = foldMap Pattern.withoutTerm children + -- TODO (thomas.tuegel): This is tricky! + -- Unifying the symbol's children may have produced new patterns + -- which allow evaluating the symbol. It is possible this pattern + -- is not actually fully simplified! + term = + (markSimplified . mkApplySymbol firstHead) + (Pattern.term <$> children) + return (Pattern.withCondition term merged) where - UnifyEqualInjectiveHeadsAndEquals - { firstHead + { firstHead , firstChildren , secondChildren } = unifyData From 139318141ca08d69da419ff95debbaecef1284b5 Mon Sep 17 00:00:00 2001 From: emarzion Date: Mon, 10 May 2021 00:33:22 -0500 Subject: [PATCH 05/86] Committing current progress. --- kore/src/Kore/Step/Simplification/AndTerms.hs | 290 +++++++++++------- .../Kore/Step/Simplification/ExpandAlias.hs | 44 +-- .../Kore/Step/Simplification/NoConfusion.hs | 55 +++- .../Kore/Step/Simplification/Overloading.hs | 154 +++++++++- 4 files changed, 395 insertions(+), 148 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 9443826999..7abe36a6ac 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -64,9 +64,7 @@ import Kore.Rewriting.RewritingVariable ( RewritingVariableName, ) import qualified Kore.Step.Simplification.Exists as Exists -import Kore.Step.Simplification.ExpandAlias ( - expandAlias, - ) +import Kore.Step.Simplification.ExpandAlias import Kore.Step.Simplification.InjSimplifier import Kore.Step.Simplification.NoConfusion import Kore.Step.Simplification.NotSimplifier @@ -78,7 +76,6 @@ import Kore.Step.Simplification.Simplify as Simplifier import Kore.Syntax.PatternF ( Const (..), ) -import Kore.TopBottom import Kore.Unification.Unify as Unify import Kore.Unparser import Pair @@ -170,11 +167,13 @@ maybeTermEquals notSimplifier childTransformers first second equalInjectiveHeadsAndEquals childTransformers unifyData | Just unifyData <- matchSortInjectionAndEquals first second = sortInjectionAndEquals childTransformers first second unifyData + | Just () <- matchConstructorSortInjectionAndEquals first second = + constructorSortInjectionAndEquals first second + | Just unifyData <- matchConstructorAndEqualsAssumesDifferentHeads first second = + constructorAndEqualsAssumesDifferentHeads first second unifyData | otherwise = asum - [ constructorSortInjectionAndEquals first second - , constructorAndEqualsAssumesDifferentHeads first second - , overloadedConstructorSortInjectionAndEquals + [ overloadedConstructorSortInjectionAndEquals childTransformers first second @@ -219,74 +218,81 @@ maybeTermAnd :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) -maybeTermAnd notSimplifier childTransformers first second = - asum - [ expandAlias - (maybeTermAnd notSimplifier childTransformers) - first - second - , boolAnd first second - , do - unifyData <- Error.hoistMaybe $ Builtin.Int.matchInt first second - Builtin.Int.unifyInt first second unifyData - , do - unifyData <- Error.hoistMaybe $ Builtin.Bool.matchBools first second - Builtin.Bool.unifyBool first second unifyData - , do - unifyData <- Error.hoistMaybe $ Builtin.String.matchString first second - Builtin.String.unifyString first second unifyData - , do - unifyData <- Error.hoistMaybe $ matchDomainValue first second - unifyDomainValue first second unifyData - , do - unifyData <- Error.hoistMaybe $ matchStringLiteral first second - unifyStringLiteral first second unifyData - , do - () <- Error.hoistMaybe $ matchEqualsAndEquals first second - equalAndEquals first - , do - () <- Error.hoistMaybe $ matchBytesDifferent first second - bytesDifferent - , variableFunctionAnd first second - , variableFunctionAnd second first - , do - unifyData <- Error.hoistMaybe $ matchEqualInjectiveHeadsAndEquals first second - equalInjectiveHeadsAndEquals childTransformers unifyData - , do - unifyData <- Error.hoistMaybe $ matchSortInjectionAndEquals first second - sortInjectionAndEquals childTransformers first second unifyData - , constructorSortInjectionAndEquals first second - , constructorAndEqualsAssumesDifferentHeads first second - , overloadedConstructorSortInjectionAndEquals - childTransformers - first - second - , do - boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd first second - Builtin.Bool.unifyBoolAnd childTransformers first boolAndData - , do - boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd second first - Builtin.Bool.unifyBoolAnd childTransformers second boolAndData - , Builtin.Bool.unifyBoolOr childTransformers first second - , Builtin.Bool.unifyBoolNot childTransformers first second - , Builtin.KEqual.unifyKequalsEq - childTransformers - notSimplifier - first - second - , Builtin.KEqual.unifyIfThenElse childTransformers first second - , Builtin.Endianness.unifyEquals first second - , Builtin.Signedness.unifyEquals first second - , Builtin.Map.unifyEquals childTransformers first second - , Builtin.Set.unifyEquals childTransformers first second - , Builtin.List.unifyEquals - SimplificationType.And - childTransformers - first - second - , domainValueAndConstructorErrors first second - , Error.hoistMaybe (functionAnd first second) - ] +maybeTermAnd notSimplifier childTransformers first second + | Just unifyData <- matchExpandAlias first second + = let UnifyExpandAlias { term1, term2 } = unifyData in + maybeTermAnd + notSimplifier + childTransformers + term1 + term2 + | Just unifyData <- matchBoolAnd first + = boolAnd first second unifyData + | Just unifyData <- matchBoolAnd second + = boolAnd second first unifyData + | Just unifyData <- Builtin.Int.matchInt first second + = Builtin.Int.unifyInt first second unifyData + | Just unifyData <- Builtin.Bool.matchBools first second + = Builtin.Bool.unifyBool first second unifyData + | Just unifyData <- Builtin.String.matchString first second + = Builtin.String.unifyString first second unifyData + | Just unifyData <- matchDomainValue first second + = unifyDomainValue first second unifyData + | Just unifyData <- matchStringLiteral first second + = unifyStringLiteral first second unifyData + | Just () <- matchEqualsAndEquals first second + = equalAndEquals first + | Just () <- matchBytesDifferent first second + = bytesDifferent + | Just unifyData <- matchVariableFunctionAnd first second + = variableFunctionAnd second unifyData + | Just unifyData <- matchVariableFunctionAnd second first + = variableFunctionAnd first unifyData + | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second + = equalInjectiveHeadsAndEquals childTransformers unifyData + -- | Just unifyData <- matchSortInjectionAndEquals first second + -- = sortInjectionAndEquals childTransformers first second unifyData + | otherwise = + asum + [ do + unifyData <- Error.hoistMaybe $ matchSortInjectionAndEquals first second + sortInjectionAndEquals childTransformers first second unifyData + , do + () <- Error.hoistMaybe $ matchConstructorSortInjectionAndEquals first second + constructorSortInjectionAndEquals first second + , do + unifyData <- Error.hoistMaybe $ matchConstructorAndEqualsAssumesDifferentHeads first second + constructorAndEqualsAssumesDifferentHeads first second unifyData + , overloadedConstructorSortInjectionAndEquals + childTransformers + first + second + , do + boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd first second + Builtin.Bool.unifyBoolAnd childTransformers first boolAndData + , do + boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd second first + Builtin.Bool.unifyBoolAnd childTransformers second boolAndData + , Builtin.Bool.unifyBoolOr childTransformers first second + , Builtin.Bool.unifyBoolNot childTransformers first second + , Builtin.KEqual.unifyKequalsEq + childTransformers + notSimplifier + first + second + , Builtin.KEqual.unifyIfThenElse childTransformers first second + , Builtin.Endianness.unifyEquals first second + , Builtin.Signedness.unifyEquals first second + , Builtin.Map.unifyEquals childTransformers first second + , Builtin.Set.unifyEquals childTransformers first second + , Builtin.List.unifyEquals + SimplificationType.And + childTransformers + first + second + , domainValueAndConstructorErrors first second + , Error.hoistMaybe (functionAnd first second) + ] {- | Construct the conjunction or unification of two terms. @@ -306,22 +312,35 @@ type TermTransformationOld variable unifier = TermLike variable -> MaybeT unifier (Pattern variable) +data UnifyBoolAnd + = UnifyBoolAndBottom + | UnifyBoolAndTop + +matchBoolAnd + :: TermLike RewritingVariableName + -> Maybe UnifyBoolAnd +matchBoolAnd term + | Pattern.isBottom term + = Just UnifyBoolAndBottom + | Pattern.isTop term + = Just UnifyBoolAndTop + | otherwise + = Nothing + -- | Simplify the conjunction of terms where one is a predicate. boolAnd :: MonadUnify unifier => TermLike RewritingVariableName -> TermLike RewritingVariableName -> + UnifyBoolAnd -> MaybeT unifier (Pattern RewritingVariableName) -boolAnd first second - | isBottom first = do - explainBoolAndBottom first second - return (Pattern.fromTermLike first) - | isTop first = return (Pattern.fromTermLike second) - | isBottom second = do - explainBoolAndBottom first second - return (Pattern.fromTermLike second) - | isTop second = return (Pattern.fromTermLike first) - | otherwise = empty +boolAnd first second unifyData + = case unifyData of + UnifyBoolAndBottom -> do + explainBoolAndBottom first second + return $ Pattern.fromTermLike first + UnifyBoolAndTop -> + return $ Pattern.fromTermLike second explainBoolAndBottom :: MonadUnify unifier => @@ -393,29 +412,61 @@ bottomTermEquals , substitution = mempty } +data VariableFunctionAnd + = VariableFunctionAnd1 (ElementVariable RewritingVariableName) + | VariableFunctionAnd2 (ElementVariable RewritingVariableName) + +matchVariableFunctionAnd + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe VariableFunctionAnd +matchVariableFunctionAnd first second + | ElemVar_ v <- first + , ElemVar_ _ <- second + = Just $ VariableFunctionAnd1 v + | ElemVar_ v <- first + , isFunctionPattern second + = Just $ VariableFunctionAnd2 v + | otherwise + = Nothing + variableFunctionAnd :: - InternalVariable variable => MonadUnify unifier => - TermLike variable -> - TermLike variable -> - MaybeT unifier (Pattern variable) -variableFunctionAnd - (ElemVar_ v1) - second@(ElemVar_ _) = - return $ Pattern.assign (inject v1) second -variableFunctionAnd - (ElemVar_ v) - second - | isFunctionPattern second = - -- Ceil predicate not needed since 'second' being bottom - -- will make the entire term bottom. However, one must - -- be careful to not just drop the term. - lift $ return (Pattern.withCondition second result) - where - result = - Condition.fromSingleSubstitution - (Substitution.assign (inject v) second) -variableFunctionAnd _ _ = empty + TermLike RewritingVariableName -> + VariableFunctionAnd -> + MaybeT unifier (Pattern RewritingVariableName) +variableFunctionAnd second unifyData + = case unifyData of + VariableFunctionAnd1 v -> return $ Pattern.assign (inject v) second + VariableFunctionAnd2 v -> lift $ return $ Pattern.withCondition second result + where + result = + Condition.fromSingleSubstitution + (Substitution.assign (inject v) second) + +-- variableFunctionAnd :: +-- InternalVariable variable => +-- MonadUnify unifier => +-- TermLike variable -> +-- TermLike variable -> +-- MaybeT unifier (Pattern variable) +-- variableFunctionAnd +-- (ElemVar_ v1) +-- second@(ElemVar_ _) = +-- return $ Pattern.assign (inject v1) second +-- variableFunctionAnd +-- (ElemVar_ v) +-- second +-- | isFunctionPattern second = +-- -- Ceil predicate not needed since 'second' being bottom +-- -- will make the entire term bottom. However, one must +-- -- be careful to not just drop the term. +-- lift $ return (Pattern.withCondition second result) +-- where +-- result = +-- Condition.fromSingleSubstitution +-- (Substitution.assign (inject v) second) +-- variableFunctionAnd _ _ = empty matchVariableFunctionEquals :: TermLike RewritingVariableName -> @@ -516,6 +567,22 @@ sortInjectionAndEquals termMerger first second unifyData = do SortInjectionAndEquals{inj1, inj2} = unifyData +matchConstructorSortInjectionAndEquals + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe () +matchConstructorSortInjectionAndEquals first second + | Inj_ _ <- first + , App_ symbol _ <- second + , Symbol.isConstructor symbol + = Just () + | Inj_ _ <- second + , App_ symbol _ <- first + , Symbol.isConstructor symbol + = Just () + | otherwise = Nothing +{-# INLINE matchConstructorSortInjectionAndEquals #-} + {- | Unify a constructor application pattern with a sort injection pattern. Sort injections clash with constructors, so @constructorSortInjectionAndEquals@ @@ -526,13 +593,8 @@ constructorSortInjectionAndEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> MaybeT unifier a -constructorSortInjectionAndEquals first@(Inj_ _) second@(App_ symbol2 _) - | Symbol.isConstructor symbol2 = - lift $ noConfusionInjectionConstructor first second -constructorSortInjectionAndEquals first@(App_ symbol1 _) second@(Inj_ _) - | Symbol.isConstructor symbol1 = - lift $ noConfusionInjectionConstructor first second -constructorSortInjectionAndEquals _ _ = empty +constructorSortInjectionAndEquals first second + = lift $ noConfusionInjectionConstructor first second noConfusionInjectionConstructor :: MonadUnify unifier => @@ -779,4 +841,4 @@ bytesDifferent :: MonadUnify unifier => MaybeT unifier (Pattern RewritingVariableName) bytesDifferent = - return Pattern.bottom + return Pattern.bottom \ No newline at end of file diff --git a/kore/src/Kore/Step/Simplification/ExpandAlias.hs b/kore/src/Kore/Step/Simplification/ExpandAlias.hs index 3151ea3292..cd9a267ca7 100644 --- a/kore/src/Kore/Step/Simplification/ExpandAlias.hs +++ b/kore/src/Kore/Step/Simplification/ExpandAlias.hs @@ -3,23 +3,16 @@ Copyright : (c) Runtime Verification, 2019 License : NCSA -} module Kore.Step.Simplification.ExpandAlias ( - expandAlias, + expandSingleAlias, + matchExpandAlias, substituteInAlias, + UnifyExpandAlias (..), ) where -import Control.Error ( - MaybeT, - ) -import Control.Error.Util ( - nothing, - ) import qualified Data.Map.Strict as Map import Kore.Internal.Alias ( Alias (..), ) -import Kore.Internal.Pattern ( - Pattern, - ) import Kore.Internal.TermLike ( InternalVariable, TermLike, @@ -34,25 +27,22 @@ import Kore.Internal.TermLike ( import Kore.Rewriting.RewritingVariable ( RewritingVariableName, ) -import Kore.Unification.Unify ( - MonadUnify, - ) + import Prelude.Kore -expandAlias :: - forall unifier. - MonadUnify unifier => - ( TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) - ) -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) -expandAlias recurse t1 t2 = - case (expandSingleAlias t1, expandSingleAlias t2) of - (Nothing, Nothing) -> nothing - (t1', t2') -> recurse (fromMaybe t1 t1') (fromMaybe t2 t2') +data UnifyExpandAlias = UnifyExpandAlias { + term1, term2 :: !(TermLike RewritingVariableName) +} + +matchExpandAlias + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyExpandAlias +matchExpandAlias t1 t2 + = case (expandSingleAlias t1, expandSingleAlias t2) of + (Nothing, Nothing) -> Nothing + (t1', t2') -> Just $ UnifyExpandAlias (fromMaybe t1 t1') (fromMaybe t2 t2') +{-# INLINE matchExpandAlias #-} expandSingleAlias :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 7c2fa06755..7d26a4ae8c 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -6,6 +6,7 @@ module Kore.Step.Simplification.NoConfusion ( equalInjectiveHeadsAndEquals, constructorAndEqualsAssumesDifferentHeads, matchEqualInjectiveHeadsAndEquals, + matchConstructorAndEqualsAssumesDifferentHeads, ) where import Control.Error ( @@ -87,29 +88,71 @@ equalInjectiveHeadsAndEquals , secondChildren } = unifyData +data ConstructorAndEqualsAssumesDifferentHeads = + ConstructorAndEqualsAssumesDifferentHeads { + firstHead, secondHead :: Symbol + } + +matchConstructorAndEqualsAssumesDifferentHeads + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe ConstructorAndEqualsAssumesDifferentHeads +matchConstructorAndEqualsAssumesDifferentHeads + first second + | App_ firstHead _ <- first + , App_ secondHead _ <- second + , firstHead /= secondHead + = Just $ ConstructorAndEqualsAssumesDifferentHeads firstHead secondHead + | otherwise = empty +{-# INLINE matchConstructorAndEqualsAssumesDifferentHeads #-} + {- | Unify two constructor application patterns. Assumes that the two patterns were already tested for equality and were found to be different; therefore their conjunction is @\\bottom@. -} +-- constructorAndEqualsAssumesDifferentHeads :: +-- MonadUnify unifier => +-- HasCallStack => +-- TermLike RewritingVariableName -> +-- TermLike RewritingVariableName -> +-- MaybeT unifier a +-- constructorAndEqualsAssumesDifferentHeads +-- first@(App_ firstHead _) +-- second@(App_ secondHead _) = +-- do +-- Monad.guard =<< Simplifier.isConstructorOrOverloaded firstHead +-- Monad.guard =<< Simplifier.isConstructorOrOverloaded secondHead +-- assert (firstHead /= secondHead) $ +-- lift $ do +-- explainBottom +-- "Cannot unify different constructors or incompatible \ +-- \sort injections." +-- first +-- second +-- empty +-- constructorAndEqualsAssumesDifferentHeads _ _ = empty + constructorAndEqualsAssumesDifferentHeads :: MonadUnify unifier => - HasCallStack => TermLike RewritingVariableName -> TermLike RewritingVariableName -> + ConstructorAndEqualsAssumesDifferentHeads -> MaybeT unifier a constructorAndEqualsAssumesDifferentHeads - first@(App_ firstHead _) - second@(App_ secondHead _) = + first second unifyData = do + -- should these two guards be pushed to the match? Monad.guard =<< Simplifier.isConstructorOrOverloaded firstHead Monad.guard =<< Simplifier.isConstructorOrOverloaded secondHead - assert (firstHead /= secondHead) $ - lift $ do + lift $ do explainBottom "Cannot unify different constructors or incompatible \ \sort injections." first second empty -constructorAndEqualsAssumesDifferentHeads _ _ = empty + + where + ConstructorAndEqualsAssumesDifferentHeads + { firstHead, secondHead } = unifyData \ No newline at end of file diff --git a/kore/src/Kore/Step/Simplification/Overloading.hs b/kore/src/Kore/Step/Simplification/Overloading.hs index f4072e9185..937dbf949f 100644 --- a/kore/src/Kore/Step/Simplification/Overloading.hs +++ b/kore/src/Kore/Step/Simplification/Overloading.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE PartialTypeSignatures #-} + {- | Copyright : (c) Runtime Verification, 2019 License : NCSA -} module Kore.Step.Simplification.Overloading ( matchOverloading, + --matchOverloadedConstructorSortInjectionAndEquals, + --getUnifyResult, -- for testing purposes unifyOverloading, UnifyOverloadingResult, @@ -127,6 +131,154 @@ matchOverloading termPair = Simple pair -> return pair _ -> notApplicable +-- flipPairBack :: Pair a -> Pair a +-- flipPairBack (Pair x y) = Pair y x + +-- data UnifyOverload1 = UnifyOverload1 { +-- firstHead, secondHead :: Symbol +-- , firstChildren :: [TermLike RewritingVariableName] +-- , inj :: Inj (TermLike RewritingVariableName) +-- } + +-- data UnifyOverload2 = UnifyOverload2 { +-- firstHead, secondHead :: Symbol +-- , secondChildren :: [TermLike RewritingVariableName] +-- , inj :: Inj (TermLike RewritingVariableName) +-- } + +-- data UnifyOverload3 = UnifyOverload3 { +-- firstHead, secondHead :: Symbol +-- , firstChildren, secondChildren :: [TermLike RewritingVariableName] +-- , inj :: Inj (TermLike RewritingVariableName) +-- } + +-- data UnifyOverload4 = UnifyOverload4 { +-- firstHead :: Symbol +-- , secondVar :: ElementVariable RewritingVariableName +-- , inj :: Inj (TermLike RewritingVariableName) +-- } + +-- data UnifyOverload5 = UnifyOverload5 { +-- firstHead :: Symbol +-- , firstChildren :: [TermLike RewritingVariableName] +-- , secondVar :: ElementVariable RewritingVariableName +-- , inj :: Inj (TermLike RewritingVariableName) +-- } + +-- data UnifyOverload6 = UnifyOverload6 { +-- firstHead :: Symbol +-- , injChild :: TermLike RewritingVariableName +-- } + +-- data OverloadedConstructorSortInjectionAndEquals = +-- Overload1 UnifyOverload1 +-- | Overload2 UnifyOverload2 +-- | Overload3 UnifyOverload3 +-- | Overload4 UnifyOverload4 +-- | Overload5 UnifyOverload5 +-- | Overload6 UnifyOverload6 + +-- matchOverloadedConstructorSortInjectionAndEquals +-- :: TermLike RewritingVariableName +-- -> TermLike RewritingVariableName +-- -> Maybe OverloadedConstructorSortInjectionAndEquals +-- matchOverloadedConstructorSortInjectionAndEquals +-- first second +-- | Inj_ inj@Inj { injChild = App_ firstHead firstChildren } <- first +-- , App_ secondHead _ <- second +-- = Just $ Overload1 $ UnifyOverload1 firstHead secondHead firstChildren inj +-- | App_ firstHead _ <- first +-- , Inj_ inj@Inj { injChild = App_ secondHead secondChildren } <- second +-- = Just $ Overload2 $ UnifyOverload2 firstHead secondHead secondChildren inj +-- | Inj_ inj@Inj { injChild = App_ firstHead firstChildren } <- first +-- , Inj_ inj'@Inj { injChild = App_ secondHead secondChildren } <- second +-- , injFrom inj /= injFrom inj' +-- = Just $ Overload3 $ UnifyOverload3 firstHead secondHead firstChildren secondChildren inj +-- | App_ firstHead _ <- first +-- , Inj_ inj@Inj { injChild = ElemVar_ secondVar } <- second +-- = Just $ Overload4 $ UnifyOverload4 firstHead secondVar inj +-- | App_ secondHead _ <- second +-- , Inj_ inj@Inj { injChild = ElemVar_ firstVar } <- first +-- = Just $ Overload4 $ UnifyOverload4 secondHead firstVar inj +-- | Inj_ Inj { injChild = (App_ firstHead firstChildren) } <- first +-- , Inj_ inj@Inj { injChild = ElemVar_ secondVar } <- second +-- = Just $ Overload5 $ UnifyOverload5 firstHead firstChildren secondVar inj +-- | Inj_ Inj { injChild = (App_ secondHead secondChildren) } <- second +-- , Inj_ inj@Inj { injChild = ElemVar_ firstVar } <- first +-- = Just $ Overload5 $ UnifyOverload5 secondHead secondChildren firstVar inj +-- | App_ firstHead _ <- first +-- , Inj_ Inj { injChild } <- second +-- = Just $ Overload6 $ UnifyOverload6 firstHead injChild +-- | otherwise +-- = Nothing + +-- getUnifyResult +-- :: MonadSimplify unifier +-- => TermLike RewritingVariableName +-- -> TermLike RewritingVariableName +-- -> OverloadedConstructorSortInjectionAndEquals +-- -> UnifyOverloadingResult unifier RewritingVariableName +-- getUnifyResult firstTerm secondTerm unifyData = +-- case unifyData of +-- Overload1 unifyData' -> +-- Simple . flipPairBack <$> unifyOverloadingVsOverloaded +-- secondHead +-- secondTerm +-- (Application firstHead firstChildren) +-- (inj :: Inj (TermLike RewritingVariableName)) { injChild = () } + +-- where +-- UnifyOverload1 { firstHead, secondHead, firstChildren, inj } = unifyData' + +-- Overload2 unifyData' -> +-- Simple <$> unifyOverloadingVsOverloaded +-- firstHead +-- firstTerm +-- (Application secondHead secondChildren) +-- (inj :: Inj (TermLike RewritingVariableName)) { injChild = () } +-- where +-- UnifyOverload2 { firstHead, secondHead, secondChildren, inj } = unifyData' + +-- Overload3 unifyData' -> +-- Simple <$> unifyOverloadingCommonOverload +-- (Application firstHead firstChildren) +-- (Application secondHead secondChildren) +-- (inj :: Inj (TermLike RewritingVariableName)) { injChild = () } +-- where +-- UnifyOverload3 { firstHead, secondHead, firstChildren, secondChildren, inj } = unifyData' + +-- Overload4 unifyData' -> +-- catchE ( +-- unifyOverloadingVsOverloadedVariable +-- firstHead +-- firstTerm +-- secondVar +-- (inj :: Inj (TermLike RewritingVariableName)) { injChild = () } +-- ) +-- throwE +-- where +-- UnifyOverload4 { firstHead, secondVar, inj } = unifyData' + +-- Overload5 unifyData' -> +-- catchE ( +-- unifyOverloadingInjVsVariable +-- (Application firstHead firstChildren) +-- secondVar +-- (Attribute.freeVariables firstTerm) +-- (inj :: Inj (TermLike RewritingVariableName)) { injChild = () } +-- ) +-- throwE +-- where +-- UnifyOverload5 { firstHead, firstChildren, secondVar, inj } = unifyData' + +-- Overload6 unifyData' -> +-- catchE ( +-- notUnifiableTest firstHead injChild +-- ) +-- throwE +-- where +-- UnifyOverload6 { firstHead, injChild } = unifyData' + {- | Tests whether the pair of terms can be coerced to have the same constructors at the top, and, if so, returns the thus obtained new pair. @@ -465,7 +617,7 @@ mkInj :: Inj () -> TermLike RewritingVariableName -> TermLike RewritingVariableName -mkInj inj injChild = (synthesize . InjF) inj{injChild} +mkInj inj injChild = (synthesize . InjF) (inj :: Inj ()) {injChild} maybeMkInj :: Maybe (Inj ()) -> From eae61bd498b3f1b52022da51ce3fe1348069a273 Mon Sep 17 00:00:00 2001 From: emarzion Date: Mon, 10 May 2021 09:22:15 -0500 Subject: [PATCH 06/86] pushing test failure --- kore/src/Kore/Step/Simplification/AndTerms.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 7abe36a6ac..9dbda25841 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -250,14 +250,15 @@ maybeTermAnd notSimplifier childTransformers first second = variableFunctionAnd first unifyData | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = equalInjectiveHeadsAndEquals childTransformers unifyData - -- | Just unifyData <- matchSortInjectionAndEquals first second - -- = sortInjectionAndEquals childTransformers first second unifyData + | Just unifyData <- matchSortInjectionAndEquals first second + = sortInjectionAndEquals childTransformers first second unifyData | otherwise = asum - [ do + [ {- do unifyData <- Error.hoistMaybe $ matchSortInjectionAndEquals first second sortInjectionAndEquals childTransformers first second unifyData - , do + , -} + do () <- Error.hoistMaybe $ matchConstructorSortInjectionAndEquals first second constructorSortInjectionAndEquals first second , do From df91cbd3f1cea1b9a374fb574dbc0a2d7a0678d5 Mon Sep 17 00:00:00 2001 From: emarzion Date: Mon, 10 May 2021 22:56:27 -0500 Subject: [PATCH 07/86] Changing type signatures and splitting up unifyInj --- kore/src/Kore/Builtin/Bool.hs | 20 ++-- kore/src/Kore/Builtin/Int.hs | 4 +- kore/src/Kore/Builtin/String.hs | 4 +- kore/src/Kore/Step/Axiom/Matcher.hs | 4 +- kore/src/Kore/Step/Simplification/AndTerms.hs | 90 +++++++-------- .../Kore/Step/Simplification/InjSimplifier.hs | 106 ++++++++++++------ .../Kore/Step/Simplification/NoConfusion.hs | 4 +- kore/test/Test/Kore/Builtin/Bool.hs | 2 +- .../Kore/Step/Simplification/InjSimplifier.hs | 3 +- 9 files changed, 137 insertions(+), 100 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index c904c4642e..148383ea7f 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -188,20 +188,16 @@ unifyBool :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> UnifyBool -> - MaybeT unifier (Pattern RewritingVariableName) + unifier (Pattern RewritingVariableName) unifyBool termLike1 termLike2 unifyData = - worker bool1 bool2 <|> worker bool2 bool1 + if bool1 == bool2 + then return (Pattern.fromTermLike termLike1) + else + Unify.explainAndReturnBottom + "different Bool domain values" + termLike1 + termLike2 where - worker a b = - lift $ - if a == b - then return (Pattern.fromTermLike termLike1) - else - Unify.explainAndReturnBottom - "different Bool domain values" - termLike1 - termLike2 - UnifyBool{bool1, bool2} = unifyData matchUnifyBoolAnd :: diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index 00343d9f37..20977cb713 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -449,9 +449,9 @@ unifyInt :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> UnifyInt -> - MaybeT unifier (Pattern RewritingVariableName) + unifier (Pattern RewritingVariableName) unifyInt term1 term2 unifyData = - assert (on (==) internalIntSort int1 int2) $ lift worker + assert (on (==) internalIntSort int1 int2) worker -- should this be part of match? where worker :: unifier (Pattern RewritingVariableName) worker diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index a4ecbab6c4..544c8097fd 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -495,9 +495,9 @@ unifyString :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> UnifyString -> - MaybeT unifier (Pattern RewritingVariableName) + unifier (Pattern RewritingVariableName) unifyString term1 term2 unifyData = - assert (on (==) internalStringSort string1 string2) $ lift worker + assert (on (==) internalStringSort string1 string2) worker where worker :: unifier (Pattern RewritingVariableName) worker diff --git a/kore/src/Kore/Step/Axiom/Matcher.hs b/kore/src/Kore/Step/Axiom/Matcher.hs index e3bd521dce..3f858cef05 100644 --- a/kore/src/Kore/Step/Axiom/Matcher.hs +++ b/kore/src/Kore/Step/Axiom/Matcher.hs @@ -418,8 +418,8 @@ matchInj :: Pair (TermLike variable) -> MaybeT (MatcherT variable simplifier) () matchInj (Pair (Inj_ inj1) (Inj_ inj2)) = do - InjSimplifier{unifyInj} <- Simplifier.askInjSimplifier - unifyInj inj1 inj2 & either (const empty) (push . injChild) + injSimplifier <- Simplifier.askInjSimplifier + unifyInj injSimplifier inj1 inj2 & either (const empty) (push . injChild) matchInj _ = empty matchOverload :: diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 9dbda25841..68c7a72f29 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -142,29 +142,29 @@ maybeTermEquals :: MaybeT unifier (Pattern RewritingVariableName) maybeTermEquals notSimplifier childTransformers first second | Just unifyData <- Builtin.Int.matchInt first second = - Builtin.Int.unifyInt first second unifyData + lift $ Builtin.Int.unifyInt first second unifyData | Just unifyData <- Builtin.Bool.matchBools first second = - Builtin.Bool.unifyBool first second unifyData + lift $ Builtin.Bool.unifyBool first second unifyData | Just unifyData <- Builtin.String.matchString first second = - Builtin.String.unifyString first second unifyData + lift $ Builtin.String.unifyString first second unifyData | Just unifyData <- matchDomainValue first second = - unifyDomainValue first second unifyData + lift $ unifyDomainValue first second unifyData | Just unifyData <- matchStringLiteral first second = - unifyStringLiteral first second unifyData + lift $ unifyStringLiteral first second unifyData | Just () <- matchEqualsAndEquals first second = - equalAndEquals first + lift $ equalAndEquals first | Just () <- matchBytesDifferent first second = - bytesDifferent + lift bytesDifferent | Just () <- matchBottomTermEquals first = - bottomTermEquals SideCondition.topTODO first second + lift $ bottomTermEquals SideCondition.topTODO first second | Just () <- matchBottomTermEquals second = - bottomTermEquals SideCondition.topTODO second first + lift $ bottomTermEquals SideCondition.topTODO second first | Just var <- matchVariableFunctionEquals first second = - variableFunctionEquals first second var + lift $ variableFunctionEquals first second var | Just var <- matchVariableFunctionEquals second first = - variableFunctionEquals second first var + lift $ variableFunctionEquals second first var | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = - equalInjectiveHeadsAndEquals childTransformers unifyData + lift $ equalInjectiveHeadsAndEquals childTransformers unifyData | Just unifyData <- matchSortInjectionAndEquals first second = sortInjectionAndEquals childTransformers first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = @@ -227,37 +227,37 @@ maybeTermAnd notSimplifier childTransformers first second term1 term2 | Just unifyData <- matchBoolAnd first - = boolAnd first second unifyData + = lift $ boolAnd first second unifyData | Just unifyData <- matchBoolAnd second - = boolAnd second first unifyData + = lift $ boolAnd second first unifyData | Just unifyData <- Builtin.Int.matchInt first second - = Builtin.Int.unifyInt first second unifyData + = lift $ Builtin.Int.unifyInt first second unifyData | Just unifyData <- Builtin.Bool.matchBools first second - = Builtin.Bool.unifyBool first second unifyData + = lift $ Builtin.Bool.unifyBool first second unifyData | Just unifyData <- Builtin.String.matchString first second - = Builtin.String.unifyString first second unifyData + = lift $ Builtin.String.unifyString first second unifyData | Just unifyData <- matchDomainValue first second - = unifyDomainValue first second unifyData + = lift $ unifyDomainValue first second unifyData | Just unifyData <- matchStringLiteral first second - = unifyStringLiteral first second unifyData + = lift $ unifyStringLiteral first second unifyData | Just () <- matchEqualsAndEquals first second - = equalAndEquals first + = lift $ equalAndEquals first | Just () <- matchBytesDifferent first second - = bytesDifferent + = lift bytesDifferent | Just unifyData <- matchVariableFunctionAnd first second - = variableFunctionAnd second unifyData + = lift $ variableFunctionAnd second unifyData | Just unifyData <- matchVariableFunctionAnd second first - = variableFunctionAnd first unifyData + = lift $ variableFunctionAnd first unifyData | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second - = equalInjectiveHeadsAndEquals childTransformers unifyData - | Just unifyData <- matchSortInjectionAndEquals first second - = sortInjectionAndEquals childTransformers first second unifyData + = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData + -- | Just unifyData <- matchSortInjectionAndEquals first second + -- = sortInjectionAndEquals childTransformers first second unifyData | otherwise = asum - [ {- do + [ do unifyData <- Error.hoistMaybe $ matchSortInjectionAndEquals first second sortInjectionAndEquals childTransformers first second unifyData - , -} + , do () <- Error.hoistMaybe $ matchConstructorSortInjectionAndEquals first second constructorSortInjectionAndEquals first second @@ -334,7 +334,7 @@ boolAnd :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> UnifyBoolAnd -> - MaybeT unifier (Pattern RewritingVariableName) + unifier (Pattern RewritingVariableName) boolAnd first second unifyData = case unifyData of UnifyBoolAndBottom -> do @@ -347,9 +347,9 @@ explainBoolAndBottom :: MonadUnify unifier => TermLike RewritingVariableName -> TermLike RewritingVariableName -> - MaybeT unifier () + unifier () explainBoolAndBottom term1 term2 = - lift $ explainBottom "Cannot unify bottom." term1 term2 + explainBottom "Cannot unify bottom." term1 term2 matchEqualsAndEquals :: TermLike RewritingVariableName -> @@ -365,7 +365,7 @@ matchEqualsAndEquals first second equalAndEquals :: Monad unifier => TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) + unifier (Pattern RewritingVariableName) equalAndEquals first = -- TODO (thomas.tuegel): Preserve simplified flags. return (Pattern.fromTermLike first) @@ -385,12 +385,12 @@ bottomTermEquals :: SideCondition RewritingVariableName -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) + unifier (Pattern RewritingVariableName) bottomTermEquals sideCondition first second = - lift $ do + do -- MonadUnify secondCeil <- makeEvaluateTermCeil sideCondition second case toList secondCeil of @@ -435,11 +435,11 @@ variableFunctionAnd :: MonadUnify unifier => TermLike RewritingVariableName -> VariableFunctionAnd -> - MaybeT unifier (Pattern RewritingVariableName) + unifier (Pattern RewritingVariableName) variableFunctionAnd second unifyData = case unifyData of VariableFunctionAnd1 v -> return $ Pattern.assign (inject v) second - VariableFunctionAnd2 v -> lift $ return $ Pattern.withCondition second result + VariableFunctionAnd2 v -> return $ Pattern.withCondition second result where result = Condition.fromSingleSubstitution @@ -489,12 +489,12 @@ variableFunctionEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> ElementVariable RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) + unifier (Pattern RewritingVariableName) variableFunctionEquals first second var = - lift $ do + do -- MonadUnify predicate <- do resultOr <- makeEvaluateTermCeil SideCondition.topTODO second @@ -553,8 +553,8 @@ sortInjectionAndEquals :: SortInjectionAndEquals -> MaybeT unifier (Pattern RewritingVariableName) sortInjectionAndEquals termMerger first second unifyData = do - InjSimplifier{unifyInj} <- Simplifier.askInjSimplifier - unifyInj inj1 inj2 & either distinct merge + injSimplifier <- Simplifier.askInjSimplifier + unifyInj injSimplifier inj1 inj2 & either distinct merge where emptyIntersection = explainAndReturnBottom "Empty sort intersection" distinct Distinct = lift $ emptyIntersection first second @@ -725,9 +725,9 @@ unifyDomainValue :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> UnifyDomainValue -> - MaybeT unifier (Pattern RewritingVariableName) + unifier (Pattern RewritingVariableName) unifyDomainValue term1 term2 unifyData = - assert (sort1 == sort2) $ lift worker + assert (sort1 == sort2) worker where worker :: unifier (Pattern RewritingVariableName) worker @@ -775,8 +775,8 @@ unifyStringLiteral :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> UnifyStringLiteral -> - MaybeT unifier (Pattern RewritingVariableName) -unifyStringLiteral term1 term2 unifyData = lift worker + unifier (Pattern RewritingVariableName) +unifyStringLiteral term1 term2 unifyData = worker where worker :: unifier (Pattern RewritingVariableName) worker @@ -840,6 +840,6 @@ matchBytesDifferent first second bytesDifferent :: MonadUnify unifier => - MaybeT unifier (Pattern RewritingVariableName) + unifier (Pattern RewritingVariableName) bytesDifferent = return Pattern.bottom \ No newline at end of file diff --git a/kore/src/Kore/Step/Simplification/InjSimplifier.hs b/kore/src/Kore/Step/Simplification/InjSimplifier.hs index f9063ade7f..731d6a459f 100644 --- a/kore/src/Kore/Step/Simplification/InjSimplifier.hs +++ b/kore/src/Kore/Step/Simplification/InjSimplifier.hs @@ -7,6 +7,7 @@ module Kore.Step.Simplification.InjSimplifier ( InjSimplifier (..), mkInjSimplifier, normalize, + unifyInj, ) where import qualified Data.Functor.Foldable as Recursive @@ -41,6 +42,11 @@ data Distinct = Distinct | Unknown deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) deriving anyclass (Debug, Diff) +data InjUnify + = InjFromEqual + | InjFrom1SubsortInjFrom2 + | InjFrom2SubsortInjFrom1 + data InjSimplifier = InjSimplifier { -- | Is 'injFrom' a proper subsort of 'injTo'? isOrderedInj :: forall child. Inj child -> Bool @@ -55,6 +61,15 @@ data InjSimplifier = InjSimplifier InternalVariable variable => Inj (TermLike variable) -> TermLike variable + + , matchInjs :: + forall variable. + HasCallStack => + InternalVariable variable => + Inj (TermLike variable) -> + Inj (TermLike variable) -> + Either Distinct InjUnify + , -- | Push down the conjunction of 'Inj': -- -- @ @@ -66,11 +81,12 @@ data InjSimplifier = InjSimplifier -- -- Returns 'Distinct' if the sort injections cannot match, or 'Unknown' if -- further simplification could produce matching injections. - unifyInj :: + unifyInjs :: forall variable. InternalVariable variable => Inj (TermLike variable) -> Inj (TermLike variable) -> + Either Distinct InjUnify -> Either Distinct (Inj (Pair (TermLike variable))) , -- | Evaluate the 'Ceil' of 'Inj': -- @@ -108,7 +124,8 @@ mkInjSimplifier :: SortGraph -> InjSimplifier mkInjSimplifier sortGraph = InjSimplifier { evaluateInj - , unifyInj + , matchInjs + , unifyInjs , isOrderedInj , evaluateCeilInj , injectTermTo @@ -156,6 +173,32 @@ mkInjSimplifier sortGraph = innerSortsAgree = injFrom inj == injTo inj' _ -> synthesize $ InjF inj + matchInjs :: + forall variable. + Inj (TermLike variable) -> + Inj (TermLike variable) -> + Either Distinct InjUnify + matchInjs inj1 inj2 + | injTo1 /= injTo2 = Left Distinct + | injFrom1 == injFrom2 = Right InjFromEqual + | injFrom2 `isSubsortOf'` injFrom1 = Right InjFrom2SubsortInjFrom1 + | injFrom1 `isSubsortOf'` injFrom2 = Right InjFrom1SubsortInjFrom2 + -- If the child patterns are simplifiable, then they could eventually be + -- simplified to produce matching sort injections, but if they are + -- non-simplifiable, then they will never match. + | hasConstructorLikeTop (injChild inj1) = Left Distinct + | hasConstructorLikeTop (injChild inj2) = Left Distinct + -- Even if the child patterns are simplifiable, if they do not have any + -- common subsorts, then they will never simplify to produce matching sort + -- injections. + | Set.disjoint subsorts1 subsorts2 = Left Distinct + | otherwise = Left Unknown + where + Inj{injFrom = injFrom1, injTo = injTo1} = inj1 + Inj{injFrom = injFrom2, injTo = injTo2} = inj2 + subsorts1 = subsortsOf sortGraph injFrom1 + subsorts2 = subsortsOf sortGraph injFrom2 + evaluateCeilInj :: forall variable. Ceil Sort (Inj (TermLike variable)) -> @@ -169,51 +212,50 @@ mkInjSimplifier sortGraph = , ceilChild = injChild inj } - unifyInj :: + unifyInjs :: forall variable. InternalVariable variable => Inj (TermLike variable) -> Inj (TermLike variable) -> + Either Distinct InjUnify -> Either Distinct (Inj (Pair (TermLike variable))) - unifyInj inj1 inj2 - | injTo1 /= injTo2 = Left Distinct - | injFrom1 == injFrom2 = - assert (injTo1 == injTo2) $ do - let child1 = injChild inj1 - child2 = injChild inj2 - pure (Pair child1 child2 <$ inj1) - | injFrom2 `isSubsortOf'` injFrom1 = - assert (injTo1 == injTo2) $ do - let child1' = injChild inj1 - child2' = evaluateInj inj2{injTo = injFrom1} - pure (Pair child1' child2' <$ inj1) - | injFrom1 `isSubsortOf'` injFrom2 = - assert (injTo1 == injTo2) $ do - let child1' = evaluateInj inj1{injTo = injFrom2} - child2' = injChild inj2 - pure (Pair child1' child2' <$ inj2) + unifyInjs inj1 inj2 unify = + case unify of + Left d -> Left d + Right InjFromEqual -> + assert (injTo1 == injTo2) $ do + let child1 = injChild inj1 + child2 = injChild inj2 + pure (Pair child1 child2 <$ inj1) + Right InjFrom2SubsortInjFrom1 -> + assert (injTo1 == injTo2) $ do + let child1' = injChild inj1 + child2' = evaluateInj inj2{injTo = injFrom1} + pure (Pair child1' child2' <$ inj1) + Right InjFrom1SubsortInjFrom2 -> + assert (injTo1 == injTo2) $ do + let child1' = evaluateInj inj1{injTo = injFrom2} + child2' = injChild inj2 + pure (Pair child1' child2' <$ inj2) - -- If the child patterns are simplifiable, then they could eventually be - -- simplified to produce matching sort injections, but if they are - -- non-simplifiable, then they will never match. - | hasConstructorLikeTop (injChild inj1) = Left Distinct - | hasConstructorLikeTop (injChild inj2) = Left Distinct - -- Even if the child patterns are simplifiable, if they do not have any - -- common subsorts, then they will never simplify to produce matching sort - -- injections. - | Set.disjoint subsorts1 subsorts2 = Left Distinct - | otherwise = Left Unknown where Inj{injFrom = injFrom1, injTo = injTo1} = inj1 Inj{injFrom = injFrom2, injTo = injTo2} = inj2 - subsorts1 = subsortsOf sortGraph injFrom1 - subsorts2 = subsortsOf sortGraph injFrom2 injectTermTo injProto injChild injTo = evaluateInj injProto{injFrom, injTo, injChild} where injFrom = termLikeSort injChild +unifyInj :: + forall variable. + InternalVariable variable => + InjSimplifier -> + Inj (TermLike variable) -> + Inj (TermLike variable) -> + Either Distinct (Inj (Pair (TermLike variable))) +unifyInj injSimplifier inj1 inj2 = unifyInjs injSimplifier inj1 inj2 (matchInjs injSimplifier inj1 inj2) + normalize :: InjSimplifier -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 7d26a4ae8c..7fa749f658 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -66,11 +66,11 @@ equalInjectiveHeadsAndEquals :: -- | Used to simplify subterm "and". TermSimplifier RewritingVariableName unifier -> UnifyEqualInjectiveHeadsAndEquals -> - MaybeT unifier (Pattern RewritingVariableName) + unifier (Pattern RewritingVariableName) equalInjectiveHeadsAndEquals termMerger unifyData = - lift $ do + do children <- Monad.zipWithM termMerger firstChildren secondChildren let merged = foldMap Pattern.withoutTerm children -- TODO (thomas.tuegel): This is tricky! diff --git a/kore/test/Test/Kore/Builtin/Bool.hs b/kore/test/Test/Kore/Builtin/Bool.hs index bbff023b50..45a74ad277 100644 --- a/kore/test/Test/Kore/Builtin/Bool.hs +++ b/kore/test/Test/Kore/Builtin/Bool.hs @@ -167,7 +167,7 @@ test_unifyBoolValues = Nothing -> assertEqual "" expected [Nothing] unify term1 term2 unifyData = - run (Bool.unifyBool term1 term2 unifyData) + run (lift $ Bool.unifyBool term1 term2 unifyData) test_unifyBoolAnd :: [TestTree] test_unifyBoolAnd = diff --git a/kore/test/Test/Kore/Step/Simplification/InjSimplifier.hs b/kore/test/Test/Kore/Step/Simplification/InjSimplifier.hs index 45cc6cc9ce..11313bd9dc 100644 --- a/kore/test/Test/Kore/Step/Simplification/InjSimplifier.hs +++ b/kore/test/Test/Kore/Step/Simplification/InjSimplifier.hs @@ -162,8 +162,7 @@ test_unifyInj = Either Distinct (Inj (Pair (TermLike RewritingVariableName))) -> TestTree test testName inj1 inj2 expect = - testCase testName (assertEqual "" expect (unifyInj inj1 inj2)) - InjSimplifier{unifyInj} = injSimplifier + testCase testName (assertEqual "" expect (unifyInj injSimplifier inj1 inj2)) test_normalize :: [TestTree] test_normalize = From ac34584c926a3c253d54f82501897280f3b5a0d2 Mon Sep 17 00:00:00 2001 From: emarzion Date: Mon, 10 May 2021 23:37:53 -0500 Subject: [PATCH 08/86] Fixed sortInjectionAndEquals --- kore/src/Kore/Step/Simplification/And.hs | 3 +- kore/src/Kore/Step/Simplification/AndTerms.hs | 47 ++++++++++--------- kore/src/Kore/Step/Simplification/Equals.hs | 5 +- .../Kore/Step/Simplification/InjSimplifier.hs | 1 + 4 files changed, 32 insertions(+), 24 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/And.hs b/kore/src/Kore/Step/Simplification/And.hs index 4b0c30ea74..6e3996238d 100644 --- a/kore/src/Kore/Step/Simplification/And.hs +++ b/kore/src/Kore/Step/Simplification/And.hs @@ -228,7 +228,8 @@ termAnd notSimplifier p1 p2 = TermLike RewritingVariableName -> UnifierT simplifier (Pattern RewritingVariableName) termAndWorker first second = do - let maybeTermAnd' = maybeTermAnd notSimplifier termAndWorker first second + injSimplifier <- askInjSimplifier + let maybeTermAnd' = maybeTermAnd notSimplifier termAndWorker injSimplifier first second patt <- runMaybeT maybeTermAnd' return $ fromMaybe andPattern patt where diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 68c7a72f29..e9dc31aedd 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -112,10 +112,11 @@ termUnification notSimplifier = \term1 term2 -> TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) termUnificationWorker pat1 pat2 = do + injSimplifier <- Simplifier.askInjSimplifier let maybeTermUnification :: MaybeT unifier (Pattern RewritingVariableName) maybeTermUnification = - maybeTermAnd notSimplifier termUnificationWorker pat1 pat2 + maybeTermAnd notSimplifier termUnificationWorker injSimplifier pat1 pat2 Error.maybeT (incompleteUnificationPattern pat1 pat2) pure @@ -137,10 +138,11 @@ maybeTermEquals :: NotSimplifier unifier -> -- | Used to simplify subterm "and". TermSimplifier RewritingVariableName unifier -> + InjSimplifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) -maybeTermEquals notSimplifier childTransformers first second +maybeTermEquals notSimplifier childTransformers injSimplifier first second | Just unifyData <- Builtin.Int.matchInt first second = lift $ Builtin.Int.unifyInt first second unifyData | Just unifyData <- Builtin.Bool.matchBools first second = @@ -165,8 +167,8 @@ maybeTermEquals notSimplifier childTransformers first second lift $ variableFunctionEquals second first var | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData - | Just unifyData <- matchSortInjectionAndEquals first second = - sortInjectionAndEquals childTransformers first second unifyData + | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second = + lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = constructorSortInjectionAndEquals first second | Just unifyData <- matchConstructorAndEqualsAssumesDifferentHeads first second = @@ -215,15 +217,17 @@ maybeTermAnd :: NotSimplifier unifier -> -- | Used to simplify subterm "and". TermSimplifier RewritingVariableName unifier -> + InjSimplifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) -maybeTermAnd notSimplifier childTransformers first second +maybeTermAnd notSimplifier childTransformers injSimplifier first second | Just unifyData <- matchExpandAlias first second = let UnifyExpandAlias { term1, term2 } = unifyData in maybeTermAnd notSimplifier childTransformers + injSimplifier term1 term2 | Just unifyData <- matchBoolAnd first @@ -250,15 +254,11 @@ maybeTermAnd notSimplifier childTransformers first second = lift $ variableFunctionAnd first unifyData | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData - -- | Just unifyData <- matchSortInjectionAndEquals first second - -- = sortInjectionAndEquals childTransformers first second unifyData + | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second + = lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData | otherwise = asum [ do - unifyData <- Error.hoistMaybe $ matchSortInjectionAndEquals first second - sortInjectionAndEquals childTransformers first second unifyData - , - do () <- Error.hoistMaybe $ matchConstructorSortInjectionAndEquals first second constructorSortInjectionAndEquals first second , do @@ -515,16 +515,20 @@ variableFunctionEquals data SortInjectionAndEquals = SortInjectionAndEquals { inj1, inj2 :: Inj (TermLike RewritingVariableName) + , matchData :: Either Distinct InjUnify } matchSortInjectionAndEquals :: + InjSimplifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe SortInjectionAndEquals -matchSortInjectionAndEquals first second +matchSortInjectionAndEquals injSimplifier first second | Inj_ inj1 <- first , Inj_ inj2 <- second = - Just $ SortInjectionAndEquals inj1 inj2 + case matchInjs injSimplifier inj1 inj2 of + Left Unknown -> Nothing + matchData -> Just $ SortInjectionAndEquals inj1 inj2 matchData | otherwise = Nothing {-# INLINE sortInjectionAndEquals #-} @@ -548,25 +552,26 @@ sortInjectionAndEquals :: forall unifier. MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> + InjSimplifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> SortInjectionAndEquals -> - MaybeT unifier (Pattern RewritingVariableName) -sortInjectionAndEquals termMerger first second unifyData = do - injSimplifier <- Simplifier.askInjSimplifier - unifyInj injSimplifier inj1 inj2 & either distinct merge + unifier (Pattern RewritingVariableName) +sortInjectionAndEquals termMerger injSimplifier first second unifyData = do + -- injSimplifier <- Simplifier.askInjSimplifier + unifyInjs injSimplifier inj1 inj2 matchData & either distinct merge where emptyIntersection = explainAndReturnBottom "Empty sort intersection" - distinct Distinct = lift $ emptyIntersection first second - distinct Unknown = empty - merge inj@Inj{injChild = Pair child1 child2} = lift $ do + distinct Distinct = emptyIntersection first second + distinct Unknown = undefined -- should be handled + merge inj@Inj{injChild = Pair child1 child2} = do childPattern <- termMerger child1 child2 InjSimplifier{evaluateInj} <- askInjSimplifier let (childTerm, childCondition) = Pattern.splitTerm childPattern inj' = evaluateInj inj{injChild = childTerm} return $ Pattern.withCondition inj' childCondition - SortInjectionAndEquals{inj1, inj2} = unifyData + SortInjectionAndEquals{inj1, inj2, matchData} = unifyData matchConstructorSortInjectionAndEquals :: TermLike RewritingVariableName diff --git a/kore/src/Kore/Step/Simplification/Equals.hs b/kore/src/Kore/Step/Simplification/Equals.hs index 14f0786592..59ebb791be 100644 --- a/kore/src/Kore/Step/Simplification/Equals.hs +++ b/kore/src/Kore/Step/Simplification/Equals.hs @@ -425,8 +425,9 @@ termEqualsAnd p1 p2 = TermLike RewritingVariableName -> TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) - maybeTermEqualsWorker = - maybeTermEquals Not.notSimplifier termEqualsAndWorker + maybeTermEqualsWorker term1 term2 = do + injSimplifier <- askInjSimplifier + maybeTermEquals Not.notSimplifier termEqualsAndWorker injSimplifier term1 term2 termEqualsAndWorker :: forall unifier. diff --git a/kore/src/Kore/Step/Simplification/InjSimplifier.hs b/kore/src/Kore/Step/Simplification/InjSimplifier.hs index 731d6a459f..607136c9cd 100644 --- a/kore/src/Kore/Step/Simplification/InjSimplifier.hs +++ b/kore/src/Kore/Step/Simplification/InjSimplifier.hs @@ -5,6 +5,7 @@ License : NCSA module Kore.Step.Simplification.InjSimplifier ( Distinct (..), InjSimplifier (..), + InjUnify (..), mkInjSimplifier, normalize, unifyInj, From 24909069f7d00aaf027d583adeacbefc10af76d0 Mon Sep 17 00:00:00 2001 From: github-actions Date: Tue, 11 May 2021 14:23:57 +0000 Subject: [PATCH 09/86] Format with fourmolu --- kore/src/Kore/Step/Simplification/AndTerms.hs | 150 +++++++++--------- .../Kore/Step/Simplification/ExpandAlias.hs | 19 ++- .../Kore/Step/Simplification/InjSimplifier.hs | 5 +- .../Kore/Step/Simplification/NoConfusion.hs | 54 ++++--- .../Kore/Step/Simplification/Overloading.hs | 2 +- 5 files changed, 115 insertions(+), 115 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index e9dc31aedd..207b59165f 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -222,40 +222,40 @@ maybeTermAnd :: TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) maybeTermAnd notSimplifier childTransformers injSimplifier first second - | Just unifyData <- matchExpandAlias first second - = let UnifyExpandAlias { term1, term2 } = unifyData in - maybeTermAnd + | Just unifyData <- matchExpandAlias first second = + let UnifyExpandAlias{term1, term2} = unifyData + in maybeTermAnd notSimplifier childTransformers injSimplifier term1 term2 - | Just unifyData <- matchBoolAnd first - = lift $ boolAnd first second unifyData - | Just unifyData <- matchBoolAnd second - = lift $ boolAnd second first unifyData - | Just unifyData <- Builtin.Int.matchInt first second - = lift $ Builtin.Int.unifyInt first second unifyData - | Just unifyData <- Builtin.Bool.matchBools first second - = lift $ Builtin.Bool.unifyBool first second unifyData - | Just unifyData <- Builtin.String.matchString first second - = lift $ Builtin.String.unifyString first second unifyData - | Just unifyData <- matchDomainValue first second - = lift $ unifyDomainValue first second unifyData - | Just unifyData <- matchStringLiteral first second - = lift $ unifyStringLiteral first second unifyData - | Just () <- matchEqualsAndEquals first second - = lift $ equalAndEquals first - | Just () <- matchBytesDifferent first second - = lift bytesDifferent - | Just unifyData <- matchVariableFunctionAnd first second - = lift $ variableFunctionAnd second unifyData - | Just unifyData <- matchVariableFunctionAnd second first - = lift $ variableFunctionAnd first unifyData - | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second - = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData - | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second - = lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData + | Just unifyData <- matchBoolAnd first = + lift $ boolAnd first second unifyData + | Just unifyData <- matchBoolAnd second = + lift $ boolAnd second first unifyData + | Just unifyData <- Builtin.Int.matchInt first second = + lift $ Builtin.Int.unifyInt first second unifyData + | Just unifyData <- Builtin.Bool.matchBools first second = + lift $ Builtin.Bool.unifyBool first second unifyData + | Just unifyData <- Builtin.String.matchString first second = + lift $ Builtin.String.unifyString first second unifyData + | Just unifyData <- matchDomainValue first second = + lift $ unifyDomainValue first second unifyData + | Just unifyData <- matchStringLiteral first second = + lift $ unifyStringLiteral first second unifyData + | Just () <- matchEqualsAndEquals first second = + lift $ equalAndEquals first + | Just () <- matchBytesDifferent first second = + lift bytesDifferent + | Just unifyData <- matchVariableFunctionAnd first second = + lift $ variableFunctionAnd second unifyData + | Just unifyData <- matchVariableFunctionAnd second first = + lift $ variableFunctionAnd first unifyData + | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = + lift $ equalInjectiveHeadsAndEquals childTransformers unifyData + | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second = + lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData | otherwise = asum [ do @@ -317,16 +317,16 @@ data UnifyBoolAnd = UnifyBoolAndBottom | UnifyBoolAndTop -matchBoolAnd - :: TermLike RewritingVariableName - -> Maybe UnifyBoolAnd +matchBoolAnd :: + TermLike RewritingVariableName -> + Maybe UnifyBoolAnd matchBoolAnd term - | Pattern.isBottom term - = Just UnifyBoolAndBottom - | Pattern.isTop term - = Just UnifyBoolAndTop - | otherwise - = Nothing + | Pattern.isBottom term = + Just UnifyBoolAndBottom + | Pattern.isTop term = + Just UnifyBoolAndTop + | otherwise = + Nothing -- | Simplify the conjunction of terms where one is a predicate. boolAnd :: @@ -335,8 +335,8 @@ boolAnd :: TermLike RewritingVariableName -> UnifyBoolAnd -> unifier (Pattern RewritingVariableName) -boolAnd first second unifyData - = case unifyData of +boolAnd first second unifyData = + case unifyData of UnifyBoolAndBottom -> do explainBoolAndBottom first second return $ Pattern.fromTermLike first @@ -390,7 +390,7 @@ bottomTermEquals sideCondition first second = - do + do -- MonadUnify secondCeil <- makeEvaluateTermCeil sideCondition second case toList secondCeil of @@ -417,34 +417,34 @@ data VariableFunctionAnd = VariableFunctionAnd1 (ElementVariable RewritingVariableName) | VariableFunctionAnd2 (ElementVariable RewritingVariableName) -matchVariableFunctionAnd - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe VariableFunctionAnd +matchVariableFunctionAnd :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe VariableFunctionAnd matchVariableFunctionAnd first second | ElemVar_ v <- first - , ElemVar_ _ <- second - = Just $ VariableFunctionAnd1 v + , ElemVar_ _ <- second = + Just $ VariableFunctionAnd1 v | ElemVar_ v <- first - , isFunctionPattern second - = Just $ VariableFunctionAnd2 v - | otherwise - = Nothing + , isFunctionPattern second = + Just $ VariableFunctionAnd2 v + | otherwise = + Nothing variableFunctionAnd :: MonadUnify unifier => TermLike RewritingVariableName -> VariableFunctionAnd -> unifier (Pattern RewritingVariableName) -variableFunctionAnd second unifyData - = case unifyData of +variableFunctionAnd second unifyData = + case unifyData of VariableFunctionAnd1 v -> return $ Pattern.assign (inject v) second VariableFunctionAnd2 v -> return $ Pattern.withCondition second result - where - result = - Condition.fromSingleSubstitution - (Substitution.assign (inject v) second) - + where + result = + Condition.fromSingleSubstitution + (Substitution.assign (inject v) second) + -- variableFunctionAnd :: -- InternalVariable variable => -- MonadUnify unifier => @@ -515,7 +515,7 @@ variableFunctionEquals data SortInjectionAndEquals = SortInjectionAndEquals { inj1, inj2 :: Inj (TermLike RewritingVariableName) - , matchData :: Either Distinct InjUnify + , matchData :: Either Distinct InjUnify } matchSortInjectionAndEquals :: @@ -526,9 +526,9 @@ matchSortInjectionAndEquals :: matchSortInjectionAndEquals injSimplifier first second | Inj_ inj1 <- first , Inj_ inj2 <- second = - case matchInjs injSimplifier inj1 inj2 of - Left Unknown -> Nothing - matchData -> Just $ SortInjectionAndEquals inj1 inj2 matchData + case matchInjs injSimplifier inj1 inj2 of + Left Unknown -> Nothing + matchData -> Just $ SortInjectionAndEquals inj1 inj2 matchData | otherwise = Nothing {-# INLINE sortInjectionAndEquals #-} @@ -573,19 +573,19 @@ sortInjectionAndEquals termMerger injSimplifier first second unifyData = do SortInjectionAndEquals{inj1, inj2, matchData} = unifyData -matchConstructorSortInjectionAndEquals - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe () +matchConstructorSortInjectionAndEquals :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe () matchConstructorSortInjectionAndEquals first second | Inj_ _ <- first - , App_ symbol _ <- second - , Symbol.isConstructor symbol - = Just () + , App_ symbol _ <- second + , Symbol.isConstructor symbol = + Just () | Inj_ _ <- second - , App_ symbol _ <- first - , Symbol.isConstructor symbol - = Just () + , App_ symbol _ <- first + , Symbol.isConstructor symbol = + Just () | otherwise = Nothing {-# INLINE matchConstructorSortInjectionAndEquals #-} @@ -599,8 +599,8 @@ constructorSortInjectionAndEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> MaybeT unifier a -constructorSortInjectionAndEquals first second - = lift $ noConfusionInjectionConstructor first second +constructorSortInjectionAndEquals first second = + lift $ noConfusionInjectionConstructor first second noConfusionInjectionConstructor :: MonadUnify unifier => @@ -847,4 +847,4 @@ bytesDifferent :: MonadUnify unifier => unifier (Pattern RewritingVariableName) bytesDifferent = - return Pattern.bottom \ No newline at end of file + return Pattern.bottom diff --git a/kore/src/Kore/Step/Simplification/ExpandAlias.hs b/kore/src/Kore/Step/Simplification/ExpandAlias.hs index cd9a267ca7..741e1addb4 100644 --- a/kore/src/Kore/Step/Simplification/ExpandAlias.hs +++ b/kore/src/Kore/Step/Simplification/ExpandAlias.hs @@ -27,19 +27,18 @@ import Kore.Internal.TermLike ( import Kore.Rewriting.RewritingVariable ( RewritingVariableName, ) - import Prelude.Kore -data UnifyExpandAlias = UnifyExpandAlias { - term1, term2 :: !(TermLike RewritingVariableName) -} +data UnifyExpandAlias = UnifyExpandAlias + { term1, term2 :: !(TermLike RewritingVariableName) + } -matchExpandAlias - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyExpandAlias -matchExpandAlias t1 t2 - = case (expandSingleAlias t1, expandSingleAlias t2) of +matchExpandAlias :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyExpandAlias +matchExpandAlias t1 t2 = + case (expandSingleAlias t1, expandSingleAlias t2) of (Nothing, Nothing) -> Nothing (t1', t2') -> Just $ UnifyExpandAlias (fromMaybe t1 t1') (fromMaybe t2 t2') {-# INLINE matchExpandAlias #-} diff --git a/kore/src/Kore/Step/Simplification/InjSimplifier.hs b/kore/src/Kore/Step/Simplification/InjSimplifier.hs index 607136c9cd..39cd2f29bf 100644 --- a/kore/src/Kore/Step/Simplification/InjSimplifier.hs +++ b/kore/src/Kore/Step/Simplification/InjSimplifier.hs @@ -62,7 +62,6 @@ data InjSimplifier = InjSimplifier InternalVariable variable => Inj (TermLike variable) -> TermLike variable - , matchInjs :: forall variable. HasCallStack => @@ -70,7 +69,6 @@ data InjSimplifier = InjSimplifier Inj (TermLike variable) -> Inj (TermLike variable) -> Either Distinct InjUnify - , -- | Push down the conjunction of 'Inj': -- -- @ @@ -223,7 +221,7 @@ mkInjSimplifier sortGraph = unifyInjs inj1 inj2 unify = case unify of Left d -> Left d - Right InjFromEqual -> + Right InjFromEqual -> assert (injTo1 == injTo2) $ do let child1 = injChild inj1 child2 = injChild inj2 @@ -238,7 +236,6 @@ mkInjSimplifier sortGraph = let child1' = evaluateInj inj1{injTo = injFrom2} child2' = injChild inj2 pure (Pair child1' child2' <$ inj2) - where Inj{injFrom = injFrom1, injTo = injTo1} = inj1 Inj{injFrom = injFrom2, injTo = injTo2} = inj2 diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 7fa749f658..57acd09176 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -88,22 +88,22 @@ equalInjectiveHeadsAndEquals , secondChildren } = unifyData -data ConstructorAndEqualsAssumesDifferentHeads = - ConstructorAndEqualsAssumesDifferentHeads { - firstHead, secondHead :: Symbol - } +data ConstructorAndEqualsAssumesDifferentHeads = ConstructorAndEqualsAssumesDifferentHeads + { firstHead, secondHead :: Symbol + } +matchConstructorAndEqualsAssumesDifferentHeads :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe ConstructorAndEqualsAssumesDifferentHeads matchConstructorAndEqualsAssumesDifferentHeads - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe ConstructorAndEqualsAssumesDifferentHeads -matchConstructorAndEqualsAssumesDifferentHeads - first second - | App_ firstHead _ <- first - , App_ secondHead _ <- second - , firstHead /= secondHead - = Just $ ConstructorAndEqualsAssumesDifferentHeads firstHead secondHead - | otherwise = empty + first + second + | App_ firstHead _ <- first + , App_ secondHead _ <- second + , firstHead /= secondHead = + Just $ ConstructorAndEqualsAssumesDifferentHeads firstHead secondHead + | otherwise = empty {-# INLINE matchConstructorAndEqualsAssumesDifferentHeads #-} {- | Unify two constructor application patterns. @@ -111,6 +111,7 @@ matchConstructorAndEqualsAssumesDifferentHeads Assumes that the two patterns were already tested for equality and were found to be different; therefore their conjunction is @\\bottom@. -} + -- constructorAndEqualsAssumesDifferentHeads :: -- MonadUnify unifier => -- HasCallStack => @@ -140,19 +141,22 @@ constructorAndEqualsAssumesDifferentHeads :: ConstructorAndEqualsAssumesDifferentHeads -> MaybeT unifier a constructorAndEqualsAssumesDifferentHeads - first second unifyData = + first + second + unifyData = do -- should these two guards be pushed to the match? Monad.guard =<< Simplifier.isConstructorOrOverloaded firstHead Monad.guard =<< Simplifier.isConstructorOrOverloaded secondHead lift $ do - explainBottom - "Cannot unify different constructors or incompatible \ - \sort injections." - first - second - empty - - where - ConstructorAndEqualsAssumesDifferentHeads - { firstHead, secondHead } = unifyData \ No newline at end of file + explainBottom + "Cannot unify different constructors or incompatible \ + \sort injections." + first + second + empty + where + ConstructorAndEqualsAssumesDifferentHeads + { firstHead + , secondHead + } = unifyData diff --git a/kore/src/Kore/Step/Simplification/Overloading.hs b/kore/src/Kore/Step/Simplification/Overloading.hs index 937dbf949f..7a07dfe809 100644 --- a/kore/src/Kore/Step/Simplification/Overloading.hs +++ b/kore/src/Kore/Step/Simplification/Overloading.hs @@ -617,7 +617,7 @@ mkInj :: Inj () -> TermLike RewritingVariableName -> TermLike RewritingVariableName -mkInj inj injChild = (synthesize . InjF) (inj :: Inj ()) {injChild} +mkInj inj injChild = (synthesize . InjF) (inj :: Inj ()){injChild} maybeMkInj :: Maybe (Inj ()) -> From 2cd35c934f15bd1df907d13f3207ecacef68d52e Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 11 May 2021 18:44:15 -0500 Subject: [PATCH 10/86] Refactoring constructorAndEqualsAssumesDifferentHeads --- kore/src/Kore/Step/Simplification/And.hs | 5 +- kore/src/Kore/Step/Simplification/AndTerms.hs | 33 +++++---- kore/src/Kore/Step/Simplification/Equals.hs | 4 +- .../Kore/Step/Simplification/NoConfusion.hs | 71 ++++++------------- 4 files changed, 45 insertions(+), 68 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/And.hs b/kore/src/Kore/Step/Simplification/And.hs index 6e3996238d..840798147e 100644 --- a/kore/src/Kore/Step/Simplification/And.hs +++ b/kore/src/Kore/Step/Simplification/And.hs @@ -56,8 +56,10 @@ import Kore.Step.Simplification.AndTerms ( maybeTermAnd, ) import Kore.Step.Simplification.NotSimplifier +import Kore.Step.Simplification.OverloadSimplifier import Kore.Step.Simplification.Simplify import qualified Kore.Step.Substitution as Substitution + import Kore.Unification.UnifierT ( UnifierT (..), runUnifierT, @@ -229,7 +231,8 @@ termAnd notSimplifier p1 p2 = UnifierT simplifier (Pattern RewritingVariableName) termAndWorker first second = do injSimplifier <- askInjSimplifier - let maybeTermAnd' = maybeTermAnd notSimplifier termAndWorker injSimplifier first second + OverloadSimplifier{isOverloaded} <- askOverloadSimplifier + let maybeTermAnd' = maybeTermAnd notSimplifier termAndWorker injSimplifier isOverloaded first second patt <- runMaybeT maybeTermAnd' return $ fromMaybe andPattern patt where diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 207b59165f..b2d8c6ba28 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -69,6 +69,7 @@ import Kore.Step.Simplification.InjSimplifier import Kore.Step.Simplification.NoConfusion import Kore.Step.Simplification.NotSimplifier import Kore.Step.Simplification.Overloading as Overloading +import Kore.Step.Simplification.OverloadSimplifier as OverloadSimplifier import qualified Kore.Step.Simplification.SimplificationType as SimplificationType ( SimplificationType (..), ) @@ -113,10 +114,11 @@ termUnification notSimplifier = \term1 term2 -> unifier (Pattern RewritingVariableName) termUnificationWorker pat1 pat2 = do injSimplifier <- Simplifier.askInjSimplifier + OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier let maybeTermUnification :: MaybeT unifier (Pattern RewritingVariableName) maybeTermUnification = - maybeTermAnd notSimplifier termUnificationWorker injSimplifier pat1 pat2 + maybeTermAnd notSimplifier termUnificationWorker injSimplifier isOverloaded pat1 pat2 Error.maybeT (incompleteUnificationPattern pat1 pat2) pure @@ -139,10 +141,11 @@ maybeTermEquals :: -- | Used to simplify subterm "and". TermSimplifier RewritingVariableName unifier -> InjSimplifier -> + (Symbol -> Bool) -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) -maybeTermEquals notSimplifier childTransformers injSimplifier first second +maybeTermEquals notSimplifier childTransformers injSimplifier isOverloaded first second | Just unifyData <- Builtin.Int.matchInt first second = lift $ Builtin.Int.unifyInt first second unifyData | Just unifyData <- Builtin.Bool.matchBools first second = @@ -170,9 +173,9 @@ maybeTermEquals notSimplifier childTransformers injSimplifier first second | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second = lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = - constructorSortInjectionAndEquals first second - | Just unifyData <- matchConstructorAndEqualsAssumesDifferentHeads first second = - constructorAndEqualsAssumesDifferentHeads first second unifyData + lift $ constructorSortInjectionAndEquals first second + | Just () <- matchConstructorAndEqualsAssumesDifferentHeads isOverloaded first second = + lift $ constructorAndEqualsAssumesDifferentHeads first second | otherwise = asum [ overloadedConstructorSortInjectionAndEquals @@ -218,16 +221,18 @@ maybeTermAnd :: -- | Used to simplify subterm "and". TermSimplifier RewritingVariableName unifier -> InjSimplifier -> + (Symbol -> Bool) -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) -maybeTermAnd notSimplifier childTransformers injSimplifier first second +maybeTermAnd notSimplifier childTransformers injSimplifier isOverloaded first second | Just unifyData <- matchExpandAlias first second = let UnifyExpandAlias{term1, term2} = unifyData in maybeTermAnd notSimplifier childTransformers injSimplifier + isOverloaded term1 term2 | Just unifyData <- matchBoolAnd first = @@ -256,15 +261,13 @@ maybeTermAnd notSimplifier childTransformers injSimplifier first second lift $ equalInjectiveHeadsAndEquals childTransformers unifyData | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second = lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData + | Just () <- matchConstructorSortInjectionAndEquals first second = + lift $ constructorSortInjectionAndEquals first second + | Just () <- matchConstructorAndEqualsAssumesDifferentHeads isOverloaded first second = + lift $ constructorAndEqualsAssumesDifferentHeads first second | otherwise = asum - [ do - () <- Error.hoistMaybe $ matchConstructorSortInjectionAndEquals first second - constructorSortInjectionAndEquals first second - , do - unifyData <- Error.hoistMaybe $ matchConstructorAndEqualsAssumesDifferentHeads first second - constructorAndEqualsAssumesDifferentHeads first second unifyData - , overloadedConstructorSortInjectionAndEquals + [ overloadedConstructorSortInjectionAndEquals childTransformers first second @@ -598,9 +601,9 @@ constructorSortInjectionAndEquals :: MonadUnify unifier => TermLike RewritingVariableName -> TermLike RewritingVariableName -> - MaybeT unifier a + unifier a constructorSortInjectionAndEquals first second = - lift $ noConfusionInjectionConstructor first second + noConfusionInjectionConstructor first second noConfusionInjectionConstructor :: MonadUnify unifier => diff --git a/kore/src/Kore/Step/Simplification/Equals.hs b/kore/src/Kore/Step/Simplification/Equals.hs index 59ebb791be..cf9ffa0f60 100644 --- a/kore/src/Kore/Step/Simplification/Equals.hs +++ b/kore/src/Kore/Step/Simplification/Equals.hs @@ -67,6 +67,7 @@ import qualified Kore.Step.Simplification.Not as Not ( import qualified Kore.Step.Simplification.Or as Or ( simplifyEvaluated, ) +import Kore.Step.Simplification.OverloadSimplifier import Kore.Step.Simplification.Simplify import Kore.Unification.UnifierT ( runUnifierT, @@ -427,7 +428,8 @@ termEqualsAnd p1 p2 = MaybeT unifier (Pattern RewritingVariableName) maybeTermEqualsWorker term1 term2 = do injSimplifier <- askInjSimplifier - maybeTermEquals Not.notSimplifier termEqualsAndWorker injSimplifier term1 term2 + OverloadSimplifier{isOverloaded} <- askOverloadSimplifier + maybeTermEquals Not.notSimplifier termEqualsAndWorker injSimplifier isOverloaded term1 term2 termEqualsAndWorker :: forall unifier. diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 57acd09176..c258401ceb 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -9,9 +9,6 @@ module Kore.Step.Simplification.NoConfusion ( matchConstructorAndEqualsAssumesDifferentHeads, ) where -import Control.Error ( - MaybeT (..), - ) import qualified Control.Monad as Monad import Kore.Internal.Pattern ( Pattern, @@ -27,7 +24,6 @@ import Kore.Unification.Unify as Unify import Prelude.Kore hiding ( concat, ) - data UnifyEqualInjectiveHeadsAndEquals = UnifyEqualInjectiveHeadsAndEquals { firstHead :: Symbol , firstChildren :: [TermLike RewritingVariableName] @@ -88,21 +84,26 @@ equalInjectiveHeadsAndEquals , secondChildren } = unifyData -data ConstructorAndEqualsAssumesDifferentHeads = ConstructorAndEqualsAssumesDifferentHeads - { firstHead, secondHead :: Symbol - } +-- data ConstructorAndEqualsAssumesDifferentHeads = ConstructorAndEqualsAssumesDifferentHeads +-- { firstHead, secondHead :: Symbol +-- } matchConstructorAndEqualsAssumesDifferentHeads :: + (Symbol -> Bool) -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe ConstructorAndEqualsAssumesDifferentHeads + Maybe () matchConstructorAndEqualsAssumesDifferentHeads + isOverloaded first second | App_ firstHead _ <- first , App_ secondHead _ <- second - , firstHead /= secondHead = - Just $ ConstructorAndEqualsAssumesDifferentHeads firstHead secondHead + , firstHead /= secondHead + , Symbol.isConstructor firstHead || isOverloaded firstHead + , Symbol.isConstructor secondHead || isOverloaded secondHead + = + Just () | otherwise = empty {-# INLINE matchConstructorAndEqualsAssumesDifferentHeads #-} @@ -112,51 +113,19 @@ Assumes that the two patterns were already tested for equality and were found to be different; therefore their conjunction is @\\bottom@. -} --- constructorAndEqualsAssumesDifferentHeads :: --- MonadUnify unifier => --- HasCallStack => --- TermLike RewritingVariableName -> --- TermLike RewritingVariableName -> --- MaybeT unifier a --- constructorAndEqualsAssumesDifferentHeads --- first@(App_ firstHead _) --- second@(App_ secondHead _) = --- do --- Monad.guard =<< Simplifier.isConstructorOrOverloaded firstHead --- Monad.guard =<< Simplifier.isConstructorOrOverloaded secondHead --- assert (firstHead /= secondHead) $ --- lift $ do --- explainBottom --- "Cannot unify different constructors or incompatible \ --- \sort injections." --- first --- second --- empty --- constructorAndEqualsAssumesDifferentHeads _ _ = empty - constructorAndEqualsAssumesDifferentHeads :: MonadUnify unifier => TermLike RewritingVariableName -> TermLike RewritingVariableName -> - ConstructorAndEqualsAssumesDifferentHeads -> - MaybeT unifier a + unifier a constructorAndEqualsAssumesDifferentHeads first second - unifyData = - do - -- should these two guards be pushed to the match? - Monad.guard =<< Simplifier.isConstructorOrOverloaded firstHead - Monad.guard =<< Simplifier.isConstructorOrOverloaded secondHead - lift $ do - explainBottom - "Cannot unify different constructors or incompatible \ - \sort injections." - first - second - empty - where - ConstructorAndEqualsAssumesDifferentHeads - { firstHead - , secondHead - } = unifyData + = do + explainBottom + "Cannot unify different constructors or incompatible \ + \sort injections." + first + second + empty + From c44ecfc5d484bd6a7f1a6ec1f468151bbc011462 Mon Sep 17 00:00:00 2001 From: github-actions Date: Tue, 11 May 2021 23:46:31 +0000 Subject: [PATCH 11/86] Format with fourmolu --- kore/src/Kore/Step/Simplification/And.hs | 3 +-- kore/src/Kore/Step/Simplification/AndTerms.hs | 2 +- kore/src/Kore/Step/Simplification/Equals.hs | 2 +- .../Kore/Step/Simplification/NoConfusion.hs | 22 +++++++++---------- 4 files changed, 13 insertions(+), 16 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/And.hs b/kore/src/Kore/Step/Simplification/And.hs index 840798147e..1382596ff5 100644 --- a/kore/src/Kore/Step/Simplification/And.hs +++ b/kore/src/Kore/Step/Simplification/And.hs @@ -59,7 +59,6 @@ import Kore.Step.Simplification.NotSimplifier import Kore.Step.Simplification.OverloadSimplifier import Kore.Step.Simplification.Simplify import qualified Kore.Step.Substitution as Substitution - import Kore.Unification.UnifierT ( UnifierT (..), runUnifierT, @@ -231,7 +230,7 @@ termAnd notSimplifier p1 p2 = UnifierT simplifier (Pattern RewritingVariableName) termAndWorker first second = do injSimplifier <- askInjSimplifier - OverloadSimplifier{isOverloaded} <- askOverloadSimplifier + OverloadSimplifier{isOverloaded} <- askOverloadSimplifier let maybeTermAnd' = maybeTermAnd notSimplifier termAndWorker injSimplifier isOverloaded first second patt <- runMaybeT maybeTermAnd' return $ fromMaybe andPattern patt diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index b2d8c6ba28..5c49be5bf4 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -68,8 +68,8 @@ import Kore.Step.Simplification.ExpandAlias import Kore.Step.Simplification.InjSimplifier import Kore.Step.Simplification.NoConfusion import Kore.Step.Simplification.NotSimplifier -import Kore.Step.Simplification.Overloading as Overloading import Kore.Step.Simplification.OverloadSimplifier as OverloadSimplifier +import Kore.Step.Simplification.Overloading as Overloading import qualified Kore.Step.Simplification.SimplificationType as SimplificationType ( SimplificationType (..), ) diff --git a/kore/src/Kore/Step/Simplification/Equals.hs b/kore/src/Kore/Step/Simplification/Equals.hs index cf9ffa0f60..c631c987e6 100644 --- a/kore/src/Kore/Step/Simplification/Equals.hs +++ b/kore/src/Kore/Step/Simplification/Equals.hs @@ -428,7 +428,7 @@ termEqualsAnd p1 p2 = MaybeT unifier (Pattern RewritingVariableName) maybeTermEqualsWorker term1 term2 = do injSimplifier <- askInjSimplifier - OverloadSimplifier{isOverloaded} <- askOverloadSimplifier + OverloadSimplifier{isOverloaded} <- askOverloadSimplifier maybeTermEquals Not.notSimplifier termEqualsAndWorker injSimplifier isOverloaded term1 term2 termEqualsAndWorker :: diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index c258401ceb..84851176b4 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -24,6 +24,7 @@ import Kore.Unification.Unify as Unify import Prelude.Kore hiding ( concat, ) + data UnifyEqualInjectiveHeadsAndEquals = UnifyEqualInjectiveHeadsAndEquals { firstHead :: Symbol , firstChildren :: [TermLike RewritingVariableName] @@ -101,8 +102,7 @@ matchConstructorAndEqualsAssumesDifferentHeads , App_ secondHead _ <- second , firstHead /= secondHead , Symbol.isConstructor firstHead || isOverloaded firstHead - , Symbol.isConstructor secondHead || isOverloaded secondHead - = + , Symbol.isConstructor secondHead || isOverloaded secondHead = Just () | otherwise = empty {-# INLINE matchConstructorAndEqualsAssumesDifferentHeads #-} @@ -112,7 +112,6 @@ matchConstructorAndEqualsAssumesDifferentHeads Assumes that the two patterns were already tested for equality and were found to be different; therefore their conjunction is @\\bottom@. -} - constructorAndEqualsAssumesDifferentHeads :: MonadUnify unifier => TermLike RewritingVariableName -> @@ -120,12 +119,11 @@ constructorAndEqualsAssumesDifferentHeads :: unifier a constructorAndEqualsAssumesDifferentHeads first - second - = do - explainBottom - "Cannot unify different constructors or incompatible \ - \sort injections." - first - second - empty - + second = + do + explainBottom + "Cannot unify different constructors or incompatible \ + \sort injections." + first + second + empty From 8eeff4a37f07f3463012bb9eab55a70d379dd7c2 Mon Sep 17 00:00:00 2001 From: emarzion Date: Thu, 13 May 2021 00:06:25 -0500 Subject: [PATCH 12/86] near fix for overloadedConstructorSortInjectionAndEquals --- kore/src/Kore/Step/Simplification/AndTerms.hs | 21 +- .../Kore/Step/Simplification/Overloading.hs | 300 +++++++++--------- 2 files changed, 163 insertions(+), 158 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 5c49be5bf4..dc2216820e 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -176,13 +176,11 @@ maybeTermEquals notSimplifier childTransformers injSimplifier isOverloaded first lift $ constructorSortInjectionAndEquals first second | Just () <- matchConstructorAndEqualsAssumesDifferentHeads isOverloaded first second = lift $ constructorAndEqualsAssumesDifferentHeads first second + | Just unifyData <- matchOverloadedConstructorSortInjectionAndEquals first second = + overloadedConstructorSortInjectionAndEquals childTransformers first second unifyData | otherwise = asum - [ overloadedConstructorSortInjectionAndEquals - childTransformers - first - second - , do + [ do boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd first second Builtin.Bool.unifyBoolAnd childTransformers first boolAndData , do @@ -265,13 +263,11 @@ maybeTermAnd notSimplifier childTransformers injSimplifier isOverloaded first se lift $ constructorSortInjectionAndEquals first second | Just () <- matchConstructorAndEqualsAssumesDifferentHeads isOverloaded first second = lift $ constructorAndEqualsAssumesDifferentHeads first second + | Just unifyData <- matchOverloadedConstructorSortInjectionAndEquals first second = + overloadedConstructorSortInjectionAndEquals childTransformers first second unifyData | otherwise = asum - [ overloadedConstructorSortInjectionAndEquals - childTransformers - first - second - , do + [ do boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd first second Builtin.Bool.unifyBoolAnd childTransformers first boolAndData , do @@ -624,12 +620,13 @@ overloadedConstructorSortInjectionAndEquals :: TermSimplifier RewritingVariableName unifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> + OverloadedConstructorSortInjectionAndEquals -> MaybeT unifier (Pattern RewritingVariableName) -overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm = +overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm unifyData = do eunifier <- lift . Error.runExceptT $ - unifyOverloading (Pair firstTerm secondTerm) + getUnifyResult firstTerm secondTerm unifyData case eunifier of Right (Simple (Pair firstTerm' secondTerm')) -> lift $ diff --git a/kore/src/Kore/Step/Simplification/Overloading.hs b/kore/src/Kore/Step/Simplification/Overloading.hs index 7a07dfe809..a12bf7ec46 100644 --- a/kore/src/Kore/Step/Simplification/Overloading.hs +++ b/kore/src/Kore/Step/Simplification/Overloading.hs @@ -6,8 +6,8 @@ License : NCSA -} module Kore.Step.Simplification.Overloading ( matchOverloading, - --matchOverloadedConstructorSortInjectionAndEquals, - --getUnifyResult, + matchOverloadedConstructorSortInjectionAndEquals, + getUnifyResult, -- for testing purposes unifyOverloading, UnifyOverloadingResult, @@ -15,6 +15,7 @@ module Kore.Step.Simplification.Overloading ( UnifyOverloadingError (..), Narrowing (..), OverloadingResolution (..), + OverloadedConstructorSortInjectionAndEquals (..), ) where import qualified Control.Monad as Monad @@ -134,150 +135,157 @@ matchOverloading termPair = -- flipPairBack :: Pair a -> Pair a -- flipPairBack (Pair x y) = Pair y x --- data UnifyOverload1 = UnifyOverload1 { --- firstHead, secondHead :: Symbol --- , firstChildren :: [TermLike RewritingVariableName] --- , inj :: Inj (TermLike RewritingVariableName) --- } - --- data UnifyOverload2 = UnifyOverload2 { --- firstHead, secondHead :: Symbol --- , secondChildren :: [TermLike RewritingVariableName] --- , inj :: Inj (TermLike RewritingVariableName) --- } - --- data UnifyOverload3 = UnifyOverload3 { --- firstHead, secondHead :: Symbol --- , firstChildren, secondChildren :: [TermLike RewritingVariableName] --- , inj :: Inj (TermLike RewritingVariableName) --- } - --- data UnifyOverload4 = UnifyOverload4 { --- firstHead :: Symbol --- , secondVar :: ElementVariable RewritingVariableName --- , inj :: Inj (TermLike RewritingVariableName) --- } - --- data UnifyOverload5 = UnifyOverload5 { --- firstHead :: Symbol --- , firstChildren :: [TermLike RewritingVariableName] --- , secondVar :: ElementVariable RewritingVariableName --- , inj :: Inj (TermLike RewritingVariableName) --- } - --- data UnifyOverload6 = UnifyOverload6 { --- firstHead :: Symbol --- , injChild :: TermLike RewritingVariableName --- } - --- data OverloadedConstructorSortInjectionAndEquals = --- Overload1 UnifyOverload1 --- | Overload2 UnifyOverload2 --- | Overload3 UnifyOverload3 --- | Overload4 UnifyOverload4 --- | Overload5 UnifyOverload5 --- | Overload6 UnifyOverload6 - --- matchOverloadedConstructorSortInjectionAndEquals --- :: TermLike RewritingVariableName --- -> TermLike RewritingVariableName --- -> Maybe OverloadedConstructorSortInjectionAndEquals --- matchOverloadedConstructorSortInjectionAndEquals --- first second --- | Inj_ inj@Inj { injChild = App_ firstHead firstChildren } <- first --- , App_ secondHead _ <- second --- = Just $ Overload1 $ UnifyOverload1 firstHead secondHead firstChildren inj --- | App_ firstHead _ <- first --- , Inj_ inj@Inj { injChild = App_ secondHead secondChildren } <- second --- = Just $ Overload2 $ UnifyOverload2 firstHead secondHead secondChildren inj --- | Inj_ inj@Inj { injChild = App_ firstHead firstChildren } <- first --- , Inj_ inj'@Inj { injChild = App_ secondHead secondChildren } <- second --- , injFrom inj /= injFrom inj' --- = Just $ Overload3 $ UnifyOverload3 firstHead secondHead firstChildren secondChildren inj --- | App_ firstHead _ <- first --- , Inj_ inj@Inj { injChild = ElemVar_ secondVar } <- second --- = Just $ Overload4 $ UnifyOverload4 firstHead secondVar inj --- | App_ secondHead _ <- second --- , Inj_ inj@Inj { injChild = ElemVar_ firstVar } <- first --- = Just $ Overload4 $ UnifyOverload4 secondHead firstVar inj --- | Inj_ Inj { injChild = (App_ firstHead firstChildren) } <- first --- , Inj_ inj@Inj { injChild = ElemVar_ secondVar } <- second --- = Just $ Overload5 $ UnifyOverload5 firstHead firstChildren secondVar inj --- | Inj_ Inj { injChild = (App_ secondHead secondChildren) } <- second --- , Inj_ inj@Inj { injChild = ElemVar_ firstVar } <- first --- = Just $ Overload5 $ UnifyOverload5 secondHead secondChildren firstVar inj --- | App_ firstHead _ <- first --- , Inj_ Inj { injChild } <- second --- = Just $ Overload6 $ UnifyOverload6 firstHead injChild --- | otherwise --- = Nothing - --- getUnifyResult --- :: MonadSimplify unifier --- => TermLike RewritingVariableName --- -> TermLike RewritingVariableName --- -> OverloadedConstructorSortInjectionAndEquals --- -> UnifyOverloadingResult unifier RewritingVariableName --- getUnifyResult firstTerm secondTerm unifyData = --- case unifyData of --- Overload1 unifyData' -> --- Simple . flipPairBack <$> unifyOverloadingVsOverloaded --- secondHead --- secondTerm --- (Application firstHead firstChildren) --- (inj :: Inj (TermLike RewritingVariableName)) { injChild = () } - --- where --- UnifyOverload1 { firstHead, secondHead, firstChildren, inj } = unifyData' - --- Overload2 unifyData' -> --- Simple <$> unifyOverloadingVsOverloaded --- firstHead --- firstTerm --- (Application secondHead secondChildren) --- (inj :: Inj (TermLike RewritingVariableName)) { injChild = () } --- where --- UnifyOverload2 { firstHead, secondHead, secondChildren, inj } = unifyData' - --- Overload3 unifyData' -> --- Simple <$> unifyOverloadingCommonOverload --- (Application firstHead firstChildren) --- (Application secondHead secondChildren) --- (inj :: Inj (TermLike RewritingVariableName)) { injChild = () } --- where --- UnifyOverload3 { firstHead, secondHead, firstChildren, secondChildren, inj } = unifyData' - --- Overload4 unifyData' -> --- catchE ( --- unifyOverloadingVsOverloadedVariable --- firstHead --- firstTerm --- secondVar --- (inj :: Inj (TermLike RewritingVariableName)) { injChild = () } --- ) --- throwE --- where --- UnifyOverload4 { firstHead, secondVar, inj } = unifyData' - --- Overload5 unifyData' -> --- catchE ( --- unifyOverloadingInjVsVariable --- (Application firstHead firstChildren) --- secondVar --- (Attribute.freeVariables firstTerm) --- (inj :: Inj (TermLike RewritingVariableName)) { injChild = () } --- ) --- throwE --- where --- UnifyOverload5 { firstHead, firstChildren, secondVar, inj } = unifyData' - --- Overload6 unifyData' -> --- catchE ( --- notUnifiableTest firstHead injChild --- ) --- throwE --- where --- UnifyOverload6 { firstHead, injChild } = unifyData' +data UnifyOverload1 = UnifyOverload1 { + firstHead, secondHead :: Symbol + , firstChildren :: [TermLike RewritingVariableName] + , inj :: Inj (TermLike RewritingVariableName) +} + +data UnifyOverload2 = UnifyOverload2 { + firstHead, secondHead :: Symbol + , secondChildren :: [TermLike RewritingVariableName] + , inj :: Inj (TermLike RewritingVariableName) +} + +data UnifyOverload3 = UnifyOverload3 { + firstHead, secondHead :: Symbol + , firstChildren, secondChildren :: [TermLike RewritingVariableName] + , inj :: Inj (TermLike RewritingVariableName) +} + +data UnifyOverload4 = UnifyOverload4 { + firstHead :: Symbol + , secondVar :: ElementVariable RewritingVariableName + , inj :: Inj (TermLike RewritingVariableName) +} + +data UnifyOverload5 = UnifyOverload5 { + firstHead :: Symbol + , firstChildren :: [TermLike RewritingVariableName] + , secondVar :: ElementVariable RewritingVariableName + , inj :: Inj (TermLike RewritingVariableName) +} + +data UnifyOverload6 = UnifyOverload6 { + firstHead :: Symbol + , injChild :: TermLike RewritingVariableName +} + +data OverloadedConstructorSortInjectionAndEquals = + Overload1 UnifyOverload1 + | Overload2 UnifyOverload2 + | Overload3 UnifyOverload3 + | Overload4 UnifyOverload4 + | Overload5 UnifyOverload5 + | Overload6 UnifyOverload6 + +matchOverloadedConstructorSortInjectionAndEquals + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe OverloadedConstructorSortInjectionAndEquals +matchOverloadedConstructorSortInjectionAndEquals + first second + | Inj_ inj@Inj { injChild = App_ firstHead firstChildren } <- first + , App_ secondHead _ <- second + = Just $ Overload1 $ UnifyOverload1 firstHead secondHead firstChildren inj + | App_ firstHead _ <- first + , Inj_ inj@Inj { injChild = App_ secondHead secondChildren } <- second + = Just $ Overload2 $ UnifyOverload2 firstHead secondHead secondChildren inj + | Inj_ inj@Inj { injChild = App_ firstHead firstChildren } <- first + , Inj_ inj'@Inj { injChild = App_ secondHead secondChildren } <- second + , injFrom inj /= injFrom inj' + = Just $ Overload3 $ UnifyOverload3 firstHead secondHead firstChildren secondChildren inj + | App_ firstHead _ <- first + , Inj_ inj@Inj { injChild = ElemVar_ secondVar } <- second + = Just $ Overload4 $ UnifyOverload4 firstHead secondVar inj + | App_ secondHead _ <- second + , Inj_ inj@Inj { injChild = ElemVar_ firstVar } <- first + = Just $ Overload4 $ UnifyOverload4 secondHead firstVar inj + | Inj_ Inj { injChild = (App_ firstHead firstChildren) } <- first + , Inj_ inj@Inj { injChild = ElemVar_ secondVar } <- second + = Just $ Overload5 $ UnifyOverload5 firstHead firstChildren secondVar inj + | Inj_ Inj { injChild = (App_ secondHead secondChildren) } <- second + , Inj_ inj@Inj { injChild = ElemVar_ firstVar } <- first + = Just $ Overload5 $ UnifyOverload5 secondHead secondChildren firstVar inj + | App_ firstHead _ <- first + , Inj_ Inj { injChild } <- second + = Just $ Overload6 $ UnifyOverload6 firstHead injChild + | otherwise + = Nothing + +getUnifyResult + :: MonadSimplify unifier + => TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> OverloadedConstructorSortInjectionAndEquals + -> UnifyOverloadingResult unifier RewritingVariableName +getUnifyResult firstTerm secondTerm unifyData = + case unifyData of + Overload1 unifyData' -> + Simple . flipPairBack + <$> unifyOverloadingVsOverloaded + secondHead + secondTerm + (Application firstHead firstChildren) + inj{injChild = ()} + + where + UnifyOverload1 { firstHead, secondHead, firstChildren, inj } = unifyData' + + Overload2 unifyData' -> + Simple + <$> unifyOverloadingVsOverloaded + firstHead + firstTerm + (Application secondHead secondChildren) + inj{injChild = ()} + where + UnifyOverload2 { firstHead, secondHead, secondChildren, inj } = unifyData' + + Overload3 unifyData' -> + Simple + <$> unifyOverloadingCommonOverload + (Application firstHead firstChildren) + (Application secondHead secondChildren) + inj{injChild = ()} + where + UnifyOverload3 { firstHead, secondHead, firstChildren, secondChildren, inj } = unifyData' + + Overload4 unifyData' -> + catchE ( + unifyOverloadingVsOverloadedVariable + firstHead + firstTerm + secondVar + inj{injChild = ()}) + throwE + where + UnifyOverload4 { firstHead, secondVar, inj } = unifyData' + + Overload5 unifyData' -> + catchE ( + unifyOverloadingInjVsVariable + (Application firstHead firstChildren) + secondVar + (Attribute.freeVariables firstTerm) + inj{injChild = ()}) + throwE + where + UnifyOverload5 { firstHead, firstChildren, secondVar, inj } = unifyData' + + Overload6 unifyData' -> + catchE ( + notUnifiableTest firstHead injChild + ) + throwE + where + UnifyOverload6 { firstHead, injChild } = unifyData' + where + flipPairBack (Pair x y) = Pair y x + notUnifiableTest termHead child = do + OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier + Monad.guard (isOverloaded termHead) + notUnifiableError child {- | Tests whether the pair of terms can be coerced to have the same constructors From 61613e49300819a84c8c0fd39864a8b3d8c417a6 Mon Sep 17 00:00:00 2001 From: github-actions Date: Thu, 13 May 2021 05:08:33 +0000 Subject: [PATCH 13/86] Format with fourmolu --- .../Kore/Step/Simplification/Overloading.hs | 175 +++++++++--------- 1 file changed, 86 insertions(+), 89 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/Overloading.hs b/kore/src/Kore/Step/Simplification/Overloading.hs index a12bf7ec46..385c4b33f2 100644 --- a/kore/src/Kore/Step/Simplification/Overloading.hs +++ b/kore/src/Kore/Step/Simplification/Overloading.hs @@ -135,90 +135,91 @@ matchOverloading termPair = -- flipPairBack :: Pair a -> Pair a -- flipPairBack (Pair x y) = Pair y x -data UnifyOverload1 = UnifyOverload1 { - firstHead, secondHead :: Symbol +data UnifyOverload1 = UnifyOverload1 + { firstHead, secondHead :: Symbol , firstChildren :: [TermLike RewritingVariableName] , inj :: Inj (TermLike RewritingVariableName) -} + } -data UnifyOverload2 = UnifyOverload2 { - firstHead, secondHead :: Symbol +data UnifyOverload2 = UnifyOverload2 + { firstHead, secondHead :: Symbol , secondChildren :: [TermLike RewritingVariableName] , inj :: Inj (TermLike RewritingVariableName) -} + } -data UnifyOverload3 = UnifyOverload3 { - firstHead, secondHead :: Symbol +data UnifyOverload3 = UnifyOverload3 + { firstHead, secondHead :: Symbol , firstChildren, secondChildren :: [TermLike RewritingVariableName] , inj :: Inj (TermLike RewritingVariableName) -} + } -data UnifyOverload4 = UnifyOverload4 { - firstHead :: Symbol +data UnifyOverload4 = UnifyOverload4 + { firstHead :: Symbol , secondVar :: ElementVariable RewritingVariableName , inj :: Inj (TermLike RewritingVariableName) -} + } -data UnifyOverload5 = UnifyOverload5 { - firstHead :: Symbol +data UnifyOverload5 = UnifyOverload5 + { firstHead :: Symbol , firstChildren :: [TermLike RewritingVariableName] , secondVar :: ElementVariable RewritingVariableName , inj :: Inj (TermLike RewritingVariableName) -} + } -data UnifyOverload6 = UnifyOverload6 { - firstHead :: Symbol +data UnifyOverload6 = UnifyOverload6 + { firstHead :: Symbol , injChild :: TermLike RewritingVariableName -} + } -data OverloadedConstructorSortInjectionAndEquals = - Overload1 UnifyOverload1 +data OverloadedConstructorSortInjectionAndEquals + = Overload1 UnifyOverload1 | Overload2 UnifyOverload2 | Overload3 UnifyOverload3 | Overload4 UnifyOverload4 | Overload5 UnifyOverload5 | Overload6 UnifyOverload6 +matchOverloadedConstructorSortInjectionAndEquals :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe OverloadedConstructorSortInjectionAndEquals matchOverloadedConstructorSortInjectionAndEquals - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe OverloadedConstructorSortInjectionAndEquals -matchOverloadedConstructorSortInjectionAndEquals - first second - | Inj_ inj@Inj { injChild = App_ firstHead firstChildren } <- first - , App_ secondHead _ <- second - = Just $ Overload1 $ UnifyOverload1 firstHead secondHead firstChildren inj - | App_ firstHead _ <- first - , Inj_ inj@Inj { injChild = App_ secondHead secondChildren } <- second - = Just $ Overload2 $ UnifyOverload2 firstHead secondHead secondChildren inj - | Inj_ inj@Inj { injChild = App_ firstHead firstChildren } <- first - , Inj_ inj'@Inj { injChild = App_ secondHead secondChildren } <- second - , injFrom inj /= injFrom inj' - = Just $ Overload3 $ UnifyOverload3 firstHead secondHead firstChildren secondChildren inj - | App_ firstHead _ <- first - , Inj_ inj@Inj { injChild = ElemVar_ secondVar } <- second - = Just $ Overload4 $ UnifyOverload4 firstHead secondVar inj - | App_ secondHead _ <- second - , Inj_ inj@Inj { injChild = ElemVar_ firstVar } <- first - = Just $ Overload4 $ UnifyOverload4 secondHead firstVar inj - | Inj_ Inj { injChild = (App_ firstHead firstChildren) } <- first - , Inj_ inj@Inj { injChild = ElemVar_ secondVar } <- second - = Just $ Overload5 $ UnifyOverload5 firstHead firstChildren secondVar inj - | Inj_ Inj { injChild = (App_ secondHead secondChildren) } <- second - , Inj_ inj@Inj { injChild = ElemVar_ firstVar } <- first - = Just $ Overload5 $ UnifyOverload5 secondHead secondChildren firstVar inj - | App_ firstHead _ <- first - , Inj_ Inj { injChild } <- second - = Just $ Overload6 $ UnifyOverload6 firstHead injChild - | otherwise - = Nothing - -getUnifyResult - :: MonadSimplify unifier - => TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> OverloadedConstructorSortInjectionAndEquals - -> UnifyOverloadingResult unifier RewritingVariableName + first + second + | Inj_ inj@Inj{injChild = App_ firstHead firstChildren} <- first + , App_ secondHead _ <- second = + Just $ Overload1 $ UnifyOverload1 firstHead secondHead firstChildren inj + | App_ firstHead _ <- first + , Inj_ inj@Inj{injChild = App_ secondHead secondChildren} <- second = + Just $ Overload2 $ UnifyOverload2 firstHead secondHead secondChildren inj + | Inj_ inj@Inj{injChild = App_ firstHead firstChildren} <- first + , Inj_ inj'@Inj{injChild = App_ secondHead secondChildren} <- second + , injFrom inj /= injFrom inj' = + Just $ Overload3 $ UnifyOverload3 firstHead secondHead firstChildren secondChildren inj + | App_ firstHead _ <- first + , Inj_ inj@Inj{injChild = ElemVar_ secondVar} <- second = + Just $ Overload4 $ UnifyOverload4 firstHead secondVar inj + | App_ secondHead _ <- second + , Inj_ inj@Inj{injChild = ElemVar_ firstVar} <- first = + Just $ Overload4 $ UnifyOverload4 secondHead firstVar inj + | Inj_ Inj{injChild = (App_ firstHead firstChildren)} <- first + , Inj_ inj@Inj{injChild = ElemVar_ secondVar} <- second = + Just $ Overload5 $ UnifyOverload5 firstHead firstChildren secondVar inj + | Inj_ Inj{injChild = (App_ secondHead secondChildren)} <- second + , Inj_ inj@Inj{injChild = ElemVar_ firstVar} <- first = + Just $ Overload5 $ UnifyOverload5 secondHead secondChildren firstVar inj + | App_ firstHead _ <- first + , Inj_ Inj{injChild} <- second = + Just $ Overload6 $ UnifyOverload6 firstHead injChild + | otherwise = + Nothing + +getUnifyResult :: + MonadSimplify unifier => + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + OverloadedConstructorSortInjectionAndEquals -> + UnifyOverloadingResult unifier RewritingVariableName getUnifyResult firstTerm secondTerm unifyData = case unifyData of Overload1 unifyData' -> @@ -228,10 +229,8 @@ getUnifyResult firstTerm secondTerm unifyData = secondTerm (Application firstHead firstChildren) inj{injChild = ()} - where - UnifyOverload1 { firstHead, secondHead, firstChildren, inj } = unifyData' - + UnifyOverload1{firstHead, secondHead, firstChildren, inj} = unifyData' Overload2 unifyData' -> Simple <$> unifyOverloadingVsOverloaded @@ -240,46 +239,44 @@ getUnifyResult firstTerm secondTerm unifyData = (Application secondHead secondChildren) inj{injChild = ()} where - UnifyOverload2 { firstHead, secondHead, secondChildren, inj } = unifyData' - + UnifyOverload2{firstHead, secondHead, secondChildren, inj} = unifyData' Overload3 unifyData' -> Simple - <$> unifyOverloadingCommonOverload - (Application firstHead firstChildren) - (Application secondHead secondChildren) - inj{injChild = ()} + <$> unifyOverloadingCommonOverload + (Application firstHead firstChildren) + (Application secondHead secondChildren) + inj{injChild = ()} where - UnifyOverload3 { firstHead, secondHead, firstChildren, secondChildren, inj } = unifyData' - + UnifyOverload3{firstHead, secondHead, firstChildren, secondChildren, inj} = unifyData' Overload4 unifyData' -> - catchE ( - unifyOverloadingVsOverloadedVariable - firstHead - firstTerm - secondVar - inj{injChild = ()}) + catchE + ( unifyOverloadingVsOverloadedVariable + firstHead + firstTerm + secondVar + inj{injChild = ()} + ) throwE where - UnifyOverload4 { firstHead, secondVar, inj } = unifyData' - + UnifyOverload4{firstHead, secondVar, inj} = unifyData' Overload5 unifyData' -> - catchE ( - unifyOverloadingInjVsVariable - (Application firstHead firstChildren) - secondVar - (Attribute.freeVariables firstTerm) - inj{injChild = ()}) + catchE + ( unifyOverloadingInjVsVariable + (Application firstHead firstChildren) + secondVar + (Attribute.freeVariables firstTerm) + inj{injChild = ()} + ) throwE where - UnifyOverload5 { firstHead, firstChildren, secondVar, inj } = unifyData' - + UnifyOverload5{firstHead, firstChildren, secondVar, inj} = unifyData' Overload6 unifyData' -> - catchE ( - notUnifiableTest firstHead injChild + catchE + ( notUnifiableTest firstHead injChild ) throwE where - UnifyOverload6 { firstHead, injChild } = unifyData' + UnifyOverload6{firstHead, injChild} = unifyData' where flipPairBack (Pair x y) = Pair y x notUnifiableTest termHead child = do From 00524a4a18437d4f0e80380c1949c3a7686491aa Mon Sep 17 00:00:00 2001 From: emarzion Date: Fri, 14 May 2021 00:48:48 -0500 Subject: [PATCH 14/86] More progress and reverting overloadedConstructor... --- kore/src/Kore/Builtin/Bool.hs | 91 ++++++----- kore/src/Kore/Builtin/Int.hs | 40 +++-- kore/src/Kore/Builtin/KEqual.hs | 41 +++-- kore/src/Kore/Step/Simplification/AndTerms.hs | 152 ++++++++++-------- kore/test/Test/Kore/Builtin/Bool.hs | 13 +- kore/test/Test/Kore/Builtin/Int.hs | 12 +- kore/test/Test/Kore/Builtin/KEqual.hs | 16 +- 7 files changed, 225 insertions(+), 140 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index 148383ea7f..8509a200c2 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -18,6 +18,8 @@ module Kore.Builtin.Bool ( matchBool, matchBools, matchUnifyBoolAnd, + matchUnifyBoolOr, + matchUnifyBoolNot, -- * Keys orKey, @@ -31,9 +33,6 @@ module Kore.Builtin.Bool ( orElseKey, ) where -import Control.Error ( - MaybeT, - ) import qualified Control.Monad as Monad import Data.Functor.Const import qualified Data.HashMap.Strict as HashMap @@ -218,7 +217,7 @@ unifyBoolAnd :: TermSimplifier RewritingVariableName unifier -> TermLike RewritingVariableName -> BoolAnd (TermLike RewritingVariableName) -> - MaybeT unifier (Pattern RewritingVariableName) + unifier (Pattern RewritingVariableName) unifyBoolAnd unifyChildren term boolAnd = unifyBothWith unifyChildren term operand1 operand2 where @@ -239,8 +238,8 @@ unifyBothWith :: TermLike variable -> -- | first term to be unified with the base term TermLike variable -> - MaybeT unifier (Pattern variable) -unifyBothWith unify termLike1 operand1 operand2 = lift $ do + unifier (Pattern variable) +unifyBothWith unify termLike1 operand1 operand2 = do unification1 <- unify' termLike1 operand1 unification2 <- unify' termLike1 operand2 let conditions = unification1 <> unification2 @@ -249,44 +248,60 @@ unifyBothWith unify termLike1 operand1 operand2 = lift $ do unify' term1 term2 = Pattern.withoutTerm <$> unify term1 term2 +matchUnifyBoolOr :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe (BoolOr (TermLike RewritingVariableName)) +matchUnifyBoolOr first second + | Just value1 <- matchBool first + , not value1 + , Just boolOr <- matchBoolOr second + , isFunctionPattern second + = Just boolOr + | otherwise = Nothing +{-# INLINE matchUnifyBoolOr #-} + unifyBoolOr :: - forall variable unifier. - InternalVariable variable => + forall unifier. MonadUnify unifier => - TermSimplifier variable unifier -> - TermLike variable -> - TermLike variable -> - MaybeT unifier (Pattern variable) -unifyBoolOr unifyChildren a b = - worker a b <|> worker b a + TermSimplifier RewritingVariableName unifier -> + TermLike RewritingVariableName -> + BoolOr (TermLike RewritingVariableName) -> + unifier (Pattern RewritingVariableName) +unifyBoolOr unifyChildren termLike boolOr + = unifyBothWith unifyChildren termLike operand1 operand2 where - worker termLike1 termLike2 - | Just value1 <- matchBool termLike1 - , not value1 - , Just BoolOr{operand1, operand2} <- matchBoolOr termLike2 - , isFunctionPattern termLike2 = - unifyBothWith unifyChildren termLike1 operand1 operand2 - worker _ _ = empty + BoolOr { operand1, operand2 } = boolOr + +data UnifyBoolNot = UnifyBoolNot { + boolNot :: BoolNot (TermLike RewritingVariableName) + , value :: Bool +} + +matchUnifyBoolNot + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyBoolNot +matchUnifyBoolNot first second + | Just boolNot <- matchBoolNot first + , isFunctionPattern first + , Just value <- matchBool second + = Just $ UnifyBoolNot boolNot value + | otherwise = Nothing +{-# INLINE matchUnifyBoolNot #-} unifyBoolNot :: - forall variable unifier. - InternalVariable variable => - MonadUnify unifier => - TermSimplifier variable unifier -> - TermLike variable -> - TermLike variable -> - MaybeT unifier (Pattern variable) -unifyBoolNot unifyChildren a b = - worker a b <|> worker b a + forall unifier. + TermSimplifier RewritingVariableName unifier -> + TermLike RewritingVariableName -> + UnifyBoolNot -> + unifier (Pattern RewritingVariableName) +unifyBoolNot unifyChildren term unifyData = + let notValue = asInternal (termLikeSort term) (not value) in + unifyChildren notValue operand where - worker termLike1 boolTerm - | Just BoolNot{operand} <- matchBoolNot termLike1 - , isFunctionPattern termLike1 - , Just value <- matchBool boolTerm = - lift $ do - let notValue = asInternal (termLikeSort boolTerm) (not value) - unifyChildren notValue operand - worker _ _ = empty + UnifyBoolNot { boolNot, value } = unifyData + BoolNot { operand } = boolNot -- | Match a @BOOL.Bool@ builtin value. matchBool :: TermLike variable -> Maybe Bool diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index 20977cb713..16021a7810 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -30,6 +30,7 @@ module Kore.Builtin.Int ( unifyIntEq, unifyInt, matchInt, + matchUnifyIntEq, -- * keys randKey, @@ -110,6 +111,8 @@ import Kore.Builtin.Int.Int import qualified Kore.Error import qualified Kore.Internal.Condition as Condition import Kore.Internal.InternalInt +import qualified Kore.Internal.MultiOr as MultiOr +import qualified Kore.Internal.OrPattern as OrPattern import Kore.Internal.Pattern ( Pattern, ) @@ -461,6 +464,22 @@ unifyInt term1 term2 unifyData = UnifyInt{int1, int2} = unifyData +data UnifyIntEq = UnifyIntEq { + eqTerm :: EqTerm (TermLike RewritingVariableName) + , value :: Bool +} + +matchUnifyIntEq + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyIntEq +matchUnifyIntEq first second + | Just eqTerm <- matchIntEqual first + , isFunctionPattern first + , Just value <- Bool.matchBool second + = Just $ UnifyIntEq eqTerm value + | otherwise = Nothing + {- | Unification of the @INT.eq@ symbol. This function is suitable only for equality simplification. @@ -470,14 +489,15 @@ unifyIntEq :: MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> NotSimplifier unifier -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) -unifyIntEq unifyChildren notSimplifier a b = - worker a b <|> worker b a + UnifyIntEq -> + unifier (Pattern RewritingVariableName) +unifyIntEq unifyChildren (NotSimplifier notSimplifier) unifyData + = do + solution <- unifyChildren operand1 operand2 & OrPattern.gather + let solution' = MultiOr.map eraseTerm solution + (if value then pure else notSimplifier SideCondition.top) solution' + >>= Unify.scatter where - worker termLike1 termLike2 - | Just eqTerm <- matchIntEqual termLike1 - , isFunctionPattern termLike1 = - unifyEqTerm unifyChildren notSimplifier eqTerm termLike2 - | otherwise = empty + UnifyIntEq { eqTerm, value } = unifyData + EqTerm{operand1, operand2} = eqTerm + eraseTerm = Pattern.fromCondition_ . Pattern.withoutTerm diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index 9c3a65acec..c187d62808 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -19,6 +19,7 @@ module Kore.Builtin.KEqual ( builtinFunctions, unifyKequalsEq, unifyIfThenElse, + matchUnifyKequalsEq, -- * keys eqKey, @@ -52,6 +53,8 @@ import qualified Kore.Builtin.Builtin as Builtin import Kore.Builtin.EqTerm import qualified Kore.Error import qualified Kore.Internal.Condition as Condition +import qualified Kore.Internal.MultiOr as MultiOr +import qualified Kore.Internal.OrPattern as OrPattern import Kore.Internal.Pattern ( Pattern, ) @@ -219,22 +222,40 @@ matchKequalEq = Monad.guard (hook2 == eqKey) & isJust +data UnifyKequalsEq = UnifyKequalsEq { + eqTerm :: EqTerm (TermLike RewritingVariableName) + , value :: Bool +} + +matchUnifyKequalsEq :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyKequalsEq +matchUnifyKequalsEq first second + | Just eqTerm <- matchKequalEq first + , isFunctionPattern first + , Just value <- Bool.matchBool second + = Just $ UnifyKequalsEq eqTerm value + | otherwise = Nothing + unifyKequalsEq :: forall unifier. MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> NotSimplifier unifier -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) -unifyKequalsEq unifyChildren notSimplifier a b = - worker a b <|> worker b a + UnifyKequalsEq -> + unifier (Pattern RewritingVariableName) +unifyKequalsEq unifyChildren (NotSimplifier notSimplifier) unifyData + = do + solution <- unifyChildren operand1 operand2 & OrPattern.gather + let solution' = MultiOr.map eraseTerm solution + (if value then pure else notSimplifier SideCondition.top) solution' + >>= Unify.scatter + where - worker termLike1 termLike2 - | Just eqTerm <- matchKequalEq termLike1 - , isFunctionPattern termLike1 = - unifyEqTerm unifyChildren notSimplifier eqTerm termLike2 - | otherwise = empty + UnifyKequalsEq { eqTerm, value } = unifyData + EqTerm{operand1, operand2} = eqTerm + eraseTerm = Pattern.fromCondition_ . Pattern.withoutTerm -- | The @KEQUAL.ite@ hooked symbol applied to @term@-type arguments. data IfThenElse term = IfThenElse diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index dc2216820e..0986b8725e 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -176,41 +176,54 @@ maybeTermEquals notSimplifier childTransformers injSimplifier isOverloaded first lift $ constructorSortInjectionAndEquals first second | Just () <- matchConstructorAndEqualsAssumesDifferentHeads isOverloaded first second = lift $ constructorAndEqualsAssumesDifferentHeads first second - | Just unifyData <- matchOverloadedConstructorSortInjectionAndEquals first second = - overloadedConstructorSortInjectionAndEquals childTransformers first second unifyData | otherwise = - asum - [ do - boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd first second - Builtin.Bool.unifyBoolAnd childTransformers first boolAndData - , do - boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd second first - Builtin.Bool.unifyBoolAnd childTransformers second boolAndData - , Builtin.Bool.unifyBoolOr childTransformers first second - , Builtin.Bool.unifyBoolNot childTransformers first second - , Builtin.Int.unifyIntEq childTransformers notSimplifier first second - , Builtin.String.unifyStringEq - childTransformers - notSimplifier - first - second - , Builtin.KEqual.unifyKequalsEq - childTransformers - notSimplifier - first - second - , Builtin.Endianness.unifyEquals first second - , Builtin.Signedness.unifyEquals first second - , Builtin.Map.unifyEquals childTransformers first second - , Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second - , Builtin.Set.unifyEquals childTransformers first second - , Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - first - second - , domainValueAndConstructorErrors first second - ] + overloadedConstructorSortInjectionAndEquals childTransformers first second + <|> rest + + where + rest + | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd first second = + lift $ Builtin.Bool.unifyBoolAnd childTransformers first boolAndData + | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd second first = + lift $ Builtin.Bool.unifyBoolAnd childTransformers second boolAndData + | Just boolOrData <- Builtin.Bool.matchUnifyBoolOr first second = + lift $ Builtin.Bool.unifyBoolOr childTransformers second boolOrData + | Just boolOrData <- Builtin.Bool.matchUnifyBoolOr second first = + lift $ Builtin.Bool.unifyBoolOr childTransformers first boolOrData + | Just boolNotData <- Builtin.Bool.matchUnifyBoolNot first second = + lift $ Builtin.Bool.unifyBoolNot childTransformers second boolNotData + | Just boolNotData <- Builtin.Bool.matchUnifyBoolNot second first = + lift $ Builtin.Bool.unifyBoolNot childTransformers first boolNotData + | Just unifyData <- Builtin.Int.matchUnifyIntEq first second = + lift $ Builtin.Int.unifyIntEq childTransformers notSimplifier unifyData + | Just unifyData <- Builtin.Int.matchUnifyIntEq second first = + lift $ Builtin.Int.unifyIntEq childTransformers notSimplifier unifyData + | otherwise = + asum + [ Builtin.String.unifyStringEq + childTransformers + notSimplifier + first + second + , do + unifyData <- Error.hoistMaybe $ Builtin.KEqual.matchUnifyKequalsEq first second + lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData + , do + unifyData <- Error.hoistMaybe $ Builtin.KEqual.matchUnifyKequalsEq second first + lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData + , Builtin.Endianness.unifyEquals first second + , Builtin.Signedness.unifyEquals first second + , Builtin.Map.unifyEquals childTransformers first second + , Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second + , Builtin.Set.unifyEquals childTransformers first second + , Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + first + second + , domainValueAndConstructorErrors first second + ] + maybeTermAnd :: MonadUnify unifier => @@ -263,36 +276,42 @@ maybeTermAnd notSimplifier childTransformers injSimplifier isOverloaded first se lift $ constructorSortInjectionAndEquals first second | Just () <- matchConstructorAndEqualsAssumesDifferentHeads isOverloaded first second = lift $ constructorAndEqualsAssumesDifferentHeads first second - | Just unifyData <- matchOverloadedConstructorSortInjectionAndEquals first second = - overloadedConstructorSortInjectionAndEquals childTransformers first second unifyData - | otherwise = - asum - [ do - boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd first second - Builtin.Bool.unifyBoolAnd childTransformers first boolAndData - , do - boolAndData <- Error.hoistMaybe $ Builtin.Bool.matchUnifyBoolAnd second first - Builtin.Bool.unifyBoolAnd childTransformers second boolAndData - , Builtin.Bool.unifyBoolOr childTransformers first second - , Builtin.Bool.unifyBoolNot childTransformers first second - , Builtin.KEqual.unifyKequalsEq - childTransformers - notSimplifier - first - second - , Builtin.KEqual.unifyIfThenElse childTransformers first second - , Builtin.Endianness.unifyEquals first second - , Builtin.Signedness.unifyEquals first second - , Builtin.Map.unifyEquals childTransformers first second - , Builtin.Set.unifyEquals childTransformers first second - , Builtin.List.unifyEquals - SimplificationType.And - childTransformers - first - second - , domainValueAndConstructorErrors first second - , Error.hoistMaybe (functionAnd first second) - ] + | otherwise = + overloadedConstructorSortInjectionAndEquals childTransformers first second + <|> rest + where + rest + | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd first second = + lift $ Builtin.Bool.unifyBoolAnd childTransformers first boolAndData + | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd second first = + lift $ Builtin.Bool.unifyBoolAnd childTransformers second boolAndData + | Just boolOrData <- Builtin.Bool.matchUnifyBoolOr first second = + lift $ Builtin.Bool.unifyBoolOr childTransformers second boolOrData + | Just boolOrData <- Builtin.Bool.matchUnifyBoolOr second first = + lift $ Builtin.Bool.unifyBoolOr childTransformers first boolOrData + | Just boolNotData <- Builtin.Bool.matchUnifyBoolNot first second = + lift $ Builtin.Bool.unifyBoolNot childTransformers second boolNotData + | Just boolNotData <- Builtin.Bool.matchUnifyBoolNot second first = + lift $ Builtin.Bool.unifyBoolNot childTransformers first boolNotData + | Just unifyData <- Builtin.KEqual.matchUnifyKequalsEq first second = + lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData + | Just unifyData <- Builtin.KEqual.matchUnifyKequalsEq second first = + lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData + | otherwise = + asum + [ Builtin.KEqual.unifyIfThenElse childTransformers first second + , Builtin.Endianness.unifyEquals first second + , Builtin.Signedness.unifyEquals first second + , Builtin.Map.unifyEquals childTransformers first second + , Builtin.Set.unifyEquals childTransformers first second + , Builtin.List.unifyEquals + SimplificationType.And + childTransformers + first + second + , domainValueAndConstructorErrors first second + , Error.hoistMaybe (functionAnd first second) + ] {- | Construct the conjunction or unification of two terms. @@ -620,13 +639,12 @@ overloadedConstructorSortInjectionAndEquals :: TermSimplifier RewritingVariableName unifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - OverloadedConstructorSortInjectionAndEquals -> MaybeT unifier (Pattern RewritingVariableName) -overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm unifyData = +overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm = do eunifier <- lift . Error.runExceptT $ - getUnifyResult firstTerm secondTerm unifyData + unifyOverloading (Pair firstTerm secondTerm) case eunifier of Right (Simple (Pair firstTerm' secondTerm')) -> lift $ diff --git a/kore/test/Test/Kore/Builtin/Bool.hs b/kore/test/Test/Kore/Builtin/Bool.hs index 45a74ad277..4ad8ffcfee 100644 --- a/kore/test/Test/Kore/Builtin/Bool.hs +++ b/kore/test/Test/Kore/Builtin/Bool.hs @@ -200,7 +200,7 @@ test_unifyBoolAnd = Nothing -> assertEqual "" expected [Nothing] unify term boolAnd = - run (Bool.unifyBoolAnd termSimplifier term boolAnd) + run (lift $ Bool.unifyBoolAnd termSimplifier term boolAnd) test_unifyBoolOr :: [TestTree] test_unifyBoolOr = @@ -226,11 +226,14 @@ test_unifyBoolOr = TestTree test testName term1 term2 expected = testCase testName $ do - actual <- unify term1 term2 - assertEqual "" expected actual + case Bool.matchUnifyBoolOr term1 term2 of + Just boolOr -> do + actual <- unify term1 boolOr + assertEqual "" expected actual + Nothing -> assertEqual "" expected [Nothing] - unify term1 term2 = - run (Bool.unifyBoolOr termSimplifier term1 term2) + unify term boolOr = + run (lift $ Bool.unifyBoolOr termSimplifier term boolOr) run :: MaybeT (UnifierT (SimplifierT SMT.NoSMT)) a -> IO [Maybe a] run = diff --git a/kore/test/Test/Kore/Builtin/Int.hs b/kore/test/Test/Kore/Builtin/Int.hs index ccc36bafcf..ef51c8218b 100644 --- a/kore/test/Test/Kore/Builtin/Int.hs +++ b/kore/test/Test/Kore/Builtin/Int.hs @@ -641,16 +641,18 @@ test_unifyIntEq = TermLike RewritingVariableName -> IO [Maybe (Pattern RewritingVariableName)] unifyIntEq term1 term2 = - Int.unifyIntEq - (termUnification Not.notSimplifier) - Not.notSimplifier - term1 - term2 + worker term1 term2 & runMaybeT & evalEnvUnifierT Not.notSimplifier & runSimplifierBranch testEnv & runNoSMT + worker a b = case unify a b of + Nothing -> empty + Just unifyData -> lift $ Int.unifyIntEq (termUnification Not.notSimplifier) Not.notSimplifier unifyData + + unify a b = Int.matchUnifyIntEq a b <|> Int.matchUnifyIntEq b a + simplifyCondition' :: Condition RewritingVariableName -> IO [Condition RewritingVariableName] diff --git a/kore/test/Test/Kore/Builtin/KEqual.hs b/kore/test/Test/Kore/Builtin/KEqual.hs index 1fec985794..44976295b3 100644 --- a/kore/test/Test/Kore/Builtin/KEqual.hs +++ b/kore/test/Test/Kore/Builtin/KEqual.hs @@ -219,8 +219,14 @@ runKEqualSimplification term1 term2 = runSimplifierBranch testEnv . evalEnvUnifierT Not.notSimplifier . runMaybeT - $ KEqual.unifyKequalsEq - (termUnification Not.notSimplifier) - Not.notSimplifier - term1 - term2 + $ (case unify of + Just unifyData -> + lift $ KEqual.unifyKequalsEq + (termUnification Not.notSimplifier) + Not.notSimplifier + unifyData + Nothing -> empty + ) + + where + unify = KEqual.matchUnifyKequalsEq term1 term2 <|> KEqual.matchUnifyKequalsEq term2 term1 \ No newline at end of file From 65e3d6a34c5574dac27fc0a4cb06499f2bd7d972 Mon Sep 17 00:00:00 2001 From: github-actions Date: Fri, 14 May 2021 05:51:01 +0000 Subject: [PATCH 15/86] Format with fourmolu --- kore/src/Kore/Builtin/Bool.hs | 42 +++++++++---------- kore/src/Kore/Builtin/Int.hs | 26 ++++++------ kore/src/Kore/Builtin/KEqual.hs | 19 ++++----- kore/src/Kore/Step/Simplification/AndTerms.hs | 10 ++--- kore/test/Test/Kore/Builtin/KEqual.hs | 20 ++++----- 5 files changed, 57 insertions(+), 60 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index 8509a200c2..c1dac07b64 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -254,10 +254,10 @@ matchUnifyBoolOr :: Maybe (BoolOr (TermLike RewritingVariableName)) matchUnifyBoolOr first second | Just value1 <- matchBool first - , not value1 - , Just boolOr <- matchBoolOr second - , isFunctionPattern second - = Just boolOr + , not value1 + , Just boolOr <- matchBoolOr second + , isFunctionPattern second = + Just boolOr | otherwise = Nothing {-# INLINE matchUnifyBoolOr #-} @@ -268,25 +268,25 @@ unifyBoolOr :: TermLike RewritingVariableName -> BoolOr (TermLike RewritingVariableName) -> unifier (Pattern RewritingVariableName) -unifyBoolOr unifyChildren termLike boolOr - = unifyBothWith unifyChildren termLike operand1 operand2 +unifyBoolOr unifyChildren termLike boolOr = + unifyBothWith unifyChildren termLike operand1 operand2 where - BoolOr { operand1, operand2 } = boolOr + BoolOr{operand1, operand2} = boolOr -data UnifyBoolNot = UnifyBoolNot { - boolNot :: BoolNot (TermLike RewritingVariableName) +data UnifyBoolNot = UnifyBoolNot + { boolNot :: BoolNot (TermLike RewritingVariableName) , value :: Bool -} + } -matchUnifyBoolNot - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyBoolNot +matchUnifyBoolNot :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyBoolNot matchUnifyBoolNot first second | Just boolNot <- matchBoolNot first - , isFunctionPattern first - , Just value <- matchBool second - = Just $ UnifyBoolNot boolNot value + , isFunctionPattern first + , Just value <- matchBool second = + Just $ UnifyBoolNot boolNot value | otherwise = Nothing {-# INLINE matchUnifyBoolNot #-} @@ -297,11 +297,11 @@ unifyBoolNot :: UnifyBoolNot -> unifier (Pattern RewritingVariableName) unifyBoolNot unifyChildren term unifyData = - let notValue = asInternal (termLikeSort term) (not value) in - unifyChildren notValue operand + let notValue = asInternal (termLikeSort term) (not value) + in unifyChildren notValue operand where - UnifyBoolNot { boolNot, value } = unifyData - BoolNot { operand } = boolNot + UnifyBoolNot{boolNot, value} = unifyData + BoolNot{operand} = boolNot -- | Match a @BOOL.Bool@ builtin value. matchBool :: TermLike variable -> Maybe Bool diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index 16021a7810..e65739b2d7 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -464,20 +464,20 @@ unifyInt term1 term2 unifyData = UnifyInt{int1, int2} = unifyData -data UnifyIntEq = UnifyIntEq { - eqTerm :: EqTerm (TermLike RewritingVariableName) +data UnifyIntEq = UnifyIntEq + { eqTerm :: EqTerm (TermLike RewritingVariableName) , value :: Bool -} + } -matchUnifyIntEq - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyIntEq +matchUnifyIntEq :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyIntEq matchUnifyIntEq first second | Just eqTerm <- matchIntEqual first - , isFunctionPattern first - , Just value <- Bool.matchBool second - = Just $ UnifyIntEq eqTerm value + , isFunctionPattern first + , Just value <- Bool.matchBool second = + Just $ UnifyIntEq eqTerm value | otherwise = Nothing {- | Unification of the @INT.eq@ symbol. @@ -491,13 +491,13 @@ unifyIntEq :: NotSimplifier unifier -> UnifyIntEq -> unifier (Pattern RewritingVariableName) -unifyIntEq unifyChildren (NotSimplifier notSimplifier) unifyData - = do +unifyIntEq unifyChildren (NotSimplifier notSimplifier) unifyData = + do solution <- unifyChildren operand1 operand2 & OrPattern.gather let solution' = MultiOr.map eraseTerm solution (if value then pure else notSimplifier SideCondition.top) solution' >>= Unify.scatter where - UnifyIntEq { eqTerm, value } = unifyData + UnifyIntEq{eqTerm, value} = unifyData EqTerm{operand1, operand2} = eqTerm eraseTerm = Pattern.fromCondition_ . Pattern.withoutTerm diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index c187d62808..8645f6f87f 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -222,10 +222,10 @@ matchKequalEq = Monad.guard (hook2 == eqKey) & isJust -data UnifyKequalsEq = UnifyKequalsEq { - eqTerm :: EqTerm (TermLike RewritingVariableName) +data UnifyKequalsEq = UnifyKequalsEq + { eqTerm :: EqTerm (TermLike RewritingVariableName) , value :: Bool -} + } matchUnifyKequalsEq :: TermLike RewritingVariableName -> @@ -233,9 +233,9 @@ matchUnifyKequalsEq :: Maybe UnifyKequalsEq matchUnifyKequalsEq first second | Just eqTerm <- matchKequalEq first - , isFunctionPattern first - , Just value <- Bool.matchBool second - = Just $ UnifyKequalsEq eqTerm value + , isFunctionPattern first + , Just value <- Bool.matchBool second = + Just $ UnifyKequalsEq eqTerm value | otherwise = Nothing unifyKequalsEq :: @@ -245,15 +245,14 @@ unifyKequalsEq :: NotSimplifier unifier -> UnifyKequalsEq -> unifier (Pattern RewritingVariableName) -unifyKequalsEq unifyChildren (NotSimplifier notSimplifier) unifyData - = do +unifyKequalsEq unifyChildren (NotSimplifier notSimplifier) unifyData = + do solution <- unifyChildren operand1 operand2 & OrPattern.gather let solution' = MultiOr.map eraseTerm solution (if value then pure else notSimplifier SideCondition.top) solution' >>= Unify.scatter - where - UnifyKequalsEq { eqTerm, value } = unifyData + UnifyKequalsEq{eqTerm, value} = unifyData EqTerm{operand1, operand2} = eqTerm eraseTerm = Pattern.fromCondition_ . Pattern.withoutTerm diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 0986b8725e..ca15cd6580 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -178,10 +178,9 @@ maybeTermEquals notSimplifier childTransformers injSimplifier isOverloaded first lift $ constructorAndEqualsAssumesDifferentHeads first second | otherwise = overloadedConstructorSortInjectionAndEquals childTransformers first second - <|> rest - + <|> rest where - rest + rest | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd first second = lift $ Builtin.Bool.unifyBoolAnd childTransformers first boolAndData | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd second first = @@ -223,7 +222,6 @@ maybeTermEquals notSimplifier childTransformers injSimplifier isOverloaded first second , domainValueAndConstructorErrors first second ] - maybeTermAnd :: MonadUnify unifier => @@ -276,9 +274,9 @@ maybeTermAnd notSimplifier childTransformers injSimplifier isOverloaded first se lift $ constructorSortInjectionAndEquals first second | Just () <- matchConstructorAndEqualsAssumesDifferentHeads isOverloaded first second = lift $ constructorAndEqualsAssumesDifferentHeads first second - | otherwise = + | otherwise = overloadedConstructorSortInjectionAndEquals childTransformers first second - <|> rest + <|> rest where rest | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd first second = diff --git a/kore/test/Test/Kore/Builtin/KEqual.hs b/kore/test/Test/Kore/Builtin/KEqual.hs index 44976295b3..38b7783aed 100644 --- a/kore/test/Test/Kore/Builtin/KEqual.hs +++ b/kore/test/Test/Kore/Builtin/KEqual.hs @@ -219,14 +219,14 @@ runKEqualSimplification term1 term2 = runSimplifierBranch testEnv . evalEnvUnifierT Not.notSimplifier . runMaybeT - $ (case unify of - Just unifyData -> - lift $ KEqual.unifyKequalsEq - (termUnification Not.notSimplifier) - Not.notSimplifier - unifyData - Nothing -> empty - ) - + $ ( case unify of + Just unifyData -> + lift $ + KEqual.unifyKequalsEq + (termUnification Not.notSimplifier) + Not.notSimplifier + unifyData + Nothing -> empty + ) where - unify = KEqual.matchUnifyKequalsEq term1 term2 <|> KEqual.matchUnifyKequalsEq term2 term1 \ No newline at end of file + unify = KEqual.matchUnifyKequalsEq term1 term2 <|> KEqual.matchUnifyKequalsEq term2 term1 From c4a6e531e107dcce2f5f3e2403e990b8bbff8e3e Mon Sep 17 00:00:00 2001 From: emarzion Date: Fri, 14 May 2021 09:27:59 -0500 Subject: [PATCH 16/86] trigger build From 2b506be416cd28cc033eb2469d7d2cf8ffdcd6a5 Mon Sep 17 00:00:00 2001 From: emarzion Date: Sat, 15 May 2021 22:57:14 -0500 Subject: [PATCH 17/86] Using named field puns --- kore/src/Kore/Builtin/Bool.hs | 2 +- kore/src/Kore/Builtin/Int.hs | 4 ++-- kore/src/Kore/Builtin/KEqual.hs | 2 +- kore/src/Kore/Builtin/String.hs | 2 +- kore/src/Kore/Step/Simplification/AndTerms.hs | 14 +++++--------- kore/src/Kore/Step/Simplification/ExpandAlias.hs | 5 ++++- kore/src/Kore/Step/Simplification/NoConfusion.hs | 10 +++++----- 7 files changed, 19 insertions(+), 20 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index c1dac07b64..e395e4550d 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -176,7 +176,7 @@ matchBools :: matchBools first second | InternalBool_ bool1 <- first , InternalBool_ bool2 <- second = - Just $ UnifyBool bool1 bool2 + Just UnifyBool{bool1, bool2} | otherwise = Nothing {-# INLINE matchBools #-} diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index e65739b2d7..9997ef61e5 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -440,7 +440,7 @@ matchInt :: matchInt first second | InternalInt_ int1 <- first , InternalInt_ int2 <- second = - Just $ UnifyInt int1 int2 + Just UnifyInt{int1, int2} | otherwise = Nothing {-# INLINE matchInt #-} @@ -477,7 +477,7 @@ matchUnifyIntEq first second | Just eqTerm <- matchIntEqual first , isFunctionPattern first , Just value <- Bool.matchBool second = - Just $ UnifyIntEq eqTerm value + Just UnifyIntEq{eqTerm, value} | otherwise = Nothing {- | Unification of the @INT.eq@ symbol. diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index 8645f6f87f..e1983a849a 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -235,7 +235,7 @@ matchUnifyKequalsEq first second | Just eqTerm <- matchKequalEq first , isFunctionPattern first , Just value <- Bool.matchBool second = - Just $ UnifyKequalsEq eqTerm value + Just UnifyKequalsEq{eqTerm, value} | otherwise = Nothing unifyKequalsEq :: diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index 544c8097fd..baa9b00798 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -483,7 +483,7 @@ matchString :: matchString first second | InternalString_ string1 <- first , InternalString_ string2 <- second = - Just $ UnifyString string1 string2 + Just UnifyString{string1, string2} | otherwise = Nothing {-# INLINE matchString #-} diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index ca15cd6580..ff6eee74aa 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -130,10 +130,6 @@ termUnification notSimplifier = \term1 term2 -> & Pattern.fromTermLike & return --- maybeTermEquals notSimplifier childTransformers first second = --- asum --- [ do { matched <- hoistMaybe $ matchInt first second; lift $ unifyInt matched } - maybeTermEquals :: MonadUnify unifier => HasCallStack => @@ -544,7 +540,7 @@ matchSortInjectionAndEquals injSimplifier first second , Inj_ inj2 <- second = case matchInjs injSimplifier inj1 inj2 of Left Unknown -> Nothing - matchData -> Just $ SortInjectionAndEquals inj1 inj2 matchData + matchData -> Just SortInjectionAndEquals{inj1, inj2, matchData} | otherwise = Nothing {-# INLINE sortInjectionAndEquals #-} @@ -725,7 +721,7 @@ matchDomainValue :: matchDomainValue first second | DV_ sort1 val1 <- first , DV_ sort2 val2 <- second = - Just $ UnifyDomainValue sort1 val1 sort2 val2 + Just UnifyDomainValue{sort1, val1, sort2, val2} | otherwise = Nothing {-# INLINE matchDomainValue #-} @@ -777,9 +773,9 @@ matchStringLiteral :: TermLike RewritingVariableName -> Maybe UnifyStringLiteral matchStringLiteral first second - | StringLiteral_ string1 <- first - , StringLiteral_ string2 <- second = - Just $ UnifyStringLiteral string1 string2 + | StringLiteral_ txt1 <- first + , StringLiteral_ txt2 <- second = + Just UnifyStringLiteral{txt1, txt2} | otherwise = Nothing {-# INLINE matchStringLiteral #-} diff --git a/kore/src/Kore/Step/Simplification/ExpandAlias.hs b/kore/src/Kore/Step/Simplification/ExpandAlias.hs index 741e1addb4..d9ad0cbdbb 100644 --- a/kore/src/Kore/Step/Simplification/ExpandAlias.hs +++ b/kore/src/Kore/Step/Simplification/ExpandAlias.hs @@ -40,7 +40,10 @@ matchExpandAlias :: matchExpandAlias t1 t2 = case (expandSingleAlias t1, expandSingleAlias t2) of (Nothing, Nothing) -> Nothing - (t1', t2') -> Just $ UnifyExpandAlias (fromMaybe t1 t1') (fromMaybe t2 t2') + (t1', t2') -> + let term1 = fromMaybe t1 t1' in + let term2 = fromMaybe t2 t2' in + Just UnifyExpandAlias{term1, term2} {-# INLINE matchExpandAlias #-} expandSingleAlias :: diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 84851176b4..9c6e5e2d3c 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -42,11 +42,11 @@ matchEqualInjectiveHeadsAndEquals first second , Symbol.isInjective secondHead , firstHead == secondHead --is one of the above redundant in light of this? = - Just $ - UnifyEqualInjectiveHeadsAndEquals - firstHead - firstChildren - secondChildren + Just + UnifyEqualInjectiveHeadsAndEquals{ + firstHead, + firstChildren, + secondChildren} | otherwise = Nothing {-# INLINE matchEqualInjectiveHeadsAndEquals #-} From eb6c82e5c536d24b49a46372be7e29151ea28af3 Mon Sep 17 00:00:00 2001 From: github-actions Date: Sun, 16 May 2021 03:59:38 +0000 Subject: [PATCH 18/86] Format with fourmolu --- kore/src/Kore/Step/Simplification/ExpandAlias.hs | 6 +++--- kore/src/Kore/Step/Simplification/NoConfusion.hs | 9 +++++---- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/ExpandAlias.hs b/kore/src/Kore/Step/Simplification/ExpandAlias.hs index d9ad0cbdbb..6f18455ab1 100644 --- a/kore/src/Kore/Step/Simplification/ExpandAlias.hs +++ b/kore/src/Kore/Step/Simplification/ExpandAlias.hs @@ -41,9 +41,9 @@ matchExpandAlias t1 t2 = case (expandSingleAlias t1, expandSingleAlias t2) of (Nothing, Nothing) -> Nothing (t1', t2') -> - let term1 = fromMaybe t1 t1' in - let term2 = fromMaybe t2 t2' in - Just UnifyExpandAlias{term1, term2} + let term1 = fromMaybe t1 t1' + in let term2 = fromMaybe t2 t2' + in Just UnifyExpandAlias{term1, term2} {-# INLINE matchExpandAlias #-} expandSingleAlias :: diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 9c6e5e2d3c..e7995cadf2 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -43,10 +43,11 @@ matchEqualInjectiveHeadsAndEquals first second , firstHead == secondHead --is one of the above redundant in light of this? = Just - UnifyEqualInjectiveHeadsAndEquals{ - firstHead, - firstChildren, - secondChildren} + UnifyEqualInjectiveHeadsAndEquals + { firstHead + , firstChildren + , secondChildren + } | otherwise = Nothing {-# INLINE matchEqualInjectiveHeadsAndEquals #-} From 7d2e4a30570ee477fe848abeadc76c7df34ad020 Mon Sep 17 00:00:00 2001 From: emarzion Date: Sat, 15 May 2021 23:55:37 -0500 Subject: [PATCH 19/86] Cleaning up code based on review suggestions --- kore/src/Kore/Builtin/Bool.hs | 44 ++--- kore/src/Kore/Builtin/Int.hs | 17 +- .../Kore/Step/Simplification/NoConfusion.hs | 18 +- .../Kore/Step/Simplification/Overloading.hs | 157 ------------------ 4 files changed, 36 insertions(+), 200 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index e395e4550d..f3c6cd1456 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -188,21 +188,21 @@ unifyBool :: TermLike RewritingVariableName -> UnifyBool -> unifier (Pattern RewritingVariableName) -unifyBool termLike1 termLike2 unifyData = - if bool1 == bool2 - then return (Pattern.fromTermLike termLike1) - else - Unify.explainAndReturnBottom - "different Bool domain values" - termLike1 - termLike2 +unifyBool termLike1 termLike2 unifyData + | bool1 == bool2 + = return (Pattern.fromTermLike termLike1) + | otherwise + = Unify.explainAndReturnBottom + "different Bool domain values" + termLike1 + termLike2 where UnifyBool{bool1, bool2} = unifyData matchUnifyBoolAnd :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe (BoolAnd (TermLike RewritingVariableName)) + Maybe BoolAnd matchUnifyBoolAnd first second | Just True <- matchBool first , Just boolAnd <- matchBoolAnd second @@ -216,7 +216,7 @@ unifyBoolAnd :: MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> TermLike RewritingVariableName -> - BoolAnd (TermLike RewritingVariableName) -> + BoolAnd -> unifier (Pattern RewritingVariableName) unifyBoolAnd unifyChildren term boolAnd = unifyBothWith unifyChildren term operand1 operand2 @@ -251,7 +251,7 @@ unifyBothWith unify termLike1 operand1 operand2 = do matchUnifyBoolOr :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe (BoolOr (TermLike RewritingVariableName)) + Maybe BoolOr matchUnifyBoolOr first second | Just value1 <- matchBool first , not value1 @@ -266,7 +266,7 @@ unifyBoolOr :: MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> TermLike RewritingVariableName -> - BoolOr (TermLike RewritingVariableName) -> + BoolOr -> unifier (Pattern RewritingVariableName) unifyBoolOr unifyChildren termLike boolOr = unifyBothWith unifyChildren termLike operand1 operand2 @@ -274,7 +274,7 @@ unifyBoolOr unifyChildren termLike boolOr = BoolOr{operand1, operand2} = boolOr data UnifyBoolNot = UnifyBoolNot - { boolNot :: BoolNot (TermLike RewritingVariableName) + { boolNot :: BoolNot , value :: Bool } @@ -310,13 +310,13 @@ matchBool (InternalBool_ InternalBool{internalBoolValue}) = matchBool _ = Nothing -- | The @BOOL.and@ hooked symbol applied to @term@-type arguments. -data BoolAnd term = BoolAnd +data BoolAnd = BoolAnd { symbol :: !Symbol - , operand1, operand2 :: !term + , operand1, operand2 :: !(TermLike RewritingVariableName) } -- | Match the @BOOL.and@ hooked symbol. -matchBoolAnd :: TermLike variable -> Maybe (BoolAnd (TermLike variable)) +matchBoolAnd :: TermLike RewritingVariableName -> Maybe BoolAnd matchBoolAnd (App_ symbol [operand1, operand2]) = do hook2 <- (getHook . symbolHook) symbol Monad.guard (hook2 == andKey) @@ -324,13 +324,13 @@ matchBoolAnd (App_ symbol [operand1, operand2]) = do matchBoolAnd _ = Nothing -- | The @BOOL.or@ hooked symbol applied to @term@-type arguments. -data BoolOr term = BoolOr +data BoolOr = BoolOr { symbol :: !Symbol - , operand1, operand2 :: !term + , operand1, operand2 :: !(TermLike RewritingVariableName) } -- | Match the @BOOL.or@ hooked symbol. -matchBoolOr :: TermLike variable -> Maybe (BoolOr (TermLike variable)) +matchBoolOr :: TermLike RewritingVariableName -> Maybe BoolOr matchBoolOr (App_ symbol [operand1, operand2]) = do hook2 <- (getHook . symbolHook) symbol Monad.guard (hook2 == orKey) @@ -338,13 +338,13 @@ matchBoolOr (App_ symbol [operand1, operand2]) = do matchBoolOr _ = Nothing -- | The @BOOL.not@ hooked symbol applied to a @term@-type argument. -data BoolNot term = BoolNot +data BoolNot = BoolNot { symbol :: !Symbol - , operand :: !term + , operand :: !(TermLike RewritingVariableName) } -- | Match the @BOOL.not@ hooked symbol. -matchBoolNot :: TermLike variable -> Maybe (BoolNot (TermLike variable)) +matchBoolNot :: TermLike RewritingVariableName -> Maybe BoolNot matchBoolNot (App_ symbol [operand]) = do hook2 <- (getHook . symbolHook) symbol Monad.guard (hook2 == notKey) diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index 9997ef61e5..502d1a4283 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -439,7 +439,8 @@ matchInt :: Maybe UnifyInt matchInt first second | InternalInt_ int1 <- first - , InternalInt_ int2 <- second = + , InternalInt_ int2 <- second + , on (==) internalIntSort int1 int2 = Just UnifyInt{int1, int2} | otherwise = Nothing {-# INLINE matchInt #-} @@ -448,20 +449,16 @@ matchInt first second unifyInt :: forall unifier. MonadUnify unifier => - HasCallStack => TermLike RewritingVariableName -> TermLike RewritingVariableName -> UnifyInt -> unifier (Pattern RewritingVariableName) -unifyInt term1 term2 unifyData = - assert (on (==) internalIntSort int1 int2) worker -- should this be part of match? - where - worker :: unifier (Pattern RewritingVariableName) - worker - | on (==) internalIntValue int1 int2 = - return $ Pattern.fromTermLike term1 - | otherwise = explainAndReturnBottom "distinct integers" term1 term2 +unifyInt term1 term2 unifyData + | on (==) internalIntValue int1 int2 = + return $ Pattern.fromTermLike term1 + | otherwise = explainAndReturnBottom "distinct integers" term1 term2 + where UnifyInt{int1, int2} = unifyData data UnifyIntEq = UnifyIntEq diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index e7995cadf2..90bae3886a 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -25,7 +25,7 @@ import Prelude.Kore hiding ( concat, ) -data UnifyEqualInjectiveHeadsAndEquals = UnifyEqualInjectiveHeadsAndEquals +data UnifyEqualInjectiveHeads= UnifyEqualInjectiveHeads { firstHead :: Symbol , firstChildren :: [TermLike RewritingVariableName] , secondChildren :: [TermLike RewritingVariableName] @@ -34,16 +34,16 @@ data UnifyEqualInjectiveHeadsAndEquals = UnifyEqualInjectiveHeadsAndEquals matchEqualInjectiveHeadsAndEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe UnifyEqualInjectiveHeadsAndEquals + Maybe UnifyEqualInjectiveHeads matchEqualInjectiveHeadsAndEquals first second | App_ firstHead firstChildren <- first , App_ secondHead secondChildren <- second , Symbol.isInjective firstHead - , Symbol.isInjective secondHead - , firstHead == secondHead --is one of the above redundant in light of this? + -- We do not need to check if secondHead is injective once we test for equality. + , firstHead == secondHead = Just - UnifyEqualInjectiveHeadsAndEquals + UnifyEqualInjectiveHeads { firstHead , firstChildren , secondChildren @@ -63,7 +63,7 @@ equalInjectiveHeadsAndEquals :: HasCallStack => -- | Used to simplify subterm "and". TermSimplifier RewritingVariableName unifier -> - UnifyEqualInjectiveHeadsAndEquals -> + UnifyEqualInjectiveHeads -> unifier (Pattern RewritingVariableName) equalInjectiveHeadsAndEquals termMerger @@ -80,16 +80,12 @@ equalInjectiveHeadsAndEquals (Pattern.term <$> children) return (Pattern.withCondition term merged) where - UnifyEqualInjectiveHeadsAndEquals + UnifyEqualInjectiveHeads { firstHead , firstChildren , secondChildren } = unifyData --- data ConstructorAndEqualsAssumesDifferentHeads = ConstructorAndEqualsAssumesDifferentHeads --- { firstHead, secondHead :: Symbol --- } - matchConstructorAndEqualsAssumesDifferentHeads :: (Symbol -> Bool) -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/Overloading.hs b/kore/src/Kore/Step/Simplification/Overloading.hs index 385c4b33f2..1281f9b361 100644 --- a/kore/src/Kore/Step/Simplification/Overloading.hs +++ b/kore/src/Kore/Step/Simplification/Overloading.hs @@ -1,13 +1,9 @@ -{-# LANGUAGE PartialTypeSignatures #-} - {- | Copyright : (c) Runtime Verification, 2019 License : NCSA -} module Kore.Step.Simplification.Overloading ( matchOverloading, - matchOverloadedConstructorSortInjectionAndEquals, - getUnifyResult, -- for testing purposes unifyOverloading, UnifyOverloadingResult, @@ -15,7 +11,6 @@ module Kore.Step.Simplification.Overloading ( UnifyOverloadingError (..), Narrowing (..), OverloadingResolution (..), - OverloadedConstructorSortInjectionAndEquals (..), ) where import qualified Control.Monad as Monad @@ -132,158 +127,6 @@ matchOverloading termPair = Simple pair -> return pair _ -> notApplicable --- flipPairBack :: Pair a -> Pair a --- flipPairBack (Pair x y) = Pair y x - -data UnifyOverload1 = UnifyOverload1 - { firstHead, secondHead :: Symbol - , firstChildren :: [TermLike RewritingVariableName] - , inj :: Inj (TermLike RewritingVariableName) - } - -data UnifyOverload2 = UnifyOverload2 - { firstHead, secondHead :: Symbol - , secondChildren :: [TermLike RewritingVariableName] - , inj :: Inj (TermLike RewritingVariableName) - } - -data UnifyOverload3 = UnifyOverload3 - { firstHead, secondHead :: Symbol - , firstChildren, secondChildren :: [TermLike RewritingVariableName] - , inj :: Inj (TermLike RewritingVariableName) - } - -data UnifyOverload4 = UnifyOverload4 - { firstHead :: Symbol - , secondVar :: ElementVariable RewritingVariableName - , inj :: Inj (TermLike RewritingVariableName) - } - -data UnifyOverload5 = UnifyOverload5 - { firstHead :: Symbol - , firstChildren :: [TermLike RewritingVariableName] - , secondVar :: ElementVariable RewritingVariableName - , inj :: Inj (TermLike RewritingVariableName) - } - -data UnifyOverload6 = UnifyOverload6 - { firstHead :: Symbol - , injChild :: TermLike RewritingVariableName - } - -data OverloadedConstructorSortInjectionAndEquals - = Overload1 UnifyOverload1 - | Overload2 UnifyOverload2 - | Overload3 UnifyOverload3 - | Overload4 UnifyOverload4 - | Overload5 UnifyOverload5 - | Overload6 UnifyOverload6 - -matchOverloadedConstructorSortInjectionAndEquals :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - Maybe OverloadedConstructorSortInjectionAndEquals -matchOverloadedConstructorSortInjectionAndEquals - first - second - | Inj_ inj@Inj{injChild = App_ firstHead firstChildren} <- first - , App_ secondHead _ <- second = - Just $ Overload1 $ UnifyOverload1 firstHead secondHead firstChildren inj - | App_ firstHead _ <- first - , Inj_ inj@Inj{injChild = App_ secondHead secondChildren} <- second = - Just $ Overload2 $ UnifyOverload2 firstHead secondHead secondChildren inj - | Inj_ inj@Inj{injChild = App_ firstHead firstChildren} <- first - , Inj_ inj'@Inj{injChild = App_ secondHead secondChildren} <- second - , injFrom inj /= injFrom inj' = - Just $ Overload3 $ UnifyOverload3 firstHead secondHead firstChildren secondChildren inj - | App_ firstHead _ <- first - , Inj_ inj@Inj{injChild = ElemVar_ secondVar} <- second = - Just $ Overload4 $ UnifyOverload4 firstHead secondVar inj - | App_ secondHead _ <- second - , Inj_ inj@Inj{injChild = ElemVar_ firstVar} <- first = - Just $ Overload4 $ UnifyOverload4 secondHead firstVar inj - | Inj_ Inj{injChild = (App_ firstHead firstChildren)} <- first - , Inj_ inj@Inj{injChild = ElemVar_ secondVar} <- second = - Just $ Overload5 $ UnifyOverload5 firstHead firstChildren secondVar inj - | Inj_ Inj{injChild = (App_ secondHead secondChildren)} <- second - , Inj_ inj@Inj{injChild = ElemVar_ firstVar} <- first = - Just $ Overload5 $ UnifyOverload5 secondHead secondChildren firstVar inj - | App_ firstHead _ <- first - , Inj_ Inj{injChild} <- second = - Just $ Overload6 $ UnifyOverload6 firstHead injChild - | otherwise = - Nothing - -getUnifyResult :: - MonadSimplify unifier => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - OverloadedConstructorSortInjectionAndEquals -> - UnifyOverloadingResult unifier RewritingVariableName -getUnifyResult firstTerm secondTerm unifyData = - case unifyData of - Overload1 unifyData' -> - Simple . flipPairBack - <$> unifyOverloadingVsOverloaded - secondHead - secondTerm - (Application firstHead firstChildren) - inj{injChild = ()} - where - UnifyOverload1{firstHead, secondHead, firstChildren, inj} = unifyData' - Overload2 unifyData' -> - Simple - <$> unifyOverloadingVsOverloaded - firstHead - firstTerm - (Application secondHead secondChildren) - inj{injChild = ()} - where - UnifyOverload2{firstHead, secondHead, secondChildren, inj} = unifyData' - Overload3 unifyData' -> - Simple - <$> unifyOverloadingCommonOverload - (Application firstHead firstChildren) - (Application secondHead secondChildren) - inj{injChild = ()} - where - UnifyOverload3{firstHead, secondHead, firstChildren, secondChildren, inj} = unifyData' - Overload4 unifyData' -> - catchE - ( unifyOverloadingVsOverloadedVariable - firstHead - firstTerm - secondVar - inj{injChild = ()} - ) - throwE - where - UnifyOverload4{firstHead, secondVar, inj} = unifyData' - Overload5 unifyData' -> - catchE - ( unifyOverloadingInjVsVariable - (Application firstHead firstChildren) - secondVar - (Attribute.freeVariables firstTerm) - inj{injChild = ()} - ) - throwE - where - UnifyOverload5{firstHead, firstChildren, secondVar, inj} = unifyData' - Overload6 unifyData' -> - catchE - ( notUnifiableTest firstHead injChild - ) - throwE - where - UnifyOverload6{firstHead, injChild} = unifyData' - where - flipPairBack (Pair x y) = Pair y x - notUnifiableTest termHead child = do - OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier - Monad.guard (isOverloaded termHead) - notUnifiableError child - {- | Tests whether the pair of terms can be coerced to have the same constructors at the top, and, if so, returns the thus obtained new pair. From 3d3f2bd1d610adc62363bb386698704cf94dfe26 Mon Sep 17 00:00:00 2001 From: github-actions Date: Sun, 16 May 2021 04:57:58 +0000 Subject: [PATCH 20/86] Format with fourmolu --- kore/src/Kore/Builtin/Bool.hs | 14 +++++++------- kore/src/Kore/Builtin/Int.hs | 1 - kore/src/Kore/Step/Simplification/NoConfusion.hs | 7 +++---- 3 files changed, 10 insertions(+), 12 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index f3c6cd1456..8e53e0d922 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -189,13 +189,13 @@ unifyBool :: UnifyBool -> unifier (Pattern RewritingVariableName) unifyBool termLike1 termLike2 unifyData - | bool1 == bool2 - = return (Pattern.fromTermLike termLike1) - | otherwise - = Unify.explainAndReturnBottom - "different Bool domain values" - termLike1 - termLike2 + | bool1 == bool2 = + return (Pattern.fromTermLike termLike1) + | otherwise = + Unify.explainAndReturnBottom + "different Bool domain values" + termLike1 + termLike2 where UnifyBool{bool1, bool2} = unifyData diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index 502d1a4283..ca9250b888 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -457,7 +457,6 @@ unifyInt term1 term2 unifyData | on (==) internalIntValue int1 int2 = return $ Pattern.fromTermLike term1 | otherwise = explainAndReturnBottom "distinct integers" term1 term2 - where UnifyInt{int1, int2} = unifyData diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 90bae3886a..4211c7339f 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -25,7 +25,7 @@ import Prelude.Kore hiding ( concat, ) -data UnifyEqualInjectiveHeads= UnifyEqualInjectiveHeads +data UnifyEqualInjectiveHeads = UnifyEqualInjectiveHeads { firstHead :: Symbol , firstChildren :: [TermLike RewritingVariableName] , secondChildren :: [TermLike RewritingVariableName] @@ -39,9 +39,8 @@ matchEqualInjectiveHeadsAndEquals first second | App_ firstHead firstChildren <- first , App_ secondHead secondChildren <- second , Symbol.isInjective firstHead - -- We do not need to check if secondHead is injective once we test for equality. - , firstHead == secondHead - = + , -- We do not need to check if secondHead is injective once we test for equality. + firstHead == secondHead = Just UnifyEqualInjectiveHeads { firstHead From c3c67b2d99cc4c21217d67a0d9051c24242d5073 Mon Sep 17 00:00:00 2001 From: emarzion Date: Sun, 16 May 2021 23:47:10 -0500 Subject: [PATCH 21/86] Misc. cleanup. --- kore/src/Kore/Builtin/Bool.hs | 1 + kore/src/Kore/Builtin/Int.hs | 1 + kore/src/Kore/Builtin/KEqual.hs | 1 + kore/src/Kore/Step/Simplification/AndTerms.hs | 32 +++---------------- .../Kore/Step/Simplification/NoConfusion.hs | 8 ++--- 5 files changed, 12 insertions(+), 31 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index 8e53e0d922..38844b7e27 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -210,6 +210,7 @@ matchUnifyBoolAnd first second Just boolAnd | otherwise = Nothing +{-# INLINE matchUnifyBoolAnd #-} unifyBoolAnd :: forall unifier. diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index ca9250b888..fecba6bc8e 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -475,6 +475,7 @@ matchUnifyIntEq first second , Just value <- Bool.matchBool second = Just UnifyIntEq{eqTerm, value} | otherwise = Nothing +{-# INLINE matchUnifyIntEq #-} {- | Unification of the @INT.eq@ symbol. diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index e1983a849a..304b859f29 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -237,6 +237,7 @@ matchUnifyKequalsEq first second , Just value <- Bool.matchBool second = Just UnifyKequalsEq{eqTerm, value} | otherwise = Nothing +{-# INLINE matchUnifyKequalsEq #-} unifyKequalsEq :: forall unifier. diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index ff6eee74aa..f96aa6e77a 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -170,7 +170,7 @@ maybeTermEquals notSimplifier childTransformers injSimplifier isOverloaded first lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = lift $ constructorSortInjectionAndEquals first second - | Just () <- matchConstructorAndEqualsAssumesDifferentHeads isOverloaded first second = + | Just () <- matchDifferentConstructors isOverloaded first second = lift $ constructorAndEqualsAssumesDifferentHeads first second | otherwise = overloadedConstructorSortInjectionAndEquals childTransformers first second @@ -268,7 +268,7 @@ maybeTermAnd notSimplifier childTransformers injSimplifier isOverloaded first se lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = lift $ constructorSortInjectionAndEquals first second - | Just () <- matchConstructorAndEqualsAssumesDifferentHeads isOverloaded first second = + | Just () <- matchDifferentConstructors isOverloaded first second = lift $ constructorAndEqualsAssumesDifferentHeads first second | otherwise = overloadedConstructorSortInjectionAndEquals childTransformers first second @@ -339,6 +339,7 @@ matchBoolAnd term Just UnifyBoolAndTop | otherwise = Nothing +{-# INLINE matchBoolAnd #-} -- | Simplify the conjunction of terms where one is a predicate. boolAnd :: @@ -442,6 +443,7 @@ matchVariableFunctionAnd first second Just $ VariableFunctionAnd2 v | otherwise = Nothing +{-# INLINE matchVariableFunctionAnd #-} variableFunctionAnd :: MonadUnify unifier => @@ -457,30 +459,6 @@ variableFunctionAnd second unifyData = Condition.fromSingleSubstitution (Substitution.assign (inject v) second) --- variableFunctionAnd :: --- InternalVariable variable => --- MonadUnify unifier => --- TermLike variable -> --- TermLike variable -> --- MaybeT unifier (Pattern variable) --- variableFunctionAnd --- (ElemVar_ v1) --- second@(ElemVar_ _) = --- return $ Pattern.assign (inject v1) second --- variableFunctionAnd --- (ElemVar_ v) --- second --- | isFunctionPattern second = --- -- Ceil predicate not needed since 'second' being bottom --- -- will make the entire term bottom. However, one must --- -- be careful to not just drop the term. --- lift $ return (Pattern.withCondition second result) --- where --- result = --- Condition.fromSingleSubstitution --- (Substitution.assign (inject v) second) --- variableFunctionAnd _ _ = empty - matchVariableFunctionEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -542,7 +520,7 @@ matchSortInjectionAndEquals injSimplifier first second Left Unknown -> Nothing matchData -> Just SortInjectionAndEquals{inj1, inj2, matchData} | otherwise = Nothing -{-# INLINE sortInjectionAndEquals #-} +{-# INLINE matchSortInjectionAndEquals #-} {- | Simplify the conjunction of two sort injections. diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 4211c7339f..cdeaf58071 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -6,7 +6,7 @@ module Kore.Step.Simplification.NoConfusion ( equalInjectiveHeadsAndEquals, constructorAndEqualsAssumesDifferentHeads, matchEqualInjectiveHeadsAndEquals, - matchConstructorAndEqualsAssumesDifferentHeads, + matchDifferentConstructors, ) where import qualified Control.Monad as Monad @@ -85,12 +85,12 @@ equalInjectiveHeadsAndEquals , secondChildren } = unifyData -matchConstructorAndEqualsAssumesDifferentHeads :: +matchDifferentConstructors :: (Symbol -> Bool) -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe () -matchConstructorAndEqualsAssumesDifferentHeads +matchDifferentConstructors isOverloaded first second @@ -101,7 +101,7 @@ matchConstructorAndEqualsAssumesDifferentHeads , Symbol.isConstructor secondHead || isOverloaded secondHead = Just () | otherwise = empty -{-# INLINE matchConstructorAndEqualsAssumesDifferentHeads #-} +{-# INLINE matchDifferentConstructors #-} {- | Unify two constructor application patterns. From c193a1cef1ef08e44995182143fa07878387b542 Mon Sep 17 00:00:00 2001 From: emarzion Date: Mon, 17 May 2021 00:22:49 -0500 Subject: [PATCH 22/86] Adding inj args to InjUnify --- kore/src/Kore/Step/Simplification/AndTerms.hs | 12 ++--- .../Kore/Step/Simplification/InjSimplifier.hs | 53 +++++++++++-------- 2 files changed, 35 insertions(+), 30 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index f96aa6e77a..ca2ad29963 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -503,9 +503,8 @@ variableFunctionEquals (Substitution.assign (inject var) second) return (Pattern.withCondition second result) -data SortInjectionAndEquals = SortInjectionAndEquals - { inj1, inj2 :: Inj (TermLike RewritingVariableName) - , matchData :: Either Distinct InjUnify +newtype SortInjectionAndEquals = SortInjectionAndEquals + { matchData :: Either Distinct (InjUnify RewritingVariableName) } matchSortInjectionAndEquals :: @@ -518,7 +517,7 @@ matchSortInjectionAndEquals injSimplifier first second , Inj_ inj2 <- second = case matchInjs injSimplifier inj1 inj2 of Left Unknown -> Nothing - matchData -> Just SortInjectionAndEquals{inj1, inj2, matchData} + matchData -> Just SortInjectionAndEquals{matchData} | otherwise = Nothing {-# INLINE matchSortInjectionAndEquals #-} @@ -548,8 +547,7 @@ sortInjectionAndEquals :: SortInjectionAndEquals -> unifier (Pattern RewritingVariableName) sortInjectionAndEquals termMerger injSimplifier first second unifyData = do - -- injSimplifier <- Simplifier.askInjSimplifier - unifyInjs injSimplifier inj1 inj2 matchData & either distinct merge + unifyInjs injSimplifier matchData & either distinct merge where emptyIntersection = explainAndReturnBottom "Empty sort intersection" distinct Distinct = emptyIntersection first second @@ -561,7 +559,7 @@ sortInjectionAndEquals termMerger injSimplifier first second unifyData = do inj' = evaluateInj inj{injChild = childTerm} return $ Pattern.withCondition inj' childCondition - SortInjectionAndEquals{inj1, inj2, matchData} = unifyData + SortInjectionAndEquals{matchData} = unifyData matchConstructorSortInjectionAndEquals :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/InjSimplifier.hs b/kore/src/Kore/Step/Simplification/InjSimplifier.hs index 39cd2f29bf..14d616e552 100644 --- a/kore/src/Kore/Step/Simplification/InjSimplifier.hs +++ b/kore/src/Kore/Step/Simplification/InjSimplifier.hs @@ -43,10 +43,12 @@ data Distinct = Distinct | Unknown deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) deriving anyclass (Debug, Diff) -data InjUnify - = InjFromEqual - | InjFrom1SubsortInjFrom2 - | InjFrom2SubsortInjFrom1 +data InjPair variable = InjPair { inj1, inj2 :: Inj (TermLike variable) } + +data InjUnify variable + = InjFromEqual !(InjPair variable) + | InjFrom1SubsortInjFrom2 !(InjPair variable) + | InjFrom2SubsortInjFrom1 !(InjPair variable) data InjSimplifier = InjSimplifier { -- | Is 'injFrom' a proper subsort of 'injTo'? @@ -68,7 +70,7 @@ data InjSimplifier = InjSimplifier InternalVariable variable => Inj (TermLike variable) -> Inj (TermLike variable) -> - Either Distinct InjUnify + Either Distinct (InjUnify variable) , -- | Push down the conjunction of 'Inj': -- -- @ @@ -83,9 +85,7 @@ data InjSimplifier = InjSimplifier unifyInjs :: forall variable. InternalVariable variable => - Inj (TermLike variable) -> - Inj (TermLike variable) -> - Either Distinct InjUnify -> + Either Distinct (InjUnify variable) -> Either Distinct (Inj (Pair (TermLike variable))) , -- | Evaluate the 'Ceil' of 'Inj': -- @@ -176,12 +176,12 @@ mkInjSimplifier sortGraph = forall variable. Inj (TermLike variable) -> Inj (TermLike variable) -> - Either Distinct InjUnify + Either Distinct (InjUnify variable) matchInjs inj1 inj2 | injTo1 /= injTo2 = Left Distinct - | injFrom1 == injFrom2 = Right InjFromEqual - | injFrom2 `isSubsortOf'` injFrom1 = Right InjFrom2SubsortInjFrom1 - | injFrom1 `isSubsortOf'` injFrom2 = Right InjFrom1SubsortInjFrom2 + | injFrom1 == injFrom2 = Right $ InjFromEqual InjPair{inj1, inj2} + | injFrom2 `isSubsortOf'` injFrom1 = Right $ InjFrom2SubsortInjFrom1 InjPair{inj1, inj2} + | injFrom1 `isSubsortOf'` injFrom2 = Right $ InjFrom1SubsortInjFrom2 InjPair{inj1, inj2} -- If the child patterns are simplifiable, then they could eventually be -- simplified to produce matching sort injections, but if they are -- non-simplifiable, then they will never match. @@ -214,31 +214,38 @@ mkInjSimplifier sortGraph = unifyInjs :: forall variable. InternalVariable variable => - Inj (TermLike variable) -> - Inj (TermLike variable) -> - Either Distinct InjUnify -> + Either Distinct (InjUnify variable) -> Either Distinct (Inj (Pair (TermLike variable))) - unifyInjs inj1 inj2 unify = + unifyInjs unify = case unify of Left d -> Left d - Right InjFromEqual -> + Right (InjFromEqual injPair) -> assert (injTo1 == injTo2) $ do let child1 = injChild inj1 child2 = injChild inj2 pure (Pair child1 child2 <$ inj1) - Right InjFrom2SubsortInjFrom1 -> + where + InjPair{inj1, inj2} = injPair + Inj{injTo = injTo1} = inj1 + Inj{injTo = injTo2} = inj2 + Right (InjFrom2SubsortInjFrom1 injPair) -> assert (injTo1 == injTo2) $ do let child1' = injChild inj1 child2' = evaluateInj inj2{injTo = injFrom1} pure (Pair child1' child2' <$ inj1) - Right InjFrom1SubsortInjFrom2 -> + where + InjPair{inj1, inj2} = injPair + Inj{injFrom = injFrom1, injTo = injTo1} = inj1 + Inj{injTo = injTo2} = inj2 + Right (InjFrom1SubsortInjFrom2 injPair) -> assert (injTo1 == injTo2) $ do let child1' = evaluateInj inj1{injTo = injFrom2} child2' = injChild inj2 pure (Pair child1' child2' <$ inj2) - where - Inj{injFrom = injFrom1, injTo = injTo1} = inj1 - Inj{injFrom = injFrom2, injTo = injTo2} = inj2 + where + InjPair{inj1, inj2} = injPair + Inj{injTo = injTo1} = inj1 + Inj{injFrom = injFrom2, injTo = injTo2} = inj2 injectTermTo injProto injChild injTo = evaluateInj injProto{injFrom, injTo, injChild} @@ -252,7 +259,7 @@ unifyInj :: Inj (TermLike variable) -> Inj (TermLike variable) -> Either Distinct (Inj (Pair (TermLike variable))) -unifyInj injSimplifier inj1 inj2 = unifyInjs injSimplifier inj1 inj2 (matchInjs injSimplifier inj1 inj2) +unifyInj injSimplifier inj1 inj2 = unifyInjs injSimplifier (matchInjs injSimplifier inj1 inj2) normalize :: InjSimplifier -> From f8ce65c4fb5d1dc9b54b277d832052820a90d416 Mon Sep 17 00:00:00 2001 From: github-actions Date: Mon, 17 May 2021 05:25:03 +0000 Subject: [PATCH 23/86] Format with fourmolu --- kore/src/Kore/Step/Simplification/InjSimplifier.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kore/src/Kore/Step/Simplification/InjSimplifier.hs b/kore/src/Kore/Step/Simplification/InjSimplifier.hs index 14d616e552..e2c31b0506 100644 --- a/kore/src/Kore/Step/Simplification/InjSimplifier.hs +++ b/kore/src/Kore/Step/Simplification/InjSimplifier.hs @@ -43,7 +43,7 @@ data Distinct = Distinct | Unknown deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) deriving anyclass (Debug, Diff) -data InjPair variable = InjPair { inj1, inj2 :: Inj (TermLike variable) } +data InjPair variable = InjPair {inj1, inj2 :: Inj (TermLike variable)} data InjUnify variable = InjFromEqual !(InjPair variable) From 6b0a406a1ad3bcbff005d92b4db838ac7eafa747 Mon Sep 17 00:00:00 2001 From: emarzion Date: Mon, 17 May 2021 00:39:49 -0500 Subject: [PATCH 24/86] adding missing strict field annotations --- kore/src/Kore/Builtin/Bool.hs | 2 +- kore/src/Kore/Builtin/Int.hs | 7 +++---- kore/src/Kore/Builtin/KEqual.hs | 4 ++-- kore/src/Kore/Builtin/String.hs | 2 +- kore/src/Kore/Step/Simplification/AndTerms.hs | 14 +++++++------- kore/src/Kore/Step/Simplification/NoConfusion.hs | 6 +++--- 6 files changed, 17 insertions(+), 18 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index 38844b7e27..b6b27db101 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -166,7 +166,7 @@ builtinFunctions = implies a b = not a || b data UnifyBool = UnifyBool - { bool1, bool2 :: InternalBool + { bool1, bool2 :: !InternalBool } matchBools :: diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index fecba6bc8e..409b704787 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -429,8 +429,7 @@ matchIntEqual = & isJust data UnifyInt = UnifyInt - { int1 :: !InternalInt - , int2 :: !InternalInt + { int1, int2 :: !InternalInt } matchInt :: @@ -461,8 +460,8 @@ unifyInt term1 term2 unifyData UnifyInt{int1, int2} = unifyData data UnifyIntEq = UnifyIntEq - { eqTerm :: EqTerm (TermLike RewritingVariableName) - , value :: Bool + { eqTerm :: !(EqTerm (TermLike RewritingVariableName)) + , value :: !Bool } matchUnifyIntEq :: diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index 304b859f29..af9fe0ac45 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -223,8 +223,8 @@ matchKequalEq = & isJust data UnifyKequalsEq = UnifyKequalsEq - { eqTerm :: EqTerm (TermLike RewritingVariableName) - , value :: Bool + { eqTerm :: !(EqTerm (TermLike RewritingVariableName)) + , value :: !Bool } matchUnifyKequalsEq :: diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index baa9b00798..0dcb5dee8e 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -473,7 +473,7 @@ matchStringEqual = & isJust data UnifyString = UnifyString - { string1, string2 :: InternalString + { string1, string2 :: !InternalString } matchString :: diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index ca2ad29963..5401db5a6d 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -427,8 +427,8 @@ bottomTermEquals } data VariableFunctionAnd - = VariableFunctionAnd1 (ElementVariable RewritingVariableName) - | VariableFunctionAnd2 (ElementVariable RewritingVariableName) + = VariableFunctionAnd1 !(ElementVariable RewritingVariableName) + | VariableFunctionAnd2 !(ElementVariable RewritingVariableName) matchVariableFunctionAnd :: TermLike RewritingVariableName -> @@ -684,10 +684,10 @@ domainValueAndConstructorErrors domainValueAndConstructorErrors _ _ = empty data UnifyDomainValue = UnifyDomainValue - { sort1 :: Sort - , val1 :: TermLike RewritingVariableName - , sort2 :: Sort - , val2 :: TermLike RewritingVariableName + { sort1 :: !Sort + , val1 :: !(TermLike RewritingVariableName) + , sort2 :: !Sort + , val2 :: !(TermLike RewritingVariableName) } matchDomainValue :: @@ -741,7 +741,7 @@ cannotUnifyDomainValues :: cannotUnifyDomainValues = explainAndReturnBottom cannotUnifyDistinctDomainValues data UnifyStringLiteral = UnifyStringLiteral - { txt1, txt2 :: Text + { txt1, txt2 :: !Text } matchStringLiteral :: diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index cdeaf58071..fe937b82d2 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -26,9 +26,9 @@ import Prelude.Kore hiding ( ) data UnifyEqualInjectiveHeads = UnifyEqualInjectiveHeads - { firstHead :: Symbol - , firstChildren :: [TermLike RewritingVariableName] - , secondChildren :: [TermLike RewritingVariableName] + { firstHead :: !Symbol + , firstChildren :: ![TermLike RewritingVariableName] + , secondChildren :: ![TermLike RewritingVariableName] } matchEqualInjectiveHeadsAndEquals :: From 4e1715c44fd2a045a6f200c663c7eb3193afad95 Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 18 May 2021 01:57:10 -0500 Subject: [PATCH 25/86] documentation for matches + minor code fixes --- kore/src/Kore/Builtin/Bool.hs | 19 +++++- kore/src/Kore/Builtin/Int.hs | 7 ++- kore/src/Kore/Builtin/KEqual.hs | 4 ++ kore/src/Kore/Builtin/String.hs | 18 +++--- kore/src/Kore/Step/Simplification/AndTerms.hs | 59 +++++++++++-------- .../Kore/Step/Simplification/ExpandAlias.hs | 1 + .../Kore/Step/Simplification/NoConfusion.hs | 5 ++ 7 files changed, 75 insertions(+), 38 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index b6b27db101..ea48d77348 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -169,6 +169,8 @@ data UnifyBool = UnifyBool { bool1, bool2 :: !InternalBool } + +-- | Matches two Bool values. matchBools :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -180,7 +182,7 @@ matchBools first second | otherwise = Nothing {-# INLINE matchBools #-} --- | Unification of @BOOL.Bool@ values. +-- | When bool values are equal, returns first term; otherwise returns bottom. unifyBool :: forall unifier. MonadUnify unifier => @@ -199,6 +201,10 @@ unifyBool termLike1 termLike2 unifyData where UnifyBool{bool1, bool2} = unifyData +{- | Matches two terms when first is a true bool term + and the second is a function pattern matching + the @BOOL.and@ hooked symbol. +-} matchUnifyBoolAnd :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -249,13 +255,16 @@ unifyBothWith unify termLike1 operand1 operand2 = do unify' term1 term2 = Pattern.withoutTerm <$> unify term1 term2 +{- | Matches two terms when first is a false bool term + and the second is a function pattern matching + the @BOOL.or@ hooked symbol. +-} matchUnifyBoolOr :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe BoolOr matchUnifyBoolOr first second - | Just value1 <- matchBool first - , not value1 + | Just False <- matchBool first , Just boolOr <- matchBoolOr second , isFunctionPattern second = Just boolOr @@ -279,6 +288,10 @@ data UnifyBoolNot = UnifyBoolNot , value :: Bool } +{- | Matches two terms when second is a bool term + and the first is a function pattern matching + the @BOOL.not@ hooked symbol. +-} matchUnifyBoolNot :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index 409b704787..92c9903f98 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -432,6 +432,7 @@ data UnifyInt = UnifyInt { int1, int2 :: !InternalInt } +-- | Matches two Int values that have equals sorts. matchInt :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -444,7 +445,7 @@ matchInt first second | otherwise = Nothing {-# INLINE matchInt #-} --- | Unification of Int values. +-- | When int values are equal, returns first term; otherwise returns bottom. unifyInt :: forall unifier. MonadUnify unifier => @@ -464,6 +465,10 @@ data UnifyIntEq = UnifyIntEq , value :: !Bool } +{- | Matches two terms when second is a bool term + and the first is a function pattern matching + the @INT.eq@ hooked symbol. +-} matchUnifyIntEq :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index af9fe0ac45..76896a336a 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -227,6 +227,10 @@ data UnifyKequalsEq = UnifyKequalsEq , value :: !Bool } +{- | Matches two terms when second is a bool term + and the first is a function pattern matching + the @KEQUAL.eq@ hooked symbol. +-} matchUnifyKequalsEq :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index 0dcb5dee8e..a0f106df38 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -476,13 +476,15 @@ data UnifyString = UnifyString { string1, string2 :: !InternalString } +-- | Matches two String values with equal sorts. matchString :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe UnifyString matchString first second | InternalString_ string1 <- first - , InternalString_ string2 <- second = + , InternalString_ string2 <- second + , on (==) internalStringSort string1 string1 = Just UnifyString{string1, string2} | otherwise = Nothing {-# INLINE matchString #-} @@ -491,20 +493,16 @@ matchString first second unifyString :: forall unifier. MonadUnify unifier => - HasCallStack => TermLike RewritingVariableName -> TermLike RewritingVariableName -> UnifyString -> unifier (Pattern RewritingVariableName) -unifyString term1 term2 unifyData = - assert (on (==) internalStringSort string1 string2) worker - where - worker :: unifier (Pattern RewritingVariableName) - worker - | on (==) internalStringValue string1 string2 = - return $ Pattern.fromTermLike term1 - | otherwise = explainAndReturnBottom "distinct strings" term1 term2 +unifyString term1 term2 unifyData + | on (==) internalStringValue string1 string2 = + return $ Pattern.fromTermLike term1 + | otherwise = explainAndReturnBottom "distinct strings" term1 term2 + where UnifyString{string1, string2} = unifyData {- | Unification of the @STRING.eq@ symbol diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 5401db5a6d..287261ba16 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -329,6 +329,7 @@ data UnifyBoolAnd = UnifyBoolAndBottom | UnifyBoolAndTop +-- | Matches a term which is either top or bottom. matchBoolAnd :: TermLike RewritingVariableName -> Maybe UnifyBoolAnd @@ -364,6 +365,7 @@ explainBoolAndBottom :: explainBoolAndBottom term1 term2 = explainBottom "Cannot unify bottom." term1 term2 +-- | Matches two syntactically identical values. matchEqualsAndEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -374,7 +376,7 @@ matchEqualsAndEquals first second | otherwise = Nothing {-# INLINE matchEqualsAndEquals #-} --- | Unify two identical ('==') patterns. +-- | Returns the term as a pattern. equalAndEquals :: Monad unifier => TermLike RewritingVariableName -> @@ -383,6 +385,7 @@ equalAndEquals first = -- TODO (thomas.tuegel): Preserve simplified flags. return (Pattern.fromTermLike first) +-- | Matches a term which is Bottom. matchBottomTermEquals :: TermLike RewritingVariableName -> Maybe () @@ -430,6 +433,10 @@ data VariableFunctionAnd = VariableFunctionAnd1 !(ElementVariable RewritingVariableName) | VariableFunctionAnd2 !(ElementVariable RewritingVariableName) +{- | Matches two terms which are either + * two variables. + * the first a variable and the second a function pattern. +-} matchVariableFunctionAnd :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -459,6 +466,7 @@ variableFunctionAnd second unifyData = Condition.fromSingleSubstitution (Substitution.assign (inject v) second) +-- | Matches two terms when the first is a variable and the second is a function pattern. matchVariableFunctionEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -507,6 +515,13 @@ newtype SortInjectionAndEquals = SortInjectionAndEquals { matchData :: Either Distinct (InjUnify RewritingVariableName) } +{- | Matches two sort injections when either + * they have distinct codomains. + * they have identical domains. + * one domain is a subsort of the other. + * the child of either satisfies @hasConstructorLikeTop@. + * the subsorts of the domains are disjoint. +-} matchSortInjectionAndEquals :: InjSimplifier -> TermLike RewritingVariableName -> @@ -561,6 +576,7 @@ sortInjectionAndEquals termMerger injSimplifier first second unifyData = do SortInjectionAndEquals{matchData} = unifyData +-- | Matches a constructor application pattern with a sort injection pattern (symmetric in the two arguments) matchConstructorSortInjectionAndEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -684,20 +700,19 @@ domainValueAndConstructorErrors domainValueAndConstructorErrors _ _ = empty data UnifyDomainValue = UnifyDomainValue - { sort1 :: !Sort - , val1 :: !(TermLike RewritingVariableName) - , sort2 :: !Sort - , val2 :: !(TermLike RewritingVariableName) + { val1, val2 :: !(TermLike RewritingVariableName) } +-- | Matches two domain values with equal sorts. matchDomainValue :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe UnifyDomainValue matchDomainValue first second | DV_ sort1 val1 <- first - , DV_ sort2 val2 <- second = - Just UnifyDomainValue{sort1, val1, sort2, val2} + , DV_ sort2 val2 <- second + , sort1 == sort2 = + Just UnifyDomainValue{val1, val2} | otherwise = Nothing {-# INLINE matchDomainValue #-} @@ -713,22 +728,18 @@ See also: 'equalAndEquals' -- but it is not. unifyDomainValue :: forall unifier. - HasCallStack => MonadUnify unifier => TermLike RewritingVariableName -> TermLike RewritingVariableName -> UnifyDomainValue -> unifier (Pattern RewritingVariableName) -unifyDomainValue term1 term2 unifyData = - assert (sort1 == sort2) worker - where - worker :: unifier (Pattern RewritingVariableName) - worker - | val1 == val2 = - return $ Pattern.fromTermLike term1 - | otherwise = cannotUnifyDomainValues term1 term2 +unifyDomainValue term1 term2 unifyData + | val1 == val2 = + return $ Pattern.fromTermLike term1 + | otherwise = cannotUnifyDomainValues term1 term2 - UnifyDomainValue{sort1, val1, sort2, val2} = unifyData + where + UnifyDomainValue{val1, val2} = unifyData cannotUnifyDistinctDomainValues :: Pretty.Doc () cannotUnifyDistinctDomainValues = "distinct domain values" @@ -744,6 +755,8 @@ data UnifyStringLiteral = UnifyStringLiteral { txt1, txt2 :: !Text } + +-- | Matches two string literal values. matchStringLiteral :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -769,14 +782,11 @@ unifyStringLiteral :: TermLike RewritingVariableName -> UnifyStringLiteral -> unifier (Pattern RewritingVariableName) -unifyStringLiteral term1 term2 unifyData = worker - where - worker :: unifier (Pattern RewritingVariableName) - worker - | txt1 == txt2 = - return $ Pattern.fromTermLike term1 - | otherwise = explainAndReturnBottom "distinct string literals" term1 term2 +unifyStringLiteral term1 term2 unifyData + | txt1 == txt2 = return $ Pattern.fromTermLike term1 + | otherwise = explainAndReturnBottom "distinct string literals" term1 term2 + where UnifyStringLiteral{txt1, txt2} = unifyData {- | Unify any two function patterns. @@ -819,6 +829,7 @@ compareForEquals first second | isConstructorLike second = GT | otherwise = compare first second +-- | Matches two constant byte values with distinct values. matchBytesDifferent :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/ExpandAlias.hs b/kore/src/Kore/Step/Simplification/ExpandAlias.hs index 6f18455ab1..af0a53bf3c 100644 --- a/kore/src/Kore/Step/Simplification/ExpandAlias.hs +++ b/kore/src/Kore/Step/Simplification/ExpandAlias.hs @@ -33,6 +33,7 @@ data UnifyExpandAlias = UnifyExpandAlias { term1, term2 :: !(TermLike RewritingVariableName) } +-- | Matches two terms when either is an @ApplyAlias_@ pattern. matchExpandAlias :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index fe937b82d2..23fc79c474 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -31,6 +31,8 @@ data UnifyEqualInjectiveHeads = UnifyEqualInjectiveHeads , secondChildren :: ![TermLike RewritingVariableName] } + +-- | Matches two application patterns with equal, injective heads. matchEqualInjectiveHeadsAndEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -85,6 +87,9 @@ equalInjectiveHeadsAndEquals , secondChildren } = unifyData +{- | Matches two application patterns with distinct + heads which are either constructors or overloaded. +-} matchDifferentConstructors :: (Symbol -> Bool) -> TermLike RewritingVariableName -> From 8453e9f960a5badf95e776c5947001774334a46d Mon Sep 17 00:00:00 2001 From: github-actions Date: Tue, 18 May 2021 06:59:24 +0000 Subject: [PATCH 26/86] Format with fourmolu --- kore/src/Kore/Builtin/Bool.hs | 1 - kore/src/Kore/Builtin/String.hs | 1 - kore/src/Kore/Step/Simplification/AndTerms.hs | 3 --- kore/src/Kore/Step/Simplification/NoConfusion.hs | 1 - 4 files changed, 6 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index ea48d77348..f2ef2f33c2 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -169,7 +169,6 @@ data UnifyBool = UnifyBool { bool1, bool2 :: !InternalBool } - -- | Matches two Bool values. matchBools :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index a0f106df38..5df57fdee7 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -501,7 +501,6 @@ unifyString term1 term2 unifyData | on (==) internalStringValue string1 string2 = return $ Pattern.fromTermLike term1 | otherwise = explainAndReturnBottom "distinct strings" term1 term2 - where UnifyString{string1, string2} = unifyData diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 287261ba16..9d0117be8f 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -737,7 +737,6 @@ unifyDomainValue term1 term2 unifyData | val1 == val2 = return $ Pattern.fromTermLike term1 | otherwise = cannotUnifyDomainValues term1 term2 - where UnifyDomainValue{val1, val2} = unifyData @@ -755,7 +754,6 @@ data UnifyStringLiteral = UnifyStringLiteral { txt1, txt2 :: !Text } - -- | Matches two string literal values. matchStringLiteral :: TermLike RewritingVariableName -> @@ -785,7 +783,6 @@ unifyStringLiteral :: unifyStringLiteral term1 term2 unifyData | txt1 == txt2 = return $ Pattern.fromTermLike term1 | otherwise = explainAndReturnBottom "distinct string literals" term1 term2 - where UnifyStringLiteral{txt1, txt2} = unifyData diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 23fc79c474..058430f0cf 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -31,7 +31,6 @@ data UnifyEqualInjectiveHeads = UnifyEqualInjectiveHeads , secondChildren :: ![TermLike RewritingVariableName] } - -- | Matches two application patterns with equal, injective heads. matchEqualInjectiveHeadsAndEquals :: TermLike RewritingVariableName -> From 2bbf1ba270b7115bb6cafe072edb8e514d7d9f22 Mon Sep 17 00:00:00 2001 From: emarzion Date: Wed, 19 May 2021 00:03:45 -0500 Subject: [PATCH 27/86] reverting the removal of assertions --- kore/src/Kore/Builtin/Int.hs | 16 +++++++++------- kore/src/Kore/Builtin/String.hs | 14 ++++++++------ 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index 92c9903f98..689f1c10f1 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -432,15 +432,14 @@ data UnifyInt = UnifyInt { int1, int2 :: !InternalInt } --- | Matches two Int values that have equals sorts. +-- | Matches two Int values. matchInt :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe UnifyInt matchInt first second | InternalInt_ int1 <- first - , InternalInt_ int2 <- second - , on (==) internalIntSort int1 int2 = + , InternalInt_ int2 <- second = Just UnifyInt{int1, int2} | otherwise = Nothing {-# INLINE matchInt #-} @@ -453,12 +452,15 @@ unifyInt :: TermLike RewritingVariableName -> UnifyInt -> unifier (Pattern RewritingVariableName) -unifyInt term1 term2 unifyData - | on (==) internalIntValue int1 int2 = - return $ Pattern.fromTermLike term1 - | otherwise = explainAndReturnBottom "distinct integers" term1 term2 +unifyInt term1 term2 unifyData = + assert (on (==) internalIntSort int1 int2) worker where UnifyInt{int1, int2} = unifyData + worker :: unifier (Pattern RewritingVariableName) + worker + | on (==) internalIntValue int1 int2 = + return $ Pattern.fromTermLike term1 + | otherwise = explainAndReturnBottom "distinct integers" term1 term2 data UnifyIntEq = UnifyIntEq { eqTerm :: !(EqTerm (TermLike RewritingVariableName)) diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index 5df57fdee7..23064294da 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -483,8 +483,7 @@ matchString :: Maybe UnifyString matchString first second | InternalString_ string1 <- first - , InternalString_ string2 <- second - , on (==) internalStringSort string1 string1 = + , InternalString_ string2 <- second = Just UnifyString{string1, string2} | otherwise = Nothing {-# INLINE matchString #-} @@ -497,11 +496,14 @@ unifyString :: TermLike RewritingVariableName -> UnifyString -> unifier (Pattern RewritingVariableName) -unifyString term1 term2 unifyData - | on (==) internalStringValue string1 string2 = - return $ Pattern.fromTermLike term1 - | otherwise = explainAndReturnBottom "distinct strings" term1 term2 +unifyString term1 term2 unifyData = + assert (on (==) internalStringSort string1 string2) worker where + worker :: unifier (Pattern RewritingVariableName) + worker + | on (==) internalStringValue string1 string2 = + return $ Pattern.fromTermLike term1 + | otherwise = explainAndReturnBottom "distinct strings" term1 term2 UnifyString{string1, string2} = unifyData {- | Unification of the @STRING.eq@ symbol From 1dff14b2614d3dfb44801d106423858a8bf6a33e Mon Sep 17 00:00:00 2001 From: emarzion Date: Thu, 20 May 2021 01:01:29 -0500 Subject: [PATCH 28/86] Fixing documentation + removal of unncess. type annotation --- kore/src/Kore/Builtin/Bool.hs | 59 +++++-- kore/src/Kore/Builtin/Int.hs | 21 ++- kore/src/Kore/Builtin/KEqual.hs | 14 ++ kore/src/Kore/Builtin/String.hs | 14 +- kore/src/Kore/Step/Simplification/AndTerms.hs | 148 ++++++++++++++++-- .../Kore/Step/Simplification/ExpandAlias.hs | 2 +- .../Kore/Step/Simplification/NoConfusion.hs | 32 +++- .../Kore/Step/Simplification/Overloading.hs | 2 +- 8 files changed, 258 insertions(+), 34 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index f2ef2f33c2..61ad7d741e 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -169,7 +169,19 @@ data UnifyBool = UnifyBool { bool1, bool2 :: !InternalBool } --- | Matches two Bool values. +{- | Matches + +@ +\\equals{_, _}(\\dv{Bool}(_), \\dv{Bool}(_)) +@ + +and + +@ +\\and{_}(\\dv{Bool}(_), \\dv{Bool}(_)) +@ + +-} matchBools :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -200,9 +212,18 @@ unifyBool termLike1 termLike2 unifyData where UnifyBool{bool1, bool2} = unifyData -{- | Matches two terms when first is a true bool term - and the second is a function pattern matching - the @BOOL.and@ hooked symbol. +{- | Matches + +@ +\\equals{_, _}(\\dv{Bool}("true"), andBool(_,_)) +@ + +and + +@ +\\and{_}(\\dv{Bool}("true"), andBool(_,_)) +@ + -} matchUnifyBoolAnd :: TermLike RewritingVariableName -> @@ -254,9 +275,18 @@ unifyBothWith unify termLike1 operand1 operand2 = do unify' term1 term2 = Pattern.withoutTerm <$> unify term1 term2 -{- | Matches two terms when first is a false bool term - and the second is a function pattern matching - the @BOOL.or@ hooked symbol. +{- | Matches + +@ +\\equals{_, _}(\\dv{Bool}("false"), boolOr(_,_)) +@ + +and + +@ +\\and{_}(\\dv{Bool}("false"), boolOr(_,_)) +@ + -} matchUnifyBoolOr :: TermLike RewritingVariableName -> @@ -287,9 +317,18 @@ data UnifyBoolNot = UnifyBoolNot , value :: Bool } -{- | Matches two terms when second is a bool term - and the first is a function pattern matching - the @BOOL.not@ hooked symbol. +{- | Matches + +@ +\\equals{_, _}(notBool(_), \\dv{Bool}(_)) +@ + +and + +@ +\\and{_}(notBool(_), \\dv{Bool}(_)) +@ + -} matchUnifyBoolNot :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index 689f1c10f1..acf246cb42 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -432,7 +432,19 @@ data UnifyInt = UnifyInt { int1, int2 :: !InternalInt } --- | Matches two Int values. +{- | Matches + +@ +\\equals{_, _}(\\dv{Int}(_), \\dv{Int}(_)) +@ + +and + +@ +\\and{_}(\\dv{Int}(_), \\dv{Int}(_)) +@ + +-} matchInt :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -467,9 +479,10 @@ data UnifyIntEq = UnifyIntEq , value :: !Bool } -{- | Matches two terms when second is a bool term - and the first is a function pattern matching - the @INT.eq@ hooked symbol. +{- | Matches +@ +\\equals{_, _}(eqInt{_}(_, _), \\dv{Bool}(_)) +@ -} matchUnifyIntEq :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index 76896a336a..2911f45498 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -231,6 +231,20 @@ data UnifyKequalsEq = UnifyKequalsEq and the first is a function pattern matching the @KEQUAL.eq@ hooked symbol. -} + +{- | Matches + +@ +\\equals{_, _}(eq(_,_), \\dv{Bool}(_)) +@ + +and + +@ +\\and{_}(eq(_,_), \\dv{Bool}(_)) +@ + +-} matchUnifyKequalsEq :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index 23064294da..c9da51b6b0 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -476,7 +476,19 @@ data UnifyString = UnifyString { string1, string2 :: !InternalString } --- | Matches two String values with equal sorts. +{- | Matches + +@ +\\equals{_, _}(\\dv{String}(_), \\dv{String}(_)) +@ + +and + +@ +\\and{_}(\\dv{String}(_), \\dv{String}}(_)) +@ + +-} matchString :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 9d0117be8f..e88985e843 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -329,7 +329,19 @@ data UnifyBoolAnd = UnifyBoolAndBottom | UnifyBoolAndTop --- | Matches a term which is either top or bottom. +{- | Matches + +@ +\\and{_}(\\bottom, _) +@ + +and + +@ +\\and{_}(\\top, _) +@ + +-} matchBoolAnd :: TermLike RewritingVariableName -> Maybe UnifyBoolAnd @@ -365,7 +377,19 @@ explainBoolAndBottom :: explainBoolAndBottom term1 term2 = explainBottom "Cannot unify bottom." term1 term2 --- | Matches two syntactically identical values. +{- | Matches + +@ +\\equals{_, _}(t, t) +@ + +and + +@ +\\and{_}(t, t) +@ + +-} matchEqualsAndEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -385,7 +409,13 @@ equalAndEquals first = -- TODO (thomas.tuegel): Preserve simplified flags. return (Pattern.fromTermLike first) --- | Matches a term which is Bottom. +{- | Matches + +@ +\\equals{_, _}(\\bottom, _) +@ + +-} matchBottomTermEquals :: TermLike RewritingVariableName -> Maybe () @@ -466,7 +496,19 @@ variableFunctionAnd second unifyData = Condition.fromSingleSubstitution (Substitution.assign (inject v) second) --- | Matches two terms when the first is a variable and the second is a function pattern. +{- | Matches + +@ +\\equals{_, _}(x, f(_)) +@ + +and + +@ +\\and{_}(x, f(_)) +@ + +-} matchVariableFunctionEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -515,12 +557,26 @@ newtype SortInjectionAndEquals = SortInjectionAndEquals { matchData :: Either Distinct (InjUnify RewritingVariableName) } -{- | Matches two sort injections when either - * they have distinct codomains. - * they have identical domains. - * one domain is a subsort of the other. - * the child of either satisfies @hasConstructorLikeTop@. - * the subsorts of the domains are disjoint. +{- | Matches + +@ +\\equals{_, _}(inj{sub, super}(children), inj{sub', super'}(children')) +@ + +and + +@ +\\and{_}(inj{sub, super}(children), inj{sub', super'}(children')) +@ + +when either + +* @super /= super'@ +* @sub == sub'@ +* @sub@ is a subsort of @sub'@ or vice-versa. +* @children@ or @children'@ satisfies @hasConstructorLikeTop@. +* the subsorts of @sub, sub'@ are disjoint. + -} matchSortInjectionAndEquals :: InjSimplifier -> @@ -576,7 +632,29 @@ sortInjectionAndEquals termMerger injSimplifier first second unifyData = do SortInjectionAndEquals{matchData} = unifyData --- | Matches a constructor application pattern with a sort injection pattern (symmetric in the two arguments) +{- | Matches + +@ +\\equals{_, _}(inj{_,_}(_), f(_)) +@ + +@ +\\equals{_, _}(f(_), inj{_,_}(_)) +@ + +and + +@ +\\and{_}(inj{_,_}(_), f(_)) +@ + +@ +\\and{_}(f(_), inj{_,_}(_)) +@ + +when @f@ has the @constructor@ attribute. + +-} matchConstructorSortInjectionAndEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -703,7 +781,19 @@ data UnifyDomainValue = UnifyDomainValue { val1, val2 :: !(TermLike RewritingVariableName) } --- | Matches two domain values with equal sorts. +{- | Matches + +@ +\\equals{_, _}(\\dv{s}(_), \\dv{s}(_)) +@ + +and + +@ +\\and{_}(\\dv{s}(_), \\dv{s}(_)) +@ + +-} matchDomainValue :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -754,7 +844,19 @@ data UnifyStringLiteral = UnifyStringLiteral { txt1, txt2 :: !Text } --- | Matches two string literal values. +{- | Matches + +@ +\\equals{_, _}("str1", "str1") +@ + +and + +@ +\\and{_}("str1", "str2") +@ + +-} matchStringLiteral :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -826,7 +928,25 @@ compareForEquals first second | isConstructorLike second = GT | otherwise = compare first second --- | Matches two constant byte values with distinct values. +{- | Matches + +@ +\\equals{_, _}(\\dv{Bytes}(bytes1), \\dv{Bytes}(bytes2)) +@ + +and + +@ +\\and{_}(\\dv{Bytes}(bytes1), \\dv{Bytes}(bytes2)) +@ + +when + +@ +bytes1 /= bytes2 +@ + +-} matchBytesDifferent :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/ExpandAlias.hs b/kore/src/Kore/Step/Simplification/ExpandAlias.hs index af0a53bf3c..2cea94a686 100644 --- a/kore/src/Kore/Step/Simplification/ExpandAlias.hs +++ b/kore/src/Kore/Step/Simplification/ExpandAlias.hs @@ -33,7 +33,7 @@ data UnifyExpandAlias = UnifyExpandAlias { term1, term2 :: !(TermLike RewritingVariableName) } --- | Matches two terms when either is an @ApplyAlias_@ pattern. +-- | Matches two terms when either is an alias. matchExpandAlias :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 058430f0cf..976508aead 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -31,7 +31,21 @@ data UnifyEqualInjectiveHeads = UnifyEqualInjectiveHeads , secondChildren :: ![TermLike RewritingVariableName] } --- | Matches two application patterns with equal, injective heads. +{- | Matches + +@ +\\equals{_, _}(f(_), f(_)) +@ + +and + +@ +\\and{_}(f(_), f(_)) +@ + +when @f@ is injective. + +-} matchEqualInjectiveHeadsAndEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -86,8 +100,20 @@ equalInjectiveHeadsAndEquals , secondChildren } = unifyData -{- | Matches two application patterns with distinct - heads which are either constructors or overloaded. + +{- | Matches + +@ +\\equals{_, _}(f(_), g(_)) +@ + +and + +@ +\\and{_}(f(_), g(_)) +@ + +when @f /= g@ and @f,g@ either have the @constructor@ attribute or are overloaded. -} matchDifferentConstructors :: (Symbol -> Bool) -> diff --git a/kore/src/Kore/Step/Simplification/Overloading.hs b/kore/src/Kore/Step/Simplification/Overloading.hs index 1281f9b361..f4072e9185 100644 --- a/kore/src/Kore/Step/Simplification/Overloading.hs +++ b/kore/src/Kore/Step/Simplification/Overloading.hs @@ -465,7 +465,7 @@ mkInj :: Inj () -> TermLike RewritingVariableName -> TermLike RewritingVariableName -mkInj inj injChild = (synthesize . InjF) (inj :: Inj ()){injChild} +mkInj inj injChild = (synthesize . InjF) inj{injChild} maybeMkInj :: Maybe (Inj ()) -> From 41ae18b04dfc0cade57d24edff86e32d8e430a39 Mon Sep 17 00:00:00 2001 From: github-actions Date: Thu, 20 May 2021 06:10:53 +0000 Subject: [PATCH 29/86] Format with fourmolu --- kore/src/Kore/Builtin/Bool.hs | 4 ---- kore/src/Kore/Builtin/Int.hs | 1 - kore/src/Kore/Builtin/KEqual.hs | 1 - kore/src/Kore/Builtin/String.hs | 1 - kore/src/Kore/Step/Simplification/AndTerms.hs | 9 --------- kore/src/Kore/Step/Simplification/NoConfusion.hs | 2 -- 6 files changed, 18 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index 61ad7d741e..b7c5ee2592 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -180,7 +180,6 @@ and @ \\and{_}(\\dv{Bool}(_), \\dv{Bool}(_)) @ - -} matchBools :: TermLike RewritingVariableName -> @@ -223,7 +222,6 @@ and @ \\and{_}(\\dv{Bool}("true"), andBool(_,_)) @ - -} matchUnifyBoolAnd :: TermLike RewritingVariableName -> @@ -286,7 +284,6 @@ and @ \\and{_}(\\dv{Bool}("false"), boolOr(_,_)) @ - -} matchUnifyBoolOr :: TermLike RewritingVariableName -> @@ -328,7 +325,6 @@ and @ \\and{_}(notBool(_), \\dv{Bool}(_)) @ - -} matchUnifyBoolNot :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index acf246cb42..1b5b71655c 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -443,7 +443,6 @@ and @ \\and{_}(\\dv{Int}(_), \\dv{Int}(_)) @ - -} matchInt :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index 2911f45498..c1b34ed3d2 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -243,7 +243,6 @@ and @ \\and{_}(eq(_,_), \\dv{Bool}(_)) @ - -} matchUnifyKequalsEq :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index c9da51b6b0..17f3d1ecbb 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -487,7 +487,6 @@ and @ \\and{_}(\\dv{String}(_), \\dv{String}}(_)) @ - -} matchString :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index e88985e843..15862daab8 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -340,7 +340,6 @@ and @ \\and{_}(\\top, _) @ - -} matchBoolAnd :: TermLike RewritingVariableName -> @@ -388,7 +387,6 @@ and @ \\and{_}(t, t) @ - -} matchEqualsAndEquals :: TermLike RewritingVariableName -> @@ -414,7 +412,6 @@ equalAndEquals first = @ \\equals{_, _}(\\bottom, _) @ - -} matchBottomTermEquals :: TermLike RewritingVariableName -> @@ -507,7 +504,6 @@ and @ \\and{_}(x, f(_)) @ - -} matchVariableFunctionEquals :: TermLike RewritingVariableName -> @@ -576,7 +572,6 @@ when either * @sub@ is a subsort of @sub'@ or vice-versa. * @children@ or @children'@ satisfies @hasConstructorLikeTop@. * the subsorts of @sub, sub'@ are disjoint. - -} matchSortInjectionAndEquals :: InjSimplifier -> @@ -653,7 +648,6 @@ and @ when @f@ has the @constructor@ attribute. - -} matchConstructorSortInjectionAndEquals :: TermLike RewritingVariableName -> @@ -792,7 +786,6 @@ and @ \\and{_}(\\dv{s}(_), \\dv{s}(_)) @ - -} matchDomainValue :: TermLike RewritingVariableName -> @@ -855,7 +848,6 @@ and @ \\and{_}("str1", "str2") @ - -} matchStringLiteral :: TermLike RewritingVariableName -> @@ -945,7 +937,6 @@ when @ bytes1 /= bytes2 @ - -} matchBytesDifferent :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 976508aead..6fe7ad3b15 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -44,7 +44,6 @@ and @ when @f@ is injective. - -} matchEqualInjectiveHeadsAndEquals :: TermLike RewritingVariableName -> @@ -100,7 +99,6 @@ equalInjectiveHeadsAndEquals , secondChildren } = unifyData - {- | Matches @ From b130fca13deae1abd2e79ba01f6634ca0b373c7c Mon Sep 17 00:00:00 2001 From: emarzion Date: Thu, 20 May 2021 10:16:55 -0500 Subject: [PATCH 30/86] changing matchBytesDifferent to matchBytes --- kore/src/Kore/Step/Simplification/AndTerms.hs | 40 ++++++++++--------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 15862daab8..4296f8babe 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -154,8 +154,8 @@ maybeTermEquals notSimplifier childTransformers injSimplifier isOverloaded first lift $ unifyStringLiteral first second unifyData | Just () <- matchEqualsAndEquals first second = lift $ equalAndEquals first - | Just () <- matchBytesDifferent first second = - lift bytesDifferent + | Just unifyData <- matchBytes first second = + lift $ bytesDifferent unifyData | Just () <- matchBottomTermEquals first = lift $ bottomTermEquals SideCondition.topTODO first second | Just () <- matchBottomTermEquals second = @@ -256,8 +256,8 @@ maybeTermAnd notSimplifier childTransformers injSimplifier isOverloaded first se lift $ unifyStringLiteral first second unifyData | Just () <- matchEqualsAndEquals first second = lift $ equalAndEquals first - | Just () <- matchBytesDifferent first second = - lift bytesDifferent + | Just unifyData <- matchBytes first second = + lift $ bytesDifferent unifyData | Just unifyData <- matchVariableFunctionAnd first second = lift $ variableFunctionAnd second unifyData | Just unifyData <- matchVariableFunctionAnd second first = @@ -920,6 +920,10 @@ compareForEquals first second | isConstructorLike second = GT | otherwise = compare first second +data UnifyBytes = UnifyBytes { + bytes1, bytes2 :: InternalBytes +} + {- | Matches @ @@ -932,26 +936,24 @@ and \\and{_}(\\dv{Bytes}(bytes1), \\dv{Bytes}(bytes2)) @ -when - -@ -bytes1 /= bytes2 -@ -} -matchBytesDifferent :: +matchBytes :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe () -matchBytesDifferent first second - | _ :< InternalBytesF (Const bytesFirst) <- Recursive.project first - , _ :< InternalBytesF (Const bytesSecond) <- Recursive.project second - , bytesFirst /= bytesSecond = - Just () + Maybe UnifyBytes +matchBytes first second + | _ :< InternalBytesF (Const bytes1) <- Recursive.project first + , _ :< InternalBytesF (Const bytes2) <- Recursive.project second = + Just UnifyBytes{bytes1, bytes2} | otherwise = Nothing -{-# INLINE matchBytesDifferent #-} +{-# INLINE matchBytes #-} bytesDifferent :: MonadUnify unifier => + UnifyBytes -> unifier (Pattern RewritingVariableName) -bytesDifferent = - return Pattern.bottom +bytesDifferent UnifyBytes{ bytes1, bytes2 } + | bytes1 == bytes2 = + return $ Pattern.fromTermLike $ mkInternalBytes' bytes1 + | otherwise = + empty \ No newline at end of file From c9ad5996d7d64f43280d065fa01db80adde8e8e4 Mon Sep 17 00:00:00 2001 From: github-actions Date: Thu, 20 May 2021 15:19:12 +0000 Subject: [PATCH 31/86] Format with fourmolu --- kore/src/Kore/Step/Simplification/AndTerms.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 4296f8babe..6636d4abb7 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -920,9 +920,9 @@ compareForEquals first second | isConstructorLike second = GT | otherwise = compare first second -data UnifyBytes = UnifyBytes { - bytes1, bytes2 :: InternalBytes -} +data UnifyBytes = UnifyBytes + { bytes1, bytes2 :: InternalBytes + } {- | Matches @@ -935,7 +935,6 @@ and @ \\and{_}(\\dv{Bytes}(bytes1), \\dv{Bytes}(bytes2)) @ - -} matchBytes :: TermLike RewritingVariableName -> @@ -952,8 +951,8 @@ bytesDifferent :: MonadUnify unifier => UnifyBytes -> unifier (Pattern RewritingVariableName) -bytesDifferent UnifyBytes{ bytes1, bytes2 } +bytesDifferent UnifyBytes{bytes1, bytes2} | bytes1 == bytes2 = return $ Pattern.fromTermLike $ mkInternalBytes' bytes1 | otherwise = - empty \ No newline at end of file + empty From ff9315da1acfee29f16044afc6ee697e87f5636e Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 21 May 2021 05:22:56 -0500 Subject: [PATCH 32/86] Apply worker-wrapper transformation Apply a worker-wrapper transformation to functions maybeTermAnd and maybeTermEquals to preserve their encapsulation and avoid passing redundant arguments. --- kore/src/Kore/Step/Simplification/And.hs | 11 +- kore/src/Kore/Step/Simplification/AndTerms.hs | 170 +++++++++--------- kore/src/Kore/Step/Simplification/Equals.hs | 7 +- 3 files changed, 92 insertions(+), 96 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/And.hs b/kore/src/Kore/Step/Simplification/And.hs index 1382596ff5..d704576ecd 100644 --- a/kore/src/Kore/Step/Simplification/And.hs +++ b/kore/src/Kore/Step/Simplification/And.hs @@ -56,7 +56,6 @@ import Kore.Step.Simplification.AndTerms ( maybeTermAnd, ) import Kore.Step.Simplification.NotSimplifier -import Kore.Step.Simplification.OverloadSimplifier import Kore.Step.Simplification.Simplify import qualified Kore.Step.Substitution as Substitution import Kore.Unification.UnifierT ( @@ -228,11 +227,9 @@ termAnd notSimplifier p1 p2 = TermLike RewritingVariableName -> TermLike RewritingVariableName -> UnifierT simplifier (Pattern RewritingVariableName) - termAndWorker first second = do - injSimplifier <- askInjSimplifier - OverloadSimplifier{isOverloaded} <- askOverloadSimplifier - let maybeTermAnd' = maybeTermAnd notSimplifier termAndWorker injSimplifier isOverloaded first second - patt <- runMaybeT maybeTermAnd' - return $ fromMaybe andPattern patt + termAndWorker first second = + maybeTermAnd notSimplifier termAndWorker first second + & runMaybeT + & fmap (fromMaybe andPattern) where andPattern = Pattern.fromTermLike (mkAnd first second) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 6636d4abb7..61b34ada67 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -113,12 +113,10 @@ termUnification notSimplifier = \term1 term2 -> TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) termUnificationWorker pat1 pat2 = do - injSimplifier <- Simplifier.askInjSimplifier - OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier let maybeTermUnification :: MaybeT unifier (Pattern RewritingVariableName) maybeTermUnification = - maybeTermAnd notSimplifier termUnificationWorker injSimplifier isOverloaded pat1 pat2 + maybeTermAnd notSimplifier termUnificationWorker pat1 pat2 Error.maybeT (incompleteUnificationPattern pat1 pat2) pure @@ -136,46 +134,49 @@ maybeTermEquals :: NotSimplifier unifier -> -- | Used to simplify subterm "and". TermSimplifier RewritingVariableName unifier -> - InjSimplifier -> - (Symbol -> Bool) -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) -maybeTermEquals notSimplifier childTransformers injSimplifier isOverloaded first second - | Just unifyData <- Builtin.Int.matchInt first second = - lift $ Builtin.Int.unifyInt first second unifyData - | Just unifyData <- Builtin.Bool.matchBools first second = - lift $ Builtin.Bool.unifyBool first second unifyData - | Just unifyData <- Builtin.String.matchString first second = - lift $ Builtin.String.unifyString first second unifyData - | Just unifyData <- matchDomainValue first second = - lift $ unifyDomainValue first second unifyData - | Just unifyData <- matchStringLiteral first second = - lift $ unifyStringLiteral first second unifyData - | Just () <- matchEqualsAndEquals first second = - lift $ equalAndEquals first - | Just unifyData <- matchBytes first second = - lift $ bytesDifferent unifyData - | Just () <- matchBottomTermEquals first = - lift $ bottomTermEquals SideCondition.topTODO first second - | Just () <- matchBottomTermEquals second = - lift $ bottomTermEquals SideCondition.topTODO second first - | Just var <- matchVariableFunctionEquals first second = - lift $ variableFunctionEquals first second var - | Just var <- matchVariableFunctionEquals second first = - lift $ variableFunctionEquals second first var - | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = - lift $ equalInjectiveHeadsAndEquals childTransformers unifyData - | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second = - lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData - | Just () <- matchConstructorSortInjectionAndEquals first second = - lift $ constructorSortInjectionAndEquals first second - | Just () <- matchDifferentConstructors isOverloaded first second = - lift $ constructorAndEqualsAssumesDifferentHeads first second - | otherwise = - overloadedConstructorSortInjectionAndEquals childTransformers first second - <|> rest +maybeTermEquals notSimplifier childTransformers first second = do + injSimplifier <- Simplifier.askInjSimplifier + OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier + worker injSimplifier isOverloaded where + worker injSimplifier isOverloaded + | Just unifyData <- Builtin.Int.matchInt first second = + lift $ Builtin.Int.unifyInt first second unifyData + | Just unifyData <- Builtin.Bool.matchBools first second = + lift $ Builtin.Bool.unifyBool first second unifyData + | Just unifyData <- Builtin.String.matchString first second = + lift $ Builtin.String.unifyString first second unifyData + | Just unifyData <- matchDomainValue first second = + lift $ unifyDomainValue first second unifyData + | Just unifyData <- matchStringLiteral first second = + lift $ unifyStringLiteral first second unifyData + | Just () <- matchEqualsAndEquals first second = + lift $ equalAndEquals first + | Just unifyData <- matchBytes first second = + lift $ bytesDifferent unifyData + | Just () <- matchBottomTermEquals first = + lift $ bottomTermEquals SideCondition.topTODO first second + | Just () <- matchBottomTermEquals second = + lift $ bottomTermEquals SideCondition.topTODO second first + | Just var <- matchVariableFunctionEquals first second = + lift $ variableFunctionEquals first second var + | Just var <- matchVariableFunctionEquals second first = + lift $ variableFunctionEquals second first var + | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = + lift $ equalInjectiveHeadsAndEquals childTransformers unifyData + | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second = + lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData + | Just () <- matchConstructorSortInjectionAndEquals first second = + lift $ constructorSortInjectionAndEquals first second + | Just () <- matchDifferentConstructors isOverloaded first second = + lift $ constructorAndEqualsAssumesDifferentHeads first second + | otherwise = + overloadedConstructorSortInjectionAndEquals childTransformers first second + <|> rest + rest | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd first second = lift $ Builtin.Bool.unifyBoolAnd childTransformers first boolAndData @@ -225,55 +226,56 @@ maybeTermAnd :: NotSimplifier unifier -> -- | Used to simplify subterm "and". TermSimplifier RewritingVariableName unifier -> - InjSimplifier -> - (Symbol -> Bool) -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) -maybeTermAnd notSimplifier childTransformers injSimplifier isOverloaded first second - | Just unifyData <- matchExpandAlias first second = - let UnifyExpandAlias{term1, term2} = unifyData - in maybeTermAnd - notSimplifier - childTransformers - injSimplifier - isOverloaded - term1 - term2 - | Just unifyData <- matchBoolAnd first = - lift $ boolAnd first second unifyData - | Just unifyData <- matchBoolAnd second = - lift $ boolAnd second first unifyData - | Just unifyData <- Builtin.Int.matchInt first second = - lift $ Builtin.Int.unifyInt first second unifyData - | Just unifyData <- Builtin.Bool.matchBools first second = - lift $ Builtin.Bool.unifyBool first second unifyData - | Just unifyData <- Builtin.String.matchString first second = - lift $ Builtin.String.unifyString first second unifyData - | Just unifyData <- matchDomainValue first second = - lift $ unifyDomainValue first second unifyData - | Just unifyData <- matchStringLiteral first second = - lift $ unifyStringLiteral first second unifyData - | Just () <- matchEqualsAndEquals first second = - lift $ equalAndEquals first - | Just unifyData <- matchBytes first second = - lift $ bytesDifferent unifyData - | Just unifyData <- matchVariableFunctionAnd first second = - lift $ variableFunctionAnd second unifyData - | Just unifyData <- matchVariableFunctionAnd second first = - lift $ variableFunctionAnd first unifyData - | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = - lift $ equalInjectiveHeadsAndEquals childTransformers unifyData - | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second = - lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData - | Just () <- matchConstructorSortInjectionAndEquals first second = - lift $ constructorSortInjectionAndEquals first second - | Just () <- matchDifferentConstructors isOverloaded first second = - lift $ constructorAndEqualsAssumesDifferentHeads first second - | otherwise = - overloadedConstructorSortInjectionAndEquals childTransformers first second - <|> rest +maybeTermAnd notSimplifier childTransformers first second = do + injSimplifier <- Simplifier.askInjSimplifier + OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier + worker injSimplifier isOverloaded where + worker injSimplifier isOverloaded + | Just unifyData <- matchExpandAlias first second = + let UnifyExpandAlias{term1, term2} = unifyData + in maybeTermAnd + notSimplifier + childTransformers + term1 + term2 + | Just unifyData <- matchBoolAnd first = + lift $ boolAnd first second unifyData + | Just unifyData <- matchBoolAnd second = + lift $ boolAnd second first unifyData + | Just unifyData <- Builtin.Int.matchInt first second = + lift $ Builtin.Int.unifyInt first second unifyData + | Just unifyData <- Builtin.Bool.matchBools first second = + lift $ Builtin.Bool.unifyBool first second unifyData + | Just unifyData <- Builtin.String.matchString first second = + lift $ Builtin.String.unifyString first second unifyData + | Just unifyData <- matchDomainValue first second = + lift $ unifyDomainValue first second unifyData + | Just unifyData <- matchStringLiteral first second = + lift $ unifyStringLiteral first second unifyData + | Just () <- matchEqualsAndEquals first second = + lift $ equalAndEquals first + | Just unifyData <- matchBytes first second = + lift $ bytesDifferent unifyData + | Just unifyData <- matchVariableFunctionAnd first second = + lift $ variableFunctionAnd second unifyData + | Just unifyData <- matchVariableFunctionAnd second first = + lift $ variableFunctionAnd first unifyData + | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = + lift $ equalInjectiveHeadsAndEquals childTransformers unifyData + | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second = + lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData + | Just () <- matchConstructorSortInjectionAndEquals first second = + lift $ constructorSortInjectionAndEquals first second + | Just () <- matchDifferentConstructors isOverloaded first second = + lift $ constructorAndEqualsAssumesDifferentHeads first second + | otherwise = + overloadedConstructorSortInjectionAndEquals childTransformers first second + <|> rest + rest | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd first second = lift $ Builtin.Bool.unifyBoolAnd childTransformers first boolAndData diff --git a/kore/src/Kore/Step/Simplification/Equals.hs b/kore/src/Kore/Step/Simplification/Equals.hs index c631c987e6..14f0786592 100644 --- a/kore/src/Kore/Step/Simplification/Equals.hs +++ b/kore/src/Kore/Step/Simplification/Equals.hs @@ -67,7 +67,6 @@ import qualified Kore.Step.Simplification.Not as Not ( import qualified Kore.Step.Simplification.Or as Or ( simplifyEvaluated, ) -import Kore.Step.Simplification.OverloadSimplifier import Kore.Step.Simplification.Simplify import Kore.Unification.UnifierT ( runUnifierT, @@ -426,10 +425,8 @@ termEqualsAnd p1 p2 = TermLike RewritingVariableName -> TermLike RewritingVariableName -> MaybeT unifier (Pattern RewritingVariableName) - maybeTermEqualsWorker term1 term2 = do - injSimplifier <- askInjSimplifier - OverloadSimplifier{isOverloaded} <- askOverloadSimplifier - maybeTermEquals Not.notSimplifier termEqualsAndWorker injSimplifier isOverloaded term1 term2 + maybeTermEqualsWorker = + maybeTermEquals Not.notSimplifier termEqualsAndWorker termEqualsAndWorker :: forall unifier. From e46c1990871e4de0e623f7829acee4515dbd7db3 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 21 May 2021 05:30:05 -0500 Subject: [PATCH 33/86] sortInjectionAndEquals: Remove extra argument --- kore/src/Kore/Step/Simplification/AndTerms.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 61b34ada67..5fdb52a3a5 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -168,7 +168,7 @@ maybeTermEquals notSimplifier childTransformers first second = do | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second = - lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData + lift $ sortInjectionAndEquals childTransformers first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = lift $ constructorSortInjectionAndEquals first second | Just () <- matchDifferentConstructors isOverloaded first second = @@ -267,7 +267,7 @@ maybeTermAnd notSimplifier childTransformers first second = do | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second = - lift $ sortInjectionAndEquals childTransformers injSimplifier first second unifyData + lift $ sortInjectionAndEquals childTransformers first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = lift $ constructorSortInjectionAndEquals first second | Just () <- matchDifferentConstructors isOverloaded first second = @@ -609,12 +609,12 @@ sortInjectionAndEquals :: forall unifier. MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> - InjSimplifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> SortInjectionAndEquals -> unifier (Pattern RewritingVariableName) -sortInjectionAndEquals termMerger injSimplifier first second unifyData = do +sortInjectionAndEquals termMerger first second unifyData = do + injSimplifier <- Simplifier.askInjSimplifier unifyInjs injSimplifier matchData & either distinct merge where emptyIntersection = explainAndReturnBottom "Empty sort intersection" From 2d585b7f160b9315a018b3cb2432e2379b4769a0 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 21 May 2021 05:55:08 -0500 Subject: [PATCH 34/86] Remove AndEquals terminology around sort injections --- kore/src/Kore/Step/Simplification/AndTerms.hs | 30 +++++++++---------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 5fdb52a3a5..c048c0383b 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -167,8 +167,8 @@ maybeTermEquals notSimplifier childTransformers first second = do lift $ variableFunctionEquals second first var | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData - | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second = - lift $ sortInjectionAndEquals childTransformers first second unifyData + | Just unifyData <- matchSortInjection injSimplifier first second = + lift $ unifySortInjection childTransformers first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = lift $ constructorSortInjectionAndEquals first second | Just () <- matchDifferentConstructors isOverloaded first second = @@ -266,8 +266,8 @@ maybeTermAnd notSimplifier childTransformers first second = do lift $ variableFunctionAnd first unifyData | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData - | Just unifyData <- matchSortInjectionAndEquals injSimplifier first second = - lift $ sortInjectionAndEquals childTransformers first second unifyData + | Just unifyData <- matchSortInjection injSimplifier first second = + lift $ unifySortInjection childTransformers first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = lift $ constructorSortInjectionAndEquals first second | Just () <- matchDifferentConstructors isOverloaded first second = @@ -551,8 +551,8 @@ variableFunctionEquals (Substitution.assign (inject var) second) return (Pattern.withCondition second result) -newtype SortInjectionAndEquals = SortInjectionAndEquals - { matchData :: Either Distinct (InjUnify RewritingVariableName) +newtype UnifySortInjection = UnifySortInjection + { getUnifySortInjection :: Either Distinct (InjUnify RewritingVariableName) } {- | Matches @@ -575,19 +575,19 @@ when either * @children@ or @children'@ satisfies @hasConstructorLikeTop@. * the subsorts of @sub, sub'@ are disjoint. -} -matchSortInjectionAndEquals :: +matchSortInjection :: InjSimplifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe SortInjectionAndEquals -matchSortInjectionAndEquals injSimplifier first second + Maybe UnifySortInjection +matchSortInjection injSimplifier first second | Inj_ inj1 <- first , Inj_ inj2 <- second = case matchInjs injSimplifier inj1 inj2 of Left Unknown -> Nothing - matchData -> Just SortInjectionAndEquals{matchData} + x -> Just UnifySortInjection{getUnifySortInjection = x} | otherwise = Nothing -{-# INLINE matchSortInjectionAndEquals #-} +{-# INLINE matchSortInjection #-} {- | Simplify the conjunction of two sort injections. @@ -605,15 +605,15 @@ sorts of the conjoined patterns, such as, when @src1@ is a subsort of @src2@. -} -sortInjectionAndEquals :: +unifySortInjection :: forall unifier. MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - SortInjectionAndEquals -> + UnifySortInjection -> unifier (Pattern RewritingVariableName) -sortInjectionAndEquals termMerger first second unifyData = do +unifySortInjection termMerger first second unifyData = do injSimplifier <- Simplifier.askInjSimplifier unifyInjs injSimplifier matchData & either distinct merge where @@ -627,7 +627,7 @@ sortInjectionAndEquals termMerger first second unifyData = do inj' = evaluateInj inj{injChild = childTerm} return $ Pattern.withCondition inj' childCondition - SortInjectionAndEquals{matchData} = unifyData + UnifySortInjection{getUnifySortInjection = matchData} = unifyData {- | Matches From 1651292594ded6f79432162cc01057e22a86b723 Mon Sep 17 00:00:00 2001 From: github-actions Date: Fri, 21 May 2021 10:57:42 +0000 Subject: [PATCH 35/86] Format with fourmolu --- kore/src/Kore/Step/Simplification/AndTerms.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index c048c0383b..01f97ce8f7 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -237,7 +237,7 @@ maybeTermAnd notSimplifier childTransformers first second = do worker injSimplifier isOverloaded | Just unifyData <- matchExpandAlias first second = let UnifyExpandAlias{term1, term2} = unifyData - in maybeTermAnd + in maybeTermAnd notSimplifier childTransformers term1 From f9b41c849fb6db5bde69a77529818d2c29be18a6 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 21 May 2021 10:50:47 -0500 Subject: [PATCH 36/86] unifyInjs: Simplify signature --- kore/src/Kore/Step/Simplification/AndTerms.hs | 2 +- .../Kore/Step/Simplification/InjSimplifier.hs | 25 ++++++++++--------- 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 01f97ce8f7..b72a60ac4f 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -615,7 +615,7 @@ unifySortInjection :: unifier (Pattern RewritingVariableName) unifySortInjection termMerger first second unifyData = do injSimplifier <- Simplifier.askInjSimplifier - unifyInjs injSimplifier matchData & either distinct merge + either distinct (merge . unifyInjs injSimplifier) matchData where emptyIntersection = explainAndReturnBottom "Empty sort intersection" distinct Distinct = emptyIntersection first second diff --git a/kore/src/Kore/Step/Simplification/InjSimplifier.hs b/kore/src/Kore/Step/Simplification/InjSimplifier.hs index e2c31b0506..409fb53f0f 100644 --- a/kore/src/Kore/Step/Simplification/InjSimplifier.hs +++ b/kore/src/Kore/Step/Simplification/InjSimplifier.hs @@ -85,8 +85,8 @@ data InjSimplifier = InjSimplifier unifyInjs :: forall variable. InternalVariable variable => - Either Distinct (InjUnify variable) -> - Either Distinct (Inj (Pair (TermLike variable))) + InjUnify variable -> + Inj (Pair (TermLike variable)) , -- | Evaluate the 'Ceil' of 'Inj': -- -- @ @@ -214,34 +214,33 @@ mkInjSimplifier sortGraph = unifyInjs :: forall variable. InternalVariable variable => - Either Distinct (InjUnify variable) -> - Either Distinct (Inj (Pair (TermLike variable))) + InjUnify variable -> + Inj (Pair (TermLike variable)) unifyInjs unify = case unify of - Left d -> Left d - Right (InjFromEqual injPair) -> + (InjFromEqual injPair) -> assert (injTo1 == injTo2) $ do let child1 = injChild inj1 child2 = injChild inj2 - pure (Pair child1 child2 <$ inj1) + (Pair child1 child2 <$ inj1) where InjPair{inj1, inj2} = injPair Inj{injTo = injTo1} = inj1 Inj{injTo = injTo2} = inj2 - Right (InjFrom2SubsortInjFrom1 injPair) -> + (InjFrom2SubsortInjFrom1 injPair) -> assert (injTo1 == injTo2) $ do let child1' = injChild inj1 child2' = evaluateInj inj2{injTo = injFrom1} - pure (Pair child1' child2' <$ inj1) + (Pair child1' child2' <$ inj1) where InjPair{inj1, inj2} = injPair Inj{injFrom = injFrom1, injTo = injTo1} = inj1 Inj{injTo = injTo2} = inj2 - Right (InjFrom1SubsortInjFrom2 injPair) -> + (InjFrom1SubsortInjFrom2 injPair) -> assert (injTo1 == injTo2) $ do let child1' = evaluateInj inj1{injTo = injFrom2} child2' = injChild inj2 - pure (Pair child1' child2' <$ inj2) + (Pair child1' child2' <$ inj2) where InjPair{inj1, inj2} = injPair Inj{injTo = injTo1} = inj1 @@ -259,7 +258,9 @@ unifyInj :: Inj (TermLike variable) -> Inj (TermLike variable) -> Either Distinct (Inj (Pair (TermLike variable))) -unifyInj injSimplifier inj1 inj2 = unifyInjs injSimplifier (matchInjs injSimplifier inj1 inj2) +unifyInj injSimplifier inj1 inj2 = + matchInjs injSimplifier inj1 inj2 + <&> unifyInjs injSimplifier normalize :: InjSimplifier -> From 9eb5facbbb3612ffd88b54aa9500a472b09097c3 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 21 May 2021 13:08:49 -0500 Subject: [PATCH 37/86] Clean up injection simplifier --- kore/src/Kore/Step/Axiom/Matcher.hs | 5 +- kore/src/Kore/Step/Simplification/AndTerms.hs | 37 ++--- .../Kore/Step/Simplification/InjSimplifier.hs | 86 ++++++------ .../Test/Kore/Step/Simplification/AndTerms.hs | 4 +- .../Kore/Step/Simplification/InjSimplifier.hs | 130 ++++++++++++++++-- 5 files changed, 177 insertions(+), 85 deletions(-) diff --git a/kore/src/Kore/Step/Axiom/Matcher.hs b/kore/src/Kore/Step/Axiom/Matcher.hs index 3f858cef05..160464c62c 100644 --- a/kore/src/Kore/Step/Axiom/Matcher.hs +++ b/kore/src/Kore/Step/Axiom/Matcher.hs @@ -418,8 +418,9 @@ matchInj :: Pair (TermLike variable) -> MaybeT (MatcherT variable simplifier) () matchInj (Pair (Inj_ inj1) (Inj_ inj2)) = do - injSimplifier <- Simplifier.askInjSimplifier - unifyInj injSimplifier inj1 inj2 & either (const empty) (push . injChild) + InjSimplifier{matchInjs, unifyInjs} <- Simplifier.askInjSimplifier + matched <- matchInjs inj1 inj2 & maybe empty return + unifyInjs matched & maybe empty (push . injChild) matchInj _ = empty matchOverload :: diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index b72a60ac4f..e13034cefa 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -167,7 +167,7 @@ maybeTermEquals notSimplifier childTransformers first second = do lift $ variableFunctionEquals second first var | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData - | Just unifyData <- matchSortInjection injSimplifier first second = + | Just unifyData <- matchInj injSimplifier first second = lift $ unifySortInjection childTransformers first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = lift $ constructorSortInjectionAndEquals first second @@ -266,7 +266,7 @@ maybeTermAnd notSimplifier childTransformers first second = do lift $ variableFunctionAnd first unifyData | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData - | Just unifyData <- matchSortInjection injSimplifier first second = + | Just unifyData <- matchInj injSimplifier first second = lift $ unifySortInjection childTransformers first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = lift $ constructorSortInjectionAndEquals first second @@ -551,10 +551,6 @@ variableFunctionEquals (Substitution.assign (inject var) second) return (Pattern.withCondition second result) -newtype UnifySortInjection = UnifySortInjection - { getUnifySortInjection :: Either Distinct (InjUnify RewritingVariableName) - } - {- | Matches @ @@ -575,19 +571,16 @@ when either * @children@ or @children'@ satisfies @hasConstructorLikeTop@. * the subsorts of @sub, sub'@ are disjoint. -} -matchSortInjection :: +matchInj :: InjSimplifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe UnifySortInjection -matchSortInjection injSimplifier first second - | Inj_ inj1 <- first - , Inj_ inj2 <- second = - case matchInjs injSimplifier inj1 inj2 of - Left Unknown -> Nothing - x -> Just UnifySortInjection{getUnifySortInjection = x} + Maybe (UnifyInj (InjPair RewritingVariableName)) +matchInj injSimplifier first second + | Inj_ inj1 <- first, Inj_ inj2 <- second = + matchInjs injSimplifier inj1 inj2 | otherwise = Nothing -{-# INLINE matchSortInjection #-} +{-# INLINE matchInj #-} {- | Simplify the conjunction of two sort injections. @@ -611,15 +604,13 @@ unifySortInjection :: TermSimplifier RewritingVariableName unifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - UnifySortInjection -> + UnifyInj (InjPair RewritingVariableName) -> unifier (Pattern RewritingVariableName) -unifySortInjection termMerger first second unifyData = do - injSimplifier <- Simplifier.askInjSimplifier - either distinct (merge . unifyInjs injSimplifier) matchData +unifySortInjection termMerger term1 term2 unifyInj = do + InjSimplifier{unifyInjs} <- Simplifier.askInjSimplifier + unifyInjs unifyInj & maybe distinct merge where - emptyIntersection = explainAndReturnBottom "Empty sort intersection" - distinct Distinct = emptyIntersection first second - distinct Unknown = undefined -- should be handled + distinct = explainAndReturnBottom "Distinct sort injections" term1 term2 merge inj@Inj{injChild = Pair child1 child2} = do childPattern <- termMerger child1 child2 InjSimplifier{evaluateInj} <- askInjSimplifier @@ -627,8 +618,6 @@ unifySortInjection termMerger first second unifyData = do inj' = evaluateInj inj{injChild = childTerm} return $ Pattern.withCondition inj' childCondition - UnifySortInjection{getUnifySortInjection = matchData} = unifyData - {- | Matches @ diff --git a/kore/src/Kore/Step/Simplification/InjSimplifier.hs b/kore/src/Kore/Step/Simplification/InjSimplifier.hs index 409fb53f0f..77dc1cf4a5 100644 --- a/kore/src/Kore/Step/Simplification/InjSimplifier.hs +++ b/kore/src/Kore/Step/Simplification/InjSimplifier.hs @@ -3,12 +3,11 @@ Copyright : (c) Runtime Verification, 2019 License : NCSA -} module Kore.Step.Simplification.InjSimplifier ( - Distinct (..), InjSimplifier (..), - InjUnify (..), + UnifyInj (..), + InjPair (..), mkInjSimplifier, normalize, - unifyInj, ) where import qualified Data.Functor.Foldable as Recursive @@ -45,10 +44,22 @@ data Distinct = Distinct | Unknown data InjPair variable = InjPair {inj1, inj2 :: Inj (TermLike variable)} -data InjUnify variable - = InjFromEqual !(InjPair variable) - | InjFrom1SubsortInjFrom2 !(InjPair variable) - | InjFrom2SubsortInjFrom1 !(InjPair variable) +data UnifyInj a + = -- | The children of the injections can be unified directly because the + -- injections have the same inner and outer sorts. + UnifyInjDirect a + | -- | The right injection's inner sort is a subsort of the left injection's, + -- so unification can proceed by splitting the right injection. + UnifyInjSplit a + | -- | The injections are known to be distinct because there is no subsort + -- relation between their inner sorts. + UnifyInjDistinct a + deriving stock (Eq, Ord, Show) + deriving stock (Functor) + deriving stock (GHC.Generic) + deriving anyclass (Hashable) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving anyclass (Debug, Diff) data InjSimplifier = InjSimplifier { -- | Is 'injFrom' a proper subsort of 'injTo'? @@ -70,7 +81,7 @@ data InjSimplifier = InjSimplifier InternalVariable variable => Inj (TermLike variable) -> Inj (TermLike variable) -> - Either Distinct (InjUnify variable) + Maybe (UnifyInj (InjPair variable)) , -- | Push down the conjunction of 'Inj': -- -- @ @@ -85,8 +96,8 @@ data InjSimplifier = InjSimplifier unifyInjs :: forall variable. InternalVariable variable => - InjUnify variable -> - Inj (Pair (TermLike variable)) + UnifyInj (InjPair variable) -> + Maybe (Inj (Pair (TermLike variable))) , -- | Evaluate the 'Ceil' of 'Inj': -- -- @ @@ -176,27 +187,31 @@ mkInjSimplifier sortGraph = forall variable. Inj (TermLike variable) -> Inj (TermLike variable) -> - Either Distinct (InjUnify variable) + Maybe (UnifyInj (InjPair variable)) matchInjs inj1 inj2 - | injTo1 /= injTo2 = Left Distinct - | injFrom1 == injFrom2 = Right $ InjFromEqual InjPair{inj1, inj2} - | injFrom2 `isSubsortOf'` injFrom1 = Right $ InjFrom2SubsortInjFrom1 InjPair{inj1, inj2} - | injFrom1 `isSubsortOf'` injFrom2 = Right $ InjFrom1SubsortInjFrom2 InjPair{inj1, inj2} + | injTo1 /= injTo2 = distinct + | injFrom1 == injFrom2 = direct + | injFrom2 `isSubsortOf'` injFrom1 = splitRight + | injFrom1 `isSubsortOf'` injFrom2 = splitLeft -- If the child patterns are simplifiable, then they could eventually be -- simplified to produce matching sort injections, but if they are -- non-simplifiable, then they will never match. - | hasConstructorLikeTop (injChild inj1) = Left Distinct - | hasConstructorLikeTop (injChild inj2) = Left Distinct + | hasConstructorLikeTop (injChild inj1) = distinct + | hasConstructorLikeTop (injChild inj2) = distinct -- Even if the child patterns are simplifiable, if they do not have any -- common subsorts, then they will never simplify to produce matching sort -- injections. - | Set.disjoint subsorts1 subsorts2 = Left Distinct - | otherwise = Left Unknown + | Set.disjoint subsorts1 subsorts2 = distinct + | otherwise = Nothing where Inj{injFrom = injFrom1, injTo = injTo1} = inj1 Inj{injFrom = injFrom2, injTo = injTo2} = inj2 subsorts1 = subsortsOf sortGraph injFrom1 subsorts2 = subsortsOf sortGraph injFrom2 + distinct = Just (UnifyInjDistinct InjPair{inj1, inj2}) + direct = Just (UnifyInjDirect InjPair{inj1, inj2}) + splitRight = Just (UnifyInjSplit InjPair{inj1, inj2}) + splitLeft = Just (UnifyInjSplit InjPair{inj1 = inj2, inj2 = inj1}) evaluateCeilInj :: forall variable. @@ -214,54 +229,35 @@ mkInjSimplifier sortGraph = unifyInjs :: forall variable. InternalVariable variable => - InjUnify variable -> - Inj (Pair (TermLike variable)) + UnifyInj (InjPair variable) -> + Maybe (Inj (Pair (TermLike variable))) unifyInjs unify = case unify of - (InjFromEqual injPair) -> + (UnifyInjDirect injPair) -> assert (injTo1 == injTo2) $ do let child1 = injChild inj1 child2 = injChild inj2 - (Pair child1 child2 <$ inj1) + Just (Pair child1 child2 <$ inj1) where InjPair{inj1, inj2} = injPair Inj{injTo = injTo1} = inj1 Inj{injTo = injTo2} = inj2 - (InjFrom2SubsortInjFrom1 injPair) -> + (UnifyInjSplit injPair) -> assert (injTo1 == injTo2) $ do let child1' = injChild inj1 child2' = evaluateInj inj2{injTo = injFrom1} - (Pair child1' child2' <$ inj1) + Just (Pair child1' child2' <$ inj1) where InjPair{inj1, inj2} = injPair Inj{injFrom = injFrom1, injTo = injTo1} = inj1 Inj{injTo = injTo2} = inj2 - (InjFrom1SubsortInjFrom2 injPair) -> - assert (injTo1 == injTo2) $ do - let child1' = evaluateInj inj1{injTo = injFrom2} - child2' = injChild inj2 - (Pair child1' child2' <$ inj2) - where - InjPair{inj1, inj2} = injPair - Inj{injTo = injTo1} = inj1 - Inj{injFrom = injFrom2, injTo = injTo2} = inj2 + UnifyInjDistinct _ -> Nothing injectTermTo injProto injChild injTo = evaluateInj injProto{injFrom, injTo, injChild} where injFrom = termLikeSort injChild -unifyInj :: - forall variable. - InternalVariable variable => - InjSimplifier -> - Inj (TermLike variable) -> - Inj (TermLike variable) -> - Either Distinct (Inj (Pair (TermLike variable))) -unifyInj injSimplifier inj1 inj2 = - matchInjs injSimplifier inj1 inj2 - <&> unifyInjs injSimplifier - normalize :: InjSimplifier -> TermLike RewritingVariableName -> diff --git a/kore/test/Test/Kore/Step/Simplification/AndTerms.hs b/kore/test/Test/Kore/Step/Simplification/AndTerms.hs index c2eee55664..5c3391382f 100644 --- a/kore/test/Test/Kore/Step/Simplification/AndTerms.hs +++ b/kore/test/Test/Kore/Step/Simplification/AndTerms.hs @@ -225,10 +225,10 @@ test_andTermsSimplification = [ Pattern.fromTermLike ( Mock.sortInjectionSubToTop ( mkAnd + Mock.plain00Subsort ( Mock.sortInjectionSubSubToSub Mock.plain00SubSubsort ) - Mock.plain00Subsort ) ) ] @@ -236,10 +236,10 @@ test_andTermsSimplification = [ Pattern.fromTermLike ( Mock.sortInjectionSubToTop ( mkAnd + Mock.plain00Subsort ( Mock.sortInjectionSubSubToSub Mock.plain00SubSubsort ) - Mock.plain00Subsort ) ) ] diff --git a/kore/test/Test/Kore/Step/Simplification/InjSimplifier.hs b/kore/test/Test/Kore/Step/Simplification/InjSimplifier.hs index 11313bd9dc..20cb646381 100644 --- a/kore/test/Test/Kore/Step/Simplification/InjSimplifier.hs +++ b/kore/test/Test/Kore/Step/Simplification/InjSimplifier.hs @@ -1,5 +1,6 @@ module Test.Kore.Step.Simplification.InjSimplifier ( - test_unifyInj, + test_matchInjs, + test_unifyInjs, test_normalize, ) where @@ -74,8 +75,8 @@ simpl0 = plain00Sort0 xSub :: TermLike RewritingVariableName xSub = mkElemVar (configElementVariableFromId "xSub" subSort) -test_unifyInj :: [TestTree] -test_unifyInj = +test_matchInjs :: [TestTree] +test_matchInjs = [ test "inj{Test, Top}(ctorTest1) ∧ inj{Test, Top}(ctorTest2)" {- @@ -83,7 +84,7 @@ test_unifyInj = -} (inj topSort ctorTest1) (inj topSort ctorTest2) - (Right (inj' testSort topSort (Pair ctorTest1 ctorTest2))) + (Just $ UnifyInjDirect ()) , test "inj{SubSub, Top}(ctorSubSub) ∧ inj{Sub, Top}(x:Sub)" {- @@ -94,7 +95,7 @@ test_unifyInj = -} (inj topSort ctorSubSub) (inj topSort xSub) - (Right (inj' subSort topSort (Pair (mkInj subSort ctorSubSub) xSub))) + (Just $ UnifyInjSplit ()) , test "inj{Sub, Top}(x:Sub) ∧ inj{SubSub, Top}(ctorSubSub)" {- @@ -105,7 +106,7 @@ test_unifyInj = -} (inj topSort xSub) (inj topSort ctorSubSub) - (Right (inj' subSort topSort (Pair xSub (mkInj subSort ctorSubSub)))) + (Just $ UnifyInjSplit ()) , test "inj{Test, Top}(ctorTest1) ∧ inj{Other, Top}(ctorOther)" {- @@ -116,7 +117,7 @@ test_unifyInj = -} (inj topSort ctorTest1) (inj topSort ctorOther) - (Left Distinct) + (Just $ UnifyInjDistinct ()) , test "inj{Sub, Top}(simplSub) ∧ inj{Other, Top}(simplOther)" {- @@ -128,7 +129,7 @@ test_unifyInj = -} (inj topSort simplSub) (inj topSort simplOther) - (Left Unknown) + Nothing , test "inj{Sub, Top}(ctorSub) ∧ inj{Other, Top}(simplOther)" {- @@ -140,7 +141,7 @@ test_unifyInj = -} (inj topSort ctorSub) (inj topSort simplOther) - (Left Distinct) + (Just $ UnifyInjDistinct ()) , test "inj{0, Top}(simpl0) ∧ inj{Other, Top}(simplOther)" {- @@ -151,7 +152,7 @@ test_unifyInj = -} (inj topSort simpl0) (inj topSort simplOther) - (Left Distinct) + (Just $ UnifyInjDistinct ()) ] where test :: @@ -159,10 +160,115 @@ test_unifyInj = TestName -> Inj (TermLike RewritingVariableName) -> Inj (TermLike RewritingVariableName) -> - Either Distinct (Inj (Pair (TermLike RewritingVariableName))) -> + Maybe (UnifyInj ()) -> TestTree test testName inj1 inj2 expect = - testCase testName (assertEqual "" expect (unifyInj injSimplifier inj1 inj2)) + testCase testName $ do + let actual = matchInjs injSimplifier inj1 inj2 + assertEqual "" expect (fmap void actual) + +test_unifyInjs :: [TestTree] +test_unifyInjs = + [ test + "inj{Test, Top}(ctorTest1) ∧ inj{Test, Top}(ctorTest2)" + {- + Injections with the same child sort are unifiable. + -} + ( UnifyInjDirect + InjPair + { inj1 = inj topSort ctorTest1 + , inj2 = inj topSort ctorTest2 + } + ) + (Just (inj' testSort topSort (Pair ctorTest1 ctorTest2))) + , test + "inj{SubSub, Top}(ctorSubSub) ∧ inj{Sub, Top}(x:Sub)" + {- + Injections with + - different child sorts, and + - the first sort is a subsort of the second + are unifiable. + -} + ( UnifyInjSplit + InjPair + { inj1 = inj topSort xSub + , inj2 = inj topSort ctorSubSub + } + ) + (Just (inj' subSort topSort (Pair xSub (mkInj subSort ctorSubSub)))) + , test + "inj{Sub, Top}(x:Sub) ∧ inj{SubSub, Top}(ctorSubSub)" + {- + Injections with + - different child sorts, and + - the second sort is a subsort of the first + are unifiable. + -} + ( UnifyInjSplit + InjPair + { inj1 = inj topSort xSub + , inj2 = inj topSort ctorSubSub + } + ) + (Just (inj' subSort topSort (Pair xSub (mkInj subSort ctorSubSub)))) + , test + "inj{Test, Top}(ctorTest1) ∧ inj{Other, Top}(ctorOther)" + {- + Injections with + - different child sorts, and + - neither sort is a subsort of the other + are known to be distinct. + -} + ( UnifyInjDistinct + InjPair + { inj1 = inj topSort ctorTest1 + , inj2 = inj topSort ctorOther + } + ) + Nothing + , test + "inj{Sub, Top}(ctorSub) ∧ inj{Other, Top}(simplOther)" + {- + Injections with + - different child sorts, and + - a common subsort, and + - at least one constructor-like child + are known to be distinct. + -} + ( UnifyInjDistinct + InjPair + { inj1 = inj topSort ctorSub + , inj2 = inj topSort simplOther + } + ) + Nothing + , test + "inj{0, Top}(simpl0) ∧ inj{Other, Top}(simplOther)" + {- + Injections with + - different child sorts, and + - no common subsorts + are known to be distinct. + -} + ( UnifyInjDistinct + InjPair + { inj1 = inj topSort simpl0 + , inj2 = inj topSort simplOther + } + ) + Nothing + ] + where + test :: + HasCallStack => + TestName -> + UnifyInj (InjPair RewritingVariableName) -> + Maybe (Inj (Pair (TermLike RewritingVariableName))) -> + TestTree + test testName unifyInj expect = + testCase testName $ do + let actual = unifyInjs injSimplifier unifyInj + assertEqual "" expect actual test_normalize :: [TestTree] test_normalize = From 4ed1d111d5993f33ed30cc0e0f75fdbdd6b90a6f Mon Sep 17 00:00:00 2001 From: github-actions Date: Fri, 21 May 2021 18:11:36 +0000 Subject: [PATCH 38/86] Format with fourmolu --- kore/src/Kore/Step/Simplification/AndTerms.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index e13034cefa..f54827dc56 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -577,7 +577,8 @@ matchInj :: TermLike RewritingVariableName -> Maybe (UnifyInj (InjPair RewritingVariableName)) matchInj injSimplifier first second - | Inj_ inj1 <- first, Inj_ inj2 <- second = + | Inj_ inj1 <- first + , Inj_ inj2 <- second = matchInjs injSimplifier inj1 inj2 | otherwise = Nothing {-# INLINE matchInj #-} From f32365c0c33cac3c2079213bc37720ed655e6932 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 4 Jun 2021 13:31:18 -0500 Subject: [PATCH 39/86] Test.Kore.Builtin.KEqual: Clean up --- kore/test/Test/Kore/Builtin/KEqual.hs | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/kore/test/Test/Kore/Builtin/KEqual.hs b/kore/test/Test/Kore/Builtin/KEqual.hs index 38b7783aed..9feac25dc7 100644 --- a/kore/test/Test/Kore/Builtin/KEqual.hs +++ b/kore/test/Test/Kore/Builtin/KEqual.hs @@ -216,17 +216,18 @@ runKEqualSimplification :: TermLike RewritingVariableName -> NoSMT [Maybe (Pattern RewritingVariableName)] runKEqualSimplification term1 term2 = - runSimplifierBranch testEnv - . evalEnvUnifierT Not.notSimplifier - . runMaybeT - $ ( case unify of - Just unifyData -> - lift $ - KEqual.unifyKequalsEq - (termUnification Not.notSimplifier) - Not.notSimplifier - unifyData - Nothing -> empty - ) + unify matched + & runMaybeT + & evalEnvUnifierT Not.notSimplifier + & runSimplifierBranch testEnv where - unify = KEqual.matchUnifyKequalsEq term1 term2 <|> KEqual.matchUnifyKequalsEq term2 term1 + matched = + KEqual.matchUnifyKequalsEq term1 term2 + <|> KEqual.matchUnifyKequalsEq term2 term1 + unify (Just unifyData) = + KEqual.unifyKequalsEq + (termUnification Not.notSimplifier) + Not.notSimplifier + unifyData + & lift + unify Nothing = empty From 1dd4f5c50eb9a093ccbf9900c3df7f170c3d5ce1 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 4 Jun 2021 13:37:26 -0500 Subject: [PATCH 40/86] Test.Kore.Builtin.Int: Clean up --- kore/test/Test/Kore/Builtin/Int.hs | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/kore/test/Test/Kore/Builtin/Int.hs b/kore/test/Test/Kore/Builtin/Int.hs index ef51c8218b..160473d3e4 100644 --- a/kore/test/Test/Kore/Builtin/Int.hs +++ b/kore/test/Test/Kore/Builtin/Int.hs @@ -641,17 +641,23 @@ test_unifyIntEq = TermLike RewritingVariableName -> IO [Maybe (Pattern RewritingVariableName)] unifyIntEq term1 term2 = - worker term1 term2 + unify matched & runMaybeT & evalEnvUnifierT Not.notSimplifier & runSimplifierBranch testEnv & runNoSMT - - worker a b = case unify a b of - Nothing -> empty - Just unifyData -> lift $ Int.unifyIntEq (termUnification Not.notSimplifier) Not.notSimplifier unifyData - - unify a b = Int.matchUnifyIntEq a b <|> Int.matchUnifyIntEq b a + where + unify Nothing = empty + unify (Just unifyData) = + Int.unifyIntEq + (termUnification Not.notSimplifier) + Not.notSimplifier + unifyData + & lift + + matched = + Int.matchUnifyIntEq term1 term2 + <|> Int.matchUnifyIntEq term2 term1 simplifyCondition' :: Condition RewritingVariableName -> From 59c19df071cd04fb8cb6122ba64769173750bb08 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 4 Jun 2021 13:42:36 -0500 Subject: [PATCH 41/86] Test.Kore.Builtin.Bool: Clean up --- kore/test/Test/Kore/Builtin/Bool.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/kore/test/Test/Kore/Builtin/Bool.hs b/kore/test/Test/Kore/Builtin/Bool.hs index 4ad8ffcfee..d4fb30c8e8 100644 --- a/kore/test/Test/Kore/Builtin/Bool.hs +++ b/kore/test/Test/Kore/Builtin/Bool.hs @@ -200,7 +200,9 @@ test_unifyBoolAnd = Nothing -> assertEqual "" expected [Nothing] unify term boolAnd = - run (lift $ Bool.unifyBoolAnd termSimplifier term boolAnd) + Bool.unifyBoolAnd termSimplifier term boolAnd + & lift + & run test_unifyBoolOr :: [TestTree] test_unifyBoolOr = @@ -233,7 +235,9 @@ test_unifyBoolOr = Nothing -> assertEqual "" expected [Nothing] unify term boolOr = - run (lift $ Bool.unifyBoolOr termSimplifier term boolOr) + Bool.unifyBoolOr termSimplifier term boolOr + & lift + & run run :: MaybeT (UnifierT (SimplifierT SMT.NoSMT)) a -> IO [Maybe a] run = From 9b7c740caa1c12408d839ed98eb87a3c68d94ab6 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 4 Jun 2021 13:51:02 -0500 Subject: [PATCH 42/86] Kore.Step.Simplification.ExpandAlias: Clean up --- kore/src/Kore/Step/Simplification/ExpandAlias.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/ExpandAlias.hs b/kore/src/Kore/Step/Simplification/ExpandAlias.hs index 2cea94a686..eb0f9a2bd9 100644 --- a/kore/src/Kore/Step/Simplification/ExpandAlias.hs +++ b/kore/src/Kore/Step/Simplification/ExpandAlias.hs @@ -43,8 +43,8 @@ matchExpandAlias t1 t2 = (Nothing, Nothing) -> Nothing (t1', t2') -> let term1 = fromMaybe t1 t1' - in let term2 = fromMaybe t2 t2' - in Just UnifyExpandAlias{term1, term2} + term2 = fromMaybe t2 t2' + in Just UnifyExpandAlias{term1, term2} {-# INLINE matchExpandAlias #-} expandSingleAlias :: From 47a592d2687924ec7662af85e6826940a4de2216 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 4 Jun 2021 14:58:17 -0500 Subject: [PATCH 43/86] Extract Bytes unifier to Kore.Builtin.InternalBytes --- kore/src/Kore/Builtin/InternalBytes.hs | 42 ++++++++++++++++ kore/src/Kore/Step/Simplification/AndTerms.hs | 49 +++---------------- 2 files changed, 48 insertions(+), 43 deletions(-) diff --git a/kore/src/Kore/Builtin/InternalBytes.hs b/kore/src/Kore/Builtin/InternalBytes.hs index 7114e4701c..cabb62351f 100644 --- a/kore/src/Kore/Builtin/InternalBytes.hs +++ b/kore/src/Kore/Builtin/InternalBytes.hs @@ -10,6 +10,9 @@ module Kore.Builtin.InternalBytes ( asInternal, internalize, asPattern, + UnifyBytes (..), + matchBytes, + unifyBytes, -- * Keys bytes2StringKey, @@ -39,6 +42,7 @@ import Data.ByteString ( ) import qualified Data.ByteString as ByteString import Data.Functor.Const +import qualified Data.Functor.Foldable as Recursive import qualified Data.HashMap.Strict as HashMap import Data.Map.Strict ( Map, @@ -67,12 +71,21 @@ import qualified Kore.Error import Kore.Internal.ApplicationSorts ( applicationSortsResult, ) +import Kore.Internal.Pattern ( + Pattern, + ) import qualified Kore.Internal.Pattern as Pattern import Kore.Internal.TermLike import Kore.Log.WarnNotImplemented +import Kore.Rewriting.RewritingVariable ( + RewritingVariableName, + ) import Kore.Step.Simplification.Simplify ( BuiltinAndAxiomSimplifier, ) +import Kore.Unification.Unify ( + MonadUnify, + ) import qualified Kore.Verified as Verified import Log (MonadLog) import Prelude.Kore @@ -546,3 +559,32 @@ builtinFunctions = , (int2bytesKey, evalInt2bytes) , (bytes2intKey, evalBytes2int) ] + +-- | @UnifyBytes@ matches unification problems on @\\dv{Bytes}(_)@ itself. +data UnifyBytes = UnifyBytes + { bytes1, bytes2 :: InternalBytes + } + +{- | Matches the unification problem: + +@\\dv{Bytes}(bytes1)@ with @\\dv{Bytes}(bytes2)@. +-} +matchBytes :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyBytes +matchBytes first second + | _ :< InternalBytesF (Const bytes1) <- Recursive.project first + , _ :< InternalBytesF (Const bytes2) <- Recursive.project second = + Just UnifyBytes{bytes1, bytes2} + | otherwise = Nothing +{-# INLINE matchBytes #-} + +unifyBytes :: + MonadUnify unifier => + UnifyBytes -> + unifier (Pattern RewritingVariableName) +unifyBytes UnifyBytes{bytes1, bytes2} + | bytes1 == bytes2 = return $ Pattern.fromTermLike $ mkInternalBytes' bytes1 + | otherwise = empty +{-# INLINE unifyBytes #-} diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index f54827dc56..e8522e4930 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -17,7 +17,6 @@ import Control.Error ( MaybeT (..), ) import qualified Control.Error as Error -import qualified Data.Functor.Foldable as Recursive import Data.String ( fromString, ) @@ -27,6 +26,10 @@ import Data.Text ( import qualified Kore.Builtin.Bool as Builtin.Bool import qualified Kore.Builtin.Endianness as Builtin.Endianness import qualified Kore.Builtin.Int as Builtin.Int +import Kore.Builtin.InternalBytes ( + matchBytes, + unifyBytes, + ) import qualified Kore.Builtin.KEqual as Builtin.KEqual import qualified Kore.Builtin.List as Builtin.List import qualified Kore.Builtin.Map as Builtin.Map @@ -74,9 +77,6 @@ import qualified Kore.Step.Simplification.SimplificationType as SimplificationTy SimplificationType (..), ) import Kore.Step.Simplification.Simplify as Simplifier -import Kore.Syntax.PatternF ( - Const (..), - ) import Kore.Unification.Unify as Unify import Kore.Unparser import Pair @@ -156,7 +156,7 @@ maybeTermEquals notSimplifier childTransformers first second = do | Just () <- matchEqualsAndEquals first second = lift $ equalAndEquals first | Just unifyData <- matchBytes first second = - lift $ bytesDifferent unifyData + lift $ unifyBytes unifyData | Just () <- matchBottomTermEquals first = lift $ bottomTermEquals SideCondition.topTODO first second | Just () <- matchBottomTermEquals second = @@ -259,7 +259,7 @@ maybeTermAnd notSimplifier childTransformers first second = do | Just () <- matchEqualsAndEquals first second = lift $ equalAndEquals first | Just unifyData <- matchBytes first second = - lift $ bytesDifferent unifyData + lift $ unifyBytes unifyData | Just unifyData <- matchVariableFunctionAnd first second = lift $ variableFunctionAnd second unifyData | Just unifyData <- matchVariableFunctionAnd second first = @@ -911,40 +911,3 @@ compareForEquals first second | isConstructorLike first = LT | isConstructorLike second = GT | otherwise = compare first second - -data UnifyBytes = UnifyBytes - { bytes1, bytes2 :: InternalBytes - } - -{- | Matches - -@ -\\equals{_, _}(\\dv{Bytes}(bytes1), \\dv{Bytes}(bytes2)) -@ - -and - -@ -\\and{_}(\\dv{Bytes}(bytes1), \\dv{Bytes}(bytes2)) -@ --} -matchBytes :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - Maybe UnifyBytes -matchBytes first second - | _ :< InternalBytesF (Const bytes1) <- Recursive.project first - , _ :< InternalBytesF (Const bytes2) <- Recursive.project second = - Just UnifyBytes{bytes1, bytes2} - | otherwise = Nothing -{-# INLINE matchBytes #-} - -bytesDifferent :: - MonadUnify unifier => - UnifyBytes -> - unifier (Pattern RewritingVariableName) -bytesDifferent UnifyBytes{bytes1, bytes2} - | bytes1 == bytes2 = - return $ Pattern.fromTermLike $ mkInternalBytes' bytes1 - | otherwise = - empty From 83ca3696b3cd5f42553e403df46591d3478cf642 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 4 Jun 2021 15:26:38 -0500 Subject: [PATCH 44/86] Clean up UnifyStringLiteral --- kore/src/Kore/Step/Simplification/AndTerms.hs | 22 +++---------------- 1 file changed, 3 insertions(+), 19 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index e8522e4930..4c46a234ae 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -825,22 +825,12 @@ cannotUnifyDomainValues :: unifier a cannotUnifyDomainValues = explainAndReturnBottom cannotUnifyDistinctDomainValues +-- | @UnifyStringLiteral@ represents unification of two string literals. data UnifyStringLiteral = UnifyStringLiteral { txt1, txt2 :: !Text } -{- | Matches - -@ -\\equals{_, _}("str1", "str1") -@ - -and - -@ -\\and{_}("str1", "str2") -@ --} +-- | Matches the unification problem @"txt1"@ with @"txt2"@. matchStringLiteral :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -852,13 +842,7 @@ matchStringLiteral first second | otherwise = Nothing {-# INLINE matchStringLiteral #-} -{- | Unify two literal strings. - -The two patterns are assumed to be inequal; therefore this case always returns -@\\bottom@. - -See also: 'equalAndEquals' --} +-- | Finish solving the 'UnifyStringLiteral' problem. unifyStringLiteral :: forall unifier. MonadUnify unifier => From 6cbce099e224e2eff85eb3eabaeb8804d939f63f Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 4 Jun 2021 16:17:26 -0500 Subject: [PATCH 45/86] Clean up variableFunctionAnd --- kore/src/Kore/Step/Simplification/AndTerms.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 4c46a234ae..6c6e81b8dc 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -491,9 +491,7 @@ variableFunctionAnd second unifyData = VariableFunctionAnd1 v -> return $ Pattern.assign (inject v) second VariableFunctionAnd2 v -> return $ Pattern.withCondition second result where - result = - Condition.fromSingleSubstitution - (Substitution.assign (inject v) second) + result = Condition.assign (inject v) second {- | Matches From c6d79cf2b486b0dbddcf4a916f140451a1cb9f26 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Fri, 4 Jun 2021 17:00:02 -0500 Subject: [PATCH 46/86] Separate matchVariables and matchVariableFunction --- kore/src/Kore/Step/Simplification/AndTerms.hs | 81 ++++++++++--------- 1 file changed, 45 insertions(+), 36 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 6c6e81b8dc..2f81979728 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -260,10 +260,10 @@ maybeTermAnd notSimplifier childTransformers first second = do lift $ equalAndEquals first | Just unifyData <- matchBytes first second = lift $ unifyBytes unifyData - | Just unifyData <- matchVariableFunctionAnd first second = - lift $ variableFunctionAnd second unifyData - | Just unifyData <- matchVariableFunctionAnd second first = - lift $ variableFunctionAnd first unifyData + | Just matched <- matchVariables first second = + lift $ unifyVariables matched + | Just matched <- matchVariableFunction second first = + lift $ unifyVariableFunction matched | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData | Just unifyData <- matchInj injSimplifier first second = @@ -458,40 +458,54 @@ bottomTermEquals , substitution = mempty } -data VariableFunctionAnd - = VariableFunctionAnd1 !(ElementVariable RewritingVariableName) - | VariableFunctionAnd2 !(ElementVariable RewritingVariableName) +data UnifyVariables = UnifyVariables + {variable1, variable2 :: !(ElementVariable RewritingVariableName)} -{- | Matches two terms which are either - * two variables. - * the first a variable and the second a function pattern. --} -matchVariableFunctionAnd :: +-- | Match the unification of two element variables. +matchVariables :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe VariableFunctionAnd -matchVariableFunctionAnd first second - | ElemVar_ v <- first - , ElemVar_ _ <- second = - Just $ VariableFunctionAnd1 v - | ElemVar_ v <- first - , isFunctionPattern second = - Just $ VariableFunctionAnd2 v - | otherwise = - Nothing -{-# INLINE matchVariableFunctionAnd #-} + Maybe UnifyVariables +matchVariables first second = do + ElemVar_ variable1 <- pure first + ElemVar_ variable2 <- pure second + pure UnifyVariables{variable1, variable2} +{-# INLINE matchVariables #-} -variableFunctionAnd :: +unifyVariables :: MonadUnify unifier => + UnifyVariables -> + unifier (Pattern RewritingVariableName) +unifyVariables UnifyVariables{variable1, variable2} = + pure $ Pattern.assign (inject variable1) (mkElemVar variable2) + +data UnifyVariableFunction = UnifyVariableFunction + { variable :: !(ElementVariable RewritingVariableName) + , term :: !(TermLike RewritingVariableName) + } + +-- | Match the unification of an element variable with a function-like term. +matchVariableFunction :: + TermLike RewritingVariableName -> TermLike RewritingVariableName -> - VariableFunctionAnd -> + Maybe UnifyVariableFunction +matchVariableFunction = \first second -> + worker first second <|> worker second first + where + worker first term = do + ElemVar_ variable <- pure first + guard (isFunctionPattern term) + pure UnifyVariableFunction{variable, term} +{-# INLINE matchVariableFunction #-} + +unifyVariableFunction :: + MonadUnify unifier => + UnifyVariableFunction -> unifier (Pattern RewritingVariableName) -variableFunctionAnd second unifyData = - case unifyData of - VariableFunctionAnd1 v -> return $ Pattern.assign (inject v) second - VariableFunctionAnd2 v -> return $ Pattern.withCondition second result - where - result = Condition.assign (inject v) second +unifyVariableFunction UnifyVariableFunction{variable, term} = + Condition.assign (inject variable) term + & Pattern.withCondition term + & pure {- | Matches @@ -499,11 +513,6 @@ variableFunctionAnd second unifyData = \\equals{_, _}(x, f(_)) @ -and - -@ -\\and{_}(x, f(_)) -@ -} matchVariableFunctionEquals :: TermLike RewritingVariableName -> From 241b84ed1705910f703f6e1a29b3d6e92919810e Mon Sep 17 00:00:00 2001 From: emarzion Date: Fri, 14 May 2021 09:27:59 -0500 Subject: [PATCH 47/86] trigger build From 26100801df7bdcbf2b7440ecd98e678a1d3e994d Mon Sep 17 00:00:00 2001 From: emarzion Date: Fri, 21 May 2021 01:31:38 -0500 Subject: [PATCH 48/86] More progress in unification refactor --- kore/src/Kore/Builtin/Endianness.hs | 43 +++++++++++++------ kore/src/Kore/Builtin/EqTerm.hs | 23 ++++------ kore/src/Kore/Builtin/KEqual.hs | 38 ++++++++-------- kore/src/Kore/Builtin/Signedness.hs | 37 +++++++++++----- kore/src/Kore/Builtin/String.hs | 34 ++++++++++----- kore/src/Kore/Step/Simplification/AndTerms.hs | 40 +++++++++-------- kore/test/Test/Kore/Builtin/String.hs | 12 +++--- 7 files changed, 136 insertions(+), 91 deletions(-) diff --git a/kore/src/Kore/Builtin/Endianness.hs b/kore/src/Kore/Builtin/Endianness.hs index 1e91e6b4ee..3dfb485ad6 100644 --- a/kore/src/Kore/Builtin/Endianness.hs +++ b/kore/src/Kore/Builtin/Endianness.hs @@ -7,12 +7,10 @@ module Kore.Builtin.Endianness ( littleEndianKey, bigEndianKey, unifyEquals, + matchUnifyEqualsEndianness, module Kore.Builtin.Endianness.Endianness, ) where -import Control.Error ( - MaybeT, - ) import Data.Functor.Const import qualified Data.HashMap.Strict as HashMap import Data.String ( @@ -28,6 +26,7 @@ import Kore.Internal.Pattern ( import qualified Kore.Internal.Pattern as Pattern import Kore.Internal.Symbol import Kore.Internal.TermLike +import Kore.Rewriting.RewritingVariable import Kore.Unification.Unify ( MonadUnify, explainAndReturnBottom, @@ -75,18 +74,34 @@ littleEndianVerifier = endiannessVerifier LittleEndian bigEndianVerifier :: ApplicationVerifier Verified.Pattern bigEndianVerifier = endiannessVerifier BigEndian +data UnifyEqualsEndianness = UnifyEqualsEndianness { + end1, end2 :: Endianness +} + +--TODO:document +matchUnifyEqualsEndianness + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyEqualsEndianness +matchUnifyEqualsEndianness first second + | Endianness_ end1 <- first + , Endianness_ end2 <- second + = Just $ UnifyEqualsEndianness end1 end2 + | otherwise = Nothing +{-# INLINE matchUnifyEqualsEndianness #-} + unifyEquals :: - InternalVariable variable => MonadUnify unifier => - TermLike variable -> - TermLike variable -> - MaybeT unifier (Pattern variable) -unifyEquals termLike1@(Endianness_ end1) termLike2@(Endianness_ end2) - | end1 == end2 = return (Pattern.fromTermLike termLike1) + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + UnifyEqualsEndianness -> + unifier (Pattern RewritingVariableName) +unifyEquals first second unifyData + | end1 == end2 = return (Pattern.fromTermLike first) | otherwise = - lift $ - explainAndReturnBottom + explainAndReturnBottom "Cannot unify distinct constructors." - termLike1 - termLike2 -unifyEquals _ _ = empty + first + second + where + UnifyEqualsEndianness { end1, end2 } = unifyData diff --git a/kore/src/Kore/Builtin/EqTerm.hs b/kore/src/Kore/Builtin/EqTerm.hs index 7fea52f3c4..aabb1dd8eb 100644 --- a/kore/src/Kore/Builtin/EqTerm.hs +++ b/kore/src/Kore/Builtin/EqTerm.hs @@ -8,11 +8,7 @@ module Kore.Builtin.EqTerm ( unifyEqTerm, ) where -import Control.Error ( - MaybeT, - ) import qualified Control.Monad as Monad -import qualified Kore.Builtin.Bool as Bool import qualified Kore.Internal.MultiOr as MultiOr import qualified Kore.Internal.OrPattern as OrPattern import Kore.Internal.Pattern ( @@ -61,16 +57,15 @@ unifyEqTerm :: TermSimplifier RewritingVariableName unifier -> NotSimplifier unifier -> EqTerm (TermLike RewritingVariableName) -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) -unifyEqTerm unifyChildren (NotSimplifier notSimplifier) eqTerm termLike2 - | Just value2 <- Bool.matchBool termLike2 = - lift $ do - solution <- unifyChildren operand1 operand2 & OrPattern.gather - let solution' = MultiOr.map eraseTerm solution - (if value2 then pure else notSimplifier SideCondition.top) solution' - >>= Unify.scatter - | otherwise = empty + Bool -> + unifier (Pattern RewritingVariableName) +unifyEqTerm unifyChildren (NotSimplifier notSimplifier) eqTerm value = + do + solution <- unifyChildren operand1 operand2 & OrPattern.gather + let solution' = MultiOr.map eraseTerm solution + (if value then pure else notSimplifier SideCondition.top) solution' + >>= Unify.scatter + where EqTerm{operand1, operand2} = eqTerm eraseTerm = Pattern.fromCondition_ . Pattern.withoutTerm diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index c1b34ed3d2..07e6edd565 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -20,6 +20,7 @@ module Kore.Builtin.KEqual ( unifyKequalsEq, unifyIfThenElse, matchUnifyKequalsEq, + matchIfThenElse, -- * keys eqKey, @@ -288,36 +289,35 @@ matchIfThenElse (App_ symbol [condition, branch1, branch2]) = do Monad.guard (hook' == iteKey) return IfThenElse{symbol, condition, branch1, branch2} matchIfThenElse _ = Nothing +{-# INLINE matchIfThenElse #-} -unifyIfThenElse :: - forall unifier. - MonadUnify unifier => - TermSimplifier RewritingVariableName unifier -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) -unifyIfThenElse unifyChildren a b = - worker a b <|> worker b a +unifyIfThenElse + :: forall unifier + . MonadUnify unifier + => TermSimplifier RewritingVariableName unifier + -> IfThenElse (TermLike RewritingVariableName) + -> TermLike RewritingVariableName + -> unifier (Pattern RewritingVariableName) +unifyIfThenElse unifyChildren ifThenElse second = + worker ifThenElse second where takeCondition value condition' = makeCeilPredicate (mkAnd (Bool.asInternal sort value) condition') - & Condition.fromPredicate + & Condition.fromPredicate where sort = termLikeSort condition' - worker termLike1 termLike2 - | Just ifThenElse <- matchIfThenElse termLike1 = - lift (takeBranch1 ifThenElse <|> takeBranch2 ifThenElse) + worker ifThenElse' second' + = takeBranch1 ifThenElse' <|> takeBranch2 ifThenElse' where - takeBranch1 IfThenElse{condition, branch1} = do - solution <- unifyChildren branch1 termLike2 + takeBranch1 IfThenElse { condition, branch1 } = do + solution <- unifyChildren branch1 second' let branchCondition = takeCondition True condition Pattern.andCondition solution branchCondition & simplifyCondition SideCondition.top & Logic.lowerLogicT - takeBranch2 IfThenElse{condition, branch2} = do - solution <- unifyChildren branch2 termLike2 + takeBranch2 IfThenElse { condition, branch2 } = do + solution <- unifyChildren branch2 second' let branchCondition = takeCondition False condition Pattern.andCondition solution branchCondition & simplifyCondition SideCondition.top - & Logic.lowerLogicT - worker _ _ = empty + & Logic.lowerLogicT \ No newline at end of file diff --git a/kore/src/Kore/Builtin/Signedness.hs b/kore/src/Kore/Builtin/Signedness.hs index fd96c98c11..11981f60c7 100644 --- a/kore/src/Kore/Builtin/Signedness.hs +++ b/kore/src/Kore/Builtin/Signedness.hs @@ -7,12 +7,10 @@ module Kore.Builtin.Signedness ( signedKey, unsignedKey, unifyEquals, + matchUnifyEqualsSignedness, module Kore.Builtin.Signedness.Signedness, ) where -import Control.Error ( - MaybeT, - ) import Data.Functor.Const import qualified Data.HashMap.Strict as HashMap import Data.String ( @@ -28,6 +26,7 @@ import Kore.Internal.Pattern ( import qualified Kore.Internal.Pattern as Pattern import Kore.Internal.Symbol import Kore.Internal.TermLike +import Kore.Rewriting.RewritingVariable import Kore.Unification.Unify ( MonadUnify, explainAndReturnBottom, @@ -75,18 +74,34 @@ signedVerifier = signednessVerifier Signed unsignedVerifier :: ApplicationVerifier Verified.Pattern unsignedVerifier = signednessVerifier Unsigned +data UnifyEqualsSignedness = UnifyEqualsSignedness { + sign1, sign2 :: Signedness +} + +matchUnifyEqualsSignedness + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyEqualsSignedness +matchUnifyEqualsSignedness first second + | Signedness_ sign1 <- first + , Signedness_ sign2 <- second + = Just UnifyEqualsSignedness{sign1, sign2} + | otherwise = Nothing +{-# INLINE matchUnifyEqualsSignedness #-} + unifyEquals :: InternalVariable variable => MonadUnify unifier => TermLike variable -> TermLike variable -> - MaybeT unifier (Pattern variable) -unifyEquals termLike1@(Signedness_ sign1) termLike2@(Signedness_ sign2) + UnifyEqualsSignedness -> + unifier (Pattern variable) +unifyEquals termLike1 termLike2 unifyData | sign1 == sign2 = return (Pattern.fromTermLike termLike1) | otherwise = - lift $ - explainAndReturnBottom - "Cannot unify distinct constructors." - termLike1 - termLike2 -unifyEquals _ _ = empty + explainAndReturnBottom + "Cannot unify distinct constructors." + termLike1 + termLike2 + where + UnifyEqualsSignedness { sign1, sign2 } = unifyData \ No newline at end of file diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index 17f3d1ecbb..aeaa3657b8 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -27,6 +27,7 @@ module Kore.Builtin.String ( unifyString, unifyStringEq, matchString, + matchUnifyStringEq, -- * keys ltKey, @@ -517,6 +518,23 @@ unifyString term1 term2 unifyData = | otherwise = explainAndReturnBottom "distinct strings" term1 term2 UnifyString{string1, string2} = unifyData +data UnifyStringEq = UnifyStringEq + { eqTerm :: !(EqTerm (TermLike RewritingVariableName)) + , value :: !Bool + } + +--TODO: document +matchUnifyStringEq + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyStringEq +matchUnifyStringEq first second + | Just eqTerm <- matchStringEqual second + , isFunctionPattern first + , Just value <- Bool.matchBool first + = Just UnifyStringEq{eqTerm, value} + | otherwise = Nothing + {- | Unification of the @STRING.eq@ symbol This function is suitable only for equality simplification. @@ -526,14 +544,10 @@ unifyStringEq :: MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> NotSimplifier unifier -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) -unifyStringEq unifyChildren notSimplifier a b = - worker a b <|> worker b a + UnifyStringEq -> + unifier (Pattern RewritingVariableName) +unifyStringEq unifyChildren notSimplifier unifyData = + unifyEqTerm unifyChildren notSimplifier eqTerm value + where - worker termLike1 termLike2 - | Just eqTerm <- matchStringEqual termLike1 - , isFunctionPattern termLike1 = - unifyEqTerm unifyChildren notSimplifier eqTerm termLike2 - | otherwise = empty + UnifyStringEq{eqTerm, value} = unifyData diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 2f81979728..6ecfc2eea3 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -194,22 +194,21 @@ maybeTermEquals notSimplifier childTransformers first second = do lift $ Builtin.Int.unifyIntEq childTransformers notSimplifier unifyData | Just unifyData <- Builtin.Int.matchUnifyIntEq second first = lift $ Builtin.Int.unifyIntEq childTransformers notSimplifier unifyData + | Just unifyData <- Builtin.String.matchUnifyStringEq first second = + lift $ Builtin.String.unifyStringEq childTransformers notSimplifier unifyData + | Just unifyData <- Builtin.String.matchUnifyStringEq second first = + lift $ Builtin.String.unifyStringEq childTransformers notSimplifier unifyData + | Just unifyData <- Builtin.KEqual.matchUnifyKequalsEq first second = + lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData + | Just unifyData <- Builtin.KEqual.matchUnifyKequalsEq second first = + lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData + | Just unifyData <- Builtin.Endianness.matchUnifyEqualsEndianness first second = + lift $ Builtin.Endianness.unifyEquals first second unifyData + | Just unifyData <- Builtin.Signedness.matchUnifyEqualsSignedness first second = + lift $ Builtin.Signedness.unifyEquals first second unifyData | otherwise = asum - [ Builtin.String.unifyStringEq - childTransformers - notSimplifier - first - second - , do - unifyData <- Error.hoistMaybe $ Builtin.KEqual.matchUnifyKequalsEq first second - lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData - , do - unifyData <- Error.hoistMaybe $ Builtin.KEqual.matchUnifyKequalsEq second first - lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData - , Builtin.Endianness.unifyEquals first second - , Builtin.Signedness.unifyEquals first second - , Builtin.Map.unifyEquals childTransformers first second + [ Builtin.Map.unifyEquals childTransformers first second , Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second , Builtin.Set.unifyEquals childTransformers first second , Builtin.List.unifyEquals @@ -293,12 +292,17 @@ maybeTermAnd notSimplifier childTransformers first second = do lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData | Just unifyData <- Builtin.KEqual.matchUnifyKequalsEq second first = lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData + | Just ifThenElse <- Builtin.KEqual.matchIfThenElse first = + lift $ Builtin.KEqual.unifyIfThenElse childTransformers ifThenElse second + | Just ifThenElse <- Builtin.KEqual.matchIfThenElse second = + lift $ Builtin.KEqual.unifyIfThenElse childTransformers ifThenElse first + | Just unifyData <- Builtin.Endianness.matchUnifyEqualsEndianness first second = + lift $ Builtin.Endianness.unifyEquals first second unifyData + | Just unifyData <- Builtin.Signedness.matchUnifyEqualsSignedness first second = + lift $ Builtin.Signedness.unifyEquals first second unifyData | otherwise = asum - [ Builtin.KEqual.unifyIfThenElse childTransformers first second - , Builtin.Endianness.unifyEquals first second - , Builtin.Signedness.unifyEquals first second - , Builtin.Map.unifyEquals childTransformers first second + [ Builtin.Map.unifyEquals childTransformers first second , Builtin.Set.unifyEquals childTransformers first second , Builtin.List.unifyEquals SimplificationType.And diff --git a/kore/test/Test/Kore/Builtin/String.hs b/kore/test/Test/Kore/Builtin/String.hs index 331e41c163..d944925b5d 100644 --- a/kore/test/Test/Kore/Builtin/String.hs +++ b/kore/test/Test/Kore/Builtin/String.hs @@ -511,16 +511,18 @@ test_unifyStringEq = TermLike RewritingVariableName -> IO [Maybe (Pattern RewritingVariableName)] unifyStringEq term1 term2 = - String.unifyStringEq - (termUnification Not.notSimplifier) - Not.notSimplifier - term1 - term2 + worker term1 term2 & runMaybeT & evalEnvUnifierT Not.notSimplifier & runSimplifierBranch testEnv & runNoSMT + worker a b = case unify a b of + Nothing -> empty + Just unifyData -> lift $ String.unifyStringEq (termUnification Not.notSimplifier) Not.notSimplifier unifyData + + unify a b = String.matchUnifyStringEq a b <|> String.matchUnifyStringEq b a + simplifyCondition' :: Condition RewritingVariableName -> IO [Condition RewritingVariableName] From f6219ac50af0c8160ccaf7a2a52469c82730a68c Mon Sep 17 00:00:00 2001 From: github-actions Date: Fri, 21 May 2021 06:34:01 +0000 Subject: [PATCH 49/86] Format with fourmolu --- kore/src/Kore/Builtin/Endianness.hs | 26 +++++++++++++------------- kore/src/Kore/Builtin/EqTerm.hs | 1 - kore/src/Kore/Builtin/KEqual.hs | 26 +++++++++++++------------- kore/src/Kore/Builtin/Signedness.hs | 20 ++++++++++---------- kore/src/Kore/Builtin/String.hs | 15 +++++++-------- 5 files changed, 43 insertions(+), 45 deletions(-) diff --git a/kore/src/Kore/Builtin/Endianness.hs b/kore/src/Kore/Builtin/Endianness.hs index 3dfb485ad6..ddef7521b3 100644 --- a/kore/src/Kore/Builtin/Endianness.hs +++ b/kore/src/Kore/Builtin/Endianness.hs @@ -74,19 +74,19 @@ littleEndianVerifier = endiannessVerifier LittleEndian bigEndianVerifier :: ApplicationVerifier Verified.Pattern bigEndianVerifier = endiannessVerifier BigEndian -data UnifyEqualsEndianness = UnifyEqualsEndianness { - end1, end2 :: Endianness -} +data UnifyEqualsEndianness = UnifyEqualsEndianness + { end1, end2 :: Endianness + } --TODO:document -matchUnifyEqualsEndianness - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyEqualsEndianness +matchUnifyEqualsEndianness :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyEqualsEndianness matchUnifyEqualsEndianness first second | Endianness_ end1 <- first - , Endianness_ end2 <- second - = Just $ UnifyEqualsEndianness end1 end2 + , Endianness_ end2 <- second = + Just $ UnifyEqualsEndianness end1 end2 | otherwise = Nothing {-# INLINE matchUnifyEqualsEndianness #-} @@ -100,8 +100,8 @@ unifyEquals first second unifyData | end1 == end2 = return (Pattern.fromTermLike first) | otherwise = explainAndReturnBottom - "Cannot unify distinct constructors." - first - second + "Cannot unify distinct constructors." + first + second where - UnifyEqualsEndianness { end1, end2 } = unifyData + UnifyEqualsEndianness{end1, end2} = unifyData diff --git a/kore/src/Kore/Builtin/EqTerm.hs b/kore/src/Kore/Builtin/EqTerm.hs index aabb1dd8eb..050bb583cd 100644 --- a/kore/src/Kore/Builtin/EqTerm.hs +++ b/kore/src/Kore/Builtin/EqTerm.hs @@ -65,7 +65,6 @@ unifyEqTerm unifyChildren (NotSimplifier notSimplifier) eqTerm value = let solution' = MultiOr.map eraseTerm solution (if value then pure else notSimplifier SideCondition.top) solution' >>= Unify.scatter - where EqTerm{operand1, operand2} = eqTerm eraseTerm = Pattern.fromCondition_ . Pattern.withoutTerm diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index 07e6edd565..d613d1ebf1 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -291,33 +291,33 @@ matchIfThenElse (App_ symbol [condition, branch1, branch2]) = do matchIfThenElse _ = Nothing {-# INLINE matchIfThenElse #-} -unifyIfThenElse - :: forall unifier - . MonadUnify unifier - => TermSimplifier RewritingVariableName unifier - -> IfThenElse (TermLike RewritingVariableName) - -> TermLike RewritingVariableName - -> unifier (Pattern RewritingVariableName) +unifyIfThenElse :: + forall unifier. + MonadUnify unifier => + TermSimplifier RewritingVariableName unifier -> + IfThenElse (TermLike RewritingVariableName) -> + TermLike RewritingVariableName -> + unifier (Pattern RewritingVariableName) unifyIfThenElse unifyChildren ifThenElse second = worker ifThenElse second where takeCondition value condition' = makeCeilPredicate (mkAnd (Bool.asInternal sort value) condition') - & Condition.fromPredicate + & Condition.fromPredicate where sort = termLikeSort condition' - worker ifThenElse' second' - = takeBranch1 ifThenElse' <|> takeBranch2 ifThenElse' + worker ifThenElse' second' = + takeBranch1 ifThenElse' <|> takeBranch2 ifThenElse' where - takeBranch1 IfThenElse { condition, branch1 } = do + takeBranch1 IfThenElse{condition, branch1} = do solution <- unifyChildren branch1 second' let branchCondition = takeCondition True condition Pattern.andCondition solution branchCondition & simplifyCondition SideCondition.top & Logic.lowerLogicT - takeBranch2 IfThenElse { condition, branch2 } = do + takeBranch2 IfThenElse{condition, branch2} = do solution <- unifyChildren branch2 second' let branchCondition = takeCondition False condition Pattern.andCondition solution branchCondition & simplifyCondition SideCondition.top - & Logic.lowerLogicT \ No newline at end of file + & Logic.lowerLogicT diff --git a/kore/src/Kore/Builtin/Signedness.hs b/kore/src/Kore/Builtin/Signedness.hs index 11981f60c7..218535a011 100644 --- a/kore/src/Kore/Builtin/Signedness.hs +++ b/kore/src/Kore/Builtin/Signedness.hs @@ -74,18 +74,18 @@ signedVerifier = signednessVerifier Signed unsignedVerifier :: ApplicationVerifier Verified.Pattern unsignedVerifier = signednessVerifier Unsigned -data UnifyEqualsSignedness = UnifyEqualsSignedness { - sign1, sign2 :: Signedness -} +data UnifyEqualsSignedness = UnifyEqualsSignedness + { sign1, sign2 :: Signedness + } -matchUnifyEqualsSignedness - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyEqualsSignedness +matchUnifyEqualsSignedness :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyEqualsSignedness matchUnifyEqualsSignedness first second | Signedness_ sign1 <- first - , Signedness_ sign2 <- second - = Just UnifyEqualsSignedness{sign1, sign2} + , Signedness_ sign2 <- second = + Just UnifyEqualsSignedness{sign1, sign2} | otherwise = Nothing {-# INLINE matchUnifyEqualsSignedness #-} @@ -104,4 +104,4 @@ unifyEquals termLike1 termLike2 unifyData termLike1 termLike2 where - UnifyEqualsSignedness { sign1, sign2 } = unifyData \ No newline at end of file + UnifyEqualsSignedness{sign1, sign2} = unifyData diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index aeaa3657b8..5cd144d116 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -524,15 +524,15 @@ data UnifyStringEq = UnifyStringEq } --TODO: document -matchUnifyStringEq - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyStringEq +matchUnifyStringEq :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyStringEq matchUnifyStringEq first second | Just eqTerm <- matchStringEqual second - , isFunctionPattern first - , Just value <- Bool.matchBool first - = Just UnifyStringEq{eqTerm, value} + , isFunctionPattern first + , Just value <- Bool.matchBool first = + Just UnifyStringEq{eqTerm, value} | otherwise = Nothing {- | Unification of the @STRING.eq@ symbol @@ -548,6 +548,5 @@ unifyStringEq :: unifier (Pattern RewritingVariableName) unifyStringEq unifyChildren notSimplifier unifyData = unifyEqTerm unifyChildren notSimplifier eqTerm value - where UnifyStringEq{eqTerm, value} = unifyData From 3edcd1c8a107d1711f113cf68d579443f130f89d Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Tue, 8 Jun 2021 08:42:56 -0500 Subject: [PATCH 50/86] More progress on refactoring unification functions --- kore/src/Kore/Builtin/List.hs | 153 +++++++++------- kore/src/Kore/Builtin/Map.hs | 102 ++++++----- kore/src/Kore/Step/Simplification/AndTerms.hs | 165 ++++++++++++------ .../Test/Kore/Step/Simplification/AndTerms.hs | 5 +- 4 files changed, 262 insertions(+), 163 deletions(-) diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index 2c858055c6..c951f51a02 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -23,6 +23,7 @@ module Kore.Builtin.List ( asPattern, asInternal, internalize, + matchUnifyEqualsList, -- * Symbols lookupSymbolGet, @@ -65,6 +66,7 @@ import qualified Data.Sequence as Seq import Data.Text ( Text, ) +import qualified Kore.Attribute.Symbol as Attribute import qualified Kore.Builtin.Bool as Bool import Kore.Builtin.Builtin ( acceptAnySort, @@ -80,6 +82,7 @@ import Kore.Internal.Pattern ( Conditional (..), Pattern, ) +import Kore.Internal.Symbol import qualified Kore.Internal.Pattern as Pattern import Kore.Internal.TermLike ( Key, @@ -372,6 +375,61 @@ builtinFunctions = , (updateAllKey, Builtin.functionEvaluator evalUpdateAll) ] +data FirstElemVarData = FirstElemVarData { + pat1, pat2 :: !(TermLike RewritingVariableName) +} + +data AppAppData = AppAppData { + args1, args2 :: ![TermLike RewritingVariableName] + , symbol2 :: !Symbol +} + +data ListListData = ListListData { + builtin1, builtin2 :: !(InternalList (TermLike RewritingVariableName)) +} + +data ListAppData = ListAppData { + pat1, pat2 :: !(TermLike RewritingVariableName) + , args2 :: ![TermLike RewritingVariableName] + , builtin1 :: !(InternalList (TermLike RewritingVariableName)) +} + +data UnifyEqualsList + = FirstElemVar !FirstElemVarData + | AppApp !AppAppData + | ListList !ListListData + | ListApp !ListAppData + +matchUnifyEqualsList :: + SmtMetadataTools Attribute.Symbol -> + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyEqualsList +matchUnifyEqualsList tools first second + | Just True <- isListSort tools sort1 + = worker (normalize first) (normalize second) + | otherwise = Nothing + where + sort1 = termLikeSort first + + worker pat1@(ElemVar_ _) pat2 + | TermLike.isFunctionPattern pat2 + = Just $ FirstElemVar FirstElemVarData{pat1, pat2} + | otherwise = Nothing + worker (App_ symbol1 args1) (App_ symbol2 args2) + | isSymbolConcat symbol1 + , isSymbolConcat symbol2 + = Just $ AppApp AppAppData{args1, args2, symbol2} + worker pat1@(InternalList_ builtin1) pat2 = + case pat2 of + InternalList_ builtin2 -> Just $ ListList ListListData{builtin1, builtin2} + App_ symbol2 args2 + | isSymbolConcat symbol2 -> Just $ ListApp ListAppData{pat1, pat2, args2, builtin1} + | otherwise -> Nothing + _ -> Nothing + worker _ _ = Nothing +{-# INLINE matchUnifyEqualsList #-} + {- | Simplify the conjunction or equality of two concrete List domain values. When it is used for simplifying equality, one should separately solve the @@ -389,45 +447,23 @@ unifyEquals :: TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) ) -> + SmtMetadataTools Attribute.Symbol -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) + UnifyEqualsList -> + unifier (Pattern RewritingVariableName) unifyEquals simplificationType simplifyChild + tools first - second = - do - tools <- Simplifier.askMetadataTools - (Monad.guard . fromMaybe False) (isListSort tools sort1) - unifyEquals0 (normalize first) (normalize second) - where - sort1 = termLikeSort first - - propagateConditions :: - InternalVariable variable => - Traversable t => - t (Conditional variable a) -> - Conditional variable (t a) - propagateConditions = sequenceA - - unifyEquals0 :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) - - unifyEquals0 pat1@(ElemVar_ _) pat2 - | TermLike.isFunctionPattern pat2 = - lift $ simplifyChild pat1 pat2 - | otherwise = empty - unifyEquals0 pat1 pat2@(ElemVar_ _) - | TermLike.isFunctionPattern pat1 = - lift $ simplifyChild pat1 pat2 - | otherwise = empty - unifyEquals0 (App_ symbol1 args1) (App_ symbol2 args2) - | isSymbolConcat symbol1 - , isSymbolConcat symbol1 = - lift $ case (args1, args2) of + second + unifyData = + case unifyData of + FirstElemVar FirstElemVarData{pat1, pat2} -> + simplifyChild pat1 pat2 + AppApp AppAppData{args1, args2, symbol2} -> + case (args1, args2) of ( [InternalList_ builtin1, x1@(Var_ _)] , [InternalList_ builtin2, x2@(Var_ _)] ) -> @@ -447,29 +483,29 @@ unifyEquals x2 builtin2 _ -> empty - unifyEquals0 dv1@(InternalList_ builtin1) pat2 = - case pat2 of - InternalList_ builtin2 -> - lift $ unifyEqualsConcrete builtin1 builtin2 - app@(App_ symbol2 args2) - | isSymbolConcat symbol2 -> - lift $ case args2 of - [InternalList_ builtin2, x@(Var_ _)] -> - unifyEqualsFramedRight builtin1 builtin2 x - [x@(Var_ _), InternalList_ builtin2] -> - unifyEqualsFramedLeft builtin1 x builtin2 - [_, _] -> - Builtin.unifyEqualsUnsolved - simplificationType - dv1 - app - _ -> Builtin.wrongArity concatKey - | otherwise -> empty - _ -> empty - unifyEquals0 pat1 pat2 = - case pat2 of - dv@(InternalList_ _) -> unifyEquals0 dv pat1 - _ -> empty + ListList ListListData{builtin1, builtin2} -> + unifyEqualsConcrete builtin1 builtin2 + ListApp ListAppData{pat1, pat2, args2, builtin1} -> + case args2 of + [InternalList_ builtin2, x@(Var_ _)] -> + unifyEqualsFramedRight builtin1 builtin2 x + [x@(Var_ _), InternalList_ builtin2] -> + unifyEqualsFramedLeft builtin1 x builtin2 + [_, _] -> + Builtin.unifyEqualsUnsolved + simplificationType + pat1 + pat2 + _ -> Builtin.wrongArity concatKey + + where + + propagateConditions :: + InternalVariable variable => + Traversable t => + t (Conditional variable a) -> + Conditional variable (t a) + propagateConditions = sequenceA unifyEqualsConcrete :: InternalList (TermLike RewritingVariableName) -> @@ -478,7 +514,6 @@ unifyEquals unifyEqualsConcrete builtin1 builtin2 | Seq.length list1 /= Seq.length list2 = bottomWithExplanation | otherwise = do - tools <- Simplifier.askMetadataTools Reflection.give tools $ do unified <- sequence $ Seq.zipWith simplifyChild list1 list2 let propagatedUnified = propagateConditions unified @@ -504,7 +539,6 @@ unifyEquals | Seq.length prefix2 > Seq.length list1 = bottomWithExplanation | otherwise = do - tools <- Simplifier.askMetadataTools let listSuffix1 = asInternal tools internalListSort suffix1 prefixUnified <- unifyEqualsConcrete @@ -536,7 +570,6 @@ unifyEquals | Seq.length suffix2 > Seq.length list1 = bottomWithExplanation | otherwise = do - tools <- Simplifier.askMetadataTools let listPrefix1 = asInternal tools internalListSort prefix1 prefixUnified <- simplifyChild frame2 listPrefix1 suffixUnified <- @@ -576,7 +609,6 @@ unifyEquals internal2 frame2 | length1 < length2 = do - tools <- Simplifier.askMetadataTools prefixUnified <- unifyEqualsConcrete internal1 @@ -626,7 +658,6 @@ unifyEquals frame2 internal2 | length1 < length2 = do - tools <- Simplifier.askMetadataTools let listPrefix2 = asInternal tools internalListSort prefix2 frame2Prefix2 = mkApplySymbol symbol [frame2, listPrefix2] prefixUnified <- simplifyChild frame1 frame2Prefix2 diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 135102004b..68bc26442e 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -19,6 +19,7 @@ module Kore.Builtin.Map ( internalize, -- * Unification + matchUnifyNotInKeys, unifyEquals, unifyNotInKeys, @@ -606,30 +607,73 @@ matchInKeys :: Maybe (InKeys (TermLike variable)) matchInKeys = retract +data UnifyNotInKeys = UnifyNotInKeys { + inKeys :: !(InKeys (TermLike RewritingVariableName)) + , keyTerm, mapTerm :: !(TermLike RewritingVariableName) + , normalizedMap :: !(Ac.TermNormalizedAc NormalizedMap RewritingVariableName) +} + +matchUnifyNotInKeys + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyNotInKeys +matchUnifyNotInKeys first second + | Just boolValue <- Bool.matchBool first + , not boolValue + , Just inKeys@InKeys { keyTerm, mapTerm } <- matchInKeys second + , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm + = Just UnifyNotInKeys{inKeys, keyTerm, mapTerm, normalizedMap} + | otherwise = Nothing + where + normalizedOrBottom :: + InternalVariable variable => + TermLike variable -> + Ac.NormalizedOrBottom NormalizedMap variable + normalizedOrBottom = Ac.toNormalized + unifyNotInKeys :: forall unifier. MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> NotSimplifier unifier -> TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) -unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) a b = - worker a b <|> worker b a + UnifyNotInKeys -> + unifier (Pattern RewritingVariableName) +unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 unifyData = + do + let symbolicKeys = getSymbolicKeysOfAc normalizedMap + concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap + mapKeys = symbolicKeys <> concreteKeys + opaqueElements = opaque . unwrapAc $ normalizedMap + if null mapKeys && null opaqueElements + then return Pattern.top + else do + Monad.guard (not (null mapKeys) || (length opaqueElements > 1)) + -- Concrete keys are constructor-like, therefore they are defined + TermLike.assertConstructorLikeKeys concreteKeys $ return () + definedKey <- defineTerm keyTerm + definedMap <- defineTerm mapTerm + keyConditions <- traverse (unifyAndNegate keyTerm) mapKeys + + let keyInKeysOpaque = + (\term -> inject @(TermLike _) (inKeys :: InKeys (TermLike RewritingVariableName)){mapTerm = term}) + <$> opaqueElements + + opaqueConditions <- + traverse (unifyChildren termLike1) keyInKeysOpaque + let conditions = + fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) + <> [definedKey, definedMap] + return $ collectConditions conditions where - normalizedOrBottom :: - InternalVariable variable => - TermLike variable -> - Ac.NormalizedOrBottom NormalizedMap variable - normalizedOrBottom = Ac.toNormalized + UnifyNotInKeys{inKeys, keyTerm, mapTerm, normalizedMap} = unifyData defineTerm :: TermLike RewritingVariableName -> - MaybeT unifier (Condition RewritingVariableName) + unifier (Condition RewritingVariableName) defineTerm termLike = makeEvaluateTermCeil SideCondition.topTODO termLike >>= Unify.scatter - & lift eraseTerm = Pattern.fromCondition_ . Pattern.withoutTerm @@ -647,39 +691,3 @@ unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) a b = >>= Unify.scatter collectConditions terms = fold terms & Pattern.fromCondition_ - - worker :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) - worker termLike1 termLike2 - | Just boolValue <- Bool.matchBool termLike1 - , not boolValue - , Just inKeys@InKeys{keyTerm, mapTerm} <- matchInKeys termLike2 - , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm = - do - let symbolicKeys = getSymbolicKeysOfAc normalizedMap - concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap - mapKeys = symbolicKeys <> concreteKeys - opaqueElements = opaque . unwrapAc $ normalizedMap - if null mapKeys && null opaqueElements - then return Pattern.top - else do - Monad.guard (not (null mapKeys) || (length opaqueElements > 1)) - -- Concrete keys are constructor-like, therefore they are defined - TermLike.assertConstructorLikeKeys concreteKeys $ return () - definedKey <- defineTerm keyTerm - definedMap <- defineTerm mapTerm - keyConditions <- lift $ traverse (unifyAndNegate keyTerm) mapKeys - - let keyInKeysOpaque = - (\term -> inject @(TermLike _) inKeys{mapTerm = term}) - <$> opaqueElements - - opaqueConditions <- - lift $ traverse (unifyChildren termLike1) keyInKeysOpaque - let conditions = - fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) - <> [definedKey, definedMap] - return $ collectConditions conditions - worker _ _ = empty diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 6ecfc2eea3..69d2c3ab0a 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -10,6 +10,7 @@ module Kore.Step.Simplification.AndTerms ( TermTransformationOld, cannotUnifyDistinctDomainValues, functionAnd, + matchFunctionAnd, compareForEquals, ) where @@ -140,9 +141,10 @@ maybeTermEquals :: maybeTermEquals notSimplifier childTransformers first second = do injSimplifier <- Simplifier.askInjSimplifier OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier - worker injSimplifier isOverloaded + tools <- Simplifier.askMetadataTools + worker injSimplifier isOverloaded tools where - worker injSimplifier isOverloaded + worker injSimplifier isOverloaded tools | Just unifyData <- Builtin.Int.matchInt first second = lift $ Builtin.Int.unifyInt first second unifyData | Just unifyData <- Builtin.Bool.matchBools first second = @@ -175,9 +177,9 @@ maybeTermEquals notSimplifier childTransformers first second = do lift $ constructorAndEqualsAssumesDifferentHeads first second | otherwise = overloadedConstructorSortInjectionAndEquals childTransformers first second - <|> rest + <|> rest tools - rest + rest tools | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd first second = lift $ Builtin.Bool.unifyBoolAnd childTransformers first boolAndData | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd second first = @@ -209,14 +211,34 @@ maybeTermEquals notSimplifier childTransformers first second = do | otherwise = asum [ Builtin.Map.unifyEquals childTransformers first second - , Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second + , do + unifyData <- Error.hoistMaybe $ Builtin.Map.matchUnifyNotInKeys first second + lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier first unifyData + , do + unifyData <- Error.hoistMaybe $ Builtin.Map.matchUnifyNotInKeys second first + lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier second unifyData , Builtin.Set.unifyEquals childTransformers first second - , Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - first - second - , domainValueAndConstructorErrors first second + , do + unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools first second + lift $ Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + tools + first + second + unifyData + , do + unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools second first + lift $ Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + tools + second + first + unifyData + , do + unifyData <- Error.hoistMaybe $ matchDomainValueAndConstructorErrors first second + lift $ domainValueAndConstructorErrors first second unifyData ] maybeTermAnd :: @@ -231,9 +253,10 @@ maybeTermAnd :: maybeTermAnd notSimplifier childTransformers first second = do injSimplifier <- Simplifier.askInjSimplifier OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier - worker injSimplifier isOverloaded + tools <- Simplifier.askMetadataTools + worker injSimplifier isOverloaded tools where - worker injSimplifier isOverloaded + worker injSimplifier isOverloaded tools | Just unifyData <- matchExpandAlias first second = let UnifyExpandAlias{term1, term2} = unifyData in maybeTermAnd @@ -273,9 +296,9 @@ maybeTermAnd notSimplifier childTransformers first second = do lift $ constructorAndEqualsAssumesDifferentHeads first second | otherwise = overloadedConstructorSortInjectionAndEquals childTransformers first second - <|> rest + <|> rest tools - rest + rest tools | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd first second = lift $ Builtin.Bool.unifyBoolAnd childTransformers first boolAndData | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd second first = @@ -304,13 +327,30 @@ maybeTermAnd notSimplifier childTransformers first second = do asum [ Builtin.Map.unifyEquals childTransformers first second , Builtin.Set.unifyEquals childTransformers first second - , Builtin.List.unifyEquals - SimplificationType.And - childTransformers - first - second - , domainValueAndConstructorErrors first second - , Error.hoistMaybe (functionAnd first second) + , do + unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools first second + lift $ Builtin.List.unifyEquals + SimplificationType.And + childTransformers + tools + first + second + unifyData + , do + unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools second first + lift $ Builtin.List.unifyEquals + SimplificationType.And + childTransformers + tools + second + first + unifyData + , do + unifyData <- Error.hoistMaybe $ matchDomainValueAndConstructorErrors first second + lift $ domainValueAndConstructorErrors first second unifyData + , do + () <- Error.hoistMaybe $ matchFunctionAnd first second + return (functionAnd first second) ] {- | Construct the conjunction or unification of two terms. @@ -738,6 +778,25 @@ overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm = explainAndReturnBottom (fromString message) firstTerm secondTerm Left Overloading.NotApplicable -> empty +data DVConstrError + = DVConstr + | ConstrDV + +matchDomainValueAndConstructorErrors + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe DVConstrError +matchDomainValueAndConstructorErrors first second + | DV_ _ _ <- first + , App_ secondHead _ <- second + , Symbol.isConstructor secondHead + = Just DVConstr + | App_ firstHead _ <- first + , Symbol.isConstructor firstHead + , DV_ _ _ <- second + = Just ConstrDV + | otherwise = Nothing + {- | Unifcation or equality for a domain value pattern vs a constructor application. @@ -745,34 +804,25 @@ This unification case throws an error because domain values may not occur in a sort with constructors. -} domainValueAndConstructorErrors :: - Monad unifier => HasCallStack => TermLike RewritingVariableName -> TermLike RewritingVariableName -> - MaybeT unifier a -domainValueAndConstructorErrors - term1@(DV_ _ _) - term2@(App_ secondHead _) - | Symbol.isConstructor secondHead = - error - ( unlines - [ "Cannot handle DomainValue and Constructor:" - , unparseToString term1 - , unparseToString term2 - ] - ) -domainValueAndConstructorErrors - term1@(App_ firstHead _) - term2@(DV_ _ _) - | Symbol.isConstructor firstHead = - error - ( unlines - [ "Cannot handle Constructor and DomainValue:" - , unparseToString term1 - , unparseToString term2 - ] - ) -domainValueAndConstructorErrors _ _ = empty + DVConstrError -> + unifier a +domainValueAndConstructorErrors term1 term2 unifyData = + error + ( unlines + [ cannotHandle + , unparseToString term1 + , unparseToString term2 + ] + ) + + where + cannotHandle = + case unifyData of + DVConstr -> "Cannot handle DomainValue and Constructor:" + ConstrDV -> "Cannot handle Constructor and DomainValue:" data UnifyDomainValue = UnifyDomainValue { val1, val2 :: !(TermLike RewritingVariableName) @@ -867,6 +917,17 @@ unifyStringLiteral term1 term2 unifyData where UnifyStringLiteral{txt1, txt2} = unifyData +matchFunctionAnd :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe () +matchFunctionAnd first second + | isFunctionPattern first + , isFunctionPattern second + = Just () + | otherwise = Nothing +{-# INLINE matchFunctionAnd #-} + {- | Unify any two function patterns. The function patterns are unified by creating an @\\equals@ predicate. If either @@ -878,19 +939,15 @@ appears on the right-hand side. functionAnd :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe (Pattern RewritingVariableName) -functionAnd first second - | isFunctionPattern first - , isFunctionPattern second = - makeEqualsPredicate first' second' + Pattern RewritingVariableName +functionAnd first second = + makeEqualsPredicate first' second' & Predicate.markSimplified -- Ceil predicate not needed since first being -- bottom will make the entire term bottom. However, -- one must be careful to not just drop the term. & Condition.fromPredicate & Pattern.withCondition first' -- different for Equals - & pure - | otherwise = empty where (first', second') = minMaxBy compareForEquals first second diff --git a/kore/test/Test/Kore/Step/Simplification/AndTerms.hs b/kore/test/Test/Kore/Step/Simplification/AndTerms.hs index 5c3391382f..1c51743d5e 100644 --- a/kore/test/Test/Kore/Step/Simplification/AndTerms.hs +++ b/kore/test/Test/Kore/Step/Simplification/AndTerms.hs @@ -57,6 +57,7 @@ import Kore.Step.Simplification.And ( ) import Kore.Step.Simplification.AndTerms ( functionAnd, + matchFunctionAnd, termUnification, ) import Kore.Step.Simplification.Equals ( @@ -1466,7 +1467,9 @@ test_functionAnd = Pattern.withCondition (f x) $ Condition.fromPredicate $ makeEqualsPredicate (f x) (f y) - let Just actual = functionAnd (f x) (f y) + let actual = functionAnd (f x) (f y) + let matchResult = matchFunctionAnd (f x) (f y) + assertEqual "" (Just ()) matchResult assertEqual "" expect (Pattern.syncSort actual) assertBool "" (Pattern.isSimplified sideRepresentation actual) ] From 9b69f53b1ed5b3b4ca3df6c3a9ba3e3f6bb42941 Mon Sep 17 00:00:00 2001 From: github-actions Date: Tue, 25 May 2021 05:28:45 +0000 Subject: [PATCH 51/86] Format with fourmolu --- kore/src/Kore/Builtin/List.hs | 40 ++++---- kore/src/Kore/Builtin/Map.hs | 70 ++++++------- kore/src/Kore/Step/Simplification/AndTerms.hs | 97 ++++++++++--------- 3 files changed, 104 insertions(+), 103 deletions(-) diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index c951f51a02..af187ffcfb 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -82,8 +82,8 @@ import Kore.Internal.Pattern ( Conditional (..), Pattern, ) -import Kore.Internal.Symbol import qualified Kore.Internal.Pattern as Pattern +import Kore.Internal.Symbol import Kore.Internal.TermLike ( Key, Sort, @@ -375,24 +375,24 @@ builtinFunctions = , (updateAllKey, Builtin.functionEvaluator evalUpdateAll) ] -data FirstElemVarData = FirstElemVarData { - pat1, pat2 :: !(TermLike RewritingVariableName) -} +data FirstElemVarData = FirstElemVarData + { pat1, pat2 :: !(TermLike RewritingVariableName) + } -data AppAppData = AppAppData { - args1, args2 :: ![TermLike RewritingVariableName] +data AppAppData = AppAppData + { args1, args2 :: ![TermLike RewritingVariableName] , symbol2 :: !Symbol -} + } -data ListListData = ListListData { - builtin1, builtin2 :: !(InternalList (TermLike RewritingVariableName)) -} +data ListListData = ListListData + { builtin1, builtin2 :: !(InternalList (TermLike RewritingVariableName)) + } -data ListAppData = ListAppData { - pat1, pat2 :: !(TermLike RewritingVariableName) +data ListAppData = ListAppData + { pat1, pat2 :: !(TermLike RewritingVariableName) , args2 :: ![TermLike RewritingVariableName] , builtin1 :: !(InternalList (TermLike RewritingVariableName)) -} + } data UnifyEqualsList = FirstElemVar !FirstElemVarData @@ -406,20 +406,20 @@ matchUnifyEqualsList :: TermLike RewritingVariableName -> Maybe UnifyEqualsList matchUnifyEqualsList tools first second - | Just True <- isListSort tools sort1 - = worker (normalize first) (normalize second) + | Just True <- isListSort tools sort1 = + worker (normalize first) (normalize second) | otherwise = Nothing where sort1 = termLikeSort first worker pat1@(ElemVar_ _) pat2 - | TermLike.isFunctionPattern pat2 - = Just $ FirstElemVar FirstElemVarData{pat1, pat2} + | TermLike.isFunctionPattern pat2 = + Just $ FirstElemVar FirstElemVarData{pat1, pat2} | otherwise = Nothing worker (App_ symbol1 args1) (App_ symbol2 args2) | isSymbolConcat symbol1 - , isSymbolConcat symbol2 - = Just $ AppApp AppAppData{args1, args2, symbol2} + , isSymbolConcat symbol2 = + Just $ AppApp AppAppData{args1, args2, symbol2} worker pat1@(InternalList_ builtin1) pat2 = case pat2 of InternalList_ builtin2 -> Just $ ListList ListListData{builtin1, builtin2} @@ -497,9 +497,7 @@ unifyEquals pat1 pat2 _ -> Builtin.wrongArity concatKey - where - propagateConditions :: InternalVariable variable => Traversable t => diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 68bc26442e..faee601f04 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -607,22 +607,22 @@ matchInKeys :: Maybe (InKeys (TermLike variable)) matchInKeys = retract -data UnifyNotInKeys = UnifyNotInKeys { - inKeys :: !(InKeys (TermLike RewritingVariableName)) +data UnifyNotInKeys = UnifyNotInKeys + { inKeys :: !(InKeys (TermLike RewritingVariableName)) , keyTerm, mapTerm :: !(TermLike RewritingVariableName) , normalizedMap :: !(Ac.TermNormalizedAc NormalizedMap RewritingVariableName) -} + } -matchUnifyNotInKeys - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyNotInKeys +matchUnifyNotInKeys :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyNotInKeys matchUnifyNotInKeys first second | Just boolValue <- Bool.matchBool first - , not boolValue - , Just inKeys@InKeys { keyTerm, mapTerm } <- matchInKeys second - , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm - = Just UnifyNotInKeys{inKeys, keyTerm, mapTerm, normalizedMap} + , not boolValue + , Just inKeys@InKeys{keyTerm, mapTerm} <- matchInKeys second + , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm = + Just UnifyNotInKeys{inKeys, keyTerm, mapTerm, normalizedMap} | otherwise = Nothing where normalizedOrBottom :: @@ -641,30 +641,30 @@ unifyNotInKeys :: unifier (Pattern RewritingVariableName) unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 unifyData = do - let symbolicKeys = getSymbolicKeysOfAc normalizedMap - concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap - mapKeys = symbolicKeys <> concreteKeys - opaqueElements = opaque . unwrapAc $ normalizedMap - if null mapKeys && null opaqueElements - then return Pattern.top - else do - Monad.guard (not (null mapKeys) || (length opaqueElements > 1)) - -- Concrete keys are constructor-like, therefore they are defined - TermLike.assertConstructorLikeKeys concreteKeys $ return () - definedKey <- defineTerm keyTerm - definedMap <- defineTerm mapTerm - keyConditions <- traverse (unifyAndNegate keyTerm) mapKeys - - let keyInKeysOpaque = - (\term -> inject @(TermLike _) (inKeys :: InKeys (TermLike RewritingVariableName)){mapTerm = term}) - <$> opaqueElements - - opaqueConditions <- - traverse (unifyChildren termLike1) keyInKeysOpaque - let conditions = - fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) - <> [definedKey, definedMap] - return $ collectConditions conditions + let symbolicKeys = getSymbolicKeysOfAc normalizedMap + concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap + mapKeys = symbolicKeys <> concreteKeys + opaqueElements = opaque . unwrapAc $ normalizedMap + if null mapKeys && null opaqueElements + then return Pattern.top + else do + Monad.guard (not (null mapKeys) || (length opaqueElements > 1)) + -- Concrete keys are constructor-like, therefore they are defined + TermLike.assertConstructorLikeKeys concreteKeys $ return () + definedKey <- defineTerm keyTerm + definedMap <- defineTerm mapTerm + keyConditions <- traverse (unifyAndNegate keyTerm) mapKeys + + let keyInKeysOpaque = + (\term -> inject @(TermLike _) (inKeys :: InKeys (TermLike RewritingVariableName)){mapTerm = term}) + <$> opaqueElements + + opaqueConditions <- + traverse (unifyChildren termLike1) keyInKeysOpaque + let conditions = + fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) + <> [definedKey, definedMap] + return $ collectConditions conditions where UnifyNotInKeys{inKeys, keyTerm, mapTerm, normalizedMap} = unifyData diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 69d2c3ab0a..85369bab12 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -220,22 +220,24 @@ maybeTermEquals notSimplifier childTransformers first second = do , Builtin.Set.unifyEquals childTransformers first second , do unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools first second - lift $ Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - tools - first - second - unifyData + lift $ + Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + tools + first + second + unifyData , do unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools second first - lift $ Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - tools - second - first - unifyData + lift $ + Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + tools + second + first + unifyData , do unifyData <- Error.hoistMaybe $ matchDomainValueAndConstructorErrors first second lift $ domainValueAndConstructorErrors first second unifyData @@ -329,22 +331,24 @@ maybeTermAnd notSimplifier childTransformers first second = do , Builtin.Set.unifyEquals childTransformers first second , do unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools first second - lift $ Builtin.List.unifyEquals - SimplificationType.And - childTransformers - tools - first - second - unifyData + lift $ + Builtin.List.unifyEquals + SimplificationType.And + childTransformers + tools + first + second + unifyData , do unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools second first - lift $ Builtin.List.unifyEquals - SimplificationType.And - childTransformers - tools - second - first - unifyData + lift $ + Builtin.List.unifyEquals + SimplificationType.And + childTransformers + tools + second + first + unifyData , do unifyData <- Error.hoistMaybe $ matchDomainValueAndConstructorErrors first second lift $ domainValueAndConstructorErrors first second unifyData @@ -782,19 +786,19 @@ data DVConstrError = DVConstr | ConstrDV -matchDomainValueAndConstructorErrors - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe DVConstrError +matchDomainValueAndConstructorErrors :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe DVConstrError matchDomainValueAndConstructorErrors first second | DV_ _ _ <- first - , App_ secondHead _ <- second - , Symbol.isConstructor secondHead - = Just DVConstr + , App_ secondHead _ <- second + , Symbol.isConstructor secondHead = + Just DVConstr | App_ firstHead _ <- first - , Symbol.isConstructor firstHead - , DV_ _ _ <- second - = Just ConstrDV + , Symbol.isConstructor firstHead + , DV_ _ _ <- second = + Just ConstrDV | otherwise = Nothing {- | Unifcation or equality for a domain value pattern vs a constructor @@ -817,7 +821,6 @@ domainValueAndConstructorErrors term1 term2 unifyData = , unparseToString term2 ] ) - where cannotHandle = case unifyData of @@ -923,8 +926,8 @@ matchFunctionAnd :: Maybe () matchFunctionAnd first second | isFunctionPattern first - , isFunctionPattern second - = Just () + , isFunctionPattern second = + Just () | otherwise = Nothing {-# INLINE matchFunctionAnd #-} @@ -942,12 +945,12 @@ functionAnd :: Pattern RewritingVariableName functionAnd first second = makeEqualsPredicate first' second' - & Predicate.markSimplified - -- Ceil predicate not needed since first being - -- bottom will make the entire term bottom. However, - -- one must be careful to not just drop the term. - & Condition.fromPredicate - & Pattern.withCondition first' -- different for Equals + & Predicate.markSimplified + -- Ceil predicate not needed since first being + -- bottom will make the entire term bottom. However, + -- one must be careful to not just drop the term. + & Condition.fromPredicate + & Pattern.withCondition first' -- different for Equals where (first', second') = minMaxBy compareForEquals first second From 8d7a383b4f01a340814f02317a5cc9f6fb996b80 Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 25 May 2021 22:00:32 -0500 Subject: [PATCH 52/86] Revert "Format with fourmolu" This reverts commit 950055919f97744a43811d0615c7de91adafe133. --- kore/src/Kore/Builtin/List.hs | 40 ++++---- kore/src/Kore/Builtin/Map.hs | 70 ++++++------- kore/src/Kore/Step/Simplification/AndTerms.hs | 97 +++++++++---------- 3 files changed, 103 insertions(+), 104 deletions(-) diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index af187ffcfb..c951f51a02 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -82,8 +82,8 @@ import Kore.Internal.Pattern ( Conditional (..), Pattern, ) -import qualified Kore.Internal.Pattern as Pattern import Kore.Internal.Symbol +import qualified Kore.Internal.Pattern as Pattern import Kore.Internal.TermLike ( Key, Sort, @@ -375,24 +375,24 @@ builtinFunctions = , (updateAllKey, Builtin.functionEvaluator evalUpdateAll) ] -data FirstElemVarData = FirstElemVarData - { pat1, pat2 :: !(TermLike RewritingVariableName) - } +data FirstElemVarData = FirstElemVarData { + pat1, pat2 :: !(TermLike RewritingVariableName) +} -data AppAppData = AppAppData - { args1, args2 :: ![TermLike RewritingVariableName] +data AppAppData = AppAppData { + args1, args2 :: ![TermLike RewritingVariableName] , symbol2 :: !Symbol - } +} -data ListListData = ListListData - { builtin1, builtin2 :: !(InternalList (TermLike RewritingVariableName)) - } +data ListListData = ListListData { + builtin1, builtin2 :: !(InternalList (TermLike RewritingVariableName)) +} -data ListAppData = ListAppData - { pat1, pat2 :: !(TermLike RewritingVariableName) +data ListAppData = ListAppData { + pat1, pat2 :: !(TermLike RewritingVariableName) , args2 :: ![TermLike RewritingVariableName] , builtin1 :: !(InternalList (TermLike RewritingVariableName)) - } +} data UnifyEqualsList = FirstElemVar !FirstElemVarData @@ -406,20 +406,20 @@ matchUnifyEqualsList :: TermLike RewritingVariableName -> Maybe UnifyEqualsList matchUnifyEqualsList tools first second - | Just True <- isListSort tools sort1 = - worker (normalize first) (normalize second) + | Just True <- isListSort tools sort1 + = worker (normalize first) (normalize second) | otherwise = Nothing where sort1 = termLikeSort first worker pat1@(ElemVar_ _) pat2 - | TermLike.isFunctionPattern pat2 = - Just $ FirstElemVar FirstElemVarData{pat1, pat2} + | TermLike.isFunctionPattern pat2 + = Just $ FirstElemVar FirstElemVarData{pat1, pat2} | otherwise = Nothing worker (App_ symbol1 args1) (App_ symbol2 args2) | isSymbolConcat symbol1 - , isSymbolConcat symbol2 = - Just $ AppApp AppAppData{args1, args2, symbol2} + , isSymbolConcat symbol2 + = Just $ AppApp AppAppData{args1, args2, symbol2} worker pat1@(InternalList_ builtin1) pat2 = case pat2 of InternalList_ builtin2 -> Just $ ListList ListListData{builtin1, builtin2} @@ -497,7 +497,9 @@ unifyEquals pat1 pat2 _ -> Builtin.wrongArity concatKey + where + propagateConditions :: InternalVariable variable => Traversable t => diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index faee601f04..68bc26442e 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -607,22 +607,22 @@ matchInKeys :: Maybe (InKeys (TermLike variable)) matchInKeys = retract -data UnifyNotInKeys = UnifyNotInKeys - { inKeys :: !(InKeys (TermLike RewritingVariableName)) +data UnifyNotInKeys = UnifyNotInKeys { + inKeys :: !(InKeys (TermLike RewritingVariableName)) , keyTerm, mapTerm :: !(TermLike RewritingVariableName) , normalizedMap :: !(Ac.TermNormalizedAc NormalizedMap RewritingVariableName) - } +} -matchUnifyNotInKeys :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - Maybe UnifyNotInKeys +matchUnifyNotInKeys + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe UnifyNotInKeys matchUnifyNotInKeys first second | Just boolValue <- Bool.matchBool first - , not boolValue - , Just inKeys@InKeys{keyTerm, mapTerm} <- matchInKeys second - , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm = - Just UnifyNotInKeys{inKeys, keyTerm, mapTerm, normalizedMap} + , not boolValue + , Just inKeys@InKeys { keyTerm, mapTerm } <- matchInKeys second + , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm + = Just UnifyNotInKeys{inKeys, keyTerm, mapTerm, normalizedMap} | otherwise = Nothing where normalizedOrBottom :: @@ -641,30 +641,30 @@ unifyNotInKeys :: unifier (Pattern RewritingVariableName) unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 unifyData = do - let symbolicKeys = getSymbolicKeysOfAc normalizedMap - concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap - mapKeys = symbolicKeys <> concreteKeys - opaqueElements = opaque . unwrapAc $ normalizedMap - if null mapKeys && null opaqueElements - then return Pattern.top - else do - Monad.guard (not (null mapKeys) || (length opaqueElements > 1)) - -- Concrete keys are constructor-like, therefore they are defined - TermLike.assertConstructorLikeKeys concreteKeys $ return () - definedKey <- defineTerm keyTerm - definedMap <- defineTerm mapTerm - keyConditions <- traverse (unifyAndNegate keyTerm) mapKeys - - let keyInKeysOpaque = - (\term -> inject @(TermLike _) (inKeys :: InKeys (TermLike RewritingVariableName)){mapTerm = term}) - <$> opaqueElements - - opaqueConditions <- - traverse (unifyChildren termLike1) keyInKeysOpaque - let conditions = - fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) - <> [definedKey, definedMap] - return $ collectConditions conditions + let symbolicKeys = getSymbolicKeysOfAc normalizedMap + concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap + mapKeys = symbolicKeys <> concreteKeys + opaqueElements = opaque . unwrapAc $ normalizedMap + if null mapKeys && null opaqueElements + then return Pattern.top + else do + Monad.guard (not (null mapKeys) || (length opaqueElements > 1)) + -- Concrete keys are constructor-like, therefore they are defined + TermLike.assertConstructorLikeKeys concreteKeys $ return () + definedKey <- defineTerm keyTerm + definedMap <- defineTerm mapTerm + keyConditions <- traverse (unifyAndNegate keyTerm) mapKeys + + let keyInKeysOpaque = + (\term -> inject @(TermLike _) (inKeys :: InKeys (TermLike RewritingVariableName)){mapTerm = term}) + <$> opaqueElements + + opaqueConditions <- + traverse (unifyChildren termLike1) keyInKeysOpaque + let conditions = + fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) + <> [definedKey, definedMap] + return $ collectConditions conditions where UnifyNotInKeys{inKeys, keyTerm, mapTerm, normalizedMap} = unifyData diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 85369bab12..69d2c3ab0a 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -220,24 +220,22 @@ maybeTermEquals notSimplifier childTransformers first second = do , Builtin.Set.unifyEquals childTransformers first second , do unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools first second - lift $ - Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - tools - first - second - unifyData + lift $ Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + tools + first + second + unifyData , do unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools second first - lift $ - Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - tools - second - first - unifyData + lift $ Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + tools + second + first + unifyData , do unifyData <- Error.hoistMaybe $ matchDomainValueAndConstructorErrors first second lift $ domainValueAndConstructorErrors first second unifyData @@ -331,24 +329,22 @@ maybeTermAnd notSimplifier childTransformers first second = do , Builtin.Set.unifyEquals childTransformers first second , do unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools first second - lift $ - Builtin.List.unifyEquals - SimplificationType.And - childTransformers - tools - first - second - unifyData + lift $ Builtin.List.unifyEquals + SimplificationType.And + childTransformers + tools + first + second + unifyData , do unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools second first - lift $ - Builtin.List.unifyEquals - SimplificationType.And - childTransformers - tools - second - first - unifyData + lift $ Builtin.List.unifyEquals + SimplificationType.And + childTransformers + tools + second + first + unifyData , do unifyData <- Error.hoistMaybe $ matchDomainValueAndConstructorErrors first second lift $ domainValueAndConstructorErrors first second unifyData @@ -786,19 +782,19 @@ data DVConstrError = DVConstr | ConstrDV -matchDomainValueAndConstructorErrors :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - Maybe DVConstrError +matchDomainValueAndConstructorErrors + :: TermLike RewritingVariableName + -> TermLike RewritingVariableName + -> Maybe DVConstrError matchDomainValueAndConstructorErrors first second | DV_ _ _ <- first - , App_ secondHead _ <- second - , Symbol.isConstructor secondHead = - Just DVConstr + , App_ secondHead _ <- second + , Symbol.isConstructor secondHead + = Just DVConstr | App_ firstHead _ <- first - , Symbol.isConstructor firstHead - , DV_ _ _ <- second = - Just ConstrDV + , Symbol.isConstructor firstHead + , DV_ _ _ <- second + = Just ConstrDV | otherwise = Nothing {- | Unifcation or equality for a domain value pattern vs a constructor @@ -821,6 +817,7 @@ domainValueAndConstructorErrors term1 term2 unifyData = , unparseToString term2 ] ) + where cannotHandle = case unifyData of @@ -926,8 +923,8 @@ matchFunctionAnd :: Maybe () matchFunctionAnd first second | isFunctionPattern first - , isFunctionPattern second = - Just () + , isFunctionPattern second + = Just () | otherwise = Nothing {-# INLINE matchFunctionAnd #-} @@ -945,12 +942,12 @@ functionAnd :: Pattern RewritingVariableName functionAnd first second = makeEqualsPredicate first' second' - & Predicate.markSimplified - -- Ceil predicate not needed since first being - -- bottom will make the entire term bottom. However, - -- one must be careful to not just drop the term. - & Condition.fromPredicate - & Pattern.withCondition first' -- different for Equals + & Predicate.markSimplified + -- Ceil predicate not needed since first being + -- bottom will make the entire term bottom. However, + -- one must be careful to not just drop the term. + & Condition.fromPredicate + & Pattern.withCondition first' -- different for Equals where (first', second') = minMaxBy compareForEquals first second From 65eb5ea6af09dae56f2f339c37b2c212c9c6755a Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 25 May 2021 22:01:04 -0500 Subject: [PATCH 53/86] Revert "More progress on refactoring unification functions" This reverts commit 042addfbc129f12a9bf2dc3bf60043c718707a0b. --- kore/src/Kore/Builtin/List.hs | 153 +++++++----------- kore/src/Kore/Builtin/Map.hs | 102 ++++++------ kore/src/Kore/Step/Simplification/AndTerms.hs | 153 ++++++------------ .../Test/Kore/Step/Simplification/AndTerms.hs | 5 +- 4 files changed, 158 insertions(+), 255 deletions(-) diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index c951f51a02..2c858055c6 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -23,7 +23,6 @@ module Kore.Builtin.List ( asPattern, asInternal, internalize, - matchUnifyEqualsList, -- * Symbols lookupSymbolGet, @@ -66,7 +65,6 @@ import qualified Data.Sequence as Seq import Data.Text ( Text, ) -import qualified Kore.Attribute.Symbol as Attribute import qualified Kore.Builtin.Bool as Bool import Kore.Builtin.Builtin ( acceptAnySort, @@ -82,7 +80,6 @@ import Kore.Internal.Pattern ( Conditional (..), Pattern, ) -import Kore.Internal.Symbol import qualified Kore.Internal.Pattern as Pattern import Kore.Internal.TermLike ( Key, @@ -375,61 +372,6 @@ builtinFunctions = , (updateAllKey, Builtin.functionEvaluator evalUpdateAll) ] -data FirstElemVarData = FirstElemVarData { - pat1, pat2 :: !(TermLike RewritingVariableName) -} - -data AppAppData = AppAppData { - args1, args2 :: ![TermLike RewritingVariableName] - , symbol2 :: !Symbol -} - -data ListListData = ListListData { - builtin1, builtin2 :: !(InternalList (TermLike RewritingVariableName)) -} - -data ListAppData = ListAppData { - pat1, pat2 :: !(TermLike RewritingVariableName) - , args2 :: ![TermLike RewritingVariableName] - , builtin1 :: !(InternalList (TermLike RewritingVariableName)) -} - -data UnifyEqualsList - = FirstElemVar !FirstElemVarData - | AppApp !AppAppData - | ListList !ListListData - | ListApp !ListAppData - -matchUnifyEqualsList :: - SmtMetadataTools Attribute.Symbol -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - Maybe UnifyEqualsList -matchUnifyEqualsList tools first second - | Just True <- isListSort tools sort1 - = worker (normalize first) (normalize second) - | otherwise = Nothing - where - sort1 = termLikeSort first - - worker pat1@(ElemVar_ _) pat2 - | TermLike.isFunctionPattern pat2 - = Just $ FirstElemVar FirstElemVarData{pat1, pat2} - | otherwise = Nothing - worker (App_ symbol1 args1) (App_ symbol2 args2) - | isSymbolConcat symbol1 - , isSymbolConcat symbol2 - = Just $ AppApp AppAppData{args1, args2, symbol2} - worker pat1@(InternalList_ builtin1) pat2 = - case pat2 of - InternalList_ builtin2 -> Just $ ListList ListListData{builtin1, builtin2} - App_ symbol2 args2 - | isSymbolConcat symbol2 -> Just $ ListApp ListAppData{pat1, pat2, args2, builtin1} - | otherwise -> Nothing - _ -> Nothing - worker _ _ = Nothing -{-# INLINE matchUnifyEqualsList #-} - {- | Simplify the conjunction or equality of two concrete List domain values. When it is used for simplifying equality, one should separately solve the @@ -447,23 +389,45 @@ unifyEquals :: TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) ) -> - SmtMetadataTools Attribute.Symbol -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - UnifyEqualsList -> - unifier (Pattern RewritingVariableName) + MaybeT unifier (Pattern RewritingVariableName) unifyEquals simplificationType simplifyChild - tools first - second - unifyData = - case unifyData of - FirstElemVar FirstElemVarData{pat1, pat2} -> - simplifyChild pat1 pat2 - AppApp AppAppData{args1, args2, symbol2} -> - case (args1, args2) of + second = + do + tools <- Simplifier.askMetadataTools + (Monad.guard . fromMaybe False) (isListSort tools sort1) + unifyEquals0 (normalize first) (normalize second) + where + sort1 = termLikeSort first + + propagateConditions :: + InternalVariable variable => + Traversable t => + t (Conditional variable a) -> + Conditional variable (t a) + propagateConditions = sequenceA + + unifyEquals0 :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + MaybeT unifier (Pattern RewritingVariableName) + + unifyEquals0 pat1@(ElemVar_ _) pat2 + | TermLike.isFunctionPattern pat2 = + lift $ simplifyChild pat1 pat2 + | otherwise = empty + unifyEquals0 pat1 pat2@(ElemVar_ _) + | TermLike.isFunctionPattern pat1 = + lift $ simplifyChild pat1 pat2 + | otherwise = empty + unifyEquals0 (App_ symbol1 args1) (App_ symbol2 args2) + | isSymbolConcat symbol1 + , isSymbolConcat symbol1 = + lift $ case (args1, args2) of ( [InternalList_ builtin1, x1@(Var_ _)] , [InternalList_ builtin2, x2@(Var_ _)] ) -> @@ -483,29 +447,29 @@ unifyEquals x2 builtin2 _ -> empty - ListList ListListData{builtin1, builtin2} -> - unifyEqualsConcrete builtin1 builtin2 - ListApp ListAppData{pat1, pat2, args2, builtin1} -> - case args2 of - [InternalList_ builtin2, x@(Var_ _)] -> - unifyEqualsFramedRight builtin1 builtin2 x - [x@(Var_ _), InternalList_ builtin2] -> - unifyEqualsFramedLeft builtin1 x builtin2 - [_, _] -> - Builtin.unifyEqualsUnsolved - simplificationType - pat1 - pat2 - _ -> Builtin.wrongArity concatKey - - where - - propagateConditions :: - InternalVariable variable => - Traversable t => - t (Conditional variable a) -> - Conditional variable (t a) - propagateConditions = sequenceA + unifyEquals0 dv1@(InternalList_ builtin1) pat2 = + case pat2 of + InternalList_ builtin2 -> + lift $ unifyEqualsConcrete builtin1 builtin2 + app@(App_ symbol2 args2) + | isSymbolConcat symbol2 -> + lift $ case args2 of + [InternalList_ builtin2, x@(Var_ _)] -> + unifyEqualsFramedRight builtin1 builtin2 x + [x@(Var_ _), InternalList_ builtin2] -> + unifyEqualsFramedLeft builtin1 x builtin2 + [_, _] -> + Builtin.unifyEqualsUnsolved + simplificationType + dv1 + app + _ -> Builtin.wrongArity concatKey + | otherwise -> empty + _ -> empty + unifyEquals0 pat1 pat2 = + case pat2 of + dv@(InternalList_ _) -> unifyEquals0 dv pat1 + _ -> empty unifyEqualsConcrete :: InternalList (TermLike RewritingVariableName) -> @@ -514,6 +478,7 @@ unifyEquals unifyEqualsConcrete builtin1 builtin2 | Seq.length list1 /= Seq.length list2 = bottomWithExplanation | otherwise = do + tools <- Simplifier.askMetadataTools Reflection.give tools $ do unified <- sequence $ Seq.zipWith simplifyChild list1 list2 let propagatedUnified = propagateConditions unified @@ -539,6 +504,7 @@ unifyEquals | Seq.length prefix2 > Seq.length list1 = bottomWithExplanation | otherwise = do + tools <- Simplifier.askMetadataTools let listSuffix1 = asInternal tools internalListSort suffix1 prefixUnified <- unifyEqualsConcrete @@ -570,6 +536,7 @@ unifyEquals | Seq.length suffix2 > Seq.length list1 = bottomWithExplanation | otherwise = do + tools <- Simplifier.askMetadataTools let listPrefix1 = asInternal tools internalListSort prefix1 prefixUnified <- simplifyChild frame2 listPrefix1 suffixUnified <- @@ -609,6 +576,7 @@ unifyEquals internal2 frame2 | length1 < length2 = do + tools <- Simplifier.askMetadataTools prefixUnified <- unifyEqualsConcrete internal1 @@ -658,6 +626,7 @@ unifyEquals frame2 internal2 | length1 < length2 = do + tools <- Simplifier.askMetadataTools let listPrefix2 = asInternal tools internalListSort prefix2 frame2Prefix2 = mkApplySymbol symbol [frame2, listPrefix2] prefixUnified <- simplifyChild frame1 frame2Prefix2 diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 68bc26442e..135102004b 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -19,7 +19,6 @@ module Kore.Builtin.Map ( internalize, -- * Unification - matchUnifyNotInKeys, unifyEquals, unifyNotInKeys, @@ -607,73 +606,30 @@ matchInKeys :: Maybe (InKeys (TermLike variable)) matchInKeys = retract -data UnifyNotInKeys = UnifyNotInKeys { - inKeys :: !(InKeys (TermLike RewritingVariableName)) - , keyTerm, mapTerm :: !(TermLike RewritingVariableName) - , normalizedMap :: !(Ac.TermNormalizedAc NormalizedMap RewritingVariableName) -} - -matchUnifyNotInKeys - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe UnifyNotInKeys -matchUnifyNotInKeys first second - | Just boolValue <- Bool.matchBool first - , not boolValue - , Just inKeys@InKeys { keyTerm, mapTerm } <- matchInKeys second - , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm - = Just UnifyNotInKeys{inKeys, keyTerm, mapTerm, normalizedMap} - | otherwise = Nothing - where - normalizedOrBottom :: - InternalVariable variable => - TermLike variable -> - Ac.NormalizedOrBottom NormalizedMap variable - normalizedOrBottom = Ac.toNormalized - unifyNotInKeys :: forall unifier. MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> NotSimplifier unifier -> TermLike RewritingVariableName -> - UnifyNotInKeys -> - unifier (Pattern RewritingVariableName) -unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 unifyData = - do - let symbolicKeys = getSymbolicKeysOfAc normalizedMap - concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap - mapKeys = symbolicKeys <> concreteKeys - opaqueElements = opaque . unwrapAc $ normalizedMap - if null mapKeys && null opaqueElements - then return Pattern.top - else do - Monad.guard (not (null mapKeys) || (length opaqueElements > 1)) - -- Concrete keys are constructor-like, therefore they are defined - TermLike.assertConstructorLikeKeys concreteKeys $ return () - definedKey <- defineTerm keyTerm - definedMap <- defineTerm mapTerm - keyConditions <- traverse (unifyAndNegate keyTerm) mapKeys - - let keyInKeysOpaque = - (\term -> inject @(TermLike _) (inKeys :: InKeys (TermLike RewritingVariableName)){mapTerm = term}) - <$> opaqueElements - - opaqueConditions <- - traverse (unifyChildren termLike1) keyInKeysOpaque - let conditions = - fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) - <> [definedKey, definedMap] - return $ collectConditions conditions + TermLike RewritingVariableName -> + MaybeT unifier (Pattern RewritingVariableName) +unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) a b = + worker a b <|> worker b a where - UnifyNotInKeys{inKeys, keyTerm, mapTerm, normalizedMap} = unifyData + normalizedOrBottom :: + InternalVariable variable => + TermLike variable -> + Ac.NormalizedOrBottom NormalizedMap variable + normalizedOrBottom = Ac.toNormalized defineTerm :: TermLike RewritingVariableName -> - unifier (Condition RewritingVariableName) + MaybeT unifier (Condition RewritingVariableName) defineTerm termLike = makeEvaluateTermCeil SideCondition.topTODO termLike >>= Unify.scatter + & lift eraseTerm = Pattern.fromCondition_ . Pattern.withoutTerm @@ -691,3 +647,39 @@ unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 unifyData = >>= Unify.scatter collectConditions terms = fold terms & Pattern.fromCondition_ + + worker :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + MaybeT unifier (Pattern RewritingVariableName) + worker termLike1 termLike2 + | Just boolValue <- Bool.matchBool termLike1 + , not boolValue + , Just inKeys@InKeys{keyTerm, mapTerm} <- matchInKeys termLike2 + , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm = + do + let symbolicKeys = getSymbolicKeysOfAc normalizedMap + concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap + mapKeys = symbolicKeys <> concreteKeys + opaqueElements = opaque . unwrapAc $ normalizedMap + if null mapKeys && null opaqueElements + then return Pattern.top + else do + Monad.guard (not (null mapKeys) || (length opaqueElements > 1)) + -- Concrete keys are constructor-like, therefore they are defined + TermLike.assertConstructorLikeKeys concreteKeys $ return () + definedKey <- defineTerm keyTerm + definedMap <- defineTerm mapTerm + keyConditions <- lift $ traverse (unifyAndNegate keyTerm) mapKeys + + let keyInKeysOpaque = + (\term -> inject @(TermLike _) inKeys{mapTerm = term}) + <$> opaqueElements + + opaqueConditions <- + lift $ traverse (unifyChildren termLike1) keyInKeysOpaque + let conditions = + fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) + <> [definedKey, definedMap] + return $ collectConditions conditions + worker _ _ = empty diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 69d2c3ab0a..2feaa874f2 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -10,7 +10,6 @@ module Kore.Step.Simplification.AndTerms ( TermTransformationOld, cannotUnifyDistinctDomainValues, functionAnd, - matchFunctionAnd, compareForEquals, ) where @@ -113,13 +112,13 @@ termUnification notSimplifier = \term1 term2 -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) - termUnificationWorker pat1 pat2 = do + termUnificationWorker term1 term2 = do let maybeTermUnification :: MaybeT unifier (Pattern RewritingVariableName) maybeTermUnification = - maybeTermAnd notSimplifier termUnificationWorker pat1 pat2 + maybeTermAnd notSimplifier termUnificationWorker term1 term2 Error.maybeT - (incompleteUnificationPattern pat1 pat2) + (incompleteUnificationPattern term1 term2) pure maybeTermUnification @@ -211,34 +210,14 @@ maybeTermEquals notSimplifier childTransformers first second = do | otherwise = asum [ Builtin.Map.unifyEquals childTransformers first second - , do - unifyData <- Error.hoistMaybe $ Builtin.Map.matchUnifyNotInKeys first second - lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier first unifyData - , do - unifyData <- Error.hoistMaybe $ Builtin.Map.matchUnifyNotInKeys second first - lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier second unifyData + , Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second , Builtin.Set.unifyEquals childTransformers first second - , do - unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools first second - lift $ Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - tools - first - second - unifyData - , do - unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools second first - lift $ Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - tools - second - first - unifyData - , do - unifyData <- Error.hoistMaybe $ matchDomainValueAndConstructorErrors first second - lift $ domainValueAndConstructorErrors first second unifyData + , Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + first + second + , domainValueAndConstructorErrors first second ] maybeTermAnd :: @@ -327,30 +306,13 @@ maybeTermAnd notSimplifier childTransformers first second = do asum [ Builtin.Map.unifyEquals childTransformers first second , Builtin.Set.unifyEquals childTransformers first second - , do - unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools first second - lift $ Builtin.List.unifyEquals - SimplificationType.And - childTransformers - tools - first - second - unifyData - , do - unifyData <- Error.hoistMaybe $ Builtin.List.matchUnifyEqualsList tools second first - lift $ Builtin.List.unifyEquals - SimplificationType.And - childTransformers - tools - second - first - unifyData - , do - unifyData <- Error.hoistMaybe $ matchDomainValueAndConstructorErrors first second - lift $ domainValueAndConstructorErrors first second unifyData - , do - () <- Error.hoistMaybe $ matchFunctionAnd first second - return (functionAnd first second) + , Builtin.List.unifyEquals + SimplificationType.And + childTransformers + first + second + , domainValueAndConstructorErrors first second + , Error.hoistMaybe (functionAnd first second) ] {- | Construct the conjunction or unification of two terms. @@ -778,25 +740,6 @@ overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm = explainAndReturnBottom (fromString message) firstTerm secondTerm Left Overloading.NotApplicable -> empty -data DVConstrError - = DVConstr - | ConstrDV - -matchDomainValueAndConstructorErrors - :: TermLike RewritingVariableName - -> TermLike RewritingVariableName - -> Maybe DVConstrError -matchDomainValueAndConstructorErrors first second - | DV_ _ _ <- first - , App_ secondHead _ <- second - , Symbol.isConstructor secondHead - = Just DVConstr - | App_ firstHead _ <- first - , Symbol.isConstructor firstHead - , DV_ _ _ <- second - = Just ConstrDV - | otherwise = Nothing - {- | Unifcation or equality for a domain value pattern vs a constructor application. @@ -804,25 +747,34 @@ This unification case throws an error because domain values may not occur in a sort with constructors. -} domainValueAndConstructorErrors :: + Monad unifier => HasCallStack => TermLike RewritingVariableName -> TermLike RewritingVariableName -> - DVConstrError -> - unifier a -domainValueAndConstructorErrors term1 term2 unifyData = - error - ( unlines - [ cannotHandle - , unparseToString term1 - , unparseToString term2 - ] - ) - - where - cannotHandle = - case unifyData of - DVConstr -> "Cannot handle DomainValue and Constructor:" - ConstrDV -> "Cannot handle Constructor and DomainValue:" + MaybeT unifier a +domainValueAndConstructorErrors + term1@(DV_ _ _) + term2@(App_ secondHead _) + | Symbol.isConstructor secondHead = + error + ( unlines + [ "Cannot handle DomainValue and Constructor:" + , unparseToString term1 + , unparseToString term2 + ] + ) +domainValueAndConstructorErrors + term1@(App_ firstHead _) + term2@(DV_ _ _) + | Symbol.isConstructor firstHead = + error + ( unlines + [ "Cannot handle Constructor and DomainValue:" + , unparseToString term1 + , unparseToString term2 + ] + ) +domainValueAndConstructorErrors _ _ = empty data UnifyDomainValue = UnifyDomainValue { val1, val2 :: !(TermLike RewritingVariableName) @@ -917,17 +869,6 @@ unifyStringLiteral term1 term2 unifyData where UnifyStringLiteral{txt1, txt2} = unifyData -matchFunctionAnd :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - Maybe () -matchFunctionAnd first second - | isFunctionPattern first - , isFunctionPattern second - = Just () - | otherwise = Nothing -{-# INLINE matchFunctionAnd #-} - {- | Unify any two function patterns. The function patterns are unified by creating an @\\equals@ predicate. If either @@ -939,15 +880,19 @@ appears on the right-hand side. functionAnd :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Pattern RewritingVariableName -functionAnd first second = - makeEqualsPredicate first' second' + Maybe (Pattern RewritingVariableName) +functionAnd first second + | isFunctionPattern first + , isFunctionPattern second = + makeEqualsPredicate first' second' & Predicate.markSimplified -- Ceil predicate not needed since first being -- bottom will make the entire term bottom. However, -- one must be careful to not just drop the term. & Condition.fromPredicate & Pattern.withCondition first' -- different for Equals + & pure + | otherwise = empty where (first', second') = minMaxBy compareForEquals first second diff --git a/kore/test/Test/Kore/Step/Simplification/AndTerms.hs b/kore/test/Test/Kore/Step/Simplification/AndTerms.hs index 1c51743d5e..5c3391382f 100644 --- a/kore/test/Test/Kore/Step/Simplification/AndTerms.hs +++ b/kore/test/Test/Kore/Step/Simplification/AndTerms.hs @@ -57,7 +57,6 @@ import Kore.Step.Simplification.And ( ) import Kore.Step.Simplification.AndTerms ( functionAnd, - matchFunctionAnd, termUnification, ) import Kore.Step.Simplification.Equals ( @@ -1467,9 +1466,7 @@ test_functionAnd = Pattern.withCondition (f x) $ Condition.fromPredicate $ makeEqualsPredicate (f x) (f y) - let actual = functionAnd (f x) (f y) - let matchResult = matchFunctionAnd (f x) (f y) - assertEqual "" (Just ()) matchResult + let Just actual = functionAnd (f x) (f y) assertEqual "" expect (Pattern.syncSort actual) assertBool "" (Pattern.isSimplified sideRepresentation actual) ] From 1ebe9105dd2b78be1bbc872d2dfb0d1f82cc18c0 Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 25 May 2021 22:45:41 -0500 Subject: [PATCH 54/86] Updating dVAndConstructorErrors --- kore/src/Kore/Step/Simplification/AndTerms.hs | 92 +++++++++++-------- 1 file changed, 53 insertions(+), 39 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 2feaa874f2..97d5973a04 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -208,17 +208,20 @@ maybeTermEquals notSimplifier childTransformers first second = do | Just unifyData <- Builtin.Signedness.matchUnifyEqualsSignedness first second = lift $ Builtin.Signedness.unifyEquals first second unifyData | otherwise = - asum - [ Builtin.Map.unifyEquals childTransformers first second - , Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second - , Builtin.Set.unifyEquals childTransformers first second - , Builtin.List.unifyEquals + Builtin.Map.unifyEquals childTransformers first second + <|> Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second + <|> Builtin.Set.unifyEquals childTransformers first second + <|> Builtin.List.unifyEquals SimplificationType.Equals childTransformers first second - , domainValueAndConstructorErrors first second - ] + <|> rest' + where + rest' + | Just unifyData <- matchDomainValueAndConstructorErrors first second = + lift $ domainValueAndConstructorErrors first second unifyData + | otherwise = empty maybeTermAnd :: MonadUnify unifier => @@ -303,17 +306,19 @@ maybeTermAnd notSimplifier childTransformers first second = do | Just unifyData <- Builtin.Signedness.matchUnifyEqualsSignedness first second = lift $ Builtin.Signedness.unifyEquals first second unifyData | otherwise = - asum - [ Builtin.Map.unifyEquals childTransformers first second - , Builtin.Set.unifyEquals childTransformers first second - , Builtin.List.unifyEquals + Builtin.Map.unifyEquals childTransformers first second + <|> Builtin.Set.unifyEquals childTransformers first second + <|> Builtin.List.unifyEquals SimplificationType.And childTransformers first second - , domainValueAndConstructorErrors first second - , Error.hoistMaybe (functionAnd first second) - ] + <|> rest' + where + rest' + | Just unifyData <- matchDomainValueAndConstructorErrors first second = + lift $ domainValueAndConstructorErrors first second unifyData + | otherwise = Error.hoistMaybe (functionAnd first second) {- | Construct the conjunction or unification of two terms. @@ -740,6 +745,25 @@ overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm = explainAndReturnBottom (fromString message) firstTerm secondTerm Left Overloading.NotApplicable -> empty +data DVConstrError + = DVConstr + | ConstrDV + +matchDomainValueAndConstructorErrors :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe DVConstrError +matchDomainValueAndConstructorErrors first second + | DV_ _ _ <- first + , App_ secondHead _ <- second + , Symbol.isConstructor secondHead = + Just DVConstr + | App_ firstHead _ <- first + , Symbol.isConstructor firstHead + , DV_ _ _ <- second = + Just ConstrDV + | otherwise = Nothing + {- | Unifcation or equality for a domain value pattern vs a constructor application. @@ -747,34 +771,24 @@ This unification case throws an error because domain values may not occur in a sort with constructors. -} domainValueAndConstructorErrors :: - Monad unifier => HasCallStack => TermLike RewritingVariableName -> TermLike RewritingVariableName -> - MaybeT unifier a -domainValueAndConstructorErrors - term1@(DV_ _ _) - term2@(App_ secondHead _) - | Symbol.isConstructor secondHead = - error - ( unlines - [ "Cannot handle DomainValue and Constructor:" - , unparseToString term1 - , unparseToString term2 - ] - ) -domainValueAndConstructorErrors - term1@(App_ firstHead _) - term2@(DV_ _ _) - | Symbol.isConstructor firstHead = - error - ( unlines - [ "Cannot handle Constructor and DomainValue:" - , unparseToString term1 - , unparseToString term2 - ] - ) -domainValueAndConstructorErrors _ _ = empty + DVConstrError -> + unifier a +domainValueAndConstructorErrors term1 term2 unifyData = + error + ( unlines + [ cannotHandle + , unparseToString term1 + , unparseToString term2 + ] + ) + where + cannotHandle = + case unifyData of + DVConstr -> "Cannot handle DomainValue and Constructor:" + ConstrDV -> "Cannot handle Constructor and DomainValue:" data UnifyDomainValue = UnifyDomainValue { val1, val2 :: !(TermLike RewritingVariableName) From dbb331ac416ee248f09ce151b897fcbbbefafc58 Mon Sep 17 00:00:00 2001 From: github-actions Date: Wed, 26 May 2021 03:47:56 +0000 Subject: [PATCH 55/86] Format with fourmolu --- kore/src/Kore/Step/Simplification/AndTerms.hs | 34 +++++++++---------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 97d5973a04..8adc87bd0d 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -209,19 +209,19 @@ maybeTermEquals notSimplifier childTransformers first second = do lift $ Builtin.Signedness.unifyEquals first second unifyData | otherwise = Builtin.Map.unifyEquals childTransformers first second - <|> Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second - <|> Builtin.Set.unifyEquals childTransformers first second - <|> Builtin.List.unifyEquals + <|> Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second + <|> Builtin.Set.unifyEquals childTransformers first second + <|> Builtin.List.unifyEquals SimplificationType.Equals childTransformers first second - <|> rest' - where - rest' - | Just unifyData <- matchDomainValueAndConstructorErrors first second = - lift $ domainValueAndConstructorErrors first second unifyData - | otherwise = empty + <|> rest' + where + rest' + | Just unifyData <- matchDomainValueAndConstructorErrors first second = + lift $ domainValueAndConstructorErrors first second unifyData + | otherwise = empty maybeTermAnd :: MonadUnify unifier => @@ -307,18 +307,18 @@ maybeTermAnd notSimplifier childTransformers first second = do lift $ Builtin.Signedness.unifyEquals first second unifyData | otherwise = Builtin.Map.unifyEquals childTransformers first second - <|> Builtin.Set.unifyEquals childTransformers first second - <|> Builtin.List.unifyEquals + <|> Builtin.Set.unifyEquals childTransformers first second + <|> Builtin.List.unifyEquals SimplificationType.And childTransformers first second - <|> rest' - where - rest' - | Just unifyData <- matchDomainValueAndConstructorErrors first second = - lift $ domainValueAndConstructorErrors first second unifyData - | otherwise = Error.hoistMaybe (functionAnd first second) + <|> rest' + where + rest' + | Just unifyData <- matchDomainValueAndConstructorErrors first second = + lift $ domainValueAndConstructorErrors first second unifyData + | otherwise = Error.hoistMaybe (functionAnd first second) {- | Construct the conjunction or unification of two terms. From 29b5db92c2b5d26b214ee0efc406f5a498972cfa Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 25 May 2021 23:36:52 -0500 Subject: [PATCH 56/86] Updating functionAnd --- kore/src/Kore/Step/Simplification/AndTerms.hs | 38 ++++++++++++------- .../Test/Kore/Step/Simplification/AndTerms.hs | 5 ++- 2 files changed, 28 insertions(+), 15 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 8adc87bd0d..3a1c4ae3c2 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -10,6 +10,7 @@ module Kore.Step.Simplification.AndTerms ( TermTransformationOld, cannotUnifyDistinctDomainValues, functionAnd, + matchFunctionAnd, compareForEquals, ) where @@ -318,7 +319,9 @@ maybeTermAnd notSimplifier childTransformers first second = do rest' | Just unifyData <- matchDomainValueAndConstructorErrors first second = lift $ domainValueAndConstructorErrors first second unifyData - | otherwise = Error.hoistMaybe (functionAnd first second) + | Just () <- matchFunctionAnd first second = + return $ functionAnd first second + | otherwise = empty {- | Construct the conjunction or unification of two terms. @@ -883,6 +886,17 @@ unifyStringLiteral term1 term2 unifyData where UnifyStringLiteral{txt1, txt2} = unifyData +matchFunctionAnd :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe () +matchFunctionAnd first second + | isFunctionPattern first + , isFunctionPattern second = + Just () + | otherwise = Nothing +{-# INLINE matchFunctionAnd #-} + {- | Unify any two function patterns. The function patterns are unified by creating an @\\equals@ predicate. If either @@ -894,19 +908,15 @@ appears on the right-hand side. functionAnd :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe (Pattern RewritingVariableName) -functionAnd first second - | isFunctionPattern first - , isFunctionPattern second = - makeEqualsPredicate first' second' - & Predicate.markSimplified - -- Ceil predicate not needed since first being - -- bottom will make the entire term bottom. However, - -- one must be careful to not just drop the term. - & Condition.fromPredicate - & Pattern.withCondition first' -- different for Equals - & pure - | otherwise = empty + Pattern RewritingVariableName +functionAnd first second = + makeEqualsPredicate first' second' + & Predicate.markSimplified + -- Ceil predicate not needed since first being + -- bottom will make the entire term bottom. However, + -- one must be careful to not just drop the term. + & Condition.fromPredicate + & Pattern.withCondition first' -- different for Equals where (first', second') = minMaxBy compareForEquals first second diff --git a/kore/test/Test/Kore/Step/Simplification/AndTerms.hs b/kore/test/Test/Kore/Step/Simplification/AndTerms.hs index 5c3391382f..1c51743d5e 100644 --- a/kore/test/Test/Kore/Step/Simplification/AndTerms.hs +++ b/kore/test/Test/Kore/Step/Simplification/AndTerms.hs @@ -57,6 +57,7 @@ import Kore.Step.Simplification.And ( ) import Kore.Step.Simplification.AndTerms ( functionAnd, + matchFunctionAnd, termUnification, ) import Kore.Step.Simplification.Equals ( @@ -1466,7 +1467,9 @@ test_functionAnd = Pattern.withCondition (f x) $ Condition.fromPredicate $ makeEqualsPredicate (f x) (f y) - let Just actual = functionAnd (f x) (f y) + let actual = functionAnd (f x) (f y) + let matchResult = matchFunctionAnd (f x) (f y) + assertEqual "" (Just ()) matchResult assertEqual "" expect (Pattern.syncSort actual) assertBool "" (Pattern.isSimplified sideRepresentation actual) ] From 8d0a6759cf3b481df0530a3587ef904410dceb3e Mon Sep 17 00:00:00 2001 From: emarzion Date: Wed, 26 May 2021 00:50:44 -0500 Subject: [PATCH 57/86] Updating unifyEqualsList --- kore/src/Kore/Builtin/List.hs | 151 +++++++++++------- kore/src/Kore/Step/Simplification/AndTerms.hs | 44 +++-- 2 files changed, 124 insertions(+), 71 deletions(-) diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index 2c858055c6..22ed31b383 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -30,6 +30,7 @@ module Kore.Builtin.List ( isSymbolElement, isSymbolUnit, unifyEquals, + matchUnifyEqualsList, -- * keys concatKey, @@ -65,6 +66,7 @@ import qualified Data.Sequence as Seq import Data.Text ( Text, ) +import qualified Kore.Attribute.Symbol as Attribute import qualified Kore.Builtin.Bool as Bool import Kore.Builtin.Builtin ( acceptAnySort, @@ -81,6 +83,7 @@ import Kore.Internal.Pattern ( Pattern, ) import qualified Kore.Internal.Pattern as Pattern +import Kore.Internal.Symbol import Kore.Internal.TermLike ( Key, Sort, @@ -372,6 +375,61 @@ builtinFunctions = , (updateAllKey, Builtin.functionEvaluator evalUpdateAll) ] +data FirstElemVarData = FirstElemVarData + { pat1, pat2 :: !(TermLike RewritingVariableName) + } + +data AppAppData = AppAppData + { args1, args2 :: ![TermLike RewritingVariableName] + , symbol2 :: !Symbol + } + +data ListListData = ListListData + { builtin1, builtin2 :: !(InternalList (TermLike RewritingVariableName)) + } + +data ListAppData = ListAppData + { pat1, pat2 :: !(TermLike RewritingVariableName) + , args2 :: ![TermLike RewritingVariableName] + , builtin1 :: !(InternalList (TermLike RewritingVariableName)) + } + +data UnifyEqualsList + = FirstElemVar !FirstElemVarData + | AppApp !AppAppData + | ListList !ListListData + | ListApp !ListAppData + +matchUnifyEqualsList :: + SmtMetadataTools Attribute.Symbol -> + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyEqualsList +matchUnifyEqualsList tools first second + | Just True <- isListSort tools sort1 = + worker (normalize first) (normalize second) + | otherwise = Nothing + where + sort1 = termLikeSort first + + worker pat1@(ElemVar_ _) pat2 + | TermLike.isFunctionPattern pat2 = + Just $ FirstElemVar FirstElemVarData{pat1, pat2} + | otherwise = Nothing + worker (App_ symbol1 args1) (App_ symbol2 args2) + | isSymbolConcat symbol1 + , isSymbolConcat symbol2 = + Just $ AppApp AppAppData{args1, args2, symbol2} + worker pat1@(InternalList_ builtin1) pat2 = + case pat2 of + InternalList_ builtin2 -> Just $ ListList ListListData{builtin1, builtin2} + App_ symbol2 args2 + | isSymbolConcat symbol2 -> Just $ ListApp ListAppData{pat1, pat2, args2, builtin1} + | otherwise -> Nothing + _ -> Nothing + worker _ _ = Nothing +{-# INLINE matchUnifyEqualsList #-} + {- | Simplify the conjunction or equality of two concrete List domain values. When it is used for simplifying equality, one should separately solve the @@ -389,45 +447,23 @@ unifyEquals :: TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) ) -> + SmtMetadataTools Attribute.Symbol -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) + UnifyEqualsList -> + unifier (Pattern RewritingVariableName) unifyEquals simplificationType simplifyChild + tools first - second = - do - tools <- Simplifier.askMetadataTools - (Monad.guard . fromMaybe False) (isListSort tools sort1) - unifyEquals0 (normalize first) (normalize second) - where - sort1 = termLikeSort first - - propagateConditions :: - InternalVariable variable => - Traversable t => - t (Conditional variable a) -> - Conditional variable (t a) - propagateConditions = sequenceA - - unifyEquals0 :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) - - unifyEquals0 pat1@(ElemVar_ _) pat2 - | TermLike.isFunctionPattern pat2 = - lift $ simplifyChild pat1 pat2 - | otherwise = empty - unifyEquals0 pat1 pat2@(ElemVar_ _) - | TermLike.isFunctionPattern pat1 = - lift $ simplifyChild pat1 pat2 - | otherwise = empty - unifyEquals0 (App_ symbol1 args1) (App_ symbol2 args2) - | isSymbolConcat symbol1 - , isSymbolConcat symbol1 = - lift $ case (args1, args2) of + second + unifyData = + case unifyData of + FirstElemVar FirstElemVarData{pat1, pat2} -> + simplifyChild pat1 pat2 + AppApp AppAppData{args1, args2, symbol2} -> + case (args1, args2) of ( [InternalList_ builtin1, x1@(Var_ _)] , [InternalList_ builtin2, x2@(Var_ _)] ) -> @@ -447,29 +483,27 @@ unifyEquals x2 builtin2 _ -> empty - unifyEquals0 dv1@(InternalList_ builtin1) pat2 = - case pat2 of - InternalList_ builtin2 -> - lift $ unifyEqualsConcrete builtin1 builtin2 - app@(App_ symbol2 args2) - | isSymbolConcat symbol2 -> - lift $ case args2 of - [InternalList_ builtin2, x@(Var_ _)] -> - unifyEqualsFramedRight builtin1 builtin2 x - [x@(Var_ _), InternalList_ builtin2] -> - unifyEqualsFramedLeft builtin1 x builtin2 - [_, _] -> - Builtin.unifyEqualsUnsolved - simplificationType - dv1 - app - _ -> Builtin.wrongArity concatKey - | otherwise -> empty - _ -> empty - unifyEquals0 pat1 pat2 = - case pat2 of - dv@(InternalList_ _) -> unifyEquals0 dv pat1 - _ -> empty + ListList ListListData{builtin1, builtin2} -> + unifyEqualsConcrete builtin1 builtin2 + ListApp ListAppData{pat1, pat2, args2, builtin1} -> + case args2 of + [InternalList_ builtin2, x@(Var_ _)] -> + unifyEqualsFramedRight builtin1 builtin2 x + [x@(Var_ _), InternalList_ builtin2] -> + unifyEqualsFramedLeft builtin1 x builtin2 + [_, _] -> + Builtin.unifyEqualsUnsolved + simplificationType + pat1 + pat2 + _ -> Builtin.wrongArity concatKey + where + propagateConditions :: + InternalVariable variable => + Traversable t => + t (Conditional variable a) -> + Conditional variable (t a) + propagateConditions = sequenceA unifyEqualsConcrete :: InternalList (TermLike RewritingVariableName) -> @@ -478,7 +512,6 @@ unifyEquals unifyEqualsConcrete builtin1 builtin2 | Seq.length list1 /= Seq.length list2 = bottomWithExplanation | otherwise = do - tools <- Simplifier.askMetadataTools Reflection.give tools $ do unified <- sequence $ Seq.zipWith simplifyChild list1 list2 let propagatedUnified = propagateConditions unified @@ -504,7 +537,6 @@ unifyEquals | Seq.length prefix2 > Seq.length list1 = bottomWithExplanation | otherwise = do - tools <- Simplifier.askMetadataTools let listSuffix1 = asInternal tools internalListSort suffix1 prefixUnified <- unifyEqualsConcrete @@ -536,7 +568,6 @@ unifyEquals | Seq.length suffix2 > Seq.length list1 = bottomWithExplanation | otherwise = do - tools <- Simplifier.askMetadataTools let listPrefix1 = asInternal tools internalListSort prefix1 prefixUnified <- simplifyChild frame2 listPrefix1 suffixUnified <- @@ -576,7 +607,6 @@ unifyEquals internal2 frame2 | length1 < length2 = do - tools <- Simplifier.askMetadataTools prefixUnified <- unifyEqualsConcrete internal1 @@ -626,7 +656,6 @@ unifyEquals frame2 internal2 | length1 < length2 = do - tools <- Simplifier.askMetadataTools let listPrefix2 = asInternal tools internalListSort prefix2 frame2Prefix2 = mkApplySymbol symbol [frame2, listPrefix2] prefixUnified <- simplifyChild frame1 frame2Prefix2 diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 3a1c4ae3c2..a898e79186 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -212,14 +212,27 @@ maybeTermEquals notSimplifier childTransformers first second = do Builtin.Map.unifyEquals childTransformers first second <|> Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second <|> Builtin.Set.unifyEquals childTransformers first second - <|> Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - first - second <|> rest' where rest' + | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = + lift $ + Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + tools + first + second + unifyData + | Just unifyData <- Builtin.List.matchUnifyEqualsList tools second first = + lift $ + Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + tools + second + first + unifyData | Just unifyData <- matchDomainValueAndConstructorErrors first second = lift $ domainValueAndConstructorErrors first second unifyData | otherwise = empty @@ -309,14 +322,25 @@ maybeTermAnd notSimplifier childTransformers first second = do | otherwise = Builtin.Map.unifyEquals childTransformers first second <|> Builtin.Set.unifyEquals childTransformers first second - <|> Builtin.List.unifyEquals - SimplificationType.And - childTransformers - first - second <|> rest' where rest' + | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = + lift $ Builtin.List.unifyEquals + SimplificationType.And + childTransformers + tools + first + second + unifyData + | Just unifyData <- Builtin.List.matchUnifyEqualsList tools second first = + lift $ Builtin.List.unifyEquals + SimplificationType.And + childTransformers + tools + second + first + unifyData | Just unifyData <- matchDomainValueAndConstructorErrors first second = lift $ domainValueAndConstructorErrors first second unifyData | Just () <- matchFunctionAnd first second = From 97d9d42c56fbf9e1f4856bb9f15c7005bcbc7f2b Mon Sep 17 00:00:00 2001 From: github-actions Date: Wed, 26 May 2021 05:53:03 +0000 Subject: [PATCH 58/86] Format with fourmolu --- kore/src/Kore/Step/Simplification/AndTerms.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index a898e79186..77122e9d5d 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -326,7 +326,8 @@ maybeTermAnd notSimplifier childTransformers first second = do where rest' | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = - lift $ Builtin.List.unifyEquals + lift $ + Builtin.List.unifyEquals SimplificationType.And childTransformers tools @@ -334,7 +335,8 @@ maybeTermAnd notSimplifier childTransformers first second = do second unifyData | Just unifyData <- Builtin.List.matchUnifyEqualsList tools second first = - lift $ Builtin.List.unifyEquals + lift $ + Builtin.List.unifyEquals SimplificationType.And childTransformers tools From 78ae583355bd3a84f03505972048c49d3d2cce1f Mon Sep 17 00:00:00 2001 From: emarzion Date: Wed, 26 May 2021 13:16:25 -0500 Subject: [PATCH 59/86] Updating unifyNotInKeys --- kore/src/Kore/Builtin/Map.hs | 121 +++++++++++------- kore/src/Kore/Step/Simplification/AndTerms.hs | 54 ++++---- 2 files changed, 105 insertions(+), 70 deletions(-) diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 135102004b..6775c3a541 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -21,6 +21,7 @@ module Kore.Builtin.Map ( -- * Unification unifyEquals, unifyNotInKeys, + matchUnifyNotInKeys, -- * Raw evaluators evalConcat, @@ -606,30 +607,92 @@ matchInKeys :: Maybe (InKeys (TermLike variable)) matchInKeys = retract -unifyNotInKeys :: - forall unifier. - MonadUnify unifier => - TermSimplifier RewritingVariableName unifier -> - NotSimplifier unifier -> +data UnifyNotInKeys = UnifyNotInKeys + { inKeys :: !(InKeys (TermLike RewritingVariableName)) + , keyTerm, mapTerm :: !(TermLike RewritingVariableName) + , concreteKeys, mapKeys, opaqueElements :: ![TermLike RewritingVariableName] + } + +data UnifyNotInKeysResult + = UnifyNotInKeys1 + | UnifyNotInKeys2 !UnifyNotInKeys + +matchUnifyNotInKeys :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) -unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) a b = - worker a b <|> worker b a + Maybe UnifyNotInKeysResult +matchUnifyNotInKeys first second + | Just False <- Bool.matchBool first + , Just inKeys@InKeys{keyTerm, mapTerm} <- matchInKeys second + , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm = + let symbolicKeys = getSymbolicKeysOfAc normalizedMap + concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap + mapKeys = symbolicKeys <> concreteKeys + opaqueElements = opaque . unwrapAc $ normalizedMap + unifyData = UnifyNotInKeys2 UnifyNotInKeys + { inKeys + , keyTerm + , mapTerm + , concreteKeys + , mapKeys + , opaqueElements + } in + case (mapKeys, opaqueElements) of + -- null mapKeys && null opaqueElements + ([], []) -> Just UnifyNotInKeys1 + -- (not (null mapKeys) || (length opaqueElements > 1)) + (_:_, _) -> Just unifyData + (_, _:_:_) -> Just unifyData + -- otherwise + _ -> Nothing + | otherwise = Nothing where normalizedOrBottom :: InternalVariable variable => TermLike variable -> Ac.NormalizedOrBottom NormalizedMap variable normalizedOrBottom = Ac.toNormalized +{-# INLINE matchUnifyNotInKeys #-} + +unifyNotInKeys :: + forall unifier. + MonadUnify unifier => + TermSimplifier RewritingVariableName unifier -> + NotSimplifier unifier -> + TermLike RewritingVariableName -> + UnifyNotInKeysResult -> + unifier (Pattern RewritingVariableName) +unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 unifyData = + case unifyData of + UnifyNotInKeys1 -> return Pattern.top + UnifyNotInKeys2 unifyData' -> + do + -- Concrete keys are constructor-like, therefore they are defined + TermLike.assertConstructorLikeKeys concreteKeys $ return () + definedKey <- defineTerm keyTerm + definedMap <- defineTerm mapTerm + keyConditions <- traverse (unifyAndNegate keyTerm) mapKeys + + let keyInKeysOpaque = + (\term -> inject @(TermLike _) (inKeys :: InKeys (TermLike RewritingVariableName)){mapTerm = term}) + <$> opaqueElements + + opaqueConditions <- + traverse (unifyChildren termLike1) keyInKeysOpaque + let conditions = + fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) + <> [definedKey, definedMap] + return $ collectConditions conditions + where + UnifyNotInKeys{inKeys, keyTerm, mapTerm, concreteKeys, mapKeys, opaqueElements} = unifyData' + where defineTerm :: TermLike RewritingVariableName -> - MaybeT unifier (Condition RewritingVariableName) + unifier (Condition RewritingVariableName) defineTerm termLike = makeEvaluateTermCeil SideCondition.topTODO termLike >>= Unify.scatter - & lift eraseTerm = Pattern.fromCondition_ . Pattern.withoutTerm @@ -646,40 +709,4 @@ unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) a b = (OrPattern.fromPatterns unificationSolutions) >>= Unify.scatter - collectConditions terms = fold terms & Pattern.fromCondition_ - - worker :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) - worker termLike1 termLike2 - | Just boolValue <- Bool.matchBool termLike1 - , not boolValue - , Just inKeys@InKeys{keyTerm, mapTerm} <- matchInKeys termLike2 - , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm = - do - let symbolicKeys = getSymbolicKeysOfAc normalizedMap - concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap - mapKeys = symbolicKeys <> concreteKeys - opaqueElements = opaque . unwrapAc $ normalizedMap - if null mapKeys && null opaqueElements - then return Pattern.top - else do - Monad.guard (not (null mapKeys) || (length opaqueElements > 1)) - -- Concrete keys are constructor-like, therefore they are defined - TermLike.assertConstructorLikeKeys concreteKeys $ return () - definedKey <- defineTerm keyTerm - definedMap <- defineTerm mapTerm - keyConditions <- lift $ traverse (unifyAndNegate keyTerm) mapKeys - - let keyInKeysOpaque = - (\term -> inject @(TermLike _) inKeys{mapTerm = term}) - <$> opaqueElements - - opaqueConditions <- - lift $ traverse (unifyChildren termLike1) keyInKeysOpaque - let conditions = - fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) - <> [definedKey, definedMap] - return $ collectConditions conditions - worker _ _ = empty + collectConditions terms = fold terms & Pattern.fromCondition_ \ No newline at end of file diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 77122e9d5d..a9f163173d 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -210,32 +210,40 @@ maybeTermEquals notSimplifier childTransformers first second = do lift $ Builtin.Signedness.unifyEquals first second unifyData | otherwise = Builtin.Map.unifyEquals childTransformers first second - <|> Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second - <|> Builtin.Set.unifyEquals childTransformers first second <|> rest' where rest' - | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = - lift $ - Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - tools - first - second - unifyData - | Just unifyData <- Builtin.List.matchUnifyEqualsList tools second first = - lift $ - Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - tools - second - first - unifyData - | Just unifyData <- matchDomainValueAndConstructorErrors first second = - lift $ domainValueAndConstructorErrors first second unifyData - | otherwise = empty + | Just unifyData <- Builtin.Map.matchUnifyNotInKeys first second = + lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier first unifyData + | Just unifyData <- Builtin.Map.matchUnifyNotInKeys second first = + lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier second unifyData + | otherwise = + Builtin.Set.unifyEquals childTransformers first second + <|> rest'' + + where + rest'' + | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = + lift $ + Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + tools + first + second + unifyData + | Just unifyData <- Builtin.List.matchUnifyEqualsList tools second first = + lift $ + Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + tools + second + first + unifyData + | Just unifyData <- matchDomainValueAndConstructorErrors first second = + lift $ domainValueAndConstructorErrors first second unifyData + | otherwise = empty maybeTermAnd :: MonadUnify unifier => From 5f4cd5b7e6c454ae2ccd300b5b5d27dd41d06177 Mon Sep 17 00:00:00 2001 From: github-actions Date: Wed, 26 May 2021 18:18:49 +0000 Subject: [PATCH 60/86] Format with fourmolu --- kore/src/Kore/Builtin/Map.hs | 39 ++++++++++--------- kore/src/Kore/Step/Simplification/AndTerms.hs | 3 +- 2 files changed, 21 insertions(+), 21 deletions(-) diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 6775c3a541..732e6b0d85 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -629,22 +629,24 @@ matchUnifyNotInKeys first second concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap mapKeys = symbolicKeys <> concreteKeys opaqueElements = opaque . unwrapAc $ normalizedMap - unifyData = UnifyNotInKeys2 UnifyNotInKeys - { inKeys - , keyTerm - , mapTerm - , concreteKeys - , mapKeys - , opaqueElements - } in - case (mapKeys, opaqueElements) of - -- null mapKeys && null opaqueElements - ([], []) -> Just UnifyNotInKeys1 - -- (not (null mapKeys) || (length opaqueElements > 1)) - (_:_, _) -> Just unifyData - (_, _:_:_) -> Just unifyData - -- otherwise - _ -> Nothing + unifyData = + UnifyNotInKeys2 + UnifyNotInKeys + { inKeys + , keyTerm + , mapTerm + , concreteKeys + , mapKeys + , opaqueElements + } + in case (mapKeys, opaqueElements) of + -- null mapKeys && null opaqueElements + ([], []) -> Just UnifyNotInKeys1 + -- (not (null mapKeys) || (length opaqueElements > 1)) + (_ : _, _) -> Just unifyData + (_, _ : _ : _) -> Just unifyData + -- otherwise + _ -> Nothing | otherwise = Nothing where normalizedOrBottom :: @@ -681,11 +683,10 @@ unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 unifyData = traverse (unifyChildren termLike1) keyInKeysOpaque let conditions = fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) - <> [definedKey, definedMap] + <> [definedKey, definedMap] return $ collectConditions conditions where UnifyNotInKeys{inKeys, keyTerm, mapTerm, concreteKeys, mapKeys, opaqueElements} = unifyData' - where defineTerm :: TermLike RewritingVariableName -> @@ -709,4 +710,4 @@ unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 unifyData = (OrPattern.fromPatterns unificationSolutions) >>= Unify.scatter - collectConditions terms = fold terms & Pattern.fromCondition_ \ No newline at end of file + collectConditions terms = fold terms & Pattern.fromCondition_ diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index a9f163173d..89e9c88194 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -219,8 +219,7 @@ maybeTermEquals notSimplifier childTransformers first second = do lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier second unifyData | otherwise = Builtin.Set.unifyEquals childTransformers first second - <|> rest'' - + <|> rest'' where rest'' | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = From 30dcbb88c340ef85f4be8df7ea46a7d9517b1b44 Mon Sep 17 00:00:00 2001 From: emarzion Date: Fri, 28 May 2021 00:39:58 -0500 Subject: [PATCH 61/86] Updating UnifyEquals functions for Map and Set --- .../Kore/Builtin/AssociativeCommutative.hs | 484 ++++++++++++++---- kore/src/Kore/Builtin/Map.hs | 113 ++-- kore/src/Kore/Builtin/Set.hs | 122 +++-- kore/src/Kore/Step/Simplification/AndTerms.hs | 128 ++--- 4 files changed, 579 insertions(+), 268 deletions(-) diff --git a/kore/src/Kore/Builtin/AssociativeCommutative.hs b/kore/src/Kore/Builtin/AssociativeCommutative.hs index fff864fc23..52b2b484d1 100644 --- a/kore/src/Kore/Builtin/AssociativeCommutative.hs +++ b/kore/src/Kore/Builtin/AssociativeCommutative.hs @@ -30,8 +30,10 @@ module Kore.Builtin.AssociativeCommutative ( renormalize, TermNormalizedAc, unifyEqualsNormalized, + matchUnifyEqualsNormalizedAc, UnitSymbol (..), VariableElements (..), + UnifyEqualsNormAc (..), ) where import Control.Error ( @@ -695,14 +697,16 @@ unifyEqualsNormalized :: ) -> InternalAc Key normalized (TermLike RewritingVariableName) -> InternalAc Key normalized (TermLike RewritingVariableName) -> - MaybeT unifier (Pattern RewritingVariableName) + UnifyEqualsNormAc normalized RewritingVariableName -> + unifier (Pattern RewritingVariableName) unifyEqualsNormalized tools first second unifyEqualsChildren normalized1 - normalized2 = + normalized2 + unifyData = do let InternalAc{builtinAcChild = firstNormalized} = normalized1 @@ -717,6 +721,7 @@ unifyEqualsNormalized unifyEqualsChildren firstNormalized secondNormalized + unifyData let unifierNormalizedTerm :: TermNormalizedAc normalized RewritingVariableName unifierCondition :: Condition RewritingVariableName @@ -757,17 +762,281 @@ unifyEqualsNormalized HasCallStack => InternalVariable variable => TermLike variable -> - MaybeT unifier (TermNormalizedAc normalized variable) + unifier (TermNormalizedAc normalized variable) normalize1 patt = case toNormalized patt of Bottom -> - lift $ Monad.Unify.explainAndReturnBottom "Duplicated elements in normalization." first second Normalized n -> return n +data UnifyEqualsElementListsData normalized = UnifyEqualsElementListsData { + allElements1, allElements2 :: [ConcreteOrWithVariable normalized RewritingVariableName] + , maybeVar :: Maybe (ElementVariable RewritingVariableName) +} + +data UnifyEqualsNormAc normalized variable + = UnifyEqualsElementLists !(UnifyEqualsElementListsData normalized) + | UnifyOpaqueVar !(UnifyOpVarResult variable) + +matchUnifyEqualsNormalizedAc :: + forall normalized. + ( --Traversable (Value normalized) + TermWrapper normalized + ) => + SmtMetadataTools Attribute.Symbol -> + InternalAc Key normalized (TermLike RewritingVariableName) -> + InternalAc Key normalized (TermLike RewritingVariableName) -> + Maybe (UnifyEqualsNormAc normalized RewritingVariableName) +matchUnifyEqualsNormalizedAc + tools + normalized1 + normalized2 = + case (opaqueDifference1, opaqueDifference2) of + ([], []) -> Just $ + UnifyEqualsElementLists $ + UnifyEqualsElementListsData + allElements1 + allElements2 + Nothing + + ([ElemVar_ v1], _) + | null opaqueDifference2 -> Just $ + UnifyEqualsElementLists $ + UnifyEqualsElementListsData + allElements1 + allElements2 + (Just v1) + + | null allElements1 -> + fmap UnifyOpaqueVar $ + matchUnifyOpaqueVariable' + v1 + allElements2 + opaqueDifference2 + + _ -> Nothing + +-- (simpleUnifier, opaques) <- case (opaqueDifference1, opaqueDifference2) of +-- ([], []) -> +-- lift $ +-- unifyEqualsElementLists' +-- allElements1 +-- allElements2 +-- Nothing +-- ([ElemVar_ v1], _) +-- | null opaqueDifference2 -> +-- lift $ +-- unifyEqualsElementLists' +-- allElements1 +-- allElements2 +-- (Just v1) +-- | null allElements1 -> +-- unifyOpaqueVariable' v1 allElements2 opaqueDifference2 +-- (_, [ElemVar_ v2]) +-- | null opaqueDifference1 -> +-- lift $ +-- unifyEqualsElementLists' +-- allElements2 +-- allElements1 +-- (Just v2) +-- | null allElements2 -> +-- unifyOpaqueVariable' v2 allElements1 opaqueDifference1 +-- _ -> empty + + + + where + + matchUnifyOpaqueVariable' = + matchUnifyOpaqueVariable tools + + listToMap :: Hashable a => Ord a => [a] -> HashMap a Int + listToMap = List.foldl' (\m k -> HashMap.insertWith (+) k 1 m) HashMap.empty + mapToList :: HashMap a Int -> [a] + mapToList = + HashMap.foldrWithKey + (\key count result -> replicate count key ++ result) + [] + + -- bottomWithExplanation :: Doc () -> unifier a + -- bottomWithExplanation explanation = + -- Monad.Unify.explainAndReturnBottom explanation first second + + -- unifyEqualsElementLists' = + -- unifyEqualsElementLists + -- tools + -- first + -- second + -- unifyEqualsChildren + + -- unifyOpaqueVariable' = + -- unifyOpaqueVariable tools bottomWithExplanation unifyEqualsChildren + + NormalizedAc + { elementsWithVariables = preElementsWithVariables1 + , concreteElements = concreteElements1 + , opaque = opaque1 + } = + unwrapAc firstNormalized + NormalizedAc + { elementsWithVariables = preElementsWithVariables2 + , concreteElements = concreteElements2 + , opaque = opaque2 + } = + unwrapAc secondNormalized + + InternalAc{builtinAcChild = firstNormalized} = + normalized1 + InternalAc{builtinAcChild = secondNormalized} = + normalized2 + + opaque1Map = listToMap opaque1 + opaque2Map = listToMap opaque2 + + elementsWithVariables1 = unwrapElement <$> preElementsWithVariables1 + elementsWithVariables2 = unwrapElement <$> preElementsWithVariables2 + elementsWithVariables1Map = HashMap.fromList elementsWithVariables1 + elementsWithVariables2Map = HashMap.fromList elementsWithVariables2 + + commonElements = + HashMap.intersectionWith + (,) + concreteElements1 + concreteElements2 + commonVariables = + HashMap.intersectionWith + (,) + elementsWithVariables1Map + elementsWithVariables2Map + + -- Duplicates must be kept in case any of the opaque terms turns out to be + -- non-empty, in which case one of the terms is bottom, which + -- means that the unification result is bottom. + commonOpaqueMap = HashMap.intersectionWith max opaque1Map opaque2Map + + -- commonOpaque = mapToList commonOpaqueMap + commonOpaqueKeys = HashMap.keysSet commonOpaqueMap + + elementDifference1 = + HashMap.toList (HashMap.difference concreteElements1 commonElements) + elementDifference2 = + HashMap.toList (HashMap.difference concreteElements2 commonElements) + elementVariableDifference1 = + HashMap.toList (HashMap.difference elementsWithVariables1Map commonVariables) + elementVariableDifference2 = + HashMap.toList (HashMap.difference elementsWithVariables2Map commonVariables) + opaqueDifference1 = + mapToList (withoutKeys opaque1Map commonOpaqueKeys) + opaqueDifference2 = + mapToList (withoutKeys opaque2Map commonOpaqueKeys) + + withoutKeys :: + Hashable k => + Eq k => + HashMap k v -> + HashSet k -> + HashMap k v + withoutKeys hmap (HashSet.toList -> hset) = + let keys = zip hset (repeat ()) & HashMap.fromList + in hmap `HashMap.difference` keys + + allElements1 = + map WithVariablePat elementVariableDifference1 + ++ map toConcretePat elementDifference1 + allElements2 = + map WithVariablePat elementVariableDifference2 + ++ map toConcretePat elementDifference2 + + toConcretePat :: + (Key, Value normalized (TermLike RewritingVariableName)) -> + ConcreteOrWithVariable + normalized + RewritingVariableName + toConcretePat (a, b) = + ConcretePat (from @Key @(TermLike RewritingVariableName) a, b) + + -- unifyElementList :: + -- forall key. + -- [ ( key + -- , ( Value normalized (TermLike RewritingVariableName) + -- , Value normalized (TermLike RewritingVariableName) + -- ) + -- ) + -- ] -> + -- unifier + -- ( [(key, Value normalized (TermLike RewritingVariableName))] + -- , Condition RewritingVariableName + -- ) + -- unifyElementList elements = do + -- result <- mapM (unifyCommonElements unifyEqualsChildren) elements + -- let terms :: [(key, Value normalized (TermLike RewritingVariableName))] + -- predicates :: [Condition RewritingVariableName] + -- (terms, predicates) = unzip (map Conditional.splitTerm result) + -- predicate :: Condition RewritingVariableName + -- predicate = + -- List.foldl' + -- andCondition + -- Condition.top + -- predicates + + -- return (terms, predicate) + + -- simplify :: + -- TermLike RewritingVariableName -> + -- unifier (Pattern RewritingVariableName) + -- simplify term = + -- lowerLogicT $ simplifyConditionalTerm SideCondition.topTODO term + + -- simplifyPair :: + -- ( TermLike RewritingVariableName + -- , Value normalized (TermLike RewritingVariableName) + -- ) -> + -- unifier + -- ( Conditional + -- RewritingVariableName + -- ( TermLike RewritingVariableName + -- , Value normalized (TermLike RewritingVariableName) + -- ) + -- ) + -- simplifyPair (key, value) = do + -- simplifiedKey <- simplifyTermLike' key + -- let (keyTerm, keyCondition) = Conditional.splitTerm simplifiedKey + -- simplifiedValue <- traverse simplifyTermLike' value + -- let splitSimplifiedValue :: + -- Value + -- normalized + -- ( TermLike RewritingVariableName + -- , Condition RewritingVariableName + -- ) + -- splitSimplifiedValue = + -- fmap Conditional.splitTerm simplifiedValue + -- simplifiedValueTerm :: + -- Value normalized (TermLike RewritingVariableName) + -- simplifiedValueTerm = fmap fst splitSimplifiedValue + -- simplifiedValueConditions :: + -- Value normalized (Condition RewritingVariableName) + -- simplifiedValueConditions = fmap snd splitSimplifiedValue + -- simplifiedValueCondition :: Condition RewritingVariableName + -- simplifiedValueCondition = + -- foldr + -- andCondition + -- Condition.top + -- simplifiedValueConditions + -- return + -- ( (keyTerm, simplifiedValueTerm) + -- `withCondition` keyCondition + -- `andCondition` simplifiedValueCondition + -- ) + -- where + -- simplifyTermLike' :: + -- TermLike RewritingVariableName -> + -- unifier (Pattern RewritingVariableName) + -- simplifyTermLike' term = + -- lowerLogicT $ simplifyConditionalTerm SideCondition.topTODO term + {- | Unifies two AC structs represented as @NormalizedAc@. Currently allows at most one opaque term in the two arguments taken together. @@ -787,7 +1056,7 @@ unifyEqualsNormalizedAc :: ) -> TermNormalizedAc normalized RewritingVariableName -> TermNormalizedAc normalized RewritingVariableName -> - MaybeT + UnifyEqualsNormAc normalized RewritingVariableName -> unifier ( Conditional RewritingVariableName @@ -799,37 +1068,28 @@ unifyEqualsNormalizedAc second unifyEqualsChildren normalized1 - normalized2 = + normalized2 + unifyData = do - (simpleUnifier, opaques) <- case (opaqueDifference1, opaqueDifference2) of - ([], []) -> - lift $ - unifyEqualsElementLists' - allElements1 - allElements2 - Nothing - ([ElemVar_ v1], _) - | null opaqueDifference2 -> - lift $ - unifyEqualsElementLists' - allElements1 - allElements2 - (Just v1) - | null allElements1 -> - unifyOpaqueVariable' v1 allElements2 opaqueDifference2 - (_, [ElemVar_ v2]) - | null opaqueDifference1 -> - lift $ - unifyEqualsElementLists' - allElements2 - allElements1 - (Just v2) - | null allElements2 -> - unifyOpaqueVariable' v2 allElements1 opaqueDifference1 - _ -> empty + (simpleUnifier, opaques) <- case unifyData of + UnifyEqualsElementLists unifyData' -> + unifyEqualsElementLists' + allElements1 + allElements2 + maybeVar + + where + UnifyEqualsElementListsData{allElements1, allElements2, maybeVar} = unifyData' + + UnifyOpaqueVar unifyData' -> + unifyOpaqueVariable + bottomWithExplanation + unifyEqualsChildren + unifyData' + let (unifiedElements, unifierCondition) = Conditional.splitTerm simpleUnifier - lift $ do + do -- unifier monad -- unify the parts not sent to unifyEqualsNormalizedElements. (commonElementsTerms, commonElementsCondition) <- @@ -874,8 +1134,8 @@ unifyEqualsNormalizedAc second unifyEqualsChildren - unifyOpaqueVariable' = - unifyOpaqueVariable tools bottomWithExplanation unifyEqualsChildren + -- unifyOpaqueVariable' = + -- unifyOpaqueVariable tools bottomWithExplanation unifyEqualsChildren NormalizedAc { elementsWithVariables = preElementsWithVariables1 @@ -915,45 +1175,45 @@ unifyEqualsNormalizedAc commonOpaqueMap = HashMap.intersectionWith max opaque1Map opaque2Map commonOpaque = mapToList commonOpaqueMap - commonOpaqueKeys = HashMap.keysSet commonOpaqueMap - - elementDifference1 = - HashMap.toList (HashMap.difference concreteElements1 commonElements) - elementDifference2 = - HashMap.toList (HashMap.difference concreteElements2 commonElements) - elementVariableDifference1 = - HashMap.toList (HashMap.difference elementsWithVariables1Map commonVariables) - elementVariableDifference2 = - HashMap.toList (HashMap.difference elementsWithVariables2Map commonVariables) - opaqueDifference1 = - mapToList (withoutKeys opaque1Map commonOpaqueKeys) - opaqueDifference2 = - mapToList (withoutKeys opaque2Map commonOpaqueKeys) - - withoutKeys :: - Hashable k => - Eq k => - HashMap k v -> - HashSet k -> - HashMap k v - withoutKeys hmap (HashSet.toList -> hset) = - let keys = zip hset (repeat ()) & HashMap.fromList - in hmap `HashMap.difference` keys - - allElements1 = - map WithVariablePat elementVariableDifference1 - ++ map toConcretePat elementDifference1 - allElements2 = - map WithVariablePat elementVariableDifference2 - ++ map toConcretePat elementDifference2 - - toConcretePat :: - (Key, Value normalized (TermLike RewritingVariableName)) -> - ConcreteOrWithVariable - normalized - RewritingVariableName - toConcretePat (a, b) = - ConcretePat (from @Key @(TermLike RewritingVariableName) a, b) + -- commonOpaqueKeys = HashMap.keysSet commonOpaqueMap + + -- elementDifference1 = + -- HashMap.toList (HashMap.difference concreteElements1 commonElements) + -- elementDifference2 = + -- HashMap.toList (HashMap.difference concreteElements2 commonElements) + -- elementVariableDifference1 = + -- HashMap.toList (HashMap.difference elementsWithVariables1Map commonVariables) + -- elementVariableDifference2 = + -- HashMap.toList (HashMap.difference elementsWithVariables2Map commonVariables) + -- opaqueDifference1 = + -- mapToList (withoutKeys opaque1Map commonOpaqueKeys) + -- opaqueDifference2 = + -- mapToList (withoutKeys opaque2Map commonOpaqueKeys) + + -- withoutKeys :: + -- Hashable k => + -- Eq k => + -- HashMap k v -> + -- HashSet k -> + -- HashMap k v + -- withoutKeys hmap (HashSet.toList -> hset) = + -- let keys = zip hset (repeat ()) & HashMap.fromList + -- in hmap `HashMap.difference` keys + + -- allElements1 = + -- map WithVariablePat elementVariableDifference1 + -- ++ map toConcretePat elementDifference1 + -- allElements2 = + -- map WithVariablePat elementVariableDifference2 + -- ++ map toConcretePat elementDifference2 + + -- toConcretePat :: + -- (Key, Value normalized (TermLike RewritingVariableName)) -> + -- ConcreteOrWithVariable + -- normalized + -- RewritingVariableName + -- toConcretePat (a, b) = + -- ConcretePat (from @Key @(TermLike RewritingVariableName) a, b) unifyElementList :: forall key. @@ -1342,39 +1602,36 @@ unifyEqualsElementLists (unifyEqualsConcreteOrWithVariable unifyEqualsChildren) remainderError = nonEmptyRemainderError first second -unifyOpaqueVariable :: - ( MonadUnify unifier - , TermWrapper normalized +data NoCheckUnifyOpaqueChildrenData variable = NoCheckUnifyOpaqueChildrenData { + v1 :: TermLike.ElementVariable variable + , second :: TermLike variable +} + +data UnifyOpVarResult variable + = NoCheckUnifyOpaqueChildren !(NoCheckUnifyOpaqueChildrenData variable) + | BottomWithExplanation + +matchUnifyOpaqueVariable :: + ( TermWrapper normalized , InternalVariable variable ) => SmtMetadataTools Attribute.Symbol -> - (forall a. Doc () -> unifier a) -> - -- | unifier function - (TermLike variable -> TermLike variable -> unifier (Pattern variable)) -> TermLike.ElementVariable variable -> [ConcreteOrWithVariable normalized variable] -> [TermLike variable] -> - MaybeT - unifier - ( Conditional - variable - [(TermLike variable, Value normalized (TermLike variable))] - , [TermLike variable] - ) -unifyOpaqueVariable _ _ unifyChildren v1 [] [second@(ElemVar_ _)] = - noCheckUnifyOpaqueChildren unifyChildren v1 second -unifyOpaqueVariable + Maybe (UnifyOpVarResult variable) +matchUnifyOpaqueVariable _ v1 [] [second@(ElemVar_ _)] = + --noCheckUnifyOpaqueChildren unifyChildren v1 second + Just $ NoCheckUnifyOpaqueChildren NoCheckUnifyOpaqueChildrenData{v1, second} +matchUnifyOpaqueVariable tools - bottomWithExplanation - unifyChildren v1 concreteOrVariableTerms opaqueTerms = case elementListAsNormalized pairs of - Nothing -> - lift $ - bottomWithExplanation - "Duplicated element in unification results" + Nothing -> Just BottomWithExplanation + -- bottomWithExplanation + -- "Duplicated element in unification results" Just elementTerm -> let secondTerm = asInternal @@ -1384,12 +1641,40 @@ unifyOpaqueVariable elementTerm{opaque = opaqueTerms} ) in if TermLike.isFunctionPattern secondTerm - then noCheckUnifyOpaqueChildren unifyChildren v1 secondTerm - else empty + then Just + $ NoCheckUnifyOpaqueChildren + $ NoCheckUnifyOpaqueChildrenData v1 secondTerm + else Nothing where sort = variableSort v1 pairs = map fromConcreteOrWithVariable concreteOrVariableTerms +unifyOpaqueVariable :: + ( MonadUnify unifier + , InternalVariable variable + ) => + (forall a. Doc () -> unifier a) -> + -- | unifier function + (TermLike variable -> TermLike variable -> unifier (Pattern variable)) -> + UnifyOpVarResult variable -> + unifier + ( Conditional + variable + [(TermLike variable, Value normalized (TermLike variable))] + , [TermLike variable] + ) +unifyOpaqueVariable + bottomWithExplanation + unifyChildren + unifyData = + case unifyData of + NoCheckUnifyOpaqueChildren unifyData' -> + noCheckUnifyOpaqueChildren unifyChildren v1 second + where + NoCheckUnifyOpaqueChildrenData{v1, second} = unifyData' + _ -> bottomWithExplanation + "Duplicated element in unification results" + noCheckUnifyOpaqueChildren :: ( MonadUnify unifier , InternalVariable variable @@ -1397,14 +1682,13 @@ noCheckUnifyOpaqueChildren :: (TermLike variable -> TermLike variable -> unifier (Pattern variable)) -> TermLike.ElementVariable variable -> TermLike variable -> - MaybeT unifier ( Conditional variable [(TermLike variable, Value normalized (TermLike variable))] , [TermLike variable] ) -noCheckUnifyOpaqueChildren unifyChildren v1 second = lift $ do +noCheckUnifyOpaqueChildren unifyChildren v1 second = do unifier <- unifyChildren (mkElemVar v1) second let (opaque, predicate) = Conditional.splitTerm unifier return ([] `Conditional.withCondition` predicate, [opaque]) diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 732e6b0d85..196bb0db7b 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -22,6 +22,7 @@ module Kore.Builtin.Map ( unifyEquals, unifyNotInKeys, matchUnifyNotInKeys, + matchUnifyEquals, -- * Raw evaluators evalConcat, @@ -31,9 +32,8 @@ module Kore.Builtin.Map ( ) where import Control.Error ( - MaybeT (MaybeT), + MaybeT, hoistMaybe, - runMaybeT, ) import qualified Control.Monad as Monad import Data.HashMap.Strict ( @@ -519,6 +519,50 @@ internalize tools termLike where sort' = termLikeSort termLike +data NormAcData = NormAcData { + normalized1, normalized2 :: InternalMap Key (TermLike RewritingVariableName) + , acData :: !(Ac.UnifyEqualsNormAc NormalizedMap RewritingVariableName) +} + +data UnifyEqualsMap + = ReturnBottom + | NormAc !NormAcData + +matchUnifyEquals :: + SmtMetadataTools Attribute.Symbol -> + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyEqualsMap +matchUnifyEquals tools first second + | Just True <- isMapSort tools sort1 = + worker first second + | otherwise = Nothing + + where + sort1 = termLikeSort first + + normalizedOrBottom :: + TermLike RewritingVariableName -> + Ac.NormalizedOrBottom NormalizedMap RewritingVariableName + normalizedOrBottom = Ac.toNormalized + + worker a b + | InternalMap_ normalized1 <- a + , InternalMap_ normalized2 <- b + = NormAc . NormAcData normalized1 normalized2 <$> Ac.matchUnifyEqualsNormalizedAc + tools + normalized1 + normalized2 + | otherwise = case normalizedOrBottom a of + Ac.Bottom -> Just ReturnBottom + Ac.Normalized normalized1 -> + let a' = Ac.asInternal tools sort1 normalized1 + in case normalizedOrBottom b of + Ac.Bottom -> Just ReturnBottom + Ac.Normalized normalized2 -> + let b' = Ac.asInternal tools sort1 normalized2 + in worker a' b' + {- | Simplify the conjunction or equality of two concrete Map domain values. When it is used for simplifying equality, one should separately solve the @@ -532,56 +576,29 @@ unifyEquals :: forall unifier. MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> + SmtMetadataTools Attribute.Symbol -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) -unifyEquals unifyEqualsChildren first second = do - tools <- Simplifier.askMetadataTools - (Monad.guard . fromMaybe False) (isMapSort tools sort1) - MaybeT $ do - unifiers <- Monad.Unify.gather (runMaybeT (unifyEquals0 first second)) - case sequence unifiers of - Nothing -> return Nothing - Just us -> Monad.Unify.scatter (map Just us) - where - sort1 = termLikeSort first - - unifyEquals0 :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) - unifyEquals0 (InternalMap_ normalized1) (InternalMap_ normalized2) = do - tools <- Simplifier.askMetadataTools - Ac.unifyEqualsNormalized - tools - first - second - unifyEqualsChildren - normalized1 - normalized2 - unifyEquals0 pat1 pat2 = do - firstDomain <- asDomain pat1 - secondDomain <- asDomain pat2 - unifyEquals0 firstDomain secondDomain - where - asDomain :: - TermLike RewritingVariableName -> - MaybeT unifier (TermLike RewritingVariableName) - asDomain patt = - case normalizedOrBottom of - Ac.Normalized normalized -> do - tools <- Simplifier.askMetadataTools - return (Ac.asInternal tools sort1 normalized) - Ac.Bottom -> - lift $ - Monad.Unify.explainAndReturnBottom + UnifyEqualsMap -> + unifier (Pattern RewritingVariableName) +unifyEquals unifyEqualsChildren tools first second unifyData = + case unifyData of + ReturnBottom -> + Monad.Unify.explainAndReturnBottom "Duplicated elements in normalization." first - second - where - normalizedOrBottom :: - Ac.NormalizedOrBottom NormalizedMap RewritingVariableName - normalizedOrBottom = Ac.toNormalized patt + second + NormAc unifyData' -> + Ac.unifyEqualsNormalized + tools + first + second + unifyEqualsChildren + normalized1 + normalized2 + acData + where + NormAcData{normalized1, normalized2, acData} = unifyData' data InKeys term = InKeys { symbol :: !Symbol diff --git a/kore/src/Kore/Builtin/Set.hs b/kore/src/Kore/Builtin/Set.hs index 3b08f83763..50633d5937 100644 --- a/kore/src/Kore/Builtin/Set.hs +++ b/kore/src/Kore/Builtin/Set.hs @@ -29,12 +29,12 @@ module Kore.Builtin.Set ( -- * Unification unifyEquals, + matchUnifyEquals, ) where import Control.Error ( - MaybeT (MaybeT), + MaybeT, hoistMaybe, - runMaybeT, ) import qualified Control.Monad as Monad import Data.HashMap.Strict ( @@ -523,46 +523,76 @@ internalize tools termLike where sort' = termLikeSort termLike -{- | Simplify the conjunction or equality of two concrete Set domain values. +data NormAcData = NormAcData { + normalized1, normalized2 :: InternalSet Key (TermLike RewritingVariableName) + , acData :: !(Ac.UnifyEqualsNormAc NormalizedSet RewritingVariableName) +} - When it is used for simplifying equality, one should separately solve the - case ⊥ = ⊥. One should also throw away the term in the returned pattern. +data UnifyEqualsMap + = ReturnBottom + | NormAc !NormAcData - The sets are assumed to have the same sort, but this is not checked. If - multiple sorts are hooked to the same builtin domain, the verifier should - reject the definition. +matchUnifyEquals :: + SmtMetadataTools Attribute.Symbol -> + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyEqualsMap +matchUnifyEquals tools first second + | Just True <- isSetSort tools sort1 = + worker first second + | otherwise = Nothing + + where + sort1 = termLikeSort first + + normalizedOrBottom :: + TermLike RewritingVariableName -> + Ac.NormalizedOrBottom NormalizedSet RewritingVariableName + normalizedOrBottom = Ac.toNormalized + + worker a b + | InternalSet_ normalized1 <- a + , InternalSet_ normalized2 <- b + = NormAc . NormAcData normalized1 normalized2 <$> Ac.matchUnifyEqualsNormalizedAc + tools + normalized1 + normalized2 + | otherwise = case normalizedOrBottom a of + Ac.Bottom -> Just ReturnBottom + Ac.Normalized normalized1 -> + let a' = Ac.asInternal tools sort1 normalized1 + in case normalizedOrBottom b of + Ac.Bottom -> Just ReturnBottom + Ac.Normalized normalized2 -> + let b' = Ac.asInternal tools sort1 normalized2 + in worker a' b' + +{- | Simplify the conjunction or equality of two concrete Map domain values. + +When it is used for simplifying equality, one should separately solve the +case ⊥ = ⊥. One should also throw away the term in the returned pattern. + +The maps are assumed to have the same sort, but this is not checked. If +multiple sorts are hooked to the same builtin domain, the verifier should +reject the definition. -} unifyEquals :: forall unifier. MonadUnify unifier => - ( TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - unifier (Pattern RewritingVariableName) - ) -> + TermSimplifier RewritingVariableName unifier -> + SmtMetadataTools Attribute.Symbol -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) -unifyEquals - unifyEqualsChildren - first - second = - do - tools <- Simplifier.askMetadataTools - (Monad.guard . fromMaybe False) (isSetSort tools sort1) - MaybeT $ do - unifiers <- Monad.Unify.gather (runMaybeT (unifyEquals0 first second)) - case sequence unifiers of - Nothing -> return Nothing - Just us -> Monad.Unify.scatter (map Just us) - where - sort1 = termLikeSort first - - unifyEquals0 :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) - unifyEquals0 (InternalSet_ normalized1) (InternalSet_ normalized2) = do - tools <- Simplifier.askMetadataTools + UnifyEqualsMap -> + unifier (Pattern RewritingVariableName) +unifyEquals unifyEqualsChildren tools first second unifyData = + case unifyData of + ReturnBottom -> + Monad.Unify.explainAndReturnBottom + "Duplicated elements in normalization." + first + second + NormAc unifyData' -> Ac.unifyEqualsNormalized tools first @@ -570,26 +600,6 @@ unifyEquals unifyEqualsChildren normalized1 normalized2 - unifyEquals0 pat1 pat2 = do - firstDomain <- asDomain pat1 - secondDomain <- asDomain pat2 - unifyEquals0 firstDomain secondDomain - where - asDomain :: - TermLike RewritingVariableName -> - MaybeT unifier (TermLike RewritingVariableName) - asDomain patt = - case normalizedOrBottom of - Ac.Normalized normalized -> do - tools <- Simplifier.askMetadataTools - return (Ac.asInternal tools sort1 normalized) - Ac.Bottom -> - lift $ - Monad.Unify.explainAndReturnBottom - "Duplicated elements in normalization." - first - second + acData where - normalizedOrBottom :: - Ac.NormalizedOrBottom NormalizedSet RewritingVariableName - normalizedOrBottom = Ac.toNormalized patt + NormAcData{normalized1, normalized2, acData} = unifyData' diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 89e9c88194..e0ea6d8336 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -208,41 +208,39 @@ maybeTermEquals notSimplifier childTransformers first second = do lift $ Builtin.Endianness.unifyEquals first second unifyData | Just unifyData <- Builtin.Signedness.matchUnifyEqualsSignedness first second = lift $ Builtin.Signedness.unifyEquals first second unifyData - | otherwise = - Builtin.Map.unifyEquals childTransformers first second - <|> rest' - where - rest' - | Just unifyData <- Builtin.Map.matchUnifyNotInKeys first second = - lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier first unifyData - | Just unifyData <- Builtin.Map.matchUnifyNotInKeys second first = - lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier second unifyData - | otherwise = - Builtin.Set.unifyEquals childTransformers first second - <|> rest'' - where - rest'' - | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = - lift $ - Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - tools - first - second - unifyData - | Just unifyData <- Builtin.List.matchUnifyEqualsList tools second first = - lift $ - Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - tools - second - first - unifyData - | Just unifyData <- matchDomainValueAndConstructorErrors first second = - lift $ domainValueAndConstructorErrors first second unifyData - | otherwise = empty + | Just unifyData <- Builtin.Map.matchUnifyEquals tools first second = + lift $ Builtin.Map.unifyEquals childTransformers tools first second unifyData + | Just unifyData <- Builtin.Map.matchUnifyEquals tools second first = + lift $ Builtin.Map.unifyEquals childTransformers tools second first unifyData + | Just unifyData <- Builtin.Map.matchUnifyNotInKeys first second = + lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier first unifyData + | Just unifyData <- Builtin.Map.matchUnifyNotInKeys second first = + lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier second unifyData + | Just unifyData <- Builtin.Set.matchUnifyEquals tools first second = + lift $ Builtin.Set.unifyEquals childTransformers tools first second unifyData + | Just unifyData <- Builtin.Set.matchUnifyEquals tools second first = + lift $ Builtin.Set.unifyEquals childTransformers tools second first unifyData + | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = + lift $ + Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + tools + first + second + unifyData + | Just unifyData <- Builtin.List.matchUnifyEqualsList tools second first = + lift $ + Builtin.List.unifyEquals + SimplificationType.Equals + childTransformers + tools + second + first + unifyData + | Just unifyData <- matchDomainValueAndConstructorErrors first second = + lift $ domainValueAndConstructorErrors first second unifyData + | otherwise = empty maybeTermAnd :: MonadUnify unifier => @@ -326,35 +324,37 @@ maybeTermAnd notSimplifier childTransformers first second = do lift $ Builtin.Endianness.unifyEquals first second unifyData | Just unifyData <- Builtin.Signedness.matchUnifyEqualsSignedness first second = lift $ Builtin.Signedness.unifyEquals first second unifyData - | otherwise = - Builtin.Map.unifyEquals childTransformers first second - <|> Builtin.Set.unifyEquals childTransformers first second - <|> rest' - where - rest' - | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = - lift $ - Builtin.List.unifyEquals - SimplificationType.And - childTransformers - tools - first - second - unifyData - | Just unifyData <- Builtin.List.matchUnifyEqualsList tools second first = - lift $ - Builtin.List.unifyEquals - SimplificationType.And - childTransformers - tools - second - first - unifyData - | Just unifyData <- matchDomainValueAndConstructorErrors first second = - lift $ domainValueAndConstructorErrors first second unifyData - | Just () <- matchFunctionAnd first second = - return $ functionAnd first second - | otherwise = empty + | Just unifyData <- Builtin.Map.matchUnifyEquals tools first second = + lift $ Builtin.Map.unifyEquals childTransformers tools first second unifyData + | Just unifyData <- Builtin.Map.matchUnifyEquals tools second first = + lift $ Builtin.Map.unifyEquals childTransformers tools second first unifyData + | Just unifyData <- Builtin.Set.matchUnifyEquals tools first second = + lift $ Builtin.Set.unifyEquals childTransformers tools first second unifyData + | Just unifyData <- Builtin.Set.matchUnifyEquals tools second first = + lift $ Builtin.Set.unifyEquals childTransformers tools second first unifyData + | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = + lift $ + Builtin.List.unifyEquals + SimplificationType.And + childTransformers + tools + first + second + unifyData + | Just unifyData <- Builtin.List.matchUnifyEqualsList tools second first = + lift $ + Builtin.List.unifyEquals + SimplificationType.And + childTransformers + tools + second + first + unifyData + | Just unifyData <- matchDomainValueAndConstructorErrors first second = + lift $ domainValueAndConstructorErrors first second unifyData + | Just () <- matchFunctionAnd first second = + return $ functionAnd first second + | otherwise = empty {- | Construct the conjunction or unification of two terms. From 0d6037e9f85f85f689bd30b4e5dcb1c13af85a18 Mon Sep 17 00:00:00 2001 From: github-actions Date: Fri, 28 May 2021 05:42:22 +0000 Subject: [PATCH 62/86] Format with fourmolu --- .../Kore/Builtin/AssociativeCommutative.hs | 301 +++++++++--------- kore/src/Kore/Builtin/Map.hs | 38 +-- kore/src/Kore/Builtin/Set.hs | 38 +-- 3 files changed, 186 insertions(+), 191 deletions(-) diff --git a/kore/src/Kore/Builtin/AssociativeCommutative.hs b/kore/src/Kore/Builtin/AssociativeCommutative.hs index 52b2b484d1..d7dfe66a49 100644 --- a/kore/src/Kore/Builtin/AssociativeCommutative.hs +++ b/kore/src/Kore/Builtin/AssociativeCommutative.hs @@ -766,16 +766,16 @@ unifyEqualsNormalized normalize1 patt = case toNormalized patt of Bottom -> - Monad.Unify.explainAndReturnBottom - "Duplicated elements in normalization." - first - second + Monad.Unify.explainAndReturnBottom + "Duplicated elements in normalization." + first + second Normalized n -> return n -data UnifyEqualsElementListsData normalized = UnifyEqualsElementListsData { - allElements1, allElements2 :: [ConcreteOrWithVariable normalized RewritingVariableName] +data UnifyEqualsElementListsData normalized = UnifyEqualsElementListsData + { allElements1, allElements2 :: [ConcreteOrWithVariable normalized RewritingVariableName] , maybeVar :: Maybe (ElementVariable RewritingVariableName) -} + } data UnifyEqualsNormAc normalized variable = UnifyEqualsElementLists !(UnifyEqualsElementListsData normalized) @@ -795,60 +795,55 @@ matchUnifyEqualsNormalizedAc normalized1 normalized2 = case (opaqueDifference1, opaqueDifference2) of - ([], []) -> Just $ - UnifyEqualsElementLists $ - UnifyEqualsElementListsData - allElements1 - allElements2 - Nothing - - ([ElemVar_ v1], _) - | null opaqueDifference2 -> Just $ + ([], []) -> + Just $ UnifyEqualsElementLists $ - UnifyEqualsElementListsData - allElements1 - allElements2 - (Just v1) - + UnifyEqualsElementListsData + allElements1 + allElements2 + Nothing + ([ElemVar_ v1], _) + | null opaqueDifference2 -> + Just $ + UnifyEqualsElementLists $ + UnifyEqualsElementListsData + allElements1 + allElements2 + (Just v1) | null allElements1 -> fmap UnifyOpaqueVar $ matchUnifyOpaqueVariable' - v1 - allElements2 - opaqueDifference2 - + v1 + allElements2 + opaqueDifference2 _ -> Nothing - --- (simpleUnifier, opaques) <- case (opaqueDifference1, opaqueDifference2) of --- ([], []) -> --- lift $ --- unifyEqualsElementLists' --- allElements1 --- allElements2 --- Nothing --- ([ElemVar_ v1], _) --- | null opaqueDifference2 -> --- lift $ --- unifyEqualsElementLists' --- allElements1 --- allElements2 --- (Just v1) --- | null allElements1 -> --- unifyOpaqueVariable' v1 allElements2 opaqueDifference2 --- (_, [ElemVar_ v2]) --- | null opaqueDifference1 -> --- lift $ --- unifyEqualsElementLists' --- allElements2 --- allElements1 --- (Just v2) --- | null allElements2 -> --- unifyOpaqueVariable' v2 allElements1 opaqueDifference1 --- _ -> empty - - - where + -- (simpleUnifier, opaques) <- case (opaqueDifference1, opaqueDifference2) of + -- ([], []) -> + -- lift $ + -- unifyEqualsElementLists' + -- allElements1 + -- allElements2 + -- Nothing + -- ([ElemVar_ v1], _) + -- | null opaqueDifference2 -> + -- lift $ + -- unifyEqualsElementLists' + -- allElements1 + -- allElements2 + -- (Just v1) + -- | null allElements1 -> + -- unifyOpaqueVariable' v1 allElements2 opaqueDifference2 + -- (_, [ElemVar_ v2]) + -- | null opaqueDifference1 -> + -- lift $ + -- unifyEqualsElementLists' + -- allElements2 + -- allElements1 + -- (Just v2) + -- | null allElements2 -> + -- unifyOpaqueVariable' v2 allElements1 opaqueDifference1 + -- _ -> empty matchUnifyOpaqueVariable' = matchUnifyOpaqueVariable tools @@ -889,9 +884,9 @@ matchUnifyEqualsNormalizedAc unwrapAc secondNormalized InternalAc{builtinAcChild = firstNormalized} = - normalized1 + normalized1 InternalAc{builtinAcChild = secondNormalized} = - normalized2 + normalized2 opaque1Map = listToMap opaque1 opaque2Map = listToMap opaque2 @@ -958,84 +953,84 @@ matchUnifyEqualsNormalizedAc toConcretePat (a, b) = ConcretePat (from @Key @(TermLike RewritingVariableName) a, b) - -- unifyElementList :: - -- forall key. - -- [ ( key - -- , ( Value normalized (TermLike RewritingVariableName) - -- , Value normalized (TermLike RewritingVariableName) - -- ) - -- ) - -- ] -> - -- unifier - -- ( [(key, Value normalized (TermLike RewritingVariableName))] - -- , Condition RewritingVariableName - -- ) - -- unifyElementList elements = do - -- result <- mapM (unifyCommonElements unifyEqualsChildren) elements - -- let terms :: [(key, Value normalized (TermLike RewritingVariableName))] - -- predicates :: [Condition RewritingVariableName] - -- (terms, predicates) = unzip (map Conditional.splitTerm result) - -- predicate :: Condition RewritingVariableName - -- predicate = - -- List.foldl' - -- andCondition - -- Condition.top - -- predicates - - -- return (terms, predicate) - - -- simplify :: - -- TermLike RewritingVariableName -> - -- unifier (Pattern RewritingVariableName) - -- simplify term = - -- lowerLogicT $ simplifyConditionalTerm SideCondition.topTODO term - - -- simplifyPair :: - -- ( TermLike RewritingVariableName - -- , Value normalized (TermLike RewritingVariableName) - -- ) -> - -- unifier - -- ( Conditional - -- RewritingVariableName - -- ( TermLike RewritingVariableName - -- , Value normalized (TermLike RewritingVariableName) - -- ) - -- ) - -- simplifyPair (key, value) = do - -- simplifiedKey <- simplifyTermLike' key - -- let (keyTerm, keyCondition) = Conditional.splitTerm simplifiedKey - -- simplifiedValue <- traverse simplifyTermLike' value - -- let splitSimplifiedValue :: - -- Value - -- normalized - -- ( TermLike RewritingVariableName - -- , Condition RewritingVariableName - -- ) - -- splitSimplifiedValue = - -- fmap Conditional.splitTerm simplifiedValue - -- simplifiedValueTerm :: - -- Value normalized (TermLike RewritingVariableName) - -- simplifiedValueTerm = fmap fst splitSimplifiedValue - -- simplifiedValueConditions :: - -- Value normalized (Condition RewritingVariableName) - -- simplifiedValueConditions = fmap snd splitSimplifiedValue - -- simplifiedValueCondition :: Condition RewritingVariableName - -- simplifiedValueCondition = - -- foldr - -- andCondition - -- Condition.top - -- simplifiedValueConditions - -- return - -- ( (keyTerm, simplifiedValueTerm) - -- `withCondition` keyCondition - -- `andCondition` simplifiedValueCondition - -- ) - -- where - -- simplifyTermLike' :: - -- TermLike RewritingVariableName -> - -- unifier (Pattern RewritingVariableName) - -- simplifyTermLike' term = - -- lowerLogicT $ simplifyConditionalTerm SideCondition.topTODO term +-- unifyElementList :: +-- forall key. +-- [ ( key +-- , ( Value normalized (TermLike RewritingVariableName) +-- , Value normalized (TermLike RewritingVariableName) +-- ) +-- ) +-- ] -> +-- unifier +-- ( [(key, Value normalized (TermLike RewritingVariableName))] +-- , Condition RewritingVariableName +-- ) +-- unifyElementList elements = do +-- result <- mapM (unifyCommonElements unifyEqualsChildren) elements +-- let terms :: [(key, Value normalized (TermLike RewritingVariableName))] +-- predicates :: [Condition RewritingVariableName] +-- (terms, predicates) = unzip (map Conditional.splitTerm result) +-- predicate :: Condition RewritingVariableName +-- predicate = +-- List.foldl' +-- andCondition +-- Condition.top +-- predicates + +-- return (terms, predicate) + +-- simplify :: +-- TermLike RewritingVariableName -> +-- unifier (Pattern RewritingVariableName) +-- simplify term = +-- lowerLogicT $ simplifyConditionalTerm SideCondition.topTODO term + +-- simplifyPair :: +-- ( TermLike RewritingVariableName +-- , Value normalized (TermLike RewritingVariableName) +-- ) -> +-- unifier +-- ( Conditional +-- RewritingVariableName +-- ( TermLike RewritingVariableName +-- , Value normalized (TermLike RewritingVariableName) +-- ) +-- ) +-- simplifyPair (key, value) = do +-- simplifiedKey <- simplifyTermLike' key +-- let (keyTerm, keyCondition) = Conditional.splitTerm simplifiedKey +-- simplifiedValue <- traverse simplifyTermLike' value +-- let splitSimplifiedValue :: +-- Value +-- normalized +-- ( TermLike RewritingVariableName +-- , Condition RewritingVariableName +-- ) +-- splitSimplifiedValue = +-- fmap Conditional.splitTerm simplifiedValue +-- simplifiedValueTerm :: +-- Value normalized (TermLike RewritingVariableName) +-- simplifiedValueTerm = fmap fst splitSimplifiedValue +-- simplifiedValueConditions :: +-- Value normalized (Condition RewritingVariableName) +-- simplifiedValueConditions = fmap snd splitSimplifiedValue +-- simplifiedValueCondition :: Condition RewritingVariableName +-- simplifiedValueCondition = +-- foldr +-- andCondition +-- Condition.top +-- simplifiedValueConditions +-- return +-- ( (keyTerm, simplifiedValueTerm) +-- `withCondition` keyCondition +-- `andCondition` simplifiedValueCondition +-- ) +-- where +-- simplifyTermLike' :: +-- TermLike RewritingVariableName -> +-- unifier (Pattern RewritingVariableName) +-- simplifyTermLike' term = +-- lowerLogicT $ simplifyConditionalTerm SideCondition.topTODO term {- | Unifies two AC structs represented as @NormalizedAc@. @@ -1057,7 +1052,7 @@ unifyEqualsNormalizedAc :: TermNormalizedAc normalized RewritingVariableName -> TermNormalizedAc normalized RewritingVariableName -> UnifyEqualsNormAc normalized RewritingVariableName -> - unifier + unifier ( Conditional RewritingVariableName (TermNormalizedAc normalized RewritingVariableName) @@ -1077,10 +1072,8 @@ unifyEqualsNormalizedAc allElements1 allElements2 maybeVar - where UnifyEqualsElementListsData{allElements1, allElements2, maybeVar} = unifyData' - UnifyOpaqueVar unifyData' -> unifyOpaqueVariable bottomWithExplanation @@ -1602,15 +1595,15 @@ unifyEqualsElementLists (unifyEqualsConcreteOrWithVariable unifyEqualsChildren) remainderError = nonEmptyRemainderError first second -data NoCheckUnifyOpaqueChildrenData variable = NoCheckUnifyOpaqueChildrenData { - v1 :: TermLike.ElementVariable variable +data NoCheckUnifyOpaqueChildrenData variable = NoCheckUnifyOpaqueChildrenData + { v1 :: TermLike.ElementVariable variable , second :: TermLike variable -} + } data UnifyOpVarResult variable = NoCheckUnifyOpaqueChildren !(NoCheckUnifyOpaqueChildrenData variable) | BottomWithExplanation - + matchUnifyOpaqueVariable :: ( TermWrapper normalized , InternalVariable variable @@ -1622,7 +1615,7 @@ matchUnifyOpaqueVariable :: Maybe (UnifyOpVarResult variable) matchUnifyOpaqueVariable _ v1 [] [second@(ElemVar_ _)] = --noCheckUnifyOpaqueChildren unifyChildren v1 second - Just $ NoCheckUnifyOpaqueChildren NoCheckUnifyOpaqueChildrenData{v1, second} + Just $ NoCheckUnifyOpaqueChildren NoCheckUnifyOpaqueChildrenData{v1, second} matchUnifyOpaqueVariable tools v1 @@ -1630,8 +1623,8 @@ matchUnifyOpaqueVariable opaqueTerms = case elementListAsNormalized pairs of Nothing -> Just BottomWithExplanation - -- bottomWithExplanation - -- "Duplicated element in unification results" + -- bottomWithExplanation + -- "Duplicated element in unification results" Just elementTerm -> let secondTerm = asInternal @@ -1641,9 +1634,10 @@ matchUnifyOpaqueVariable elementTerm{opaque = opaqueTerms} ) in if TermLike.isFunctionPattern secondTerm - then Just - $ NoCheckUnifyOpaqueChildren - $ NoCheckUnifyOpaqueChildrenData v1 secondTerm + then + Just $ + NoCheckUnifyOpaqueChildren $ + NoCheckUnifyOpaqueChildrenData v1 secondTerm else Nothing where sort = variableSort v1 @@ -1657,7 +1651,7 @@ unifyOpaqueVariable :: -- | unifier function (TermLike variable -> TermLike variable -> unifier (Pattern variable)) -> UnifyOpVarResult variable -> - unifier + unifier ( Conditional variable [(TermLike variable, Value normalized (TermLike variable))] @@ -1668,12 +1662,13 @@ unifyOpaqueVariable unifyChildren unifyData = case unifyData of - NoCheckUnifyOpaqueChildren unifyData' -> + NoCheckUnifyOpaqueChildren unifyData' -> noCheckUnifyOpaqueChildren unifyChildren v1 second where NoCheckUnifyOpaqueChildrenData{v1, second} = unifyData' - _ -> bottomWithExplanation - "Duplicated element in unification results" + _ -> + bottomWithExplanation + "Duplicated element in unification results" noCheckUnifyOpaqueChildren :: ( MonadUnify unifier @@ -1682,7 +1677,7 @@ noCheckUnifyOpaqueChildren :: (TermLike variable -> TermLike variable -> unifier (Pattern variable)) -> TermLike.ElementVariable variable -> TermLike variable -> - unifier + unifier ( Conditional variable [(TermLike variable, Value normalized (TermLike variable))] diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 196bb0db7b..6217ca1a5a 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -519,10 +519,10 @@ internalize tools termLike where sort' = termLikeSort termLike -data NormAcData = NormAcData { - normalized1, normalized2 :: InternalMap Key (TermLike RewritingVariableName) +data NormAcData = NormAcData + { normalized1, normalized2 :: InternalMap Key (TermLike RewritingVariableName) , acData :: !(Ac.UnifyEqualsNormAc NormalizedMap RewritingVariableName) -} + } data UnifyEqualsMap = ReturnBottom @@ -537,7 +537,6 @@ matchUnifyEquals tools first second | Just True <- isMapSort tools sort1 = worker first second | otherwise = Nothing - where sort1 = termLikeSort first @@ -548,20 +547,21 @@ matchUnifyEquals tools first second worker a b | InternalMap_ normalized1 <- a - , InternalMap_ normalized2 <- b - = NormAc . NormAcData normalized1 normalized2 <$> Ac.matchUnifyEqualsNormalizedAc - tools - normalized1 - normalized2 + , InternalMap_ normalized2 <- b = + NormAc . NormAcData normalized1 normalized2 + <$> Ac.matchUnifyEqualsNormalizedAc + tools + normalized1 + normalized2 | otherwise = case normalizedOrBottom a of Ac.Bottom -> Just ReturnBottom Ac.Normalized normalized1 -> let a' = Ac.asInternal tools sort1 normalized1 in case normalizedOrBottom b of - Ac.Bottom -> Just ReturnBottom - Ac.Normalized normalized2 -> - let b' = Ac.asInternal tools sort1 normalized2 - in worker a' b' + Ac.Bottom -> Just ReturnBottom + Ac.Normalized normalized2 -> + let b' = Ac.asInternal tools sort1 normalized2 + in worker a' b' {- | Simplify the conjunction or equality of two concrete Map domain values. @@ -583,11 +583,11 @@ unifyEquals :: unifier (Pattern RewritingVariableName) unifyEquals unifyEqualsChildren tools first second unifyData = case unifyData of - ReturnBottom -> + ReturnBottom -> Monad.Unify.explainAndReturnBottom - "Duplicated elements in normalization." - first - second + "Duplicated elements in normalization." + first + second NormAc unifyData' -> Ac.unifyEqualsNormalized tools @@ -597,8 +597,8 @@ unifyEquals unifyEqualsChildren tools first second unifyData = normalized1 normalized2 acData - where - NormAcData{normalized1, normalized2, acData} = unifyData' + where + NormAcData{normalized1, normalized2, acData} = unifyData' data InKeys term = InKeys { symbol :: !Symbol diff --git a/kore/src/Kore/Builtin/Set.hs b/kore/src/Kore/Builtin/Set.hs index 50633d5937..3247664bfc 100644 --- a/kore/src/Kore/Builtin/Set.hs +++ b/kore/src/Kore/Builtin/Set.hs @@ -523,10 +523,10 @@ internalize tools termLike where sort' = termLikeSort termLike -data NormAcData = NormAcData { - normalized1, normalized2 :: InternalSet Key (TermLike RewritingVariableName) +data NormAcData = NormAcData + { normalized1, normalized2 :: InternalSet Key (TermLike RewritingVariableName) , acData :: !(Ac.UnifyEqualsNormAc NormalizedSet RewritingVariableName) -} + } data UnifyEqualsMap = ReturnBottom @@ -541,7 +541,6 @@ matchUnifyEquals tools first second | Just True <- isSetSort tools sort1 = worker first second | otherwise = Nothing - where sort1 = termLikeSort first @@ -552,20 +551,21 @@ matchUnifyEquals tools first second worker a b | InternalSet_ normalized1 <- a - , InternalSet_ normalized2 <- b - = NormAc . NormAcData normalized1 normalized2 <$> Ac.matchUnifyEqualsNormalizedAc - tools - normalized1 - normalized2 + , InternalSet_ normalized2 <- b = + NormAc . NormAcData normalized1 normalized2 + <$> Ac.matchUnifyEqualsNormalizedAc + tools + normalized1 + normalized2 | otherwise = case normalizedOrBottom a of Ac.Bottom -> Just ReturnBottom Ac.Normalized normalized1 -> let a' = Ac.asInternal tools sort1 normalized1 in case normalizedOrBottom b of - Ac.Bottom -> Just ReturnBottom - Ac.Normalized normalized2 -> - let b' = Ac.asInternal tools sort1 normalized2 - in worker a' b' + Ac.Bottom -> Just ReturnBottom + Ac.Normalized normalized2 -> + let b' = Ac.asInternal tools sort1 normalized2 + in worker a' b' {- | Simplify the conjunction or equality of two concrete Map domain values. @@ -587,11 +587,11 @@ unifyEquals :: unifier (Pattern RewritingVariableName) unifyEquals unifyEqualsChildren tools first second unifyData = case unifyData of - ReturnBottom -> + ReturnBottom -> Monad.Unify.explainAndReturnBottom - "Duplicated elements in normalization." - first - second + "Duplicated elements in normalization." + first + second NormAc unifyData' -> Ac.unifyEqualsNormalized tools @@ -601,5 +601,5 @@ unifyEquals unifyEqualsChildren tools first second unifyData = normalized1 normalized2 acData - where - NormAcData{normalized1, normalized2, acData} = unifyData' + where + NormAcData{normalized1, normalized2, acData} = unifyData' From 5f15b7a04a444b463a45d6a2eb385b13c3b11926 Mon Sep 17 00:00:00 2001 From: emarzion Date: Mon, 31 May 2021 23:56:36 -0500 Subject: [PATCH 63/86] Work toward fixing Overloading code --- kore/src/Kore/Step/Simplification/AndTerms.hs | 63 ++--- .../Kore/Step/Simplification/NoConfusion.hs | 5 +- .../Kore/Step/Simplification/Overloading.hs | 261 ++++++++++-------- .../Kore/Step/Simplification/Overloading.hs | 40 +-- 4 files changed, 188 insertions(+), 181 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index e0ea6d8336..4974bdac71 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -72,7 +72,6 @@ import Kore.Step.Simplification.ExpandAlias import Kore.Step.Simplification.InjSimplifier import Kore.Step.Simplification.NoConfusion import Kore.Step.Simplification.NotSimplifier -import Kore.Step.Simplification.OverloadSimplifier as OverloadSimplifier import Kore.Step.Simplification.Overloading as Overloading import qualified Kore.Step.Simplification.SimplificationType as SimplificationType ( SimplificationType (..), @@ -140,11 +139,11 @@ maybeTermEquals :: MaybeT unifier (Pattern RewritingVariableName) maybeTermEquals notSimplifier childTransformers first second = do injSimplifier <- Simplifier.askInjSimplifier - OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier + overloadSimplifier <- Simplifier.askOverloadSimplifier tools <- Simplifier.askMetadataTools - worker injSimplifier isOverloaded tools + worker injSimplifier overloadSimplifier tools where - worker injSimplifier isOverloaded tools + worker injSimplifier overloadSimplifier tools | Just unifyData <- Builtin.Int.matchInt first second = lift $ Builtin.Int.unifyInt first second unifyData | Just unifyData <- Builtin.Bool.matchBools first second = @@ -173,13 +172,10 @@ maybeTermEquals notSimplifier childTransformers first second = do lift $ unifySortInjection childTransformers first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = lift $ constructorSortInjectionAndEquals first second - | Just () <- matchDifferentConstructors isOverloaded first second = + | Just () <- matchDifferentConstructors overloadSimplifier first second = lift $ constructorAndEqualsAssumesDifferentHeads first second - | otherwise = - overloadedConstructorSortInjectionAndEquals childTransformers first second - <|> rest tools - - rest tools + | Just unifyData <- unifyOverloading overloadSimplifier (Pair first second) = + lift $ overloadedConstructorSortInjectionAndEquals childTransformers first second unifyData | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd first second = lift $ Builtin.Bool.unifyBoolAnd childTransformers first boolAndData | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd second first = @@ -253,11 +249,11 @@ maybeTermAnd :: MaybeT unifier (Pattern RewritingVariableName) maybeTermAnd notSimplifier childTransformers first second = do injSimplifier <- Simplifier.askInjSimplifier - OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier + overloadSimplifier <- Simplifier.askOverloadSimplifier tools <- Simplifier.askMetadataTools - worker injSimplifier isOverloaded tools + worker injSimplifier overloadSimplifier tools where - worker injSimplifier isOverloaded tools + worker injSimplifier overloadSimplifier tools | Just unifyData <- matchExpandAlias first second = let UnifyExpandAlias{term1, term2} = unifyData in maybeTermAnd @@ -293,13 +289,10 @@ maybeTermAnd notSimplifier childTransformers first second = do lift $ unifySortInjection childTransformers first second unifyData | Just () <- matchConstructorSortInjectionAndEquals first second = lift $ constructorSortInjectionAndEquals first second - | Just () <- matchDifferentConstructors isOverloaded first second = + | Just () <- matchDifferentConstructors overloadSimplifier first second = lift $ constructorAndEqualsAssumesDifferentHeads first second - | otherwise = - overloadedConstructorSortInjectionAndEquals childTransformers first second - <|> rest tools - - rest tools + | Just unifyData <- unifyOverloading overloadSimplifier (Pair first second) = + lift $ overloadedConstructorSortInjectionAndEquals childTransformers first second unifyData | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd first second = lift $ Builtin.Bool.unifyBoolAnd childTransformers first boolAndData | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd second first = @@ -743,17 +736,13 @@ overloadedConstructorSortInjectionAndEquals :: TermSimplifier RewritingVariableName unifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - MaybeT unifier (Pattern RewritingVariableName) -overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm = - do - eunifier <- - lift . Error.runExceptT $ - unifyOverloading (Pair firstTerm secondTerm) - case eunifier of - Right (Simple (Pair firstTerm' secondTerm')) -> - lift $ - termMerger firstTerm' secondTerm' - Right + MatchResult -> + unifier (Pattern RewritingVariableName) +overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm unifyData = + case unifyData of + Resolution (Simple (Pair firstTerm' secondTerm')) -> + termMerger firstTerm' secondTerm' + Resolution ( WithNarrowing Narrowing { narrowingSubst @@ -761,25 +750,21 @@ overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm = , overloadPair = Pair firstTerm' secondTerm' } ) -> do - boundPattern <- lift $ do + boundPattern <- do merged <- termMerger firstTerm' secondTerm' Exists.makeEvaluate SideCondition.topTODO narrowingVars $ merged `Pattern.andCondition` narrowingSubst case OrPattern.toPatterns boundPattern of [result] -> return result - [] -> - lift $ - explainAndReturnBottom + [] -> explainAndReturnBottom ( "exists simplification for overloaded" <> " constructors returned no pattern" ) firstTerm secondTerm - _ -> empty - Left (Clash message) -> - lift $ - explainAndReturnBottom (fromString message) firstTerm secondTerm - Left Overloading.NotApplicable -> empty + _ -> scatter boundPattern + ClashResult message -> + explainAndReturnBottom (fromString message) firstTerm secondTerm data DVConstrError = DVConstr diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 6fe7ad3b15..55609a01e9 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -19,6 +19,7 @@ import Kore.Internal.TermLike import Kore.Rewriting.RewritingVariable ( RewritingVariableName, ) +import Kore.Step.Simplification.OverloadSimplifier import Kore.Step.Simplification.Simplify as Simplifier import Kore.Unification.Unify as Unify import Prelude.Kore hiding ( @@ -114,12 +115,12 @@ and when @f /= g@ and @f,g@ either have the @constructor@ attribute or are overloaded. -} matchDifferentConstructors :: - (Symbol -> Bool) -> + OverloadSimplifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe () matchDifferentConstructors - isOverloaded + OverloadSimplifier{isOverloaded} first second | App_ firstHead _ <- first diff --git a/kore/src/Kore/Step/Simplification/Overloading.hs b/kore/src/Kore/Step/Simplification/Overloading.hs index f4072e9185..d14020291f 100644 --- a/kore/src/Kore/Step/Simplification/Overloading.hs +++ b/kore/src/Kore/Step/Simplification/Overloading.hs @@ -11,13 +11,12 @@ module Kore.Step.Simplification.Overloading ( UnifyOverloadingError (..), Narrowing (..), OverloadingResolution (..), + MatchResult (..), ) where import qualified Control.Monad as Monad import Control.Monad.Trans.Except ( ExceptT, - catchE, - throwE, ) import Data.Text ( Text, @@ -31,13 +30,11 @@ import Kore.Attribute.Synthetic ( synthesize, ) import Kore.Debug -import Kore.Internal.ApplicationSorts ( - ApplicationSorts (..), - ) import Kore.Internal.Condition ( Condition, ) import qualified Kore.Internal.Condition as Condition +import Kore.Internal.Symbol import Kore.Internal.TermLike import Kore.Rewriting.RewritingVariable ( RewritingVariableName, @@ -46,7 +43,6 @@ import Kore.Rewriting.RewritingVariable ( import Kore.Step.Simplification.OverloadSimplifier import Kore.Step.Simplification.Simplify as Simplifier ( MonadSimplify (..), - isConstructorOrOverloaded, ) import Pair import Prelude.Kore hiding ( @@ -78,6 +74,23 @@ data OverloadingResolution variable deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) deriving anyclass (Debug, Diff) +data MatchResult + = ClashResult !String + | Resolution !(OverloadingResolution RewritingVariableName) + deriving stock (Eq, Ord, Show) + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving anyclass (Debug, Diff) + +flipResult + :: MatchResult + -> MatchResult +flipResult result = + case result of + Resolution (Simple (Pair term1 term2)) -> + Resolution (Simple (Pair term2 term1)) + _ -> result + -- | Describes the possible errors encountered during unification. data UnifyOverloadingError = -- | the unification problem could not be solved by the current method @@ -108,24 +121,18 @@ type MatchOverloadingResult unifier variable = unifier (Pair (TermLike variable)) -type OverloadingResult unifier a = ExceptT UnifyOverloadingError unifier a - -notApplicable :: Monad unifier => OverloadingResult unifier a -notApplicable = empty - -throwBottom :: Monad unifier => String -> OverloadingResult unifier a -throwBottom = throwE . Clash +throwBottom :: String -> Maybe MatchResult +throwBottom = Just . ClashResult matchOverloading :: MonadSimplify unifier => Pair (TermLike RewritingVariableName) -> MatchOverloadingResult unifier RewritingVariableName -matchOverloading termPair = - do - unifyResult <- unifyOverloading termPair - case unifyResult of - Simple pair -> return pair - _ -> notApplicable +matchOverloading termPair = do + overloadSimplifier <- askOverloadSimplifier + case unifyOverloading overloadSimplifier termPair of + Just (Resolution (Simple pair)) -> return pair + _ -> empty {- | Tests whether the pair of terms can be coerced to have the same constructors @@ -141,16 +148,16 @@ matchOverloading termPair = the first and second terms in a pair are not interchangeable. -} unifyOverloading :: - forall unifier. - MonadSimplify unifier => + OverloadSimplifier -> Pair (TermLike RewritingVariableName) -> - UnifyOverloadingResult unifier RewritingVariableName -unifyOverloading termPair = case termPair of + Maybe MatchResult +unifyOverloading overloadSimplifier termPair = case termPair of Pair (Inj_ inj@Inj{injChild = App_ firstHead firstChildren}) secondTerm@(App_ secondHead _) -> - Simple . flipPairBack - <$> unifyOverloadingVsOverloaded + flipResult <$> + unifyOverloadingVsOverloaded + overloadSimplifier secondHead secondTerm (Application firstHead firstChildren) @@ -158,37 +165,36 @@ unifyOverloading termPair = case termPair of Pair firstTerm@(App_ firstHead _) (Inj_ inj@Inj{injChild = App_ secondHead secondChildren}) -> - Simple - <$> unifyOverloadingVsOverloaded - firstHead - firstTerm - (Application secondHead secondChildren) - inj{injChild = ()} + unifyOverloadingVsOverloaded + overloadSimplifier + firstHead + firstTerm + (Application secondHead secondChildren) + inj{injChild = ()} Pair (Inj_ inj@Inj{injChild = App_ firstHead firstChildren}) (Inj_ inj'@Inj{injChild = App_ secondHead secondChildren}) | injFrom inj /= injFrom inj' -> -- this case should have been handled by now - Simple - <$> unifyOverloadingCommonOverload - (Application firstHead firstChildren) - (Application secondHead secondChildren) - inj{injChild = ()} + unifyOverloadingCommonOverload + overloadSimplifier + (Application firstHead firstChildren) + (Application secondHead secondChildren) + inj{injChild = ()} Pair firstTerm secondTerm -> - catchE - (worker firstTerm secondTerm) - ( \case - NotApplicable -> worker secondTerm firstTerm - clash -> throwE clash - ) + case worker firstTerm secondTerm of + Nothing -> worker secondTerm firstTerm + Just result -> Just result + where worker :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - UnifyOverloadingResult unifier RewritingVariableName + Maybe MatchResult worker firstTerm@(App_ firstHead _) (Inj_ inj@Inj{injChild = ElemVar_ secondVar}) = unifyOverloadingVsOverloadedVariable + overloadSimplifier firstHead firstTerm secondVar @@ -197,19 +203,21 @@ unifyOverloading termPair = case termPair of (Inj_ Inj{injChild = firstTerm@(App_ firstHead firstChildren)}) (Inj_ inj@Inj{injChild = ElemVar_ secondVar}) = unifyOverloadingInjVsVariable + overloadSimplifier (Application firstHead firstChildren) secondVar (Attribute.freeVariables firstTerm) inj{injChild = ()} worker (App_ firstHead _) (Inj_ Inj{injChild}) = notUnifiableTest firstHead injChild - worker _ _ = notApplicable + worker _ _ = Nothing - flipPairBack (Pair x y) = Pair y x notUnifiableTest termHead child = do - OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier + --OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier Monad.guard (isOverloaded termHead) notUnifiableError child + where + OverloadSimplifier{isOverloaded} = overloadSimplifier {- Handles the case inj{S1,injTo}(firstHead(firstChildren)) @@ -228,30 +236,33 @@ unifyOverloading termPair = case termPair of inj{S,injTo}(headUnion(inj2(secondChildren))) -} unifyOverloadingCommonOverload :: - MonadSimplify unifier => + OverloadSimplifier -> Application Symbol (TermLike RewritingVariableName) -> Application Symbol (TermLike RewritingVariableName) -> Inj () -> - MatchOverloadingResult unifier RewritingVariableName + Maybe MatchResult unifyOverloadingCommonOverload + overloadSimplifier (Application firstHead firstChildren) (Application secondHead secondChildren) - injProto@Inj{injTo} = - do - OverloadSimplifier - { isOverloaded - , resolveOverloading - , unifyOverloadWithinBound - } <- - Simplifier.askOverloadSimplifier - Monad.guard (isOverloaded firstHead && isOverloaded secondHead) - case unifyOverloadWithinBound injProto firstHead secondHead injTo of - Nothing -> notUnifiableOverloads - Just InjectedOverload{overload, injectionHead} -> - let first' = resolveOverloading injProto overload firstChildren - second' = resolveOverloading injProto overload secondChildren - mkInj' = maybeMkInj injectionHead - in return $ Pair (mkInj' first') (mkInj' second') + injProto@Inj{injTo} + | isOverloaded firstHead + , isOverloaded secondHead + = case unifyOverloadWithinBound injProto firstHead secondHead injTo of + Nothing -> Just $ ClashResult "overloaded constructors not unifiable" + Just InjectedOverload{overload, injectionHead} -> + let first' = resolveOverloading injProto overload firstChildren + second' = resolveOverloading injProto overload secondChildren + mkInj' = maybeMkInj injectionHead + in Just $ Resolution $ Simple $ Pair (mkInj' first') (mkInj' second') + | otherwise = Nothing + + where + OverloadSimplifier + { isOverloaded + , resolveOverloading + , unifyOverloadWithinBound + } = overloadSimplifier {- Handles the case overloadingTerm@(overloadingHead(overloadingChildren)) @@ -267,28 +278,32 @@ unifyOverloadingCommonOverload overloadingHead(inj'(overloadedChildren)) -} unifyOverloadingVsOverloaded :: - MonadSimplify unifier => + OverloadSimplifier -> Symbol -> TermLike RewritingVariableName -> Application Symbol (TermLike RewritingVariableName) -> Inj () -> - MatchOverloadingResult unifier RewritingVariableName + Maybe MatchResult unifyOverloadingVsOverloaded + overloadSimplifier overloadingHead overloadingTerm (Application overloadedHead overloadedChildren) - injProto = - do - OverloadSimplifier{isOverloaded, isOverloading, resolveOverloading} <- - Simplifier.askOverloadSimplifier - Monad.guard (isOverloaded overloadingHead) - isSecondHeadConstructor <- isConstructorOrOverloaded overloadedHead - Monad.guard isSecondHeadConstructor - let ~overloadedTerm' = - resolveOverloading injProto overloadingHead overloadedChildren - if isOverloading overloadingHead overloadedHead - then return $ Pair overloadingTerm overloadedTerm' + injProto + | isOverloaded overloadingHead + , isConstructor overloadedHead || isOverloaded overloadedHead + = let ~overloadedTerm' = + resolveOverloading injProto overloadingHead overloadedChildren + in if isOverloading overloadingHead overloadedHead + then Just $ Resolution $ Simple $ Pair overloadingTerm overloadedTerm' else throwBottom "different injected ctor" + | otherwise = Nothing + where + OverloadSimplifier + { isOverloaded + , isOverloading + , resolveOverloading + } = overloadSimplifier {- Handles the case overloadingTerm@(overloadingHead(overloadingChildren)) @@ -306,26 +321,26 @@ unifyOverloadingVsOverloaded overloadingHead(inj2(freshVars)) -} unifyOverloadingVsOverloadedVariable :: - MonadSimplify unifier => + OverloadSimplifier -> Symbol -> TermLike RewritingVariableName -> ElementVariable RewritingVariableName -> Inj () -> - UnifyOverloadingResult unifier RewritingVariableName + Maybe MatchResult unifyOverloadingVsOverloadedVariable + overloadSimplifier overloadingHead overloadingTerm overloadedVar injProto@Inj{injFrom} = do - OverloadSimplifier{isOverloaded, getOverloadedWithinSort} <- - Simplifier.askOverloadSimplifier Monad.guard (isOverloaded overloadingHead) case getOverloadedWithinSort injProto overloadingHead injFrom of - Right Nothing -> notUnifiableOverloads - Right (Just overHead) -> + Right Nothing -> Just notUnifiableOverloads + Right (Just overHead) -> Just $ Resolution $ WithNarrowing - <$> computeNarrowing + $ computeNarrowing + overloadSimplifier overloadingTerm Nothing overloadingHead @@ -336,6 +351,7 @@ unifyOverloadingVsOverloadedVariable Left err -> error err where freeVars = freeVariables overloadingTerm + OverloadSimplifier{isOverloaded, getOverloadedWithinSort} = overloadSimplifier {- Handles the case inj{S1,injTo}(firstHead(firstChildren)) @@ -356,35 +372,29 @@ unifyOverloadingVsOverloadedVariable inj{S,injTo}(headUnion(inj2(freshVars))) -} unifyOverloadingInjVsVariable :: - MonadSimplify unifier => + OverloadSimplifier -> Application Symbol (TermLike RewritingVariableName) -> ElementVariable RewritingVariableName -> Attribute.FreeVariables RewritingVariableName -> Inj () -> - UnifyOverloadingResult unifier RewritingVariableName + Maybe MatchResult unifyOverloadingInjVsVariable + overloadSimplifier (Application firstHead firstChildren) overloadedVar freeVars - injProto = - do - OverloadSimplifier - { isOverloaded - , resolveOverloading - , unifyOverloadWithSortWithinBound - } <- - Simplifier.askOverloadSimplifier - Monad.guard (isOverloaded firstHead) - case unifyOverloadWithSortWithinBound firstHead injProto of + injProto + | isOverloaded firstHead + = case unifyOverloadWithSortWithinBound firstHead injProto of Left err -> error err - Right Nothing -> notUnifiableOverloads + Right Nothing -> Just notUnifiableOverloads Right (Just InjectedOverloadPair{overloadingSymbol, overloadedSymbol}) -> - do - let (InjectedOverload headUnion maybeInjUnion) = overloadingSymbol - first' = resolveOverloading injProto headUnion firstChildren - WithNarrowing - <$> computeNarrowing + let (InjectedOverload headUnion maybeInjUnion) = overloadingSymbol + first' = resolveOverloading injProto headUnion firstChildren + in Just $ Resolution $ WithNarrowing + $ computeNarrowing + overloadSimplifier first' maybeInjUnion headUnion @@ -392,10 +402,19 @@ unifyOverloadingInjVsVariable freeVars overloadedVar overloadedSymbol + | otherwise = Nothing + + where + OverloadSimplifier + { isOverloaded + , resolveOverloading + , unifyOverloadWithSortWithinBound + } = overloadSimplifier computeNarrowing :: HasCallStack => - MonadSimplify unifier => + -- |overloading simpifier + OverloadSimplifier -> -- |overloading pair LHS TermLike RewritingVariableName -> -- |optional injection @@ -410,8 +429,9 @@ computeNarrowing :: ElementVariable RewritingVariableName -> -- |overloaded symbol injected into the variable's sort InjectedOverload -> - ExceptT UnifyOverloadingError unifier (Narrowing RewritingVariableName) + Narrowing RewritingVariableName computeNarrowing + overloadSimplifier first' injection' headUnion @@ -420,12 +440,9 @@ computeNarrowing overloadedVar overloaded | App_ _ freshTerms <- overloadedTerm = - do - OverloadSimplifier{resolveOverloading} <- - Simplifier.askOverloadSimplifier let second' = resolveOverloading injUnion headUnion freshTerms - return + in Narrowing { narrowingSubst = Condition.assign (inject overloadedVar) narrowingTerm @@ -440,6 +457,7 @@ computeNarrowing overloadedTerm = freshSymbolInstance allVars overload "x" mkInj' = maybeMkInj injection' narrowingTerm = maybeMkInj injectionHead overloadedTerm + OverloadSimplifier{resolveOverloading} = overloadSimplifier -- | Generates fresh variables as arguments for a symbol to create a pattern. freshSymbolInstance :: @@ -473,16 +491,17 @@ maybeMkInj :: TermLike RewritingVariableName maybeMkInj maybeInj injChild = maybe injChild (flip mkInj injChild) maybeInj -notUnifiableError :: - Monad unifier => TermLike RewritingVariableName -> OverloadingResult unifier a -notUnifiableError (DV_ _ _) = throwBottom "injected domain value" -notUnifiableError (InternalBool_ _) = throwBottom "injected builtin bool" -notUnifiableError (InternalInt_ _) = throwBottom "injected builtin int" -notUnifiableError (InternalList_ _) = throwBottom "injected builtin list" -notUnifiableError (InternalMap_ _) = throwBottom "injected builtin map" -notUnifiableError (InternalSet_ _) = throwBottom "injected builtin set" -notUnifiableError (InternalString_ _) = throwBottom "injected builtin string" -notUnifiableError _ = notApplicable - -notUnifiableOverloads :: Monad unifier => OverloadingResult unifier a -notUnifiableOverloads = throwBottom "overloaded constructors not unifiable" +notUnifiableError + :: TermLike RewritingVariableName -> Maybe MatchResult +notUnifiableError = \case + (DV_ _ _) -> Just $ ClashResult "injected domain value" + (InternalBool_ _) -> Just $ ClashResult "injected builtin bool" + (InternalInt_ _) -> Just $ ClashResult "injected builtin int" + (InternalList_ _) -> Just $ ClashResult "injected builtin list" + (InternalMap_ _) -> Just $ ClashResult "injected builtin map" + (InternalSet_ _) -> Just $ ClashResult "injected builtin set" + (InternalString_ _) -> Just $ ClashResult "injected builtin string" + _ -> Nothing + +notUnifiableOverloads :: MatchResult +notUnifiableOverloads = ClashResult "overloaded constructors not unifiable" diff --git a/kore/test/Test/Kore/Step/Simplification/Overloading.hs b/kore/test/Test/Kore/Step/Simplification/Overloading.hs index 868f38df7c..f04fbd4a41 100644 --- a/kore/test/Test/Kore/Step/Simplification/Overloading.hs +++ b/kore/test/Test/Kore/Step/Simplification/Overloading.hs @@ -400,9 +400,9 @@ doesn'tMatch :: TermLike RewritingVariableName -> String -> TestTree -doesn'tMatch comment term1 term2 reason = +doesn'tMatch comment term1 term2 _ = --reason = withMatching - (assertEqual "" (Left (Clash reason))) + (assertEqual "" (Left NotApplicable)) --(Left (Clash reason))) TODO:fix comment (Pair term1 term2) @@ -438,7 +438,7 @@ unifies :: TestTree unifies comment (term1, term2) (term1', term2') = withUnification - (assertEqual "" (Right (Simple (Pair term1' term2')))) + (assertEqual "" (Just (Resolution (Simple (Pair term1' term2'))))) comment (Pair term1 term2) @@ -458,10 +458,10 @@ narrows comment (term1, term2) ((v, term), (term1', term2')) = where checkNarrowing :: UnificationResult -> Assertion checkNarrowing - ( Right + ( Just (Resolution ( WithNarrowing Narrowing{narrowingSubst, overloadPair} - ) + )) ) = do assertEqual "" (Pair term1' term2') overloadPair @@ -478,7 +478,7 @@ doesn'tUnify :: TestTree doesn'tUnify comment term1 term2 reason = withUnification - (assertEqual "" (Left (Clash reason))) + (assertEqual "" (Just (ClashResult reason))) comment (Pair term1 term2) @@ -490,7 +490,7 @@ unifyNotApplicable :: TestTree unifyNotApplicable comment term1 term2 = withUnification - (assertEqual "" (Left NotApplicable)) + (assertEqual "" Nothing) comment (Pair term1 term2) @@ -502,16 +502,16 @@ unifyNotApplicableTwice :: TestTree unifyNotApplicableTwice comment term1 term2 = withUnificationTwice - (assertEqual "" (Left NotApplicable)) + (assertEqual "" Nothing) comment (Pair term1 term2) -type MatchResult = +type TestMatchResult = Either UnifyOverloadingError (Pair (TermLike RewritingVariableName)) match :: Pair (TermLike RewritingVariableName) -> - IO MatchResult + IO TestMatchResult match termPair = runSimplifier Mock.env $ runExceptT matchResult where matchResult :: @@ -519,7 +519,7 @@ match termPair = runSimplifier Mock.env $ runExceptT matchResult matchResult = matchOverloading termPair withMatching :: - (MatchResult -> Assertion) -> + (TestMatchResult -> Assertion) -> TestName -> Pair (TermLike RewritingVariableName) -> TestTree @@ -529,7 +529,7 @@ withMatching check comment termPair = check actual withMatchingTwice :: - (MatchResult -> Assertion) -> + (TestMatchResult -> Assertion) -> TestName -> Pair (TermLike RewritingVariableName) -> TestTree @@ -543,15 +543,16 @@ withMatchingTwice check comment termPair = check actual' type UnificationResult = - Either UnifyOverloadingError (OverloadingResolution RewritingVariableName) + Maybe MatchResult unify :: Pair (TermLike RewritingVariableName) -> IO UnificationResult -unify termPair = runSimplifier Mock.env $ runExceptT unifyResult +unify termPair = + runSimplifier Mock.env $ return unifyResult where - unifyResult :: UnifyOverloadingResult (SimplifierT NoSMT) RewritingVariableName - unifyResult = unifyOverloading termPair + unifyResult :: Maybe MatchResult + unifyResult = unifyOverloading Mock.overloadSimplifier termPair withUnification :: (UnificationResult -> Assertion) -> @@ -572,13 +573,14 @@ withUnificationTwice check comment termPair = testCase comment $ do actual <- unify termPair case actual of - Left _ -> assertFailure "Expected matching solution." - Right (Simple termPair') -> do + Just (Resolution (Simple termPair')) -> do actual' <- unify termPair' check actual' - Right (WithNarrowing Narrowing{overloadPair}) -> do + Just (Resolution (WithNarrowing Narrowing{overloadPair})) -> do actual' <- unify overloadPair check actual' + _ -> assertFailure "Expected matching solution." + x1 :: TermLike RewritingVariableName x1 = From 00846d55f47155cfc65da9f4174e9c47c49b26f0 Mon Sep 17 00:00:00 2001 From: github-actions Date: Tue, 1 Jun 2021 04:59:10 +0000 Subject: [PATCH 64/86] Format with fourmolu --- kore/src/Kore/Step/Simplification/AndTerms.hs | 52 +++--- .../Kore/Step/Simplification/Overloading.hs | 164 +++++++++--------- .../Kore/Step/Simplification/Overloading.hs | 14 +- 3 files changed, 116 insertions(+), 114 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 4974bdac71..500d57f561 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -552,7 +552,6 @@ unifyVariableFunction UnifyVariableFunction{variable, term} = @ \\equals{_, _}(x, f(_)) @ - -} matchVariableFunctionEquals :: TermLike RewritingVariableName -> @@ -740,31 +739,32 @@ overloadedConstructorSortInjectionAndEquals :: unifier (Pattern RewritingVariableName) overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm unifyData = case unifyData of - Resolution (Simple (Pair firstTerm' secondTerm')) -> - termMerger firstTerm' secondTerm' - Resolution - ( WithNarrowing - Narrowing - { narrowingSubst - , narrowingVars - , overloadPair = Pair firstTerm' secondTerm' - } - ) -> do - boundPattern <- do - merged <- termMerger firstTerm' secondTerm' - Exists.makeEvaluate SideCondition.topTODO narrowingVars $ - merged `Pattern.andCondition` narrowingSubst - case OrPattern.toPatterns boundPattern of - [result] -> return result - [] -> explainAndReturnBottom - ( "exists simplification for overloaded" - <> " constructors returned no pattern" - ) - firstTerm - secondTerm - _ -> scatter boundPattern - ClashResult message -> - explainAndReturnBottom (fromString message) firstTerm secondTerm + Resolution (Simple (Pair firstTerm' secondTerm')) -> + termMerger firstTerm' secondTerm' + Resolution + ( WithNarrowing + Narrowing + { narrowingSubst + , narrowingVars + , overloadPair = Pair firstTerm' secondTerm' + } + ) -> do + boundPattern <- do + merged <- termMerger firstTerm' secondTerm' + Exists.makeEvaluate SideCondition.topTODO narrowingVars $ + merged `Pattern.andCondition` narrowingSubst + case OrPattern.toPatterns boundPattern of + [result] -> return result + [] -> + explainAndReturnBottom + ( "exists simplification for overloaded" + <> " constructors returned no pattern" + ) + firstTerm + secondTerm + _ -> scatter boundPattern + ClashResult message -> + explainAndReturnBottom (fromString message) firstTerm secondTerm data DVConstrError = DVConstr diff --git a/kore/src/Kore/Step/Simplification/Overloading.hs b/kore/src/Kore/Step/Simplification/Overloading.hs index d14020291f..2f0c90ed64 100644 --- a/kore/src/Kore/Step/Simplification/Overloading.hs +++ b/kore/src/Kore/Step/Simplification/Overloading.hs @@ -82,10 +82,10 @@ data MatchResult deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) deriving anyclass (Debug, Diff) -flipResult - :: MatchResult - -> MatchResult -flipResult result = +flipResult :: + MatchResult -> + MatchResult +flipResult result = case result of Resolution (Simple (Pair term1 term2)) -> Resolution (Simple (Pair term2 term1)) @@ -155,8 +155,8 @@ unifyOverloading overloadSimplifier termPair = case termPair of Pair (Inj_ inj@Inj{injChild = App_ firstHead firstChildren}) secondTerm@(App_ secondHead _) -> - flipResult <$> - unifyOverloadingVsOverloaded + flipResult + <$> unifyOverloadingVsOverloaded overloadSimplifier secondHead secondTerm @@ -184,7 +184,6 @@ unifyOverloading overloadSimplifier termPair = case termPair of case worker firstTerm secondTerm of Nothing -> worker secondTerm firstTerm Just result -> Just result - where worker :: TermLike RewritingVariableName -> @@ -246,23 +245,22 @@ unifyOverloadingCommonOverload (Application firstHead firstChildren) (Application secondHead secondChildren) injProto@Inj{injTo} - | isOverloaded firstHead - , isOverloaded secondHead - = case unifyOverloadWithinBound injProto firstHead secondHead injTo of - Nothing -> Just $ ClashResult "overloaded constructors not unifiable" - Just InjectedOverload{overload, injectionHead} -> - let first' = resolveOverloading injProto overload firstChildren - second' = resolveOverloading injProto overload secondChildren - mkInj' = maybeMkInj injectionHead - in Just $ Resolution $ Simple $ Pair (mkInj' first') (mkInj' second') - | otherwise = Nothing - - where - OverloadSimplifier - { isOverloaded - , resolveOverloading - , unifyOverloadWithinBound - } = overloadSimplifier + | isOverloaded firstHead + , isOverloaded secondHead = + case unifyOverloadWithinBound injProto firstHead secondHead injTo of + Nothing -> Just $ ClashResult "overloaded constructors not unifiable" + Just InjectedOverload{overload, injectionHead} -> + let first' = resolveOverloading injProto overload firstChildren + second' = resolveOverloading injProto overload secondChildren + mkInj' = maybeMkInj injectionHead + in Just $ Resolution $ Simple $ Pair (mkInj' first') (mkInj' second') + | otherwise = Nothing + where + OverloadSimplifier + { isOverloaded + , resolveOverloading + , unifyOverloadWithinBound + } = overloadSimplifier {- Handles the case overloadingTerm@(overloadingHead(overloadingChildren)) @@ -290,20 +288,20 @@ unifyOverloadingVsOverloaded overloadingTerm (Application overloadedHead overloadedChildren) injProto - | isOverloaded overloadingHead - , isConstructor overloadedHead || isOverloaded overloadedHead - = let ~overloadedTerm' = - resolveOverloading injProto overloadingHead overloadedChildren - in if isOverloading overloadingHead overloadedHead - then Just $ Resolution $ Simple $ Pair overloadingTerm overloadedTerm' - else throwBottom "different injected ctor" - | otherwise = Nothing - where - OverloadSimplifier - { isOverloaded - , isOverloading - , resolveOverloading - } = overloadSimplifier + | isOverloaded overloadingHead + , isConstructor overloadedHead || isOverloaded overloadedHead = + let ~overloadedTerm' = + resolveOverloading injProto overloadingHead overloadedChildren + in if isOverloading overloadingHead overloadedHead + then Just $ Resolution $ Simple $ Pair overloadingTerm overloadedTerm' + else throwBottom "different injected ctor" + | otherwise = Nothing + where + OverloadSimplifier + { isOverloaded + , isOverloading + , resolveOverloading + } = overloadSimplifier {- Handles the case overloadingTerm@(overloadingHead(overloadingChildren)) @@ -337,17 +335,19 @@ unifyOverloadingVsOverloadedVariable Monad.guard (isOverloaded overloadingHead) case getOverloadedWithinSort injProto overloadingHead injFrom of Right Nothing -> Just notUnifiableOverloads - Right (Just overHead) -> Just $ Resolution $ - WithNarrowing - $ computeNarrowing - overloadSimplifier - overloadingTerm - Nothing - overloadingHead - injProto - freeVars - overloadedVar - overHead + Right (Just overHead) -> + Just $ + Resolution $ + WithNarrowing $ + computeNarrowing + overloadSimplifier + overloadingTerm + Nothing + overloadingHead + injProto + freeVars + overloadedVar + overHead Left err -> error err where freeVars = freeVariables overloadingTerm @@ -383,33 +383,34 @@ unifyOverloadingInjVsVariable (Application firstHead firstChildren) overloadedVar freeVars - injProto - | isOverloaded firstHead - = case unifyOverloadWithSortWithinBound firstHead injProto of + injProto + | isOverloaded firstHead = + case unifyOverloadWithSortWithinBound firstHead injProto of Left err -> error err Right Nothing -> Just notUnifiableOverloads Right (Just InjectedOverloadPair{overloadingSymbol, overloadedSymbol}) -> let (InjectedOverload headUnion maybeInjUnion) = overloadingSymbol first' = resolveOverloading injProto headUnion firstChildren - in Just $ Resolution $ WithNarrowing - $ computeNarrowing - overloadSimplifier - first' - maybeInjUnion - headUnion - injProto - freeVars - overloadedVar - overloadedSymbol - | otherwise = Nothing - - where - OverloadSimplifier - { isOverloaded - , resolveOverloading - , unifyOverloadWithSortWithinBound - } = overloadSimplifier + in Just $ + Resolution $ + WithNarrowing $ + computeNarrowing + overloadSimplifier + first' + maybeInjUnion + headUnion + injProto + freeVars + overloadedVar + overloadedSymbol + | otherwise = Nothing + where + OverloadSimplifier + { isOverloaded + , resolveOverloading + , unifyOverloadWithSortWithinBound + } = overloadSimplifier computeNarrowing :: HasCallStack => @@ -440,16 +441,15 @@ computeNarrowing overloadedVar overloaded | App_ _ freshTerms <- overloadedTerm = - let second' = - resolveOverloading injUnion headUnion freshTerms - in - Narrowing - { narrowingSubst = - Condition.assign (inject overloadedVar) narrowingTerm - , narrowingVars = - Attribute.getFreeElementVariables $ freeVariables narrowingTerm - , overloadPair = Pair (mkInj' first') (mkInj' second') - } + let second' = + resolveOverloading injUnion headUnion freshTerms + in Narrowing + { narrowingSubst = + Condition.assign (inject overloadedVar) narrowingTerm + , narrowingVars = + Attribute.getFreeElementVariables $ freeVariables narrowingTerm + , overloadPair = Pair (mkInj' first') (mkInj' second') + } | otherwise = error "This should not happen" where InjectedOverload{overload, injectionHead} = overloaded @@ -491,8 +491,8 @@ maybeMkInj :: TermLike RewritingVariableName maybeMkInj maybeInj injChild = maybe injChild (flip mkInj injChild) maybeInj -notUnifiableError - :: TermLike RewritingVariableName -> Maybe MatchResult +notUnifiableError :: + TermLike RewritingVariableName -> Maybe MatchResult notUnifiableError = \case (DV_ _ _) -> Just $ ClashResult "injected domain value" (InternalBool_ _) -> Just $ ClashResult "injected builtin bool" diff --git a/kore/test/Test/Kore/Step/Simplification/Overloading.hs b/kore/test/Test/Kore/Step/Simplification/Overloading.hs index f04fbd4a41..13f71d75c0 100644 --- a/kore/test/Test/Kore/Step/Simplification/Overloading.hs +++ b/kore/test/Test/Kore/Step/Simplification/Overloading.hs @@ -400,7 +400,8 @@ doesn'tMatch :: TermLike RewritingVariableName -> String -> TestTree -doesn'tMatch comment term1 term2 _ = --reason = +doesn'tMatch comment term1 term2 _ = + --reason = withMatching (assertEqual "" (Left NotApplicable)) --(Left (Clash reason))) TODO:fix comment @@ -458,10 +459,12 @@ narrows comment (term1, term2) ((v, term), (term1', term2')) = where checkNarrowing :: UnificationResult -> Assertion checkNarrowing - ( Just (Resolution - ( WithNarrowing - Narrowing{narrowingSubst, overloadPair} - )) + ( Just + ( Resolution + ( WithNarrowing + Narrowing{narrowingSubst, overloadPair} + ) + ) ) = do assertEqual "" (Pair term1' term2') overloadPair @@ -581,7 +584,6 @@ withUnificationTwice check comment termPair = check actual' _ -> assertFailure "Expected matching solution." - x1 :: TermLike RewritingVariableName x1 = mkElemVar From 5dc55a86802791ccaa01faef8eb2389f6d2fa924 Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 1 Jun 2021 22:20:11 -0500 Subject: [PATCH 65/86] Fixing tests for unifyoverloading --- kore/src/Kore/Step/Simplification/Overloading.hs | 3 +++ kore/test/Test/Kore/Step/Simplification/Overloading.hs | 5 ++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/Overloading.hs b/kore/src/Kore/Step/Simplification/Overloading.hs index 2f0c90ed64..1eb7629936 100644 --- a/kore/src/Kore/Step/Simplification/Overloading.hs +++ b/kore/src/Kore/Step/Simplification/Overloading.hs @@ -17,6 +17,7 @@ module Kore.Step.Simplification.Overloading ( import qualified Control.Monad as Monad import Control.Monad.Trans.Except ( ExceptT, + throwE, ) import Data.Text ( Text, @@ -132,6 +133,7 @@ matchOverloading termPair = do overloadSimplifier <- askOverloadSimplifier case unifyOverloading overloadSimplifier termPair of Just (Resolution (Simple pair)) -> return pair + Just (ClashResult msg) -> throwE $ Clash msg _ -> empty {- | @@ -217,6 +219,7 @@ unifyOverloading overloadSimplifier termPair = case termPair of notUnifiableError child where OverloadSimplifier{isOverloaded} = overloadSimplifier +{-# INLINE unifyOverloading #-} {- Handles the case inj{S1,injTo}(firstHead(firstChildren)) diff --git a/kore/test/Test/Kore/Step/Simplification/Overloading.hs b/kore/test/Test/Kore/Step/Simplification/Overloading.hs index 13f71d75c0..333df6e033 100644 --- a/kore/test/Test/Kore/Step/Simplification/Overloading.hs +++ b/kore/test/Test/Kore/Step/Simplification/Overloading.hs @@ -400,10 +400,9 @@ doesn'tMatch :: TermLike RewritingVariableName -> String -> TestTree -doesn'tMatch comment term1 term2 _ = - --reason = +doesn'tMatch comment term1 term2 reason = withMatching - (assertEqual "" (Left NotApplicable)) --(Left (Clash reason))) TODO:fix + (assertEqual "" (Left (Clash reason))) comment (Pair term1 term2) From 31b7b2ebe80825ddf2042987e6b7e300ff6ce891 Mon Sep 17 00:00:00 2001 From: emarzion Date: Thu, 3 Jun 2021 01:52:15 -0500 Subject: [PATCH 66/86] Documentation --- .../Kore/Builtin/AssociativeCommutative.hs | 158 ------------------ kore/src/Kore/Builtin/Endianness.hs | 3 +- kore/src/Kore/Builtin/KEqual.hs | 5 - kore/src/Kore/Builtin/List.hs | 21 +++ kore/src/Kore/Builtin/Map.hs | 14 +- kore/src/Kore/Builtin/Set.hs | 2 + kore/src/Kore/Builtin/Signedness.hs | 2 + kore/src/Kore/Step/Simplification/AndTerms.hs | 29 ++++ 8 files changed, 67 insertions(+), 167 deletions(-) diff --git a/kore/src/Kore/Builtin/AssociativeCommutative.hs b/kore/src/Kore/Builtin/AssociativeCommutative.hs index d7dfe66a49..d16af5a8a3 100644 --- a/kore/src/Kore/Builtin/AssociativeCommutative.hs +++ b/kore/src/Kore/Builtin/AssociativeCommutative.hs @@ -818,32 +818,6 @@ matchUnifyEqualsNormalizedAc opaqueDifference2 _ -> Nothing where - -- (simpleUnifier, opaques) <- case (opaqueDifference1, opaqueDifference2) of - -- ([], []) -> - -- lift $ - -- unifyEqualsElementLists' - -- allElements1 - -- allElements2 - -- Nothing - -- ([ElemVar_ v1], _) - -- | null opaqueDifference2 -> - -- lift $ - -- unifyEqualsElementLists' - -- allElements1 - -- allElements2 - -- (Just v1) - -- | null allElements1 -> - -- unifyOpaqueVariable' v1 allElements2 opaqueDifference2 - -- (_, [ElemVar_ v2]) - -- | null opaqueDifference1 -> - -- lift $ - -- unifyEqualsElementLists' - -- allElements2 - -- allElements1 - -- (Just v2) - -- | null allElements2 -> - -- unifyOpaqueVariable' v2 allElements1 opaqueDifference1 - -- _ -> empty matchUnifyOpaqueVariable' = matchUnifyOpaqueVariable tools @@ -856,20 +830,6 @@ matchUnifyEqualsNormalizedAc (\key count result -> replicate count key ++ result) [] - -- bottomWithExplanation :: Doc () -> unifier a - -- bottomWithExplanation explanation = - -- Monad.Unify.explainAndReturnBottom explanation first second - - -- unifyEqualsElementLists' = - -- unifyEqualsElementLists - -- tools - -- first - -- second - -- unifyEqualsChildren - - -- unifyOpaqueVariable' = - -- unifyOpaqueVariable tools bottomWithExplanation unifyEqualsChildren - NormalizedAc { elementsWithVariables = preElementsWithVariables1 , concreteElements = concreteElements1 @@ -953,85 +913,6 @@ matchUnifyEqualsNormalizedAc toConcretePat (a, b) = ConcretePat (from @Key @(TermLike RewritingVariableName) a, b) --- unifyElementList :: --- forall key. --- [ ( key --- , ( Value normalized (TermLike RewritingVariableName) --- , Value normalized (TermLike RewritingVariableName) --- ) --- ) --- ] -> --- unifier --- ( [(key, Value normalized (TermLike RewritingVariableName))] --- , Condition RewritingVariableName --- ) --- unifyElementList elements = do --- result <- mapM (unifyCommonElements unifyEqualsChildren) elements --- let terms :: [(key, Value normalized (TermLike RewritingVariableName))] --- predicates :: [Condition RewritingVariableName] --- (terms, predicates) = unzip (map Conditional.splitTerm result) --- predicate :: Condition RewritingVariableName --- predicate = --- List.foldl' --- andCondition --- Condition.top --- predicates - --- return (terms, predicate) - --- simplify :: --- TermLike RewritingVariableName -> --- unifier (Pattern RewritingVariableName) --- simplify term = --- lowerLogicT $ simplifyConditionalTerm SideCondition.topTODO term - --- simplifyPair :: --- ( TermLike RewritingVariableName --- , Value normalized (TermLike RewritingVariableName) --- ) -> --- unifier --- ( Conditional --- RewritingVariableName --- ( TermLike RewritingVariableName --- , Value normalized (TermLike RewritingVariableName) --- ) --- ) --- simplifyPair (key, value) = do --- simplifiedKey <- simplifyTermLike' key --- let (keyTerm, keyCondition) = Conditional.splitTerm simplifiedKey --- simplifiedValue <- traverse simplifyTermLike' value --- let splitSimplifiedValue :: --- Value --- normalized --- ( TermLike RewritingVariableName --- , Condition RewritingVariableName --- ) --- splitSimplifiedValue = --- fmap Conditional.splitTerm simplifiedValue --- simplifiedValueTerm :: --- Value normalized (TermLike RewritingVariableName) --- simplifiedValueTerm = fmap fst splitSimplifiedValue --- simplifiedValueConditions :: --- Value normalized (Condition RewritingVariableName) --- simplifiedValueConditions = fmap snd splitSimplifiedValue --- simplifiedValueCondition :: Condition RewritingVariableName --- simplifiedValueCondition = --- foldr --- andCondition --- Condition.top --- simplifiedValueConditions --- return --- ( (keyTerm, simplifiedValueTerm) --- `withCondition` keyCondition --- `andCondition` simplifiedValueCondition --- ) --- where --- simplifyTermLike' :: --- TermLike RewritingVariableName -> --- unifier (Pattern RewritingVariableName) --- simplifyTermLike' term = --- lowerLogicT $ simplifyConditionalTerm SideCondition.topTODO term - {- | Unifies two AC structs represented as @NormalizedAc@. Currently allows at most one opaque term in the two arguments taken together. @@ -1168,45 +1049,6 @@ unifyEqualsNormalizedAc commonOpaqueMap = HashMap.intersectionWith max opaque1Map opaque2Map commonOpaque = mapToList commonOpaqueMap - -- commonOpaqueKeys = HashMap.keysSet commonOpaqueMap - - -- elementDifference1 = - -- HashMap.toList (HashMap.difference concreteElements1 commonElements) - -- elementDifference2 = - -- HashMap.toList (HashMap.difference concreteElements2 commonElements) - -- elementVariableDifference1 = - -- HashMap.toList (HashMap.difference elementsWithVariables1Map commonVariables) - -- elementVariableDifference2 = - -- HashMap.toList (HashMap.difference elementsWithVariables2Map commonVariables) - -- opaqueDifference1 = - -- mapToList (withoutKeys opaque1Map commonOpaqueKeys) - -- opaqueDifference2 = - -- mapToList (withoutKeys opaque2Map commonOpaqueKeys) - - -- withoutKeys :: - -- Hashable k => - -- Eq k => - -- HashMap k v -> - -- HashSet k -> - -- HashMap k v - -- withoutKeys hmap (HashSet.toList -> hset) = - -- let keys = zip hset (repeat ()) & HashMap.fromList - -- in hmap `HashMap.difference` keys - - -- allElements1 = - -- map WithVariablePat elementVariableDifference1 - -- ++ map toConcretePat elementDifference1 - -- allElements2 = - -- map WithVariablePat elementVariableDifference2 - -- ++ map toConcretePat elementDifference2 - - -- toConcretePat :: - -- (Key, Value normalized (TermLike RewritingVariableName)) -> - -- ConcreteOrWithVariable - -- normalized - -- RewritingVariableName - -- toConcretePat (a, b) = - -- ConcretePat (from @Key @(TermLike RewritingVariableName) a, b) unifyElementList :: forall key. diff --git a/kore/src/Kore/Builtin/Endianness.hs b/kore/src/Kore/Builtin/Endianness.hs index ddef7521b3..431e9fbc6b 100644 --- a/kore/src/Kore/Builtin/Endianness.hs +++ b/kore/src/Kore/Builtin/Endianness.hs @@ -78,7 +78,8 @@ data UnifyEqualsEndianness = UnifyEqualsEndianness { end1, end2 :: Endianness } ---TODO:document +{- | Matches two terms having the Endianness constructor. +-} matchUnifyEqualsEndianness :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index d613d1ebf1..ca201ebcd0 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -228,11 +228,6 @@ data UnifyKequalsEq = UnifyKequalsEq , value :: !Bool } -{- | Matches two terms when second is a bool term - and the first is a function pattern matching - the @KEQUAL.eq@ hooked symbol. --} - {- | Matches @ diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index 22ed31b383..c704963024 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -400,6 +400,27 @@ data UnifyEqualsList | ListList !ListListData | ListApp !ListAppData +{- | Matches two lists of the following patterns: + +@ +\\equals{_, _}(x, f(y)) +@ + +@ +\\equals{_, _}(concat(args1), concat(args2)) +@ + +@ +\\equals{_, _}(list1, list2) +@ + +@ +\\equals{_, _}(list1, concat(args2)) +@ + +or similarly with \\and. + +-} matchUnifyEqualsList :: SmtMetadataTools Attribute.Symbol -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 6217ca1a5a..a9997bf76d 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -528,6 +528,8 @@ data UnifyEqualsMap = ReturnBottom | NormAc !NormAcData +{- | Matches two concrete Map domain values. +-} matchUnifyEquals :: SmtMetadataTools Attribute.Symbol -> TermLike RewritingVariableName -> @@ -568,9 +570,6 @@ matchUnifyEquals tools first second When it is used for simplifying equality, one should separately solve the case ⊥ = ⊥. One should also throw away the term in the returned pattern. -The maps are assumed to have the same sort, but this is not checked. If -multiple sorts are hooked to the same builtin domain, the verifier should -reject the definition. -} unifyEquals :: forall unifier. @@ -634,6 +633,15 @@ data UnifyNotInKeysResult = UnifyNotInKeys1 | UnifyNotInKeys2 !UnifyNotInKeys +{- | Matches + +@ +\\equals{_, _}(\\dv{Bool}(false), inKeys(map, key)) +@ + +when @key@ does not belong to the keys of @map@. + +-} matchUnifyNotInKeys :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/Set.hs b/kore/src/Kore/Builtin/Set.hs index 3247664bfc..e1f9ae3ce7 100644 --- a/kore/src/Kore/Builtin/Set.hs +++ b/kore/src/Kore/Builtin/Set.hs @@ -532,6 +532,8 @@ data UnifyEqualsMap = ReturnBottom | NormAc !NormAcData +{- | Matches two concrete Set domain values. +-} matchUnifyEquals :: SmtMetadataTools Attribute.Symbol -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/Signedness.hs b/kore/src/Kore/Builtin/Signedness.hs index 218535a011..6374916b04 100644 --- a/kore/src/Kore/Builtin/Signedness.hs +++ b/kore/src/Kore/Builtin/Signedness.hs @@ -78,6 +78,8 @@ data UnifyEqualsSignedness = UnifyEqualsSignedness { sign1, sign2 :: Signedness } +{- | Matches two terms having the Signedness constructor. +-} matchUnifyEqualsSignedness :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 500d57f561..8f533504ec 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -770,6 +770,27 @@ data DVConstrError = DVConstr | ConstrDV +{- | Matches + +@ +\\equals{_, _}(\\dv{_}(_), f(_)) +@ + +@ +\\equals{_, _}(f(_), \\dv{_}(_)) +@ + +@ +\\and{_}(\\dv{_}(_), f(_)) +@ + +@ +\\and{_}(f(_), \\dv{_}(_)) +@ + +when @f@ is a constructor. + +-} matchDomainValueAndConstructorErrors :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> @@ -904,6 +925,14 @@ unifyStringLiteral term1 term2 unifyData where UnifyStringLiteral{txt1, txt2} = unifyData + +{-| Matches + +@ +\\and{_}(f(_), g(_)) +@ + +-} matchFunctionAnd :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> From df3e56dfcba7a049f0dc62d4800633e77b19bfb9 Mon Sep 17 00:00:00 2001 From: github-actions Date: Thu, 3 Jun 2021 06:54:34 +0000 Subject: [PATCH 67/86] Format with fourmolu --- kore/src/Kore/Builtin/AssociativeCommutative.hs | 1 - kore/src/Kore/Builtin/Endianness.hs | 3 +-- kore/src/Kore/Builtin/List.hs | 1 - kore/src/Kore/Builtin/Map.hs | 5 +---- kore/src/Kore/Builtin/Set.hs | 3 +-- kore/src/Kore/Builtin/Signedness.hs | 3 +-- kore/src/Kore/Step/Simplification/AndTerms.hs | 5 +---- 7 files changed, 5 insertions(+), 16 deletions(-) diff --git a/kore/src/Kore/Builtin/AssociativeCommutative.hs b/kore/src/Kore/Builtin/AssociativeCommutative.hs index d16af5a8a3..592f77915a 100644 --- a/kore/src/Kore/Builtin/AssociativeCommutative.hs +++ b/kore/src/Kore/Builtin/AssociativeCommutative.hs @@ -818,7 +818,6 @@ matchUnifyEqualsNormalizedAc opaqueDifference2 _ -> Nothing where - matchUnifyOpaqueVariable' = matchUnifyOpaqueVariable tools diff --git a/kore/src/Kore/Builtin/Endianness.hs b/kore/src/Kore/Builtin/Endianness.hs index 431e9fbc6b..396efbf59c 100644 --- a/kore/src/Kore/Builtin/Endianness.hs +++ b/kore/src/Kore/Builtin/Endianness.hs @@ -78,8 +78,7 @@ data UnifyEqualsEndianness = UnifyEqualsEndianness { end1, end2 :: Endianness } -{- | Matches two terms having the Endianness constructor. --} +-- | Matches two terms having the Endianness constructor. matchUnifyEqualsEndianness :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index c704963024..4ebea6659c 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -419,7 +419,6 @@ data UnifyEqualsList @ or similarly with \\and. - -} matchUnifyEqualsList :: SmtMetadataTools Attribute.Symbol -> diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index a9997bf76d..bd8574fd50 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -528,8 +528,7 @@ data UnifyEqualsMap = ReturnBottom | NormAc !NormAcData -{- | Matches two concrete Map domain values. --} +-- | Matches two concrete Map domain values. matchUnifyEquals :: SmtMetadataTools Attribute.Symbol -> TermLike RewritingVariableName -> @@ -569,7 +568,6 @@ matchUnifyEquals tools first second When it is used for simplifying equality, one should separately solve the case ⊥ = ⊥. One should also throw away the term in the returned pattern. - -} unifyEquals :: forall unifier. @@ -640,7 +638,6 @@ data UnifyNotInKeysResult @ when @key@ does not belong to the keys of @map@. - -} matchUnifyNotInKeys :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/Set.hs b/kore/src/Kore/Builtin/Set.hs index e1f9ae3ce7..02f7ee7712 100644 --- a/kore/src/Kore/Builtin/Set.hs +++ b/kore/src/Kore/Builtin/Set.hs @@ -532,8 +532,7 @@ data UnifyEqualsMap = ReturnBottom | NormAc !NormAcData -{- | Matches two concrete Set domain values. --} +-- | Matches two concrete Set domain values. matchUnifyEquals :: SmtMetadataTools Attribute.Symbol -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/Signedness.hs b/kore/src/Kore/Builtin/Signedness.hs index 6374916b04..a9faa32a51 100644 --- a/kore/src/Kore/Builtin/Signedness.hs +++ b/kore/src/Kore/Builtin/Signedness.hs @@ -78,8 +78,7 @@ data UnifyEqualsSignedness = UnifyEqualsSignedness { sign1, sign2 :: Signedness } -{- | Matches two terms having the Signedness constructor. --} +-- | Matches two terms having the Signedness constructor. matchUnifyEqualsSignedness :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 8f533504ec..3fbf06ccdc 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -789,7 +789,6 @@ data DVConstrError @ when @f@ is a constructor. - -} matchDomainValueAndConstructorErrors :: TermLike RewritingVariableName -> @@ -925,13 +924,11 @@ unifyStringLiteral term1 term2 unifyData where UnifyStringLiteral{txt1, txt2} = unifyData - -{-| Matches +{- | Matches @ \\and{_}(f(_), g(_)) @ - -} matchFunctionAnd :: TermLike RewritingVariableName -> From a0905ac7591d24fe036033100de62693fe69eb04 Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 15 Jun 2021 01:44:33 -0500 Subject: [PATCH 68/86] Removing stray comments. --- kore/src/Kore/Builtin/AssociativeCommutative.hs | 11 +---------- kore/src/Kore/Step/Simplification/Overloading.hs | 1 - 2 files changed, 1 insertion(+), 11 deletions(-) diff --git a/kore/src/Kore/Builtin/AssociativeCommutative.hs b/kore/src/Kore/Builtin/AssociativeCommutative.hs index 592f77915a..5c579bd2b6 100644 --- a/kore/src/Kore/Builtin/AssociativeCommutative.hs +++ b/kore/src/Kore/Builtin/AssociativeCommutative.hs @@ -783,9 +783,7 @@ data UnifyEqualsNormAc normalized variable matchUnifyEqualsNormalizedAc :: forall normalized. - ( --Traversable (Value normalized) - TermWrapper normalized - ) => + TermWrapper normalized => SmtMetadataTools Attribute.Symbol -> InternalAc Key normalized (TermLike RewritingVariableName) -> InternalAc Key normalized (TermLike RewritingVariableName) -> @@ -871,7 +869,6 @@ matchUnifyEqualsNormalizedAc -- means that the unification result is bottom. commonOpaqueMap = HashMap.intersectionWith max opaque1Map opaque2Map - -- commonOpaque = mapToList commonOpaqueMap commonOpaqueKeys = HashMap.keysSet commonOpaqueMap elementDifference1 = @@ -1007,9 +1004,6 @@ unifyEqualsNormalizedAc second unifyEqualsChildren - -- unifyOpaqueVariable' = - -- unifyOpaqueVariable tools bottomWithExplanation unifyEqualsChildren - NormalizedAc { elementsWithVariables = preElementsWithVariables1 , concreteElements = concreteElements1 @@ -1455,7 +1449,6 @@ matchUnifyOpaqueVariable :: [TermLike variable] -> Maybe (UnifyOpVarResult variable) matchUnifyOpaqueVariable _ v1 [] [second@(ElemVar_ _)] = - --noCheckUnifyOpaqueChildren unifyChildren v1 second Just $ NoCheckUnifyOpaqueChildren NoCheckUnifyOpaqueChildrenData{v1, second} matchUnifyOpaqueVariable tools @@ -1464,8 +1457,6 @@ matchUnifyOpaqueVariable opaqueTerms = case elementListAsNormalized pairs of Nothing -> Just BottomWithExplanation - -- bottomWithExplanation - -- "Duplicated element in unification results" Just elementTerm -> let secondTerm = asInternal diff --git a/kore/src/Kore/Step/Simplification/Overloading.hs b/kore/src/Kore/Step/Simplification/Overloading.hs index 1eb7629936..4528d1c43d 100644 --- a/kore/src/Kore/Step/Simplification/Overloading.hs +++ b/kore/src/Kore/Step/Simplification/Overloading.hs @@ -214,7 +214,6 @@ unifyOverloading overloadSimplifier termPair = case termPair of worker _ _ = Nothing notUnifiableTest termHead child = do - --OverloadSimplifier{isOverloaded} <- Simplifier.askOverloadSimplifier Monad.guard (isOverloaded termHead) notUnifiableError child where From 520042cb368f4025a02ce16fc4b3f18006c1e9dd Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 15 Jun 2021 02:53:25 -0500 Subject: [PATCH 69/86] Cleaning up constructor names + error message --- kore/src/Kore/Builtin/Map.hs | 12 ++++++------ kore/src/Kore/Step/Simplification/AndTerms.hs | 9 +++++---- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index bd8574fd50..7ba2b0c53e 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -628,8 +628,8 @@ data UnifyNotInKeys = UnifyNotInKeys } data UnifyNotInKeysResult - = UnifyNotInKeys1 - | UnifyNotInKeys2 !UnifyNotInKeys + = NullKeysNullOpaques + | NonNullKeysOrMultipleOpaques !UnifyNotInKeys {- | Matches @@ -652,7 +652,7 @@ matchUnifyNotInKeys first second mapKeys = symbolicKeys <> concreteKeys opaqueElements = opaque . unwrapAc $ normalizedMap unifyData = - UnifyNotInKeys2 + NonNullKeysOrMultipleOpaques UnifyNotInKeys { inKeys , keyTerm @@ -663,7 +663,7 @@ matchUnifyNotInKeys first second } in case (mapKeys, opaqueElements) of -- null mapKeys && null opaqueElements - ([], []) -> Just UnifyNotInKeys1 + ([], []) -> Just NullKeysNullOpaques -- (not (null mapKeys) || (length opaqueElements > 1)) (_ : _, _) -> Just unifyData (_, _ : _ : _) -> Just unifyData @@ -688,8 +688,8 @@ unifyNotInKeys :: unifier (Pattern RewritingVariableName) unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 unifyData = case unifyData of - UnifyNotInKeys1 -> return Pattern.top - UnifyNotInKeys2 unifyData' -> + NullKeysNullOpaques -> return Pattern.top + NonNullKeysOrMultipleOpaques unifyData' -> do -- Concrete keys are constructor-like, therefore they are defined TermLike.assertConstructorLikeKeys concreteKeys $ return () diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 3fbf06ccdc..26dc34d0f3 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -818,11 +818,12 @@ domainValueAndConstructorErrors :: DVConstrError -> unifier a domainValueAndConstructorErrors term1 term2 unifyData = - error - ( unlines + error $ show + ( Pretty.vsep [ cannotHandle - , unparseToString term1 - , unparseToString term2 + , fromString $ unparseToString term1 + , fromString $ unparseToString term2 + , "" ] ) where From 9e59ccf731b7b6de31a716a538bc82c393c8355f Mon Sep 17 00:00:00 2001 From: github-actions Date: Tue, 15 Jun 2021 07:55:44 +0000 Subject: [PATCH 70/86] Format with fourmolu --- kore/src/Kore/Step/Simplification/AndTerms.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 26dc34d0f3..ff4df17110 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -818,14 +818,15 @@ domainValueAndConstructorErrors :: DVConstrError -> unifier a domainValueAndConstructorErrors term1 term2 unifyData = - error $ show - ( Pretty.vsep - [ cannotHandle - , fromString $ unparseToString term1 - , fromString $ unparseToString term2 - , "" - ] - ) + error $ + show + ( Pretty.vsep + [ cannotHandle + , fromString $ unparseToString term1 + , fromString $ unparseToString term2 + , "" + ] + ) where cannotHandle = case unifyData of From fab12ecb536a4c89327e7b00fbf2eb2d1f176f1b Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 15 Jun 2021 09:10:57 -0500 Subject: [PATCH 71/86] Adding missing documentation for matchUnifyStringEq --- kore/src/Kore/Builtin/String.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index 5cd144d116..cdf8253f54 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -523,7 +523,13 @@ data UnifyStringEq = UnifyStringEq , value :: !Bool } ---TODO: document +{- | Matches + +@ +\\equals{_, _}(\\dv{Bool}(_), eqString{_}(_,_)) +@ + +-} matchUnifyStringEq :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> From e75704ed04973e1df42b1924f59dc0706a11d62e Mon Sep 17 00:00:00 2001 From: github-actions Date: Tue, 15 Jun 2021 14:12:57 +0000 Subject: [PATCH 72/86] Format with fourmolu --- kore/src/Kore/Builtin/String.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index cdf8253f54..1723ae086a 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -528,7 +528,6 @@ data UnifyStringEq = UnifyStringEq @ \\equals{_, _}(\\dv{Bool}(_), eqString{_}(_,_)) @ - -} matchUnifyStringEq :: TermLike RewritingVariableName -> From badea9468d2fd55cd489b59169bdf2ee06ec1452 Mon Sep 17 00:00:00 2001 From: emarzion Date: Thu, 17 Jun 2021 09:20:32 -0500 Subject: [PATCH 73/86] Fixing merge --- kore/src/Kore/Step/Simplification/AndTerms.hs | 29 ------------------- 1 file changed, 29 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index fcae0e84c6..ff4df17110 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -72,7 +72,6 @@ import Kore.Step.Simplification.ExpandAlias import Kore.Step.Simplification.InjSimplifier import Kore.Step.Simplification.NoConfusion import Kore.Step.Simplification.NotSimplifier -import Kore.Step.Simplification.OverloadSimplifier as OverloadSimplifier import Kore.Step.Simplification.Overloading as Overloading import qualified Kore.Step.Simplification.SimplificationType as SimplificationType ( SimplificationType (..), @@ -862,34 +861,6 @@ matchDomainValue first second | otherwise = Nothing {-# INLINE matchDomainValue #-} -data UnifyDomainValue = UnifyDomainValue - { val1, val2 :: !(TermLike RewritingVariableName) - } - -{- | Matches - -@ -\\equals{_, _}(\\dv{s}(_), \\dv{s}(_)) -@ - -and - -@ -\\and{_}(\\dv{s}(_), \\dv{s}(_)) -@ --} -matchDomainValue :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - Maybe UnifyDomainValue -matchDomainValue first second - | DV_ sort1 val1 <- first - , DV_ sort2 val2 <- second - , sort1 == sort2 = - Just UnifyDomainValue{val1, val2} - | otherwise = Nothing -{-# INLINE matchDomainValue #-} - {- | Unify two domain values. The two patterns are assumed to be inequal; therefore this case always return From 7f21495cf78968393bed1c5f67678d8a31e70591 Mon Sep 17 00:00:00 2001 From: emarzion Date: Fri, 18 Jun 2021 02:03:11 -0500 Subject: [PATCH 74/86] Adding bangs and explanations. --- kore/src/Kore/Builtin/AssociativeCommutative.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/kore/src/Kore/Builtin/AssociativeCommutative.hs b/kore/src/Kore/Builtin/AssociativeCommutative.hs index 5c579bd2b6..647b21944d 100644 --- a/kore/src/Kore/Builtin/AssociativeCommutative.hs +++ b/kore/src/Kore/Builtin/AssociativeCommutative.hs @@ -773,8 +773,10 @@ unifyEqualsNormalized Normalized n -> return n data UnifyEqualsElementListsData normalized = UnifyEqualsElementListsData - { allElements1, allElements2 :: [ConcreteOrWithVariable normalized RewritingVariableName] - , maybeVar :: Maybe (ElementVariable RewritingVariableName) + { -- Given normalized data norm1, norm2, norm1 - norm2 and norm2 - norm1 + allElements1, allElements2 :: ![ConcreteOrWithVariable normalized RewritingVariableName] + -- Is Just v if v is the sole opaque in norm1 - norm2, else Nothing + , maybeVar :: !(Maybe (ElementVariable RewritingVariableName)) } data UnifyEqualsNormAc normalized variable @@ -1431,8 +1433,10 @@ unifyEqualsElementLists remainderError = nonEmptyRemainderError first second data NoCheckUnifyOpaqueChildrenData variable = NoCheckUnifyOpaqueChildrenData - { v1 :: TermLike.ElementVariable variable - , second :: TermLike variable + { -- Given normalized data norm1, norm2, the sole opaque variable in norm1 - norm2 + v1 :: !(TermLike.ElementVariable variable) + -- The term to unify against v1 + , second :: !(TermLike variable) } data UnifyOpVarResult variable From 3a1c208291bf22cb44a24abfe2b2f192b5c5a2f0 Mon Sep 17 00:00:00 2001 From: github-actions Date: Fri, 18 Jun 2021 07:05:23 +0000 Subject: [PATCH 75/86] Format with fourmolu --- kore/src/Kore/Builtin/AssociativeCommutative.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/kore/src/Kore/Builtin/AssociativeCommutative.hs b/kore/src/Kore/Builtin/AssociativeCommutative.hs index 647b21944d..141f0aca0c 100644 --- a/kore/src/Kore/Builtin/AssociativeCommutative.hs +++ b/kore/src/Kore/Builtin/AssociativeCommutative.hs @@ -775,8 +775,8 @@ unifyEqualsNormalized data UnifyEqualsElementListsData normalized = UnifyEqualsElementListsData { -- Given normalized data norm1, norm2, norm1 - norm2 and norm2 - norm1 allElements1, allElements2 :: ![ConcreteOrWithVariable normalized RewritingVariableName] - -- Is Just v if v is the sole opaque in norm1 - norm2, else Nothing - , maybeVar :: !(Maybe (ElementVariable RewritingVariableName)) + , -- Is Just v if v is the sole opaque in norm1 - norm2, else Nothing + maybeVar :: !(Maybe (ElementVariable RewritingVariableName)) } data UnifyEqualsNormAc normalized variable @@ -1435,8 +1435,8 @@ unifyEqualsElementLists data NoCheckUnifyOpaqueChildrenData variable = NoCheckUnifyOpaqueChildrenData { -- Given normalized data norm1, norm2, the sole opaque variable in norm1 - norm2 v1 :: !(TermLike.ElementVariable variable) - -- The term to unify against v1 - , second :: !(TermLike variable) + , -- The term to unify against v1 + second :: !(TermLike variable) } data UnifyOpVarResult variable From 1b51dcd40304897d01fab45b4ab60ffe3f399354 Mon Sep 17 00:00:00 2001 From: emarzion Date: Mon, 28 Jun 2021 00:21:02 -0500 Subject: [PATCH 76/86] adding missing bang --- kore/src/Kore/Builtin/Endianness.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kore/src/Kore/Builtin/Endianness.hs b/kore/src/Kore/Builtin/Endianness.hs index 396efbf59c..96da6164db 100644 --- a/kore/src/Kore/Builtin/Endianness.hs +++ b/kore/src/Kore/Builtin/Endianness.hs @@ -75,7 +75,7 @@ bigEndianVerifier :: ApplicationVerifier Verified.Pattern bigEndianVerifier = endiannessVerifier BigEndian data UnifyEqualsEndianness = UnifyEqualsEndianness - { end1, end2 :: Endianness + { end1, end2 :: !Endianness } -- | Matches two terms having the Endianness constructor. From 316835255e4623637526f23a9af620030bde9a94 Mon Sep 17 00:00:00 2001 From: emarzion Date: Wed, 30 Jun 2021 01:44:45 -0500 Subject: [PATCH 77/86] symmetrizing match functions --- kore/src/Kore/Builtin/Bool.hs | 57 ++++-- kore/src/Kore/Builtin/Int.hs | 4 + kore/src/Kore/Builtin/KEqual.hs | 40 +++- kore/src/Kore/Builtin/List.hs | 76 +++++--- kore/src/Kore/Builtin/Map.hs | 80 ++++++-- kore/src/Kore/Builtin/Set.hs | 30 +-- kore/src/Kore/Builtin/String.hs | 4 + kore/src/Kore/Step/Simplification/AndTerms.hs | 174 ++++++++---------- kore/test/Test/Kore/Builtin/Bool.hs | 16 +- 9 files changed, 291 insertions(+), 190 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index b7c5ee2592..8c48257364 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -211,6 +211,11 @@ unifyBool termLike1 termLike2 unifyData where UnifyBool{bool1, bool2} = unifyData +data UnifyBoolAnd = UnifyBoolAnd + { isFirstMatched :: !Bool + , boolAnd :: !BoolAnd + } + {- | Matches @ @@ -226,12 +231,16 @@ and matchUnifyBoolAnd :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe BoolAnd + Maybe UnifyBoolAnd matchUnifyBoolAnd first second | Just True <- matchBool first , Just boolAnd <- matchBoolAnd second , isFunctionPattern second = - Just boolAnd + Just $ UnifyBoolAnd{isFirstMatched = True, boolAnd} + | Just True <- matchBool second + , Just boolAnd <- matchBoolAnd first + , isFunctionPattern first = + Just $ UnifyBoolAnd{isFirstMatched = False, boolAnd} | otherwise = Nothing {-# INLINE matchUnifyBoolAnd #-} @@ -241,11 +250,14 @@ unifyBoolAnd :: MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> TermLike RewritingVariableName -> - BoolAnd -> + TermLike RewritingVariableName -> + UnifyBoolAnd -> unifier (Pattern RewritingVariableName) -unifyBoolAnd unifyChildren term boolAnd = +unifyBoolAnd unifyChildren term1 term2 unifyData = unifyBothWith unifyChildren term operand1 operand2 where + UnifyBoolAnd{isFirstMatched, boolAnd} = unifyData + term = if isFirstMatched then term1 else term2 BoolAnd{operand1, operand2} = boolAnd {- |Takes a (function-like) pattern and unifies it against two other patterns. @@ -273,6 +285,11 @@ unifyBothWith unify termLike1 operand1 operand2 = do unify' term1 term2 = Pattern.withoutTerm <$> unify term1 term2 +data UnifyBoolOr = UnifyBoolOr + { isFirstMatched :: !Bool + , boolOr :: !BoolOr + } + {- | Matches @ @@ -288,12 +305,16 @@ and matchUnifyBoolOr :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe BoolOr + Maybe UnifyBoolOr matchUnifyBoolOr first second | Just False <- matchBool first , Just boolOr <- matchBoolOr second , isFunctionPattern second = - Just boolOr + Just UnifyBoolOr{isFirstMatched = True, boolOr} + | Just False <- matchBool second + , Just boolOr <- matchBoolOr first + , isFunctionPattern first = + Just UnifyBoolOr{isFirstMatched = False, boolOr} | otherwise = Nothing {-# INLINE matchUnifyBoolOr #-} @@ -302,16 +323,20 @@ unifyBoolOr :: MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> TermLike RewritingVariableName -> - BoolOr -> + TermLike RewritingVariableName -> + UnifyBoolOr -> unifier (Pattern RewritingVariableName) -unifyBoolOr unifyChildren termLike boolOr = +unifyBoolOr unifyChildren first second unifyData = unifyBothWith unifyChildren termLike operand1 operand2 where + UnifyBoolOr{isFirstMatched, boolOr} = unifyData BoolOr{operand1, operand2} = boolOr + termLike = if isFirstMatched then first else second data UnifyBoolNot = UnifyBoolNot - { boolNot :: BoolNot - , value :: Bool + { boolNot :: !BoolNot + , value :: !Bool + , isFirstMatched :: !Bool } {- | Matches @@ -334,7 +359,11 @@ matchUnifyBoolNot first second | Just boolNot <- matchBoolNot first , isFunctionPattern first , Just value <- matchBool second = - Just $ UnifyBoolNot boolNot value + Just UnifyBoolNot{boolNot, value, isFirstMatched = True} + | Just boolNot <- matchBoolNot second + , isFunctionPattern second + , Just value <- matchBool first = + Just UnifyBoolNot{boolNot, value, isFirstMatched = False} | otherwise = Nothing {-# INLINE matchUnifyBoolNot #-} @@ -342,14 +371,16 @@ unifyBoolNot :: forall unifier. TermSimplifier RewritingVariableName unifier -> TermLike RewritingVariableName -> + TermLike RewritingVariableName -> UnifyBoolNot -> unifier (Pattern RewritingVariableName) -unifyBoolNot unifyChildren term unifyData = +unifyBoolNot unifyChildren term1 term2 unifyData = let notValue = asInternal (termLikeSort term) (not value) in unifyChildren notValue operand where - UnifyBoolNot{boolNot, value} = unifyData + UnifyBoolNot{boolNot, value, isFirstMatched} = unifyData BoolNot{operand} = boolNot + term = if isFirstMatched then term2 else term1 -- | Match a @BOOL.Bool@ builtin value. matchBool :: TermLike variable -> Maybe Bool diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index 1b5b71655c..d50b4d86be 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -492,6 +492,10 @@ matchUnifyIntEq first second , isFunctionPattern first , Just value <- Bool.matchBool second = Just UnifyIntEq{eqTerm, value} + | Just eqTerm <- matchIntEqual second + , isFunctionPattern second + , Just value <- Bool.matchBool first = + Just UnifyIntEq{eqTerm, value} | otherwise = Nothing {-# INLINE matchUnifyIntEq #-} diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index ca201ebcd0..3c4ba314cb 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -249,6 +249,10 @@ matchUnifyKequalsEq first second , isFunctionPattern first , Just value <- Bool.matchBool second = Just UnifyKequalsEq{eqTerm, value} + | Just eqTerm <- matchKequalEq second + , isFunctionPattern second + , Just value <- Bool.matchBool first = + Just UnifyKequalsEq{eqTerm, value} | otherwise = Nothing {-# INLINE matchUnifyKequalsEq #-} @@ -277,25 +281,41 @@ data IfThenElse term = IfThenElse , branch1, branch2 :: !term } +data UnifyIfThenElse = UnifyIfThenElse + { ifThenElse :: IfThenElse (TermLike RewritingVariableName) + -- The term that was not matched by @matchIfThenElse@ + , otherTerm :: TermLike RewritingVariableName + } + -- | Match the @KEQUAL.eq@ hooked symbol. -matchIfThenElse :: TermLike variable -> Maybe (IfThenElse (TermLike variable)) -matchIfThenElse (App_ symbol [condition, branch1, branch2]) = do - hook' <- (getHook . symbolHook) symbol - Monad.guard (hook' == iteKey) - return IfThenElse{symbol, condition, branch1, branch2} -matchIfThenElse _ = Nothing +matchIfThenElse :: + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> + Maybe UnifyIfThenElse +matchIfThenElse first second + | Just ifThenElse <- match first + = Just $ UnifyIfThenElse{ifThenElse, otherTerm = second} + | Just ifThenElse <- match second + = Just $ UnifyIfThenElse{ifThenElse, otherTerm = first} + | otherwise = Nothing + where + match (App_ symbol [condition, branch1, branch2]) = do + hook' <- (getHook . symbolHook) symbol + Monad.guard (hook' == iteKey) + return IfThenElse{symbol, condition, branch1, branch2} + match _ = Nothing {-# INLINE matchIfThenElse #-} unifyIfThenElse :: forall unifier. MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> - IfThenElse (TermLike RewritingVariableName) -> - TermLike RewritingVariableName -> + UnifyIfThenElse -> unifier (Pattern RewritingVariableName) -unifyIfThenElse unifyChildren ifThenElse second = - worker ifThenElse second +unifyIfThenElse unifyChildren unifyData = + worker ifThenElse otherTerm where + UnifyIfThenElse{ifThenElse, otherTerm} = unifyData takeCondition value condition' = makeCeilPredicate (mkAnd (Bool.asInternal sort value) condition') & Condition.fromPredicate diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index 4ebea6659c..534e0d9b92 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -377,21 +377,25 @@ builtinFunctions = data FirstElemVarData = FirstElemVarData { pat1, pat2 :: !(TermLike RewritingVariableName) + , isFirstMatched :: !Bool } data AppAppData = AppAppData { args1, args2 :: ![TermLike RewritingVariableName] , symbol2 :: !Symbol + , isFirstMatched :: !Bool } data ListListData = ListListData { builtin1, builtin2 :: !(InternalList (TermLike RewritingVariableName)) + , isFirstMatched :: !Bool } data ListAppData = ListAppData { pat1, pat2 :: !(TermLike RewritingVariableName) , args2 :: ![TermLike RewritingVariableName] , builtin1 :: !(InternalList (TermLike RewritingVariableName)) + , isFirstMatched :: !Bool } data UnifyEqualsList @@ -427,27 +431,29 @@ matchUnifyEqualsList :: Maybe UnifyEqualsList matchUnifyEqualsList tools first second | Just True <- isListSort tools sort1 = - worker (normalize first) (normalize second) + worker normFirst normSecond True <|> worker normSecond normFirst False | otherwise = Nothing where sort1 = termLikeSort first + normFirst = normalize first + normSecond = normalize second - worker pat1@(ElemVar_ _) pat2 + worker pat1@(ElemVar_ _) pat2 isFirstMatched | TermLike.isFunctionPattern pat2 = - Just $ FirstElemVar FirstElemVarData{pat1, pat2} + Just $ FirstElemVar FirstElemVarData{pat1, pat2, isFirstMatched} | otherwise = Nothing - worker (App_ symbol1 args1) (App_ symbol2 args2) + worker (App_ symbol1 args1) (App_ symbol2 args2) isFirstMatched | isSymbolConcat symbol1 , isSymbolConcat symbol2 = - Just $ AppApp AppAppData{args1, args2, symbol2} - worker pat1@(InternalList_ builtin1) pat2 = + Just $ AppApp AppAppData{args1, args2, symbol2, isFirstMatched} + worker pat1@(InternalList_ builtin1) pat2 isFirstMatched = case pat2 of - InternalList_ builtin2 -> Just $ ListList ListListData{builtin1, builtin2} + InternalList_ builtin2 -> Just $ ListList ListListData{builtin1, builtin2, isFirstMatched} App_ symbol2 args2 - | isSymbolConcat symbol2 -> Just $ ListApp ListAppData{pat1, pat2, args2, builtin1} + | isSymbolConcat symbol2 -> Just $ ListApp ListAppData{pat1, pat2, args2, builtin1, isFirstMatched} | otherwise -> Nothing _ -> Nothing - worker _ _ = Nothing + worker _ _ _ = Nothing {-# INLINE matchUnifyEqualsList #-} {- | Simplify the conjunction or equality of two concrete List domain values. @@ -482,7 +488,7 @@ unifyEquals case unifyData of FirstElemVar FirstElemVarData{pat1, pat2} -> simplifyChild pat1 pat2 - AppApp AppAppData{args1, args2, symbol2} -> + AppApp AppAppData{args1, args2, symbol2, isFirstMatched} -> case (args1, args2) of ( [InternalList_ builtin1, x1@(Var_ _)] , [InternalList_ builtin2, x2@(Var_ _)] @@ -493,6 +499,7 @@ unifyEquals x1 builtin2 x2 + isFirstMatched ( [x1@(Var_ _), InternalList_ builtin1] , [x2@(Var_ _), InternalList_ builtin2] ) -> @@ -502,15 +509,16 @@ unifyEquals builtin1 x2 builtin2 + isFirstMatched _ -> empty - ListList ListListData{builtin1, builtin2} -> - unifyEqualsConcrete builtin1 builtin2 - ListApp ListAppData{pat1, pat2, args2, builtin1} -> + ListList ListListData{builtin1, builtin2, isFirstMatched} -> + unifyEqualsConcrete builtin1 builtin2 isFirstMatched + ListApp ListAppData{pat1, pat2, args2, builtin1, isFirstMatched} -> case args2 of [InternalList_ builtin2, x@(Var_ _)] -> - unifyEqualsFramedRight builtin1 builtin2 x + unifyEqualsFramedRight builtin1 builtin2 x isFirstMatched [x@(Var_ _), InternalList_ builtin2] -> - unifyEqualsFramedLeft builtin1 x builtin2 + unifyEqualsFramedLeft builtin1 x builtin2 isFirstMatched [_, _] -> Builtin.unifyEqualsUnsolved simplificationType @@ -528,9 +536,10 @@ unifyEquals unifyEqualsConcrete :: InternalList (TermLike RewritingVariableName) -> InternalList (TermLike RewritingVariableName) -> + Bool -> unifier (Pattern RewritingVariableName) - unifyEqualsConcrete builtin1 builtin2 - | Seq.length list1 /= Seq.length list2 = bottomWithExplanation + unifyEqualsConcrete builtin1 builtin2 isFirstMatched + | Seq.length list1 /= Seq.length list2 = bottomWithExplanation isFirstMatched | otherwise = do Reflection.give tools $ do unified <- sequence $ Seq.zipWith simplifyChild list1 list2 @@ -549,12 +558,14 @@ unifyEquals InternalList (TermLike RewritingVariableName) -> InternalList (TermLike RewritingVariableName) -> TermLike RewritingVariableName -> + Bool -> unifier (Pattern RewritingVariableName) unifyEqualsFramedRight internal1 internal2 frame2 - | Seq.length prefix2 > Seq.length list1 = bottomWithExplanation + isFirstMatched + | Seq.length prefix2 > Seq.length list1 = bottomWithExplanation isFirstMatched | otherwise = do let listSuffix1 = asInternal tools internalListSort suffix1 @@ -562,6 +573,7 @@ unifyEquals unifyEqualsConcrete internal1{internalListChild = prefix1} internal2 + isFirstMatched suffixUnified <- simplifyChild frame2 listSuffix1 let result = TermLike.markSimplified (mkInternalList internal1) @@ -580,12 +592,14 @@ unifyEquals InternalList (TermLike RewritingVariableName) -> TermLike RewritingVariableName -> InternalList (TermLike RewritingVariableName) -> + Bool -> unifier (Pattern RewritingVariableName) unifyEqualsFramedLeft internal1 frame2 internal2 - | Seq.length suffix2 > Seq.length list1 = bottomWithExplanation + isFirstMatched + | Seq.length suffix2 > Seq.length list1 = bottomWithExplanation isFirstMatched | otherwise = do let listPrefix1 = asInternal tools internalListSort prefix1 @@ -594,6 +608,7 @@ unifyEquals unifyEqualsConcrete internal1{internalListChild = suffix1} internal2 + isFirstMatched let result = mkInternalList internal1 <$ prefixUnified @@ -606,12 +621,15 @@ unifyEquals (prefix1, suffix1) = Seq.splitAt prefixLength list1 where prefixLength = Seq.length list1 - Seq.length suffix2 - bottomWithExplanation = do + bottomWithExplanation isFirstMatched = do Monad.Unify.explainBottom "Cannot unify lists of different length." - first - second + first' + second' return Pattern.bottom + + where + (first',second') = if isFirstMatched then (first,second) else (second,first) unifyEqualsFramedRightRight :: TermLike.Symbol -> @@ -619,6 +637,7 @@ unifyEquals TermLike RewritingVariableName -> InternalList (TermLike RewritingVariableName) -> TermLike RewritingVariableName -> + Bool -> unifier (Pattern RewritingVariableName) unifyEqualsFramedRightRight symbol @@ -626,11 +645,13 @@ unifyEquals frame1 internal2 frame2 + isFirstMatched | length1 < length2 = do prefixUnified <- unifyEqualsConcrete internal1 internal2{internalListChild = prefix2} + isFirstMatched let listSuffix2 = asInternal tools internalListSort suffix2 suffix2Frame2 = mkApplySymbol symbol [listSuffix2, frame2] suffixUnified <- @@ -644,7 +665,7 @@ unifyEquals return result | length1 == length2 = do prefixUnified <- - unifyEqualsConcrete internal1 internal2 + unifyEqualsConcrete internal1 internal2 isFirstMatched suffixUnified <- simplifyChild frame1 frame2 let result = TermLike.markSimplified initial @@ -652,7 +673,7 @@ unifyEquals <* suffixUnified return result | otherwise = - unifyEqualsFramedRightRight symbol internal2 frame2 internal1 frame1 + unifyEqualsFramedRightRight symbol internal2 frame2 internal1 frame1 isFirstMatched where initial = mkApplySymbol symbol [mkInternalList internal1, frame1] InternalList{internalListSort} = internal1 @@ -668,6 +689,7 @@ unifyEquals InternalList (TermLike RewritingVariableName) -> TermLike RewritingVariableName -> InternalList (TermLike RewritingVariableName) -> + Bool -> unifier (Pattern RewritingVariableName) unifyEqualsFramedLeftLeft symbol @@ -675,6 +697,7 @@ unifyEquals internal1 frame2 internal2 + isFirstMatched | length1 < length2 = do let listPrefix2 = asInternal tools internalListSort prefix2 frame2Prefix2 = mkApplySymbol symbol [frame2, listPrefix2] @@ -683,19 +706,20 @@ unifyEquals unifyEqualsConcrete internal1 internal2{internalListChild = suffix2} + isFirstMatched let result = TermLike.markSimplified initial <$ prefixUnified <* suffixUnified return result | length1 == length2 = do prefixUnified <- simplifyChild frame1 frame2 - suffixUnified <- unifyEqualsConcrete internal1 internal2 + suffixUnified <- unifyEqualsConcrete internal1 internal2 isFirstMatched let result = TermLike.markSimplified initial <$ prefixUnified <* suffixUnified return result | otherwise = - unifyEqualsFramedLeftLeft symbol frame2 internal2 frame1 internal1 + unifyEqualsFramedLeftLeft symbol frame2 internal2 frame1 internal1 isFirstMatched where initial = mkApplySymbol symbol [frame1, mkInternalList internal1] InternalList{internalListSort} = internal1 diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 7ba2b0c53e..67efd21b49 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -520,12 +520,13 @@ internalize tools termLike sort' = termLikeSort termLike data NormAcData = NormAcData - { normalized1, normalized2 :: InternalMap Key (TermLike RewritingVariableName) + { normalized1, normalized2 :: !(InternalMap Key (TermLike RewritingVariableName)) + , isFirstMatched :: !Bool , acData :: !(Ac.UnifyEqualsNormAc NormalizedMap RewritingVariableName) } data UnifyEqualsMap - = ReturnBottom + = ReturnBottom !Bool | NormAc !NormAcData -- | Matches two concrete Map domain values. @@ -536,7 +537,7 @@ matchUnifyEquals :: Maybe UnifyEqualsMap matchUnifyEquals tools first second | Just True <- isMapSort tools sort1 = - worker first second + worker first second True <|> worker second first False | otherwise = Nothing where sort1 = termLikeSort first @@ -546,23 +547,23 @@ matchUnifyEquals tools first second Ac.NormalizedOrBottom NormalizedMap RewritingVariableName normalizedOrBottom = Ac.toNormalized - worker a b + worker a b isFirstMatched | InternalMap_ normalized1 <- a , InternalMap_ normalized2 <- b = - NormAc . NormAcData normalized1 normalized2 + NormAc . NormAcData normalized1 normalized2 isFirstMatched <$> Ac.matchUnifyEqualsNormalizedAc tools normalized1 normalized2 | otherwise = case normalizedOrBottom a of - Ac.Bottom -> Just ReturnBottom + Ac.Bottom -> Just $ ReturnBottom isFirstMatched Ac.Normalized normalized1 -> let a' = Ac.asInternal tools sort1 normalized1 in case normalizedOrBottom b of - Ac.Bottom -> Just ReturnBottom + Ac.Bottom -> Just $ ReturnBottom isFirstMatched Ac.Normalized normalized2 -> let b' = Ac.asInternal tools sort1 normalized2 - in worker a' b' + in worker a' b' isFirstMatched {- | Simplify the conjunction or equality of two concrete Map domain values. @@ -580,22 +581,25 @@ unifyEquals :: unifier (Pattern RewritingVariableName) unifyEquals unifyEqualsChildren tools first second unifyData = case unifyData of - ReturnBottom -> + ReturnBottom isFirstMatched -> Monad.Unify.explainAndReturnBottom "Duplicated elements in normalization." - first - second + first' + second' + where + (first',second') = if isFirstMatched then (first,second) else (second,first) NormAc unifyData' -> Ac.unifyEqualsNormalized tools - first - second + first' + second' unifyEqualsChildren normalized1 normalized2 acData where - NormAcData{normalized1, normalized2, acData} = unifyData' + NormAcData{normalized1, normalized2, isFirstMatched, acData} = unifyData' + (first',second') = if isFirstMatched then (first,second) else (second,first) data InKeys term = InKeys { symbol :: !Symbol @@ -625,6 +629,7 @@ data UnifyNotInKeys = UnifyNotInKeys { inKeys :: !(InKeys (TermLike RewritingVariableName)) , keyTerm, mapTerm :: !(TermLike RewritingVariableName) , concreteKeys, mapKeys, opaqueElements :: ![TermLike RewritingVariableName] + , isFirstMatched :: !Bool } data UnifyNotInKeysResult @@ -660,6 +665,33 @@ matchUnifyNotInKeys first second , concreteKeys , mapKeys , opaqueElements + , isFirstMatched = True + } + in case (mapKeys, opaqueElements) of + -- null mapKeys && null opaqueElements + ([], []) -> Just NullKeysNullOpaques + -- (not (null mapKeys) || (length opaqueElements > 1)) + (_ : _, _) -> Just unifyData + (_, _ : _ : _) -> Just unifyData + -- otherwise + _ -> Nothing + | Just False <- Bool.matchBool second + , Just inKeys@InKeys{keyTerm, mapTerm} <- matchInKeys first + , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm = + let symbolicKeys = getSymbolicKeysOfAc normalizedMap + concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap + mapKeys = symbolicKeys <> concreteKeys + opaqueElements = opaque . unwrapAc $ normalizedMap + unifyData = + NonNullKeysOrMultipleOpaques + UnifyNotInKeys + { inKeys + , keyTerm + , mapTerm + , concreteKeys + , mapKeys + , opaqueElements + , isFirstMatched = False } in case (mapKeys, opaqueElements) of -- null mapKeys && null opaqueElements @@ -684,9 +716,10 @@ unifyNotInKeys :: TermSimplifier RewritingVariableName unifier -> NotSimplifier unifier -> TermLike RewritingVariableName -> + TermLike RewritingVariableName -> UnifyNotInKeysResult -> unifier (Pattern RewritingVariableName) -unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 unifyData = +unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 termLike2 unifyData = case unifyData of NullKeysNullOpaques -> return Pattern.top NonNullKeysOrMultipleOpaques unifyData' -> @@ -702,19 +735,28 @@ unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 unifyData = <$> opaqueElements opaqueConditions <- - traverse (unifyChildren termLike1) keyInKeysOpaque + traverse (unifyChildren termLike) keyInKeysOpaque let conditions = fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) <> [definedKey, definedMap] return $ collectConditions conditions where - UnifyNotInKeys{inKeys, keyTerm, mapTerm, concreteKeys, mapKeys, opaqueElements} = unifyData' + UnifyNotInKeys + { inKeys + , keyTerm + , mapTerm + , concreteKeys + , mapKeys + , opaqueElements + , isFirstMatched + } = unifyData' + termLike = if isFirstMatched then termLike1 else termLike2 where defineTerm :: TermLike RewritingVariableName -> unifier (Condition RewritingVariableName) - defineTerm termLike = - makeEvaluateTermCeil SideCondition.topTODO termLike + defineTerm term = + makeEvaluateTermCeil SideCondition.topTODO term >>= Unify.scatter eraseTerm = diff --git a/kore/src/Kore/Builtin/Set.hs b/kore/src/Kore/Builtin/Set.hs index 02f7ee7712..0db27c3913 100644 --- a/kore/src/Kore/Builtin/Set.hs +++ b/kore/src/Kore/Builtin/Set.hs @@ -525,11 +525,12 @@ internalize tools termLike data NormAcData = NormAcData { normalized1, normalized2 :: InternalSet Key (TermLike RewritingVariableName) + , isFirstMatched :: !Bool , acData :: !(Ac.UnifyEqualsNormAc NormalizedSet RewritingVariableName) } data UnifyEqualsMap - = ReturnBottom + = ReturnBottom !Bool | NormAc !NormAcData -- | Matches two concrete Set domain values. @@ -540,7 +541,7 @@ matchUnifyEquals :: Maybe UnifyEqualsMap matchUnifyEquals tools first second | Just True <- isSetSort tools sort1 = - worker first second + worker first second True <|> worker second first False | otherwise = Nothing where sort1 = termLikeSort first @@ -550,23 +551,23 @@ matchUnifyEquals tools first second Ac.NormalizedOrBottom NormalizedSet RewritingVariableName normalizedOrBottom = Ac.toNormalized - worker a b + worker a b isFirstMatched | InternalSet_ normalized1 <- a , InternalSet_ normalized2 <- b = - NormAc . NormAcData normalized1 normalized2 + NormAc . NormAcData normalized1 normalized2 isFirstMatched <$> Ac.matchUnifyEqualsNormalizedAc tools normalized1 normalized2 | otherwise = case normalizedOrBottom a of - Ac.Bottom -> Just ReturnBottom + Ac.Bottom -> Just $ ReturnBottom isFirstMatched Ac.Normalized normalized1 -> let a' = Ac.asInternal tools sort1 normalized1 in case normalizedOrBottom b of - Ac.Bottom -> Just ReturnBottom + Ac.Bottom -> Just $ ReturnBottom isFirstMatched Ac.Normalized normalized2 -> let b' = Ac.asInternal tools sort1 normalized2 - in worker a' b' + in worker a' b' isFirstMatched {- | Simplify the conjunction or equality of two concrete Map domain values. @@ -588,19 +589,22 @@ unifyEquals :: unifier (Pattern RewritingVariableName) unifyEquals unifyEqualsChildren tools first second unifyData = case unifyData of - ReturnBottom -> + ReturnBottom isFirstMatched -> Monad.Unify.explainAndReturnBottom "Duplicated elements in normalization." - first - second + first' + second' + where + (first',second') = if isFirstMatched then (first,second) else (second,first) NormAc unifyData' -> Ac.unifyEqualsNormalized tools - first - second + first' + second' unifyEqualsChildren normalized1 normalized2 acData where - NormAcData{normalized1, normalized2, acData} = unifyData' + NormAcData{normalized1, normalized2, isFirstMatched, acData} = unifyData' + (first',second') = if isFirstMatched then (first,second) else (second,first) diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index 1723ae086a..ca006fb907 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -538,6 +538,10 @@ matchUnifyStringEq first second , isFunctionPattern first , Just value <- Bool.matchBool first = Just UnifyStringEq{eqTerm, value} + | Just eqTerm <- matchStringEqual first + , isFunctionPattern second + , Just value <- Bool.matchBool second = + Just UnifyStringEq{eqTerm, value} | otherwise = Nothing {- | Unification of the @STRING.eq@ symbol diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index ff4df17110..b0b6327b20 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -158,14 +158,10 @@ maybeTermEquals notSimplifier childTransformers first second = do lift $ equalAndEquals first | Just unifyData <- matchBytes first second = lift $ unifyBytes unifyData - | Just () <- matchBottomTermEquals first = - lift $ bottomTermEquals SideCondition.topTODO first second - | Just () <- matchBottomTermEquals second = - lift $ bottomTermEquals SideCondition.topTODO second first - | Just var <- matchVariableFunctionEquals first second = - lift $ variableFunctionEquals first second var - | Just var <- matchVariableFunctionEquals second first = - lift $ variableFunctionEquals second first var + | Just isFirstMatched <- matchBottomTermEquals first second = + lift $ bottomTermEquals SideCondition.topTODO isFirstMatched first second + | Just unifyData <- matchVariableFunctionEquals first second = + lift $ variableFunctionEquals first second unifyData | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData | Just unifyData <- matchInj injSimplifier first second = @@ -176,46 +172,28 @@ maybeTermEquals notSimplifier childTransformers first second = do lift $ constructorAndEqualsAssumesDifferentHeads first second | Just unifyData <- unifyOverloading overloadSimplifier (Pair first second) = lift $ overloadedConstructorSortInjectionAndEquals childTransformers first second unifyData - | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd first second = - lift $ Builtin.Bool.unifyBoolAnd childTransformers first boolAndData - | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd second first = - lift $ Builtin.Bool.unifyBoolAnd childTransformers second boolAndData - | Just boolOrData <- Builtin.Bool.matchUnifyBoolOr first second = - lift $ Builtin.Bool.unifyBoolOr childTransformers second boolOrData - | Just boolOrData <- Builtin.Bool.matchUnifyBoolOr second first = - lift $ Builtin.Bool.unifyBoolOr childTransformers first boolOrData + | Just unifyData <- Builtin.Bool.matchUnifyBoolAnd first second = + lift $ Builtin.Bool.unifyBoolAnd childTransformers first second unifyData + | Just unifyData <- Builtin.Bool.matchUnifyBoolOr first second = + lift $ Builtin.Bool.unifyBoolOr childTransformers first second unifyData | Just boolNotData <- Builtin.Bool.matchUnifyBoolNot first second = - lift $ Builtin.Bool.unifyBoolNot childTransformers second boolNotData - | Just boolNotData <- Builtin.Bool.matchUnifyBoolNot second first = - lift $ Builtin.Bool.unifyBoolNot childTransformers first boolNotData + lift $ Builtin.Bool.unifyBoolNot childTransformers first second boolNotData | Just unifyData <- Builtin.Int.matchUnifyIntEq first second = lift $ Builtin.Int.unifyIntEq childTransformers notSimplifier unifyData - | Just unifyData <- Builtin.Int.matchUnifyIntEq second first = - lift $ Builtin.Int.unifyIntEq childTransformers notSimplifier unifyData | Just unifyData <- Builtin.String.matchUnifyStringEq first second = lift $ Builtin.String.unifyStringEq childTransformers notSimplifier unifyData - | Just unifyData <- Builtin.String.matchUnifyStringEq second first = - lift $ Builtin.String.unifyStringEq childTransformers notSimplifier unifyData | Just unifyData <- Builtin.KEqual.matchUnifyKequalsEq first second = lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData - | Just unifyData <- Builtin.KEqual.matchUnifyKequalsEq second first = - lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData | Just unifyData <- Builtin.Endianness.matchUnifyEqualsEndianness first second = lift $ Builtin.Endianness.unifyEquals first second unifyData | Just unifyData <- Builtin.Signedness.matchUnifyEqualsSignedness first second = lift $ Builtin.Signedness.unifyEquals first second unifyData | Just unifyData <- Builtin.Map.matchUnifyEquals tools first second = lift $ Builtin.Map.unifyEquals childTransformers tools first second unifyData - | Just unifyData <- Builtin.Map.matchUnifyEquals tools second first = - lift $ Builtin.Map.unifyEquals childTransformers tools second first unifyData | Just unifyData <- Builtin.Map.matchUnifyNotInKeys first second = - lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier first unifyData - | Just unifyData <- Builtin.Map.matchUnifyNotInKeys second first = - lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier second unifyData + lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second unifyData | Just unifyData <- Builtin.Set.matchUnifyEquals tools first second = lift $ Builtin.Set.unifyEquals childTransformers tools first second unifyData - | Just unifyData <- Builtin.Set.matchUnifyEquals tools second first = - lift $ Builtin.Set.unifyEquals childTransformers tools second first unifyData | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = lift $ Builtin.List.unifyEquals @@ -225,15 +203,6 @@ maybeTermEquals notSimplifier childTransformers first second = do first second unifyData - | Just unifyData <- Builtin.List.matchUnifyEqualsList tools second first = - lift $ - Builtin.List.unifyEquals - SimplificationType.Equals - childTransformers - tools - second - first - unifyData | Just unifyData <- matchDomainValueAndConstructorErrors first second = lift $ domainValueAndConstructorErrors first second unifyData | otherwise = empty @@ -261,10 +230,8 @@ maybeTermAnd notSimplifier childTransformers first second = do childTransformers term1 term2 - | Just unifyData <- matchBoolAnd first = + | Just unifyData <- matchBoolAnd first second = lift $ boolAnd first second unifyData - | Just unifyData <- matchBoolAnd second = - lift $ boolAnd second first unifyData | Just unifyData <- Builtin.Int.matchInt first second = lift $ Builtin.Int.unifyInt first second unifyData | Just unifyData <- Builtin.Bool.matchBools first second = @@ -293,38 +260,24 @@ maybeTermAnd notSimplifier childTransformers first second = do lift $ constructorAndEqualsAssumesDifferentHeads first second | Just unifyData <- unifyOverloading overloadSimplifier (Pair first second) = lift $ overloadedConstructorSortInjectionAndEquals childTransformers first second unifyData - | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd first second = - lift $ Builtin.Bool.unifyBoolAnd childTransformers first boolAndData - | Just boolAndData <- Builtin.Bool.matchUnifyBoolAnd second first = - lift $ Builtin.Bool.unifyBoolAnd childTransformers second boolAndData - | Just boolOrData <- Builtin.Bool.matchUnifyBoolOr first second = - lift $ Builtin.Bool.unifyBoolOr childTransformers second boolOrData - | Just boolOrData <- Builtin.Bool.matchUnifyBoolOr second first = - lift $ Builtin.Bool.unifyBoolOr childTransformers first boolOrData + | Just unifyData <- Builtin.Bool.matchUnifyBoolAnd first second = + lift $ Builtin.Bool.unifyBoolAnd childTransformers first second unifyData + | Just unifyData <- Builtin.Bool.matchUnifyBoolOr first second = + lift $ Builtin.Bool.unifyBoolOr childTransformers first second unifyData | Just boolNotData <- Builtin.Bool.matchUnifyBoolNot first second = - lift $ Builtin.Bool.unifyBoolNot childTransformers second boolNotData - | Just boolNotData <- Builtin.Bool.matchUnifyBoolNot second first = - lift $ Builtin.Bool.unifyBoolNot childTransformers first boolNotData + lift $ Builtin.Bool.unifyBoolNot childTransformers first second boolNotData | Just unifyData <- Builtin.KEqual.matchUnifyKequalsEq first second = lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData - | Just unifyData <- Builtin.KEqual.matchUnifyKequalsEq second first = - lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData - | Just ifThenElse <- Builtin.KEqual.matchIfThenElse first = - lift $ Builtin.KEqual.unifyIfThenElse childTransformers ifThenElse second - | Just ifThenElse <- Builtin.KEqual.matchIfThenElse second = - lift $ Builtin.KEqual.unifyIfThenElse childTransformers ifThenElse first + | Just unifyData <- Builtin.KEqual.matchIfThenElse first second = + lift $ Builtin.KEqual.unifyIfThenElse childTransformers unifyData | Just unifyData <- Builtin.Endianness.matchUnifyEqualsEndianness first second = lift $ Builtin.Endianness.unifyEquals first second unifyData | Just unifyData <- Builtin.Signedness.matchUnifyEqualsSignedness first second = lift $ Builtin.Signedness.unifyEquals first second unifyData | Just unifyData <- Builtin.Map.matchUnifyEquals tools first second = lift $ Builtin.Map.unifyEquals childTransformers tools first second unifyData - | Just unifyData <- Builtin.Map.matchUnifyEquals tools second first = - lift $ Builtin.Map.unifyEquals childTransformers tools second first unifyData | Just unifyData <- Builtin.Set.matchUnifyEquals tools first second = lift $ Builtin.Set.unifyEquals childTransformers tools first second unifyData - | Just unifyData <- Builtin.Set.matchUnifyEquals tools second first = - lift $ Builtin.Set.unifyEquals childTransformers tools second first unifyData | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = lift $ Builtin.List.unifyEquals @@ -334,15 +287,6 @@ maybeTermAnd notSimplifier childTransformers first second = do first second unifyData - | Just unifyData <- Builtin.List.matchUnifyEqualsList tools second first = - lift $ - Builtin.List.unifyEquals - SimplificationType.And - childTransformers - tools - second - first - unifyData | Just unifyData <- matchDomainValueAndConstructorErrors first second = lift $ domainValueAndConstructorErrors first second unifyData | Just () <- matchFunctionAnd first second = @@ -368,8 +312,8 @@ type TermTransformationOld variable unifier = MaybeT unifier (Pattern variable) data UnifyBoolAnd - = UnifyBoolAndBottom - | UnifyBoolAndTop + = UnifyBoolAndBottom !Bool + | UnifyBoolAndTop !Bool {- | Matches @@ -384,13 +328,18 @@ and @ -} matchBoolAnd :: + TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe UnifyBoolAnd -matchBoolAnd term - | Pattern.isBottom term = - Just UnifyBoolAndBottom - | Pattern.isTop term = - Just UnifyBoolAndTop +matchBoolAnd term1 term2 + | Pattern.isBottom term1 = + Just $ UnifyBoolAndBottom True + | Pattern.isTop term1 = + Just $ UnifyBoolAndTop True + | Pattern.isBottom term2 = + Just $ UnifyBoolAndBottom False + | Pattern.isTop term2 = + Just $ UnifyBoolAndTop False | otherwise = Nothing {-# INLINE matchBoolAnd #-} @@ -404,11 +353,13 @@ boolAnd :: unifier (Pattern RewritingVariableName) boolAnd first second unifyData = case unifyData of - UnifyBoolAndBottom -> do - explainBoolAndBottom first second - return $ Pattern.fromTermLike first - UnifyBoolAndTop -> - return $ Pattern.fromTermLike second + UnifyBoolAndBottom isFirstMatched -> do + let (first',second') = if isFirstMatched then (first,second) else (second,first) + explainBoolAndBottom first' second' + return $ Pattern.fromTermLike first' + UnifyBoolAndTop isFirstMatched -> do + let second' = if isFirstMatched then second else first + return $ Pattern.fromTermLike second' explainBoolAndBottom :: MonadUnify unifier => @@ -457,10 +408,13 @@ equalAndEquals first = -} matchBottomTermEquals :: TermLike RewritingVariableName -> - Maybe () -matchBottomTermEquals first + TermLike RewritingVariableName -> + Maybe Bool +matchBottomTermEquals first second | Bottom_ _ <- first = - Just () + Just True + | Bottom_ _ <- second = + Just False | otherwise = Nothing {-# INLINE matchBottomTermEquals #-} @@ -468,24 +422,29 @@ matchBottomTermEquals first bottomTermEquals :: MonadUnify unifier => SideCondition RewritingVariableName -> + Bool -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) bottomTermEquals sideCondition + isFirstMatched first second = do -- MonadUnify - secondCeil <- makeEvaluateTermCeil sideCondition second + let (first',second') = if isFirstMatched + then (first,second) + else (second,first) + secondCeil <- makeEvaluateTermCeil sideCondition second' case toList secondCeil of [] -> return Pattern.top [Conditional{predicate = PredicateTrue, substitution}] | substitution == mempty -> do explainBottom "Cannot unify bottom with non-bottom pattern." - first - second + first' + second' empty _ -> return @@ -547,6 +506,11 @@ unifyVariableFunction UnifyVariableFunction{variable, term} = & Pattern.withCondition term & pure +data VariableFunctionEquals = VariableFunctionEquals + { isFirstMatched :: !Bool + , var :: !(ElementVariable RewritingVariableName) + } + {- | Matches @ @@ -556,11 +520,14 @@ unifyVariableFunction UnifyVariableFunction{variable, term} = matchVariableFunctionEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe (ElementVariable RewritingVariableName) + Maybe VariableFunctionEquals matchVariableFunctionEquals first second | ElemVar_ var <- first , isFunctionPattern second = - Just var + Just VariableFunctionEquals{isFirstMatched = True, var} + | ElemVar_ var <- second + , isFunctionPattern first = + Just VariableFunctionEquals{isFirstMatched = False, var} | otherwise = Nothing {-# INLINE matchVariableFunctionEquals #-} @@ -572,30 +539,35 @@ variableFunctionEquals :: MonadUnify unifier => TermLike RewritingVariableName -> TermLike RewritingVariableName -> - ElementVariable RewritingVariableName -> + VariableFunctionEquals -> unifier (Pattern RewritingVariableName) variableFunctionEquals first second - var = + unifyData = do -- MonadUnify predicate <- do - resultOr <- makeEvaluateTermCeil SideCondition.topTODO second + resultOr <- makeEvaluateTermCeil SideCondition.topTODO second' case toList resultOr of [] -> do explainBottom "Unification of variable and bottom \ \when attempting to simplify equals." - first - second + first' + second' empty resultConditions -> Unify.scatter resultConditions let result = predicate <> Condition.fromSingleSubstitution - (Substitution.assign (inject var) second) - return (Pattern.withCondition second result) + (Substitution.assign (inject var) second') + return (Pattern.withCondition second' result) + where + VariableFunctionEquals{isFirstMatched, var} = unifyData + (first',second') = if isFirstMatched + then (first,second) + else (second,first) {- | Matches diff --git a/kore/test/Test/Kore/Builtin/Bool.hs b/kore/test/Test/Kore/Builtin/Bool.hs index d4fb30c8e8..be13fda5eb 100644 --- a/kore/test/Test/Kore/Builtin/Bool.hs +++ b/kore/test/Test/Kore/Builtin/Bool.hs @@ -194,13 +194,13 @@ test_unifyBoolAnd = test testName term1 term2 expected = testCase testName $ do case Bool.matchUnifyBoolAnd term1 term2 of - Just boolAnd -> do - actual <- unify term1 boolAnd + Just unifyData -> do + actual <- unify term1 term2 unifyData assertEqual "" expected actual Nothing -> assertEqual "" expected [Nothing] - unify term boolAnd = - Bool.unifyBoolAnd termSimplifier term boolAnd + unify term1 term2 unifyData = + Bool.unifyBoolAnd termSimplifier term1 term2 unifyData & lift & run @@ -229,13 +229,13 @@ test_unifyBoolOr = test testName term1 term2 expected = testCase testName $ do case Bool.matchUnifyBoolOr term1 term2 of - Just boolOr -> do - actual <- unify term1 boolOr + Just unifyData -> do + actual <- unify term1 term2 unifyData assertEqual "" expected actual Nothing -> assertEqual "" expected [Nothing] - unify term boolOr = - Bool.unifyBoolOr termSimplifier term boolOr + unify term1 term2 unifyData = + Bool.unifyBoolOr termSimplifier term1 term2 unifyData & lift & run From 0503e7e35f64a80b3132e5641ea2dd4f024c57ff Mon Sep 17 00:00:00 2001 From: github-actions Date: Wed, 30 Jun 2021 06:48:00 +0000 Subject: [PATCH 78/86] Format with fourmolu --- kore/src/Kore/Builtin/KEqual.hs | 12 +++++------ kore/src/Kore/Builtin/List.hs | 3 +-- kore/src/Kore/Builtin/Map.hs | 4 ++-- kore/src/Kore/Builtin/Set.hs | 4 ++-- kore/src/Kore/Step/Simplification/AndTerms.hs | 20 ++++++++++--------- 5 files changed, 22 insertions(+), 21 deletions(-) diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index 3c4ba314cb..84e60305cf 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -283,8 +283,8 @@ data IfThenElse term = IfThenElse data UnifyIfThenElse = UnifyIfThenElse { ifThenElse :: IfThenElse (TermLike RewritingVariableName) - -- The term that was not matched by @matchIfThenElse@ - , otherTerm :: TermLike RewritingVariableName + , -- The term that was not matched by @matchIfThenElse@ + otherTerm :: TermLike RewritingVariableName } -- | Match the @KEQUAL.eq@ hooked symbol. @@ -293,10 +293,10 @@ matchIfThenElse :: TermLike RewritingVariableName -> Maybe UnifyIfThenElse matchIfThenElse first second - | Just ifThenElse <- match first - = Just $ UnifyIfThenElse{ifThenElse, otherTerm = second} - | Just ifThenElse <- match second - = Just $ UnifyIfThenElse{ifThenElse, otherTerm = first} + | Just ifThenElse <- match first = + Just $ UnifyIfThenElse{ifThenElse, otherTerm = second} + | Just ifThenElse <- match second = + Just $ UnifyIfThenElse{ifThenElse, otherTerm = first} | otherwise = Nothing where match (App_ symbol [condition, branch1, branch2]) = do diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index 534e0d9b92..8f5500b2be 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -627,9 +627,8 @@ unifyEquals first' second' return Pattern.bottom - where - (first',second') = if isFirstMatched then (first,second) else (second,first) + (first', second') = if isFirstMatched then (first, second) else (second, first) unifyEqualsFramedRightRight :: TermLike.Symbol -> diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 67efd21b49..e79ae7c8b7 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -587,7 +587,7 @@ unifyEquals unifyEqualsChildren tools first second unifyData = first' second' where - (first',second') = if isFirstMatched then (first,second) else (second,first) + (first', second') = if isFirstMatched then (first, second) else (second, first) NormAc unifyData' -> Ac.unifyEqualsNormalized tools @@ -599,7 +599,7 @@ unifyEquals unifyEqualsChildren tools first second unifyData = acData where NormAcData{normalized1, normalized2, isFirstMatched, acData} = unifyData' - (first',second') = if isFirstMatched then (first,second) else (second,first) + (first', second') = if isFirstMatched then (first, second) else (second, first) data InKeys term = InKeys { symbol :: !Symbol diff --git a/kore/src/Kore/Builtin/Set.hs b/kore/src/Kore/Builtin/Set.hs index 0db27c3913..aa6774643c 100644 --- a/kore/src/Kore/Builtin/Set.hs +++ b/kore/src/Kore/Builtin/Set.hs @@ -595,7 +595,7 @@ unifyEquals unifyEqualsChildren tools first second unifyData = first' second' where - (first',second') = if isFirstMatched then (first,second) else (second,first) + (first', second') = if isFirstMatched then (first, second) else (second, first) NormAc unifyData' -> Ac.unifyEqualsNormalized tools @@ -607,4 +607,4 @@ unifyEquals unifyEqualsChildren tools first second unifyData = acData where NormAcData{normalized1, normalized2, isFirstMatched, acData} = unifyData' - (first',second') = if isFirstMatched then (first,second) else (second,first) + (first', second') = if isFirstMatched then (first, second) else (second, first) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index b0b6327b20..37536eec28 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -354,7 +354,7 @@ boolAnd :: boolAnd first second unifyData = case unifyData of UnifyBoolAndBottom isFirstMatched -> do - let (first',second') = if isFirstMatched then (first,second) else (second,first) + let (first', second') = if isFirstMatched then (first, second) else (second, first) explainBoolAndBottom first' second' return $ Pattern.fromTermLike first' UnifyBoolAndTop isFirstMatched -> do @@ -433,9 +433,10 @@ bottomTermEquals second = do -- MonadUnify - let (first',second') = if isFirstMatched - then (first,second) - else (second,first) + let (first', second') = + if isFirstMatched + then (first, second) + else (second, first) secondCeil <- makeEvaluateTermCeil sideCondition second' case toList secondCeil of [] -> return Pattern.top @@ -563,11 +564,12 @@ variableFunctionEquals <> Condition.fromSingleSubstitution (Substitution.assign (inject var) second') return (Pattern.withCondition second' result) - where - VariableFunctionEquals{isFirstMatched, var} = unifyData - (first',second') = if isFirstMatched - then (first,second) - else (second,first) + where + VariableFunctionEquals{isFirstMatched, var} = unifyData + (first', second') = + if isFirstMatched + then (first, second) + else (second, first) {- | Matches From 15d2caee477cc670abdefed41d8a9c27779882bc Mon Sep 17 00:00:00 2001 From: emarzion Date: Thu, 1 Jul 2021 02:22:06 -0500 Subject: [PATCH 79/86] Adding symmetry to documentation --- kore/src/Kore/Builtin/Bool.hs | 12 +++++++++--- kore/src/Kore/Builtin/Int.hs | 4 +++- kore/src/Kore/Builtin/KEqual.hs | 4 +++- kore/src/Kore/Builtin/List.hs | 2 +- kore/src/Kore/Builtin/Map.hs | 2 +- kore/src/Kore/Builtin/String.hs | 4 +++- kore/src/Kore/Step/Simplification/AndTerms.hs | 12 +++++++++--- 7 files changed, 29 insertions(+), 11 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index 8c48257364..c35ba61b54 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -225,8 +225,10 @@ data UnifyBoolAnd = UnifyBoolAnd and @ -\\and{_}(\\dv{Bool}("true"), andBool(_,_)) +\\and{_}(\\dv{Bool}("true"), andBool(_,_)), @ + +symmetric in the two arguments. -} matchUnifyBoolAnd :: TermLike RewritingVariableName -> @@ -299,8 +301,10 @@ data UnifyBoolOr = UnifyBoolOr and @ -\\and{_}(\\dv{Bool}("false"), boolOr(_,_)) +\\and{_}(\\dv{Bool}("false"), boolOr(_,_)), @ + +symmetric in the two arguments. -} matchUnifyBoolOr :: TermLike RewritingVariableName -> @@ -348,8 +352,10 @@ data UnifyBoolNot = UnifyBoolNot and @ -\\and{_}(notBool(_), \\dv{Bool}(_)) +\\and{_}(notBool(_), \\dv{Bool}(_)), @ + +symmetric in the two arguments. -} matchUnifyBoolNot :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index d50b4d86be..9defefecf0 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -480,8 +480,10 @@ data UnifyIntEq = UnifyIntEq {- | Matches @ -\\equals{_, _}(eqInt{_}(_, _), \\dv{Bool}(_)) +\\equals{_, _}(eqInt{_}(_, _), \\dv{Bool}(_)), @ + +symmetric in the two arguments. -} matchUnifyIntEq :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index 84e60305cf..75599001bd 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -237,8 +237,10 @@ data UnifyKequalsEq = UnifyKequalsEq and @ -\\and{_}(eq(_,_), \\dv{Bool}(_)) +\\and{_}(eq(_,_), \\dv{Bool}(_)), @ + +symmetric in the two arguments. -} matchUnifyKequalsEq :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index 8f5500b2be..4eca4fd34f 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -422,7 +422,7 @@ data UnifyEqualsList \\equals{_, _}(list1, concat(args2)) @ -or similarly with \\and. +or similarly with \\and. Symmetric in the two arguments. -} matchUnifyEqualsList :: SmtMetadataTools Attribute.Symbol -> diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index e79ae7c8b7..4598bf95f2 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -642,7 +642,7 @@ data UnifyNotInKeysResult \\equals{_, _}(\\dv{Bool}(false), inKeys(map, key)) @ -when @key@ does not belong to the keys of @map@. +when @key@ does not belong to the keys of @map@. Symmetric in the two arguments. -} matchUnifyNotInKeys :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index ca006fb907..f02963874e 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -526,8 +526,10 @@ data UnifyStringEq = UnifyStringEq {- | Matches @ -\\equals{_, _}(\\dv{Bool}(_), eqString{_}(_,_)) +\\equals{_, _}(\\dv{Bool}(_), eqString{_}(_,_)), @ + +symmetric in the two arguments. -} matchUnifyStringEq :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 37536eec28..99591af956 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -324,8 +324,10 @@ data UnifyBoolAnd and @ -\\and{_}(\\top, _) +\\and{_}(\\top, _), @ + +symmetric in the two arguments. -} matchBoolAnd :: TermLike RewritingVariableName -> @@ -403,8 +405,10 @@ equalAndEquals first = {- | Matches @ -\\equals{_, _}(\\bottom, _) +\\equals{_, _}(\\bottom, _), @ + +symmetric in the two arguments. -} matchBottomTermEquals :: TermLike RewritingVariableName -> @@ -515,8 +519,10 @@ data VariableFunctionEquals = VariableFunctionEquals {- | Matches @ -\\equals{_, _}(x, f(_)) +\\equals{_, _}(x, f(_)), @ + +symmetric in the two arguments. -} matchVariableFunctionEquals :: TermLike RewritingVariableName -> From bb8637b00a1fbaa22c6468f2322cd33deef384b7 Mon Sep 17 00:00:00 2001 From: emarzion Date: Wed, 7 Jul 2021 01:20:23 -0500 Subject: [PATCH 80/86] moving term args into records --- kore/src/Kore/Builtin/Bool.hs | 62 ++-- kore/src/Kore/Builtin/Endianness.hs | 21 +- kore/src/Kore/Builtin/Int.hs | 15 +- kore/src/Kore/Builtin/KEqual.hs | 10 +- kore/src/Kore/Builtin/List.hs | 110 +++--- kore/src/Kore/Builtin/Map.hs | 31 +- kore/src/Kore/Builtin/Set.hs | 33 +- kore/src/Kore/Builtin/Signedness.hs | 26 +- kore/src/Kore/Builtin/String.hs | 15 +- kore/src/Kore/Step/Simplification/AndTerms.hs | 317 +++++++++--------- .../Kore/Step/Simplification/NoConfusion.hs | 20 +- .../Kore/Step/Simplification/Overloading.hs | 20 +- kore/test/Test/Kore/Builtin/Bool.hs | 18 +- .../Test/Kore/Step/Simplification/AndTerms.hs | 5 +- .../Kore/Step/Simplification/Overloading.hs | 2 +- 15 files changed, 350 insertions(+), 355 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index c35ba61b54..7e3ab3a74a 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -167,6 +167,7 @@ builtinFunctions = data UnifyBool = UnifyBool { bool1, bool2 :: !InternalBool + , term1, term2 :: !(TermLike RewritingVariableName) } {- | Matches @@ -185,10 +186,10 @@ matchBools :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe UnifyBool -matchBools first second - | InternalBool_ bool1 <- first - , InternalBool_ bool2 <- second = - Just UnifyBool{bool1, bool2} +matchBools term1 term2 + | InternalBool_ bool1 <- term2 + , InternalBool_ bool2 <- term1 = + Just UnifyBool{bool1, bool2, term1, term2} | otherwise = Nothing {-# INLINE matchBools #-} @@ -196,23 +197,21 @@ matchBools first second unifyBool :: forall unifier. MonadUnify unifier => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyBool -> unifier (Pattern RewritingVariableName) -unifyBool termLike1 termLike2 unifyData +unifyBool unifyData | bool1 == bool2 = - return (Pattern.fromTermLike termLike1) + return (Pattern.fromTermLike term1) | otherwise = Unify.explainAndReturnBottom "different Bool domain values" - termLike1 - termLike2 + term1 + term2 where - UnifyBool{bool1, bool2} = unifyData + UnifyBool{bool1, bool2, term1, term2} = unifyData data UnifyBoolAnd = UnifyBoolAnd - { isFirstMatched :: !Bool + { term :: !(TermLike RewritingVariableName) , boolAnd :: !BoolAnd } @@ -238,11 +237,11 @@ matchUnifyBoolAnd first second | Just True <- matchBool first , Just boolAnd <- matchBoolAnd second , isFunctionPattern second = - Just $ UnifyBoolAnd{isFirstMatched = True, boolAnd} + Just $ UnifyBoolAnd{term = first, boolAnd} | Just True <- matchBool second , Just boolAnd <- matchBoolAnd first , isFunctionPattern first = - Just $ UnifyBoolAnd{isFirstMatched = False, boolAnd} + Just $ UnifyBoolAnd{term = second, boolAnd} | otherwise = Nothing {-# INLINE matchUnifyBoolAnd #-} @@ -251,15 +250,12 @@ unifyBoolAnd :: forall unifier. MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyBoolAnd -> unifier (Pattern RewritingVariableName) -unifyBoolAnd unifyChildren term1 term2 unifyData = +unifyBoolAnd unifyChildren unifyData = unifyBothWith unifyChildren term operand1 operand2 where - UnifyBoolAnd{isFirstMatched, boolAnd} = unifyData - term = if isFirstMatched then term1 else term2 + UnifyBoolAnd{term, boolAnd} = unifyData BoolAnd{operand1, operand2} = boolAnd {- |Takes a (function-like) pattern and unifies it against two other patterns. @@ -288,7 +284,7 @@ unifyBothWith unify termLike1 operand1 operand2 = do Pattern.withoutTerm <$> unify term1 term2 data UnifyBoolOr = UnifyBoolOr - { isFirstMatched :: !Bool + { term :: !(TermLike RewritingVariableName) , boolOr :: !BoolOr } @@ -314,11 +310,11 @@ matchUnifyBoolOr first second | Just False <- matchBool first , Just boolOr <- matchBoolOr second , isFunctionPattern second = - Just UnifyBoolOr{isFirstMatched = True, boolOr} + Just UnifyBoolOr{term = first, boolOr} | Just False <- matchBool second , Just boolOr <- matchBoolOr first , isFunctionPattern first = - Just UnifyBoolOr{isFirstMatched = False, boolOr} + Just UnifyBoolOr{term = second, boolOr} | otherwise = Nothing {-# INLINE matchUnifyBoolOr #-} @@ -326,21 +322,18 @@ unifyBoolOr :: forall unifier. MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyBoolOr -> unifier (Pattern RewritingVariableName) -unifyBoolOr unifyChildren first second unifyData = - unifyBothWith unifyChildren termLike operand1 operand2 +unifyBoolOr unifyChildren unifyData = + unifyBothWith unifyChildren term operand1 operand2 where - UnifyBoolOr{isFirstMatched, boolOr} = unifyData + UnifyBoolOr{term, boolOr} = unifyData BoolOr{operand1, operand2} = boolOr - termLike = if isFirstMatched then first else second data UnifyBoolNot = UnifyBoolNot { boolNot :: !BoolNot , value :: !Bool - , isFirstMatched :: !Bool + , term :: !(TermLike RewritingVariableName) } {- | Matches @@ -365,28 +358,25 @@ matchUnifyBoolNot first second | Just boolNot <- matchBoolNot first , isFunctionPattern first , Just value <- matchBool second = - Just UnifyBoolNot{boolNot, value, isFirstMatched = True} + Just UnifyBoolNot{boolNot, value, term = second} | Just boolNot <- matchBoolNot second , isFunctionPattern second , Just value <- matchBool first = - Just UnifyBoolNot{boolNot, value, isFirstMatched = False} + Just UnifyBoolNot{boolNot, value, term = first} | otherwise = Nothing {-# INLINE matchUnifyBoolNot #-} unifyBoolNot :: forall unifier. TermSimplifier RewritingVariableName unifier -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyBoolNot -> unifier (Pattern RewritingVariableName) -unifyBoolNot unifyChildren term1 term2 unifyData = +unifyBoolNot unifyChildren unifyData = let notValue = asInternal (termLikeSort term) (not value) in unifyChildren notValue operand where - UnifyBoolNot{boolNot, value, isFirstMatched} = unifyData + UnifyBoolNot{boolNot, value, term} = unifyData BoolNot{operand} = boolNot - term = if isFirstMatched then term2 else term1 -- | Match a @BOOL.Bool@ builtin value. matchBool :: TermLike variable -> Maybe Bool diff --git a/kore/src/Kore/Builtin/Endianness.hs b/kore/src/Kore/Builtin/Endianness.hs index 96da6164db..804e6a7520 100644 --- a/kore/src/Kore/Builtin/Endianness.hs +++ b/kore/src/Kore/Builtin/Endianness.hs @@ -76,6 +76,7 @@ bigEndianVerifier = endiannessVerifier BigEndian data UnifyEqualsEndianness = UnifyEqualsEndianness { end1, end2 :: !Endianness + , term1, term2 :: !(TermLike RewritingVariableName) } -- | Matches two terms having the Endianness constructor. @@ -83,25 +84,23 @@ matchUnifyEqualsEndianness :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe UnifyEqualsEndianness -matchUnifyEqualsEndianness first second - | Endianness_ end1 <- first - , Endianness_ end2 <- second = - Just $ UnifyEqualsEndianness end1 end2 +matchUnifyEqualsEndianness term1 term2 + | Endianness_ end1 <- term1 + , Endianness_ end2 <- term2 = + Just UnifyEqualsEndianness{end1, end2, term1, term2} | otherwise = Nothing {-# INLINE matchUnifyEqualsEndianness #-} unifyEquals :: MonadUnify unifier => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyEqualsEndianness -> unifier (Pattern RewritingVariableName) -unifyEquals first second unifyData - | end1 == end2 = return (Pattern.fromTermLike first) +unifyEquals unifyData + | end1 == end2 = return (Pattern.fromTermLike term1) | otherwise = explainAndReturnBottom "Cannot unify distinct constructors." - first - second + term1 + term2 where - UnifyEqualsEndianness{end1, end2} = unifyData + UnifyEqualsEndianness{end1, end2, term1, term2} = unifyData diff --git a/kore/src/Kore/Builtin/Int.hs b/kore/src/Kore/Builtin/Int.hs index 9defefecf0..8a5277d810 100644 --- a/kore/src/Kore/Builtin/Int.hs +++ b/kore/src/Kore/Builtin/Int.hs @@ -430,6 +430,7 @@ matchIntEqual = data UnifyInt = UnifyInt { int1, int2 :: !InternalInt + , term1, term2 :: !(TermLike RewritingVariableName) } {- | Matches @@ -448,10 +449,10 @@ matchInt :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe UnifyInt -matchInt first second - | InternalInt_ int1 <- first - , InternalInt_ int2 <- second = - Just UnifyInt{int1, int2} +matchInt term1 term2 + | InternalInt_ int1 <- term1 + , InternalInt_ int2 <- term2 = + Just UnifyInt{int1, int2, term1, term2} | otherwise = Nothing {-# INLINE matchInt #-} @@ -459,14 +460,12 @@ matchInt first second unifyInt :: forall unifier. MonadUnify unifier => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyInt -> unifier (Pattern RewritingVariableName) -unifyInt term1 term2 unifyData = +unifyInt unifyData = assert (on (==) internalIntSort int1 int2) worker where - UnifyInt{int1, int2} = unifyData + UnifyInt{int1, int2, term1, term2} = unifyData worker :: unifier (Pattern RewritingVariableName) worker | on (==) internalIntValue int1 int2 = diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index 75599001bd..d6f6efe25f 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -286,7 +286,7 @@ data IfThenElse term = IfThenElse data UnifyIfThenElse = UnifyIfThenElse { ifThenElse :: IfThenElse (TermLike RewritingVariableName) , -- The term that was not matched by @matchIfThenElse@ - otherTerm :: TermLike RewritingVariableName + term :: TermLike RewritingVariableName } -- | Match the @KEQUAL.eq@ hooked symbol. @@ -296,9 +296,9 @@ matchIfThenElse :: Maybe UnifyIfThenElse matchIfThenElse first second | Just ifThenElse <- match first = - Just $ UnifyIfThenElse{ifThenElse, otherTerm = second} + Just $ UnifyIfThenElse{ifThenElse, term = second} | Just ifThenElse <- match second = - Just $ UnifyIfThenElse{ifThenElse, otherTerm = first} + Just $ UnifyIfThenElse{ifThenElse, term = first} | otherwise = Nothing where match (App_ symbol [condition, branch1, branch2]) = do @@ -315,9 +315,9 @@ unifyIfThenElse :: UnifyIfThenElse -> unifier (Pattern RewritingVariableName) unifyIfThenElse unifyChildren unifyData = - worker ifThenElse otherTerm + worker ifThenElse term where - UnifyIfThenElse{ifThenElse, otherTerm} = unifyData + UnifyIfThenElse{ifThenElse, term} = unifyData takeCondition value condition' = makeCeilPredicate (mkAnd (Bool.asInternal sort value) condition') & Condition.fromPredicate diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index 4eca4fd34f..7e06c920fc 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -377,25 +377,25 @@ builtinFunctions = data FirstElemVarData = FirstElemVarData { pat1, pat2 :: !(TermLike RewritingVariableName) - , isFirstMatched :: !Bool + , term1, term2 :: !(TermLike RewritingVariableName) } data AppAppData = AppAppData { args1, args2 :: ![TermLike RewritingVariableName] , symbol2 :: !Symbol - , isFirstMatched :: !Bool + , term1, term2 :: !(TermLike RewritingVariableName) } data ListListData = ListListData { builtin1, builtin2 :: !(InternalList (TermLike RewritingVariableName)) - , isFirstMatched :: !Bool + , term1, term2 :: !(TermLike RewritingVariableName) } data ListAppData = ListAppData { pat1, pat2 :: !(TermLike RewritingVariableName) , args2 :: ![TermLike RewritingVariableName] , builtin1 :: !(InternalList (TermLike RewritingVariableName)) - , isFirstMatched :: !Bool + , term1, term2 :: !(TermLike RewritingVariableName) } data UnifyEqualsList @@ -431,29 +431,29 @@ matchUnifyEqualsList :: Maybe UnifyEqualsList matchUnifyEqualsList tools first second | Just True <- isListSort tools sort1 = - worker normFirst normSecond True <|> worker normSecond normFirst False + worker first second normFirst normSecond <|> worker second first normSecond normFirst | otherwise = Nothing where sort1 = termLikeSort first normFirst = normalize first normSecond = normalize second - worker pat1@(ElemVar_ _) pat2 isFirstMatched + worker term1 term2 pat1@(ElemVar_ _) pat2 | TermLike.isFunctionPattern pat2 = - Just $ FirstElemVar FirstElemVarData{pat1, pat2, isFirstMatched} + Just $ FirstElemVar FirstElemVarData{pat1, pat2, term1, term2} | otherwise = Nothing - worker (App_ symbol1 args1) (App_ symbol2 args2) isFirstMatched + worker term1 term2 (App_ symbol1 args1) (App_ symbol2 args2) | isSymbolConcat symbol1 , isSymbolConcat symbol2 = - Just $ AppApp AppAppData{args1, args2, symbol2, isFirstMatched} - worker pat1@(InternalList_ builtin1) pat2 isFirstMatched = + Just $ AppApp AppAppData{args1, args2, symbol2, term1, term2} + worker term1 term2 pat1@(InternalList_ builtin1) pat2 = case pat2 of - InternalList_ builtin2 -> Just $ ListList ListListData{builtin1, builtin2, isFirstMatched} + InternalList_ builtin2 -> Just $ ListList ListListData{builtin1, builtin2, term1, term2} App_ symbol2 args2 - | isSymbolConcat symbol2 -> Just $ ListApp ListAppData{pat1, pat2, args2, builtin1, isFirstMatched} + | isSymbolConcat symbol2 -> Just $ ListApp ListAppData{pat1, pat2, args2, builtin1, term1, term2} | otherwise -> Nothing _ -> Nothing - worker _ _ _ = Nothing + worker _ _ _ _ = Nothing {-# INLINE matchUnifyEqualsList #-} {- | Simplify the conjunction or equality of two concrete List domain values. @@ -474,21 +474,17 @@ unifyEquals :: unifier (Pattern RewritingVariableName) ) -> SmtMetadataTools Attribute.Symbol -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyEqualsList -> unifier (Pattern RewritingVariableName) unifyEquals simplificationType simplifyChild tools - first - second unifyData = case unifyData of FirstElemVar FirstElemVarData{pat1, pat2} -> simplifyChild pat1 pat2 - AppApp AppAppData{args1, args2, symbol2, isFirstMatched} -> + AppApp AppAppData{args1, args2, symbol2, term1, term2} -> case (args1, args2) of ( [InternalList_ builtin1, x1@(Var_ _)] , [InternalList_ builtin2, x2@(Var_ _)] @@ -499,7 +495,7 @@ unifyEquals x1 builtin2 x2 - isFirstMatched + term1 term2 ( [x1@(Var_ _), InternalList_ builtin1] , [x2@(Var_ _), InternalList_ builtin2] ) -> @@ -509,16 +505,17 @@ unifyEquals builtin1 x2 builtin2 - isFirstMatched + term1 + term2 _ -> empty - ListList ListListData{builtin1, builtin2, isFirstMatched} -> - unifyEqualsConcrete builtin1 builtin2 isFirstMatched - ListApp ListAppData{pat1, pat2, args2, builtin1, isFirstMatched} -> + ListList ListListData{builtin1, builtin2, term1, term2} -> + unifyEqualsConcrete builtin1 builtin2 term1 term2 + ListApp ListAppData{pat1, pat2, args2, builtin1, term1, term2} -> case args2 of [InternalList_ builtin2, x@(Var_ _)] -> - unifyEqualsFramedRight builtin1 builtin2 x isFirstMatched + unifyEqualsFramedRight builtin1 builtin2 x term1 term2 [x@(Var_ _), InternalList_ builtin2] -> - unifyEqualsFramedLeft builtin1 x builtin2 isFirstMatched + unifyEqualsFramedLeft builtin1 x builtin2 term1 term2 [_, _] -> Builtin.unifyEqualsUnsolved simplificationType @@ -536,10 +533,11 @@ unifyEquals unifyEqualsConcrete :: InternalList (TermLike RewritingVariableName) -> InternalList (TermLike RewritingVariableName) -> - Bool -> + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) - unifyEqualsConcrete builtin1 builtin2 isFirstMatched - | Seq.length list1 /= Seq.length list2 = bottomWithExplanation isFirstMatched + unifyEqualsConcrete builtin1 builtin2 term1 term2 + | Seq.length list1 /= Seq.length list2 = bottomWithExplanation term1 term2 | otherwise = do Reflection.give tools $ do unified <- sequence $ Seq.zipWith simplifyChild list1 list2 @@ -558,14 +556,16 @@ unifyEquals InternalList (TermLike RewritingVariableName) -> InternalList (TermLike RewritingVariableName) -> TermLike RewritingVariableName -> - Bool -> + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) unifyEqualsFramedRight internal1 internal2 frame2 - isFirstMatched - | Seq.length prefix2 > Seq.length list1 = bottomWithExplanation isFirstMatched + term1 + term2 + | Seq.length prefix2 > Seq.length list1 = bottomWithExplanation term1 term2 | otherwise = do let listSuffix1 = asInternal tools internalListSort suffix1 @@ -573,7 +573,8 @@ unifyEquals unifyEqualsConcrete internal1{internalListChild = prefix1} internal2 - isFirstMatched + term1 + term2 suffixUnified <- simplifyChild frame2 listSuffix1 let result = TermLike.markSimplified (mkInternalList internal1) @@ -592,14 +593,16 @@ unifyEquals InternalList (TermLike RewritingVariableName) -> TermLike RewritingVariableName -> InternalList (TermLike RewritingVariableName) -> - Bool -> + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) unifyEqualsFramedLeft internal1 frame2 internal2 - isFirstMatched - | Seq.length suffix2 > Seq.length list1 = bottomWithExplanation isFirstMatched + term1 + term2 + | Seq.length suffix2 > Seq.length list1 = bottomWithExplanation term1 term2 | otherwise = do let listPrefix1 = asInternal tools internalListSort prefix1 @@ -608,7 +611,8 @@ unifyEquals unifyEqualsConcrete internal1{internalListChild = suffix1} internal2 - isFirstMatched + term1 + term2 let result = mkInternalList internal1 <$ prefixUnified @@ -621,14 +625,12 @@ unifyEquals (prefix1, suffix1) = Seq.splitAt prefixLength list1 where prefixLength = Seq.length list1 - Seq.length suffix2 - bottomWithExplanation isFirstMatched = do + bottomWithExplanation term1 term2 = do Monad.Unify.explainBottom "Cannot unify lists of different length." - first' - second' + term1 + term2 return Pattern.bottom - where - (first', second') = if isFirstMatched then (first, second) else (second, first) unifyEqualsFramedRightRight :: TermLike.Symbol -> @@ -636,7 +638,8 @@ unifyEquals TermLike RewritingVariableName -> InternalList (TermLike RewritingVariableName) -> TermLike RewritingVariableName -> - Bool -> + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) unifyEqualsFramedRightRight symbol @@ -644,13 +647,15 @@ unifyEquals frame1 internal2 frame2 - isFirstMatched + term1 + term2 | length1 < length2 = do prefixUnified <- unifyEqualsConcrete internal1 internal2{internalListChild = prefix2} - isFirstMatched + term1 + term2 let listSuffix2 = asInternal tools internalListSort suffix2 suffix2Frame2 = mkApplySymbol symbol [listSuffix2, frame2] suffixUnified <- @@ -664,7 +669,7 @@ unifyEquals return result | length1 == length2 = do prefixUnified <- - unifyEqualsConcrete internal1 internal2 isFirstMatched + unifyEqualsConcrete internal1 internal2 term1 term2 suffixUnified <- simplifyChild frame1 frame2 let result = TermLike.markSimplified initial @@ -672,7 +677,7 @@ unifyEquals <* suffixUnified return result | otherwise = - unifyEqualsFramedRightRight symbol internal2 frame2 internal1 frame1 isFirstMatched + unifyEqualsFramedRightRight symbol internal2 frame2 internal1 frame1 term1 term2 where initial = mkApplySymbol symbol [mkInternalList internal1, frame1] InternalList{internalListSort} = internal1 @@ -688,7 +693,8 @@ unifyEquals InternalList (TermLike RewritingVariableName) -> TermLike RewritingVariableName -> InternalList (TermLike RewritingVariableName) -> - Bool -> + TermLike RewritingVariableName -> + TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) unifyEqualsFramedLeftLeft symbol @@ -696,7 +702,8 @@ unifyEquals internal1 frame2 internal2 - isFirstMatched + term1 + term2 | length1 < length2 = do let listPrefix2 = asInternal tools internalListSort prefix2 frame2Prefix2 = mkApplySymbol symbol [frame2, listPrefix2] @@ -705,20 +712,21 @@ unifyEquals unifyEqualsConcrete internal1 internal2{internalListChild = suffix2} - isFirstMatched + term1 + term2 let result = TermLike.markSimplified initial <$ prefixUnified <* suffixUnified return result | length1 == length2 = do prefixUnified <- simplifyChild frame1 frame2 - suffixUnified <- unifyEqualsConcrete internal1 internal2 isFirstMatched + suffixUnified <- unifyEqualsConcrete internal1 internal2 term1 term2 let result = TermLike.markSimplified initial <$ prefixUnified <* suffixUnified return result | otherwise = - unifyEqualsFramedLeftLeft symbol frame2 internal2 frame1 internal1 isFirstMatched + unifyEqualsFramedLeftLeft symbol frame2 internal2 frame1 internal1 term1 term2 where initial = mkApplySymbol symbol [frame1, mkInternalList internal1] InternalList{internalListSort} = internal1 diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 4598bf95f2..3271f5f612 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -521,12 +521,12 @@ internalize tools termLike data NormAcData = NormAcData { normalized1, normalized2 :: !(InternalMap Key (TermLike RewritingVariableName)) - , isFirstMatched :: !Bool + , term1, term2 :: !(TermLike RewritingVariableName) , acData :: !(Ac.UnifyEqualsNormAc NormalizedMap RewritingVariableName) } data UnifyEqualsMap - = ReturnBottom !Bool + = ReturnBottom !(TermLike RewritingVariableName) !(TermLike RewritingVariableName) | NormAc !NormAcData -- | Matches two concrete Map domain values. @@ -550,20 +550,22 @@ matchUnifyEquals tools first second worker a b isFirstMatched | InternalMap_ normalized1 <- a , InternalMap_ normalized2 <- b = - NormAc . NormAcData normalized1 normalized2 isFirstMatched + NormAc . NormAcData normalized1 normalized2 term1 term2 <$> Ac.matchUnifyEqualsNormalizedAc tools normalized1 normalized2 | otherwise = case normalizedOrBottom a of - Ac.Bottom -> Just $ ReturnBottom isFirstMatched + Ac.Bottom -> Just $ ReturnBottom term1 term2 Ac.Normalized normalized1 -> let a' = Ac.asInternal tools sort1 normalized1 in case normalizedOrBottom b of - Ac.Bottom -> Just $ ReturnBottom isFirstMatched + Ac.Bottom -> Just $ ReturnBottom term1 term2 Ac.Normalized normalized2 -> let b' = Ac.asInternal tools sort1 normalized2 in worker a' b' isFirstMatched + where + (term1, term2) = if isFirstMatched then (a,b) else (b,a) {- | Simplify the conjunction or equality of two concrete Map domain values. @@ -575,31 +577,26 @@ unifyEquals :: MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> SmtMetadataTools Attribute.Symbol -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyEqualsMap -> unifier (Pattern RewritingVariableName) -unifyEquals unifyEqualsChildren tools first second unifyData = +unifyEquals unifyEqualsChildren tools unifyData = case unifyData of - ReturnBottom isFirstMatched -> + ReturnBottom term1 term2 -> Monad.Unify.explainAndReturnBottom "Duplicated elements in normalization." - first' - second' - where - (first', second') = if isFirstMatched then (first, second) else (second, first) + term1 + term2 NormAc unifyData' -> Ac.unifyEqualsNormalized tools - first' - second' + term1 + term2 unifyEqualsChildren normalized1 normalized2 acData where - NormAcData{normalized1, normalized2, isFirstMatched, acData} = unifyData' - (first', second') = if isFirstMatched then (first, second) else (second, first) + NormAcData{normalized1, normalized2, term1, term2, acData} = unifyData' data InKeys term = InKeys { symbol :: !Symbol diff --git a/kore/src/Kore/Builtin/Set.hs b/kore/src/Kore/Builtin/Set.hs index aa6774643c..21562eb097 100644 --- a/kore/src/Kore/Builtin/Set.hs +++ b/kore/src/Kore/Builtin/Set.hs @@ -524,13 +524,13 @@ internalize tools termLike sort' = termLikeSort termLike data NormAcData = NormAcData - { normalized1, normalized2 :: InternalSet Key (TermLike RewritingVariableName) - , isFirstMatched :: !Bool + { normalized1, normalized2 :: !(InternalSet Key (TermLike RewritingVariableName)) + , term1, term2 :: !(TermLike RewritingVariableName) , acData :: !(Ac.UnifyEqualsNormAc NormalizedSet RewritingVariableName) } data UnifyEqualsMap - = ReturnBottom !Bool + = ReturnBottom !(TermLike RewritingVariableName) !(TermLike RewritingVariableName) | NormAc !NormAcData -- | Matches two concrete Set domain values. @@ -554,20 +554,22 @@ matchUnifyEquals tools first second worker a b isFirstMatched | InternalSet_ normalized1 <- a , InternalSet_ normalized2 <- b = - NormAc . NormAcData normalized1 normalized2 isFirstMatched + NormAc . NormAcData normalized1 normalized2 term1 term2 <$> Ac.matchUnifyEqualsNormalizedAc tools normalized1 normalized2 | otherwise = case normalizedOrBottom a of - Ac.Bottom -> Just $ ReturnBottom isFirstMatched + Ac.Bottom -> Just $ ReturnBottom term1 term2 Ac.Normalized normalized1 -> let a' = Ac.asInternal tools sort1 normalized1 in case normalizedOrBottom b of - Ac.Bottom -> Just $ ReturnBottom isFirstMatched + Ac.Bottom -> Just $ ReturnBottom term1 term2 Ac.Normalized normalized2 -> let b' = Ac.asInternal tools sort1 normalized2 in worker a' b' isFirstMatched + where + (term1, term2) = if isFirstMatched then (a,b) else (b,a) {- | Simplify the conjunction or equality of two concrete Map domain values. @@ -583,28 +585,23 @@ unifyEquals :: MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> SmtMetadataTools Attribute.Symbol -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyEqualsMap -> unifier (Pattern RewritingVariableName) -unifyEquals unifyEqualsChildren tools first second unifyData = +unifyEquals unifyEqualsChildren tools unifyData = case unifyData of - ReturnBottom isFirstMatched -> + ReturnBottom term1 term2 -> Monad.Unify.explainAndReturnBottom "Duplicated elements in normalization." - first' - second' - where - (first', second') = if isFirstMatched then (first, second) else (second, first) + term1 + term2 NormAc unifyData' -> Ac.unifyEqualsNormalized tools - first' - second' + term1 + term2 unifyEqualsChildren normalized1 normalized2 acData where - NormAcData{normalized1, normalized2, isFirstMatched, acData} = unifyData' - (first', second') = if isFirstMatched then (first, second) else (second, first) + NormAcData{normalized1, normalized2, term1, term2, acData} = unifyData' diff --git a/kore/src/Kore/Builtin/Signedness.hs b/kore/src/Kore/Builtin/Signedness.hs index a9faa32a51..25a75c7846 100644 --- a/kore/src/Kore/Builtin/Signedness.hs +++ b/kore/src/Kore/Builtin/Signedness.hs @@ -75,7 +75,8 @@ unsignedVerifier :: ApplicationVerifier Verified.Pattern unsignedVerifier = signednessVerifier Unsigned data UnifyEqualsSignedness = UnifyEqualsSignedness - { sign1, sign2 :: Signedness + { sign1, sign2 :: !Signedness + , term1, term2 :: !(TermLike RewritingVariableName) } -- | Matches two terms having the Signedness constructor. @@ -83,26 +84,23 @@ matchUnifyEqualsSignedness :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe UnifyEqualsSignedness -matchUnifyEqualsSignedness first second - | Signedness_ sign1 <- first - , Signedness_ sign2 <- second = - Just UnifyEqualsSignedness{sign1, sign2} +matchUnifyEqualsSignedness term1 term2 + | Signedness_ sign1 <- term1 + , Signedness_ sign2 <- term2 = + Just UnifyEqualsSignedness{sign1, sign2, term1, term2} | otherwise = Nothing {-# INLINE matchUnifyEqualsSignedness #-} unifyEquals :: - InternalVariable variable => MonadUnify unifier => - TermLike variable -> - TermLike variable -> UnifyEqualsSignedness -> - unifier (Pattern variable) -unifyEquals termLike1 termLike2 unifyData - | sign1 == sign2 = return (Pattern.fromTermLike termLike1) + unifier (Pattern RewritingVariableName) +unifyEquals unifyData + | sign1 == sign2 = return (Pattern.fromTermLike term1) | otherwise = explainAndReturnBottom "Cannot unify distinct constructors." - termLike1 - termLike2 + term1 + term2 where - UnifyEqualsSignedness{sign1, sign2} = unifyData + UnifyEqualsSignedness{sign1, sign2, term1, term2} = unifyData diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index f02963874e..cf8428905a 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -475,6 +475,7 @@ matchStringEqual = data UnifyString = UnifyString { string1, string2 :: !InternalString + , term1, term2 :: !(TermLike RewritingVariableName) } {- | Matches @@ -493,10 +494,10 @@ matchString :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe UnifyString -matchString first second - | InternalString_ string1 <- first - , InternalString_ string2 <- second = - Just UnifyString{string1, string2} +matchString term1 term2 + | InternalString_ string1 <- term1 + , InternalString_ string2 <- term2 = + Just UnifyString{string1, string2, term1, term2} | otherwise = Nothing {-# INLINE matchString #-} @@ -504,11 +505,9 @@ matchString first second unifyString :: forall unifier. MonadUnify unifier => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyString -> unifier (Pattern RewritingVariableName) -unifyString term1 term2 unifyData = +unifyString unifyData = assert (on (==) internalStringSort string1 string2) worker where worker :: unifier (Pattern RewritingVariableName) @@ -516,7 +515,7 @@ unifyString term1 term2 unifyData = | on (==) internalStringValue string1 string2 = return $ Pattern.fromTermLike term1 | otherwise = explainAndReturnBottom "distinct strings" term1 term2 - UnifyString{string1, string2} = unifyData + UnifyString{string1, string2, term1, term2} = unifyData data UnifyStringEq = UnifyStringEq { eqTerm :: !(EqTerm (TermLike RewritingVariableName)) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 99591af956..4dd8900664 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -12,6 +12,7 @@ module Kore.Step.Simplification.AndTerms ( functionAnd, matchFunctionAnd, compareForEquals, + FunctionAnd (..), ) where import Control.Error ( @@ -145,39 +146,39 @@ maybeTermEquals notSimplifier childTransformers first second = do where worker injSimplifier overloadSimplifier tools | Just unifyData <- Builtin.Int.matchInt first second = - lift $ Builtin.Int.unifyInt first second unifyData + lift $ Builtin.Int.unifyInt unifyData | Just unifyData <- Builtin.Bool.matchBools first second = - lift $ Builtin.Bool.unifyBool first second unifyData + lift $ Builtin.Bool.unifyBool unifyData | Just unifyData <- Builtin.String.matchString first second = - lift $ Builtin.String.unifyString first second unifyData + lift $ Builtin.String.unifyString unifyData | Just unifyData <- matchDomainValue first second = - lift $ unifyDomainValue first second unifyData + lift $ unifyDomainValue unifyData | Just unifyData <- matchStringLiteral first second = - lift $ unifyStringLiteral first second unifyData - | Just () <- matchEqualsAndEquals first second = - lift $ equalAndEquals first + lift $ unifyStringLiteral unifyData + | Just term <- matchEqualsAndEquals first second = + lift $ equalAndEquals term | Just unifyData <- matchBytes first second = lift $ unifyBytes unifyData - | Just isFirstMatched <- matchBottomTermEquals first second = - lift $ bottomTermEquals SideCondition.topTODO isFirstMatched first second + | Just unifyData <- matchBottomTermEquals first second = + lift $ bottomTermEquals SideCondition.topTODO unifyData | Just unifyData <- matchVariableFunctionEquals first second = - lift $ variableFunctionEquals first second unifyData + lift $ variableFunctionEquals unifyData | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData | Just unifyData <- matchInj injSimplifier first second = - lift $ unifySortInjection childTransformers first second unifyData - | Just () <- matchConstructorSortInjectionAndEquals first second = - lift $ constructorSortInjectionAndEquals first second - | Just () <- matchDifferentConstructors overloadSimplifier first second = - lift $ constructorAndEqualsAssumesDifferentHeads first second + lift $ unifySortInjection childTransformers unifyData + | Just unifyData <- matchConstructorSortInjectionAndEquals first second = + lift $ constructorSortInjectionAndEquals unifyData + | Just unifyData <- matchDifferentConstructors overloadSimplifier first second = + lift $ constructorAndEqualsAssumesDifferentHeads unifyData | Just unifyData <- unifyOverloading overloadSimplifier (Pair first second) = - lift $ overloadedConstructorSortInjectionAndEquals childTransformers first second unifyData + lift $ overloadedConstructorSortInjectionAndEquals childTransformers unifyData | Just unifyData <- Builtin.Bool.matchUnifyBoolAnd first second = - lift $ Builtin.Bool.unifyBoolAnd childTransformers first second unifyData + lift $ Builtin.Bool.unifyBoolAnd childTransformers unifyData | Just unifyData <- Builtin.Bool.matchUnifyBoolOr first second = - lift $ Builtin.Bool.unifyBoolOr childTransformers first second unifyData + lift $ Builtin.Bool.unifyBoolOr childTransformers unifyData | Just boolNotData <- Builtin.Bool.matchUnifyBoolNot first second = - lift $ Builtin.Bool.unifyBoolNot childTransformers first second boolNotData + lift $ Builtin.Bool.unifyBoolNot childTransformers boolNotData | Just unifyData <- Builtin.Int.matchUnifyIntEq first second = lift $ Builtin.Int.unifyIntEq childTransformers notSimplifier unifyData | Just unifyData <- Builtin.String.matchUnifyStringEq first second = @@ -185,26 +186,24 @@ maybeTermEquals notSimplifier childTransformers first second = do | Just unifyData <- Builtin.KEqual.matchUnifyKequalsEq first second = lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData | Just unifyData <- Builtin.Endianness.matchUnifyEqualsEndianness first second = - lift $ Builtin.Endianness.unifyEquals first second unifyData + lift $ Builtin.Endianness.unifyEquals unifyData | Just unifyData <- Builtin.Signedness.matchUnifyEqualsSignedness first second = - lift $ Builtin.Signedness.unifyEquals first second unifyData + lift $ Builtin.Signedness.unifyEquals unifyData | Just unifyData <- Builtin.Map.matchUnifyEquals tools first second = - lift $ Builtin.Map.unifyEquals childTransformers tools first second unifyData + lift $ Builtin.Map.unifyEquals childTransformers tools unifyData | Just unifyData <- Builtin.Map.matchUnifyNotInKeys first second = lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second unifyData | Just unifyData <- Builtin.Set.matchUnifyEquals tools first second = - lift $ Builtin.Set.unifyEquals childTransformers tools first second unifyData + lift $ Builtin.Set.unifyEquals childTransformers tools unifyData | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = lift $ Builtin.List.unifyEquals SimplificationType.Equals childTransformers tools - first - second unifyData | Just unifyData <- matchDomainValueAndConstructorErrors first second = - lift $ domainValueAndConstructorErrors first second unifyData + lift $ domainValueAndConstructorErrors unifyData | otherwise = empty maybeTermAnd :: @@ -231,19 +230,19 @@ maybeTermAnd notSimplifier childTransformers first second = do term1 term2 | Just unifyData <- matchBoolAnd first second = - lift $ boolAnd first second unifyData + lift $ boolAnd unifyData | Just unifyData <- Builtin.Int.matchInt first second = - lift $ Builtin.Int.unifyInt first second unifyData + lift $ Builtin.Int.unifyInt unifyData | Just unifyData <- Builtin.Bool.matchBools first second = - lift $ Builtin.Bool.unifyBool first second unifyData + lift $ Builtin.Bool.unifyBool unifyData | Just unifyData <- Builtin.String.matchString first second = - lift $ Builtin.String.unifyString first second unifyData + lift $ Builtin.String.unifyString unifyData | Just unifyData <- matchDomainValue first second = - lift $ unifyDomainValue first second unifyData + lift $ unifyDomainValue unifyData | Just unifyData <- matchStringLiteral first second = - lift $ unifyStringLiteral first second unifyData - | Just () <- matchEqualsAndEquals first second = - lift $ equalAndEquals first + lift $ unifyStringLiteral unifyData + | Just term <- matchEqualsAndEquals first second = + lift $ equalAndEquals term | Just unifyData <- matchBytes first second = lift $ unifyBytes unifyData | Just matched <- matchVariables first second = @@ -253,44 +252,42 @@ maybeTermAnd notSimplifier childTransformers first second = do | Just unifyData <- matchEqualInjectiveHeadsAndEquals first second = lift $ equalInjectiveHeadsAndEquals childTransformers unifyData | Just unifyData <- matchInj injSimplifier first second = - lift $ unifySortInjection childTransformers first second unifyData - | Just () <- matchConstructorSortInjectionAndEquals first second = - lift $ constructorSortInjectionAndEquals first second - | Just () <- matchDifferentConstructors overloadSimplifier first second = - lift $ constructorAndEqualsAssumesDifferentHeads first second + lift $ unifySortInjection childTransformers unifyData + | Just unifyData <- matchConstructorSortInjectionAndEquals first second = + lift $ constructorSortInjectionAndEquals unifyData + | Just unifyData <- matchDifferentConstructors overloadSimplifier first second = + lift $ constructorAndEqualsAssumesDifferentHeads unifyData | Just unifyData <- unifyOverloading overloadSimplifier (Pair first second) = - lift $ overloadedConstructorSortInjectionAndEquals childTransformers first second unifyData + lift $ overloadedConstructorSortInjectionAndEquals childTransformers unifyData | Just unifyData <- Builtin.Bool.matchUnifyBoolAnd first second = - lift $ Builtin.Bool.unifyBoolAnd childTransformers first second unifyData + lift $ Builtin.Bool.unifyBoolAnd childTransformers unifyData | Just unifyData <- Builtin.Bool.matchUnifyBoolOr first second = - lift $ Builtin.Bool.unifyBoolOr childTransformers first second unifyData + lift $ Builtin.Bool.unifyBoolOr childTransformers unifyData | Just boolNotData <- Builtin.Bool.matchUnifyBoolNot first second = - lift $ Builtin.Bool.unifyBoolNot childTransformers first second boolNotData + lift $ Builtin.Bool.unifyBoolNot childTransformers boolNotData | Just unifyData <- Builtin.KEqual.matchUnifyKequalsEq first second = lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData | Just unifyData <- Builtin.KEqual.matchIfThenElse first second = lift $ Builtin.KEqual.unifyIfThenElse childTransformers unifyData | Just unifyData <- Builtin.Endianness.matchUnifyEqualsEndianness first second = - lift $ Builtin.Endianness.unifyEquals first second unifyData + lift $ Builtin.Endianness.unifyEquals unifyData | Just unifyData <- Builtin.Signedness.matchUnifyEqualsSignedness first second = - lift $ Builtin.Signedness.unifyEquals first second unifyData + lift $ Builtin.Signedness.unifyEquals unifyData | Just unifyData <- Builtin.Map.matchUnifyEquals tools first second = - lift $ Builtin.Map.unifyEquals childTransformers tools first second unifyData + lift $ Builtin.Map.unifyEquals childTransformers tools unifyData | Just unifyData <- Builtin.Set.matchUnifyEquals tools first second = - lift $ Builtin.Set.unifyEquals childTransformers tools first second unifyData + lift $ Builtin.Set.unifyEquals childTransformers tools unifyData | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = lift $ Builtin.List.unifyEquals SimplificationType.And childTransformers tools - first - second unifyData | Just unifyData <- matchDomainValueAndConstructorErrors first second = - lift $ domainValueAndConstructorErrors first second unifyData - | Just () <- matchFunctionAnd first second = - return $ functionAnd first second + lift $ domainValueAndConstructorErrors unifyData + | Just unifyData <- matchFunctionAnd first second = + return $ functionAnd unifyData | otherwise = empty {- | Construct the conjunction or unification of two terms. @@ -312,8 +309,8 @@ type TermTransformationOld variable unifier = MaybeT unifier (Pattern variable) data UnifyBoolAnd - = UnifyBoolAndBottom !Bool - | UnifyBoolAndTop !Bool + = UnifyBoolAndBottom !(TermLike RewritingVariableName) !(TermLike RewritingVariableName) + | UnifyBoolAndTop !(TermLike RewritingVariableName) {- | Matches @@ -335,13 +332,13 @@ matchBoolAnd :: Maybe UnifyBoolAnd matchBoolAnd term1 term2 | Pattern.isBottom term1 = - Just $ UnifyBoolAndBottom True + Just $ UnifyBoolAndBottom term1 term2 --first, second | Pattern.isTop term1 = - Just $ UnifyBoolAndTop True + Just $ UnifyBoolAndTop term2 | Pattern.isBottom term2 = - Just $ UnifyBoolAndBottom False + Just $ UnifyBoolAndBottom term2 term1 --second, first | Pattern.isTop term2 = - Just $ UnifyBoolAndTop False + Just $ UnifyBoolAndTop term1 | otherwise = Nothing {-# INLINE matchBoolAnd #-} @@ -349,19 +346,15 @@ matchBoolAnd term1 term2 -- | Simplify the conjunction of terms where one is a predicate. boolAnd :: MonadUnify unifier => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyBoolAnd -> unifier (Pattern RewritingVariableName) -boolAnd first second unifyData = +boolAnd unifyData = case unifyData of - UnifyBoolAndBottom isFirstMatched -> do - let (first', second') = if isFirstMatched then (first, second) else (second, first) - explainBoolAndBottom first' second' - return $ Pattern.fromTermLike first' - UnifyBoolAndTop isFirstMatched -> do - let second' = if isFirstMatched then second else first - return $ Pattern.fromTermLike second' + UnifyBoolAndBottom term1 term2 -> do + explainBoolAndBottom term1 term2 + return $ Pattern.fromTermLike term1 + UnifyBoolAndTop term -> do + return $ Pattern.fromTermLike term explainBoolAndBottom :: MonadUnify unifier => @@ -386,10 +379,10 @@ and matchEqualsAndEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe () + Maybe (TermLike RewritingVariableName) matchEqualsAndEquals first second | first == second = - Just () + Just first | otherwise = Nothing {-# INLINE matchEqualsAndEquals #-} @@ -398,9 +391,13 @@ equalAndEquals :: Monad unifier => TermLike RewritingVariableName -> unifier (Pattern RewritingVariableName) -equalAndEquals first = +equalAndEquals term = -- TODO (thomas.tuegel): Preserve simplified flags. - return (Pattern.fromTermLike first) + return (Pattern.fromTermLike term) + +data BottomTermEquals = BottomTermEquals + { term1, term2 :: !(TermLike RewritingVariableName) + } {- | Matches @@ -413,12 +410,12 @@ symmetric in the two arguments. matchBottomTermEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe Bool + Maybe BottomTermEquals matchBottomTermEquals first second | Bottom_ _ <- first = - Just True + Just BottomTermEquals{term1 = first, term2 = second} | Bottom_ _ <- second = - Just False + Just BottomTermEquals{term1 = second, term2 = first} | otherwise = Nothing {-# INLINE matchBottomTermEquals #-} @@ -426,30 +423,22 @@ matchBottomTermEquals first second bottomTermEquals :: MonadUnify unifier => SideCondition RewritingVariableName -> - Bool -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> + BottomTermEquals -> unifier (Pattern RewritingVariableName) bottomTermEquals sideCondition - isFirstMatched - first - second = + unifyData = do -- MonadUnify - let (first', second') = - if isFirstMatched - then (first, second) - else (second, first) - secondCeil <- makeEvaluateTermCeil sideCondition second' + secondCeil <- makeEvaluateTermCeil sideCondition term2 case toList secondCeil of [] -> return Pattern.top [Conditional{predicate = PredicateTrue, substitution}] | substitution == mempty -> do explainBottom "Cannot unify bottom with non-bottom pattern." - first' - second' + term1 + term2 empty _ -> return @@ -461,6 +450,8 @@ bottomTermEquals OrPattern.map Condition.toPredicate secondCeil , substitution = mempty } + where + BottomTermEquals{term1, term2} = unifyData data UnifyVariables = UnifyVariables {variable1, variable2 :: !(ElementVariable RewritingVariableName)} @@ -512,8 +503,8 @@ unifyVariableFunction UnifyVariableFunction{variable, term} = & pure data VariableFunctionEquals = VariableFunctionEquals - { isFirstMatched :: !Bool - , var :: !(ElementVariable RewritingVariableName) + { var :: !(ElementVariable RewritingVariableName) + , term1, term2 :: !(TermLike RewritingVariableName) } {- | Matches @@ -531,10 +522,10 @@ matchVariableFunctionEquals :: matchVariableFunctionEquals first second | ElemVar_ var <- first , isFunctionPattern second = - Just VariableFunctionEquals{isFirstMatched = True, var} + Just VariableFunctionEquals{term1 = first, term2 = second, var} | ElemVar_ var <- second , isFunctionPattern first = - Just VariableFunctionEquals{isFirstMatched = False, var} + Just VariableFunctionEquals{term1 = second, term2 = first, var} | otherwise = Nothing {-# INLINE matchVariableFunctionEquals #-} @@ -544,38 +535,36 @@ See also: 'isFunctionPattern' -} variableFunctionEquals :: MonadUnify unifier => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> VariableFunctionEquals -> unifier (Pattern RewritingVariableName) variableFunctionEquals - first - second unifyData = do -- MonadUnify predicate <- do - resultOr <- makeEvaluateTermCeil SideCondition.topTODO second' + resultOr <- makeEvaluateTermCeil SideCondition.topTODO term2 case toList resultOr of [] -> do explainBottom "Unification of variable and bottom \ \when attempting to simplify equals." - first' - second' + term1 + term2 empty resultConditions -> Unify.scatter resultConditions let result = predicate <> Condition.fromSingleSubstitution - (Substitution.assign (inject var) second') - return (Pattern.withCondition second' result) + (Substitution.assign (inject var) term2) + return (Pattern.withCondition term2 result) where - VariableFunctionEquals{isFirstMatched, var} = unifyData - (first', second') = - if isFirstMatched - then (first, second) - else (second, first) + VariableFunctionEquals{term1, term2, var} = unifyData + + +data UnifyInjData = UnifyInjData + { term1, term2 :: !(TermLike RewritingVariableName) + , unifyInj :: !(UnifyInj (InjPair RewritingVariableName)) + } {- | Matches @@ -601,11 +590,12 @@ matchInj :: InjSimplifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe (UnifyInj (InjPair RewritingVariableName)) + Maybe UnifyInjData matchInj injSimplifier first second | Inj_ inj1 <- first , Inj_ inj2 <- second = - matchInjs injSimplifier inj1 inj2 + UnifyInjData first second <$> + matchInjs injSimplifier inj1 inj2 | otherwise = Nothing {-# INLINE matchInj #-} @@ -629,11 +619,9 @@ unifySortInjection :: forall unifier. MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - UnifyInj (InjPair RewritingVariableName) -> + UnifyInjData -> unifier (Pattern RewritingVariableName) -unifySortInjection termMerger term1 term2 unifyInj = do +unifySortInjection termMerger unifyData = do InjSimplifier{unifyInjs} <- Simplifier.askInjSimplifier unifyInjs unifyInj & maybe distinct merge where @@ -644,6 +632,11 @@ unifySortInjection termMerger term1 term2 unifyInj = do let (childTerm, childCondition) = Pattern.splitTerm childPattern inj' = evaluateInj inj{injChild = childTerm} return $ Pattern.withCondition inj' childCondition + UnifyInjData{unifyInj, term1, term2} = unifyData + +data ConstructorSortInjectionAndEquals = ConstructorSortInjectionAndEquals + { term1, term2 :: !(TermLike RewritingVariableName) + } {- | Matches @@ -670,16 +663,16 @@ when @f@ has the @constructor@ attribute. matchConstructorSortInjectionAndEquals :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe () + Maybe ConstructorSortInjectionAndEquals matchConstructorSortInjectionAndEquals first second | Inj_ _ <- first , App_ symbol _ <- second , Symbol.isConstructor symbol = - Just () + Just ConstructorSortInjectionAndEquals{term1 = first, term2 = second} | Inj_ _ <- second , App_ symbol _ <- first , Symbol.isConstructor symbol = - Just () + Just ConstructorSortInjectionAndEquals{term1 = first, term2 = second} | otherwise = Nothing {-# INLINE matchConstructorSortInjectionAndEquals #-} @@ -690,11 +683,12 @@ returns @\\bottom@. -} constructorSortInjectionAndEquals :: MonadUnify unifier => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> + ConstructorSortInjectionAndEquals -> unifier a -constructorSortInjectionAndEquals first second = - noConfusionInjectionConstructor first second +constructorSortInjectionAndEquals unifyData = + noConfusionInjectionConstructor term1 term2 + where + ConstructorSortInjectionAndEquals{term1, term2} = unifyData noConfusionInjectionConstructor :: MonadUnify unifier => @@ -713,12 +707,10 @@ See TermSimplifier RewritingVariableName unifier -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> - MatchResult -> + OverloadingData -> unifier (Pattern RewritingVariableName) -overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm unifyData = - case unifyData of +overloadedConstructorSortInjectionAndEquals termMerger unifyData = + case matchResult of Resolution (Simple (Pair firstTerm' secondTerm')) -> termMerger firstTerm' secondTerm' Resolution @@ -740,15 +732,17 @@ overloadedConstructorSortInjectionAndEquals termMerger firstTerm secondTerm unif ( "exists simplification for overloaded" <> " constructors returned no pattern" ) - firstTerm - secondTerm + term1 + term2 _ -> scatter boundPattern ClashResult message -> - explainAndReturnBottom (fromString message) firstTerm secondTerm + explainAndReturnBottom (fromString message) term1 term2 + where + OverloadingData{term1, term2, matchResult} = unifyData data DVConstrError - = DVConstr - | ConstrDV + = DVConstr !(TermLike RewritingVariableName) !(TermLike RewritingVariableName) + | ConstrDV !(TermLike RewritingVariableName) !(TermLike RewritingVariableName) {- | Matches @@ -778,11 +772,11 @@ matchDomainValueAndConstructorErrors first second | DV_ _ _ <- first , App_ secondHead _ <- second , Symbol.isConstructor secondHead = - Just DVConstr + Just $ DVConstr first second | App_ firstHead _ <- first , Symbol.isConstructor firstHead , DV_ _ _ <- second = - Just ConstrDV + Just $ ConstrDV first second | otherwise = Nothing {- | Unifcation or equality for a domain value pattern vs a constructor @@ -793,11 +787,9 @@ sort with constructors. -} domainValueAndConstructorErrors :: HasCallStack => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> DVConstrError -> unifier a -domainValueAndConstructorErrors term1 term2 unifyData = +domainValueAndConstructorErrors unifyData = error $ show ( Pretty.vsep @@ -808,13 +800,14 @@ domainValueAndConstructorErrors term1 term2 unifyData = ] ) where - cannotHandle = + (term1, term2, cannotHandle) = case unifyData of - DVConstr -> "Cannot handle DomainValue and Constructor:" - ConstrDV -> "Cannot handle Constructor and DomainValue:" + DVConstr a b -> (a, b, "Cannot handle DomainValue and Constructor:") + ConstrDV a b -> (a, b, "Cannot handle Constructor and DomainValue:") data UnifyDomainValue = UnifyDomainValue { val1, val2 :: !(TermLike RewritingVariableName) + , term1, term2 :: !(TermLike RewritingVariableName) } {- | Matches @@ -833,11 +826,11 @@ matchDomainValue :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe UnifyDomainValue -matchDomainValue first second - | DV_ sort1 val1 <- first - , DV_ sort2 val2 <- second +matchDomainValue term1 term2 + | DV_ sort1 val1 <- term1 + , DV_ sort2 val2 <- term2 , sort1 == sort2 = - Just UnifyDomainValue{val1, val2} + Just UnifyDomainValue{val1, val2, term1, term2} | otherwise = Nothing {-# INLINE matchDomainValue #-} @@ -854,16 +847,14 @@ See also: 'equalAndEquals' unifyDomainValue :: forall unifier. MonadUnify unifier => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyDomainValue -> unifier (Pattern RewritingVariableName) -unifyDomainValue term1 term2 unifyData +unifyDomainValue unifyData | val1 == val2 = return $ Pattern.fromTermLike term1 | otherwise = cannotUnifyDomainValues term1 term2 where - UnifyDomainValue{val1, val2} = unifyData + UnifyDomainValue{val1, val2, term1, term2} = unifyData cannotUnifyDistinctDomainValues :: Pretty.Doc () cannotUnifyDistinctDomainValues = "distinct domain values" @@ -878,6 +869,7 @@ cannotUnifyDomainValues = explainAndReturnBottom cannotUnifyDistinctDomainValues -- | @UnifyStringLiteral@ represents unification of two string literals. data UnifyStringLiteral = UnifyStringLiteral { txt1, txt2 :: !Text + , term1, term2 :: !(TermLike RewritingVariableName) } -- | Matches the unification problem @"txt1"@ with @"txt2"@. @@ -885,10 +877,10 @@ matchStringLiteral :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe UnifyStringLiteral -matchStringLiteral first second - | StringLiteral_ txt1 <- first - , StringLiteral_ txt2 <- second = - Just UnifyStringLiteral{txt1, txt2} +matchStringLiteral term1 term2 + | StringLiteral_ txt1 <- term1 + , StringLiteral_ txt2 <- term2 = + Just UnifyStringLiteral{txt1, txt2, term1, term2} | otherwise = Nothing {-# INLINE matchStringLiteral #-} @@ -896,15 +888,17 @@ matchStringLiteral first second unifyStringLiteral :: forall unifier. MonadUnify unifier => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyStringLiteral -> unifier (Pattern RewritingVariableName) -unifyStringLiteral term1 term2 unifyData +unifyStringLiteral unifyData | txt1 == txt2 = return $ Pattern.fromTermLike term1 | otherwise = explainAndReturnBottom "distinct string literals" term1 term2 where - UnifyStringLiteral{txt1, txt2} = unifyData + UnifyStringLiteral{txt1, txt2, term1, term2} = unifyData + +data FunctionAnd = FunctionAnd + { term1, term2 :: !(TermLike RewritingVariableName) + } {- | Matches @@ -915,11 +909,11 @@ unifyStringLiteral term1 term2 unifyData matchFunctionAnd :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe () -matchFunctionAnd first second - | isFunctionPattern first - , isFunctionPattern second = - Just () + Maybe FunctionAnd +matchFunctionAnd term1 term2 + | isFunctionPattern term1 + , isFunctionPattern term2 = + Just FunctionAnd{term1, term2} | otherwise = Nothing {-# INLINE matchFunctionAnd #-} @@ -932,10 +926,9 @@ on the left-hand side of the @\\equals@ predicate, and the other argument appears on the right-hand side. -} functionAnd :: - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> + FunctionAnd -> Pattern RewritingVariableName -functionAnd first second = +functionAnd FunctionAnd{term1, term2} = makeEqualsPredicate first' second' & Predicate.markSimplified -- Ceil predicate not needed since first being @@ -944,7 +937,7 @@ functionAnd first second = & Condition.fromPredicate & Pattern.withCondition first' -- different for Equals where - (first', second') = minMaxBy compareForEquals first second + (first', second') = minMaxBy compareForEquals term1 term2 {- | Normal ordering for terms in @\equals(_, _)@. diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 55609a01e9..26daf692da 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -100,6 +100,10 @@ equalInjectiveHeadsAndEquals , secondChildren } = unifyData +data DifferentConstructors = DifferentConstructors + { term1, term2 :: !(TermLike RewritingVariableName) + } + {- | Matches @ @@ -118,7 +122,7 @@ matchDifferentConstructors :: OverloadSimplifier -> TermLike RewritingVariableName -> TermLike RewritingVariableName -> - Maybe () + Maybe DifferentConstructors matchDifferentConstructors OverloadSimplifier{isOverloaded} first @@ -128,7 +132,7 @@ matchDifferentConstructors , firstHead /= secondHead , Symbol.isConstructor firstHead || isOverloaded firstHead , Symbol.isConstructor secondHead || isOverloaded secondHead = - Just () + Just DifferentConstructors{term1 = first, term2 = second} | otherwise = empty {-# INLINE matchDifferentConstructors #-} @@ -139,16 +143,16 @@ to be different; therefore their conjunction is @\\bottom@. -} constructorAndEqualsAssumesDifferentHeads :: MonadUnify unifier => - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> + DifferentConstructors -> unifier a constructorAndEqualsAssumesDifferentHeads - first - second = + unifyData = do explainBottom "Cannot unify different constructors or incompatible \ \sort injections." - first - second + term1 + term2 empty + where + DifferentConstructors{term1, term2} = unifyData \ No newline at end of file diff --git a/kore/src/Kore/Step/Simplification/Overloading.hs b/kore/src/Kore/Step/Simplification/Overloading.hs index 4528d1c43d..ca010f9da4 100644 --- a/kore/src/Kore/Step/Simplification/Overloading.hs +++ b/kore/src/Kore/Step/Simplification/Overloading.hs @@ -6,6 +6,7 @@ module Kore.Step.Simplification.Overloading ( matchOverloading, -- for testing purposes unifyOverloading, + OverloadingData (..), UnifyOverloadingResult, MatchOverloadingResult, UnifyOverloadingError (..), @@ -132,9 +133,16 @@ matchOverloading :: matchOverloading termPair = do overloadSimplifier <- askOverloadSimplifier case unifyOverloading overloadSimplifier termPair of - Just (Resolution (Simple pair)) -> return pair - Just (ClashResult msg) -> throwE $ Clash msg - _ -> empty + Just OverloadingData{matchResult} -> case matchResult of + Resolution (Simple pair) -> return pair + ClashResult msg -> throwE $ Clash msg + _ -> empty + Nothing -> empty + +data OverloadingData = OverloadingData + { term1, term2 :: !(TermLike RewritingVariableName) + , matchResult :: !MatchResult + } {- | Tests whether the pair of terms can be coerced to have the same constructors @@ -152,8 +160,9 @@ matchOverloading termPair = do unifyOverloading :: OverloadSimplifier -> Pair (TermLike RewritingVariableName) -> - Maybe MatchResult -unifyOverloading overloadSimplifier termPair = case termPair of + Maybe OverloadingData +unifyOverloading overloadSimplifier termPair = + OverloadingData term1 term2 <$> case termPair of Pair (Inj_ inj@Inj{injChild = App_ firstHead firstChildren}) secondTerm@(App_ secondHead _) -> @@ -187,6 +196,7 @@ unifyOverloading overloadSimplifier termPair = case termPair of Nothing -> worker secondTerm firstTerm Just result -> Just result where + Pair term1 term2 = termPair worker :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> diff --git a/kore/test/Test/Kore/Builtin/Bool.hs b/kore/test/Test/Kore/Builtin/Bool.hs index be13fda5eb..803422f445 100644 --- a/kore/test/Test/Kore/Builtin/Bool.hs +++ b/kore/test/Test/Kore/Builtin/Bool.hs @@ -162,12 +162,12 @@ test_unifyBoolValues = testCase testName $ do case Bool.matchBools term1 term2 of Just unifyData -> do - actual <- unify term1 term2 unifyData + actual <- unify unifyData assertEqual "" expected actual Nothing -> assertEqual "" expected [Nothing] - unify term1 term2 unifyData = - run (lift $ Bool.unifyBool term1 term2 unifyData) + unify unifyData = + run (lift $ Bool.unifyBool unifyData) test_unifyBoolAnd :: [TestTree] test_unifyBoolAnd = @@ -195,12 +195,12 @@ test_unifyBoolAnd = testCase testName $ do case Bool.matchUnifyBoolAnd term1 term2 of Just unifyData -> do - actual <- unify term1 term2 unifyData + actual <- unify unifyData assertEqual "" expected actual Nothing -> assertEqual "" expected [Nothing] - unify term1 term2 unifyData = - Bool.unifyBoolAnd termSimplifier term1 term2 unifyData + unify unifyData = + Bool.unifyBoolAnd termSimplifier unifyData & lift & run @@ -230,12 +230,12 @@ test_unifyBoolOr = testCase testName $ do case Bool.matchUnifyBoolOr term1 term2 of Just unifyData -> do - actual <- unify term1 term2 unifyData + actual <- unify unifyData assertEqual "" expected actual Nothing -> assertEqual "" expected [Nothing] - unify term1 term2 unifyData = - Bool.unifyBoolOr termSimplifier term1 term2 unifyData + unify unifyData = + Bool.unifyBoolOr termSimplifier unifyData & lift & run diff --git a/kore/test/Test/Kore/Step/Simplification/AndTerms.hs b/kore/test/Test/Kore/Step/Simplification/AndTerms.hs index 1c51743d5e..eafa0305f3 100644 --- a/kore/test/Test/Kore/Step/Simplification/AndTerms.hs +++ b/kore/test/Test/Kore/Step/Simplification/AndTerms.hs @@ -59,6 +59,7 @@ import Kore.Step.Simplification.AndTerms ( functionAnd, matchFunctionAnd, termUnification, + FunctionAnd (..), ) import Kore.Step.Simplification.Equals ( termEquals, @@ -1467,9 +1468,9 @@ test_functionAnd = Pattern.withCondition (f x) $ Condition.fromPredicate $ makeEqualsPredicate (f x) (f y) - let actual = functionAnd (f x) (f y) + let actual = functionAnd $ FunctionAnd (f x) (f y) let matchResult = matchFunctionAnd (f x) (f y) - assertEqual "" (Just ()) matchResult + assertBool "" (isJust matchResult) assertEqual "" expect (Pattern.syncSort actual) assertBool "" (Pattern.isSimplified sideRepresentation actual) ] diff --git a/kore/test/Test/Kore/Step/Simplification/Overloading.hs b/kore/test/Test/Kore/Step/Simplification/Overloading.hs index 333df6e033..dba0073469 100644 --- a/kore/test/Test/Kore/Step/Simplification/Overloading.hs +++ b/kore/test/Test/Kore/Step/Simplification/Overloading.hs @@ -554,7 +554,7 @@ unify termPair = runSimplifier Mock.env $ return unifyResult where unifyResult :: Maybe MatchResult - unifyResult = unifyOverloading Mock.overloadSimplifier termPair + unifyResult = matchResult <$> unifyOverloading Mock.overloadSimplifier termPair withUnification :: (UnificationResult -> Assertion) -> From 030bf0a2317796e3b271b8b94c593f7c532bf08a Mon Sep 17 00:00:00 2001 From: github-actions Date: Wed, 7 Jul 2021 06:22:48 +0000 Subject: [PATCH 81/86] Format with fourmolu --- kore/src/Kore/Builtin/List.hs | 3 +- kore/src/Kore/Builtin/Map.hs | 2 +- kore/src/Kore/Builtin/Set.hs | 2 +- kore/src/Kore/Step/Simplification/AndTerms.hs | 9 ++- .../Kore/Step/Simplification/NoConfusion.hs | 4 +- .../Kore/Step/Simplification/Overloading.hs | 58 +++++++++---------- .../Test/Kore/Step/Simplification/AndTerms.hs | 2 +- 7 files changed, 40 insertions(+), 40 deletions(-) diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index 7e06c920fc..ec709c11c2 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -495,7 +495,8 @@ unifyEquals x1 builtin2 x2 - term1 term2 + term1 + term2 ( [x1@(Var_ _), InternalList_ builtin1] , [x2@(Var_ _), InternalList_ builtin2] ) -> diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 3271f5f612..5bde547c2a 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -565,7 +565,7 @@ matchUnifyEquals tools first second let b' = Ac.asInternal tools sort1 normalized2 in worker a' b' isFirstMatched where - (term1, term2) = if isFirstMatched then (a,b) else (b,a) + (term1, term2) = if isFirstMatched then (a, b) else (b, a) {- | Simplify the conjunction or equality of two concrete Map domain values. diff --git a/kore/src/Kore/Builtin/Set.hs b/kore/src/Kore/Builtin/Set.hs index 21562eb097..e8529ebf0e 100644 --- a/kore/src/Kore/Builtin/Set.hs +++ b/kore/src/Kore/Builtin/Set.hs @@ -569,7 +569,7 @@ matchUnifyEquals tools first second let b' = Ac.asInternal tools sort1 normalized2 in worker a' b' isFirstMatched where - (term1, term2) = if isFirstMatched then (a,b) else (b,a) + (term1, term2) = if isFirstMatched then (a, b) else (b, a) {- | Simplify the conjunction or equality of two concrete Map domain values. diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 4dd8900664..3de180fa50 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -450,8 +450,8 @@ bottomTermEquals OrPattern.map Condition.toPredicate secondCeil , substitution = mempty } - where - BottomTermEquals{term1, term2} = unifyData + where + BottomTermEquals{term1, term2} = unifyData data UnifyVariables = UnifyVariables {variable1, variable2 :: !(ElementVariable RewritingVariableName)} @@ -560,7 +560,6 @@ variableFunctionEquals where VariableFunctionEquals{term1, term2, var} = unifyData - data UnifyInjData = UnifyInjData { term1, term2 :: !(TermLike RewritingVariableName) , unifyInj :: !(UnifyInj (InjPair RewritingVariableName)) @@ -594,8 +593,8 @@ matchInj :: matchInj injSimplifier first second | Inj_ inj1 <- first , Inj_ inj2 <- second = - UnifyInjData first second <$> - matchInjs injSimplifier inj1 inj2 + UnifyInjData first second + <$> matchInjs injSimplifier inj1 inj2 | otherwise = Nothing {-# INLINE matchInj #-} diff --git a/kore/src/Kore/Step/Simplification/NoConfusion.hs b/kore/src/Kore/Step/Simplification/NoConfusion.hs index 26daf692da..42f0d95a88 100644 --- a/kore/src/Kore/Step/Simplification/NoConfusion.hs +++ b/kore/src/Kore/Step/Simplification/NoConfusion.hs @@ -154,5 +154,5 @@ constructorAndEqualsAssumesDifferentHeads term1 term2 empty - where - DifferentConstructors{term1, term2} = unifyData \ No newline at end of file + where + DifferentConstructors{term1, term2} = unifyData diff --git a/kore/src/Kore/Step/Simplification/Overloading.hs b/kore/src/Kore/Step/Simplification/Overloading.hs index ca010f9da4..5b4b635925 100644 --- a/kore/src/Kore/Step/Simplification/Overloading.hs +++ b/kore/src/Kore/Step/Simplification/Overloading.hs @@ -163,38 +163,38 @@ unifyOverloading :: Maybe OverloadingData unifyOverloading overloadSimplifier termPair = OverloadingData term1 term2 <$> case termPair of - Pair - (Inj_ inj@Inj{injChild = App_ firstHead firstChildren}) - secondTerm@(App_ secondHead _) -> - flipResult - <$> unifyOverloadingVsOverloaded + Pair + (Inj_ inj@Inj{injChild = App_ firstHead firstChildren}) + secondTerm@(App_ secondHead _) -> + flipResult + <$> unifyOverloadingVsOverloaded + overloadSimplifier + secondHead + secondTerm + (Application firstHead firstChildren) + inj{injChild = ()} + Pair + firstTerm@(App_ firstHead _) + (Inj_ inj@Inj{injChild = App_ secondHead secondChildren}) -> + unifyOverloadingVsOverloaded overloadSimplifier - secondHead - secondTerm - (Application firstHead firstChildren) - inj{injChild = ()} - Pair - firstTerm@(App_ firstHead _) - (Inj_ inj@Inj{injChild = App_ secondHead secondChildren}) -> - unifyOverloadingVsOverloaded - overloadSimplifier - firstHead - firstTerm - (Application secondHead secondChildren) - inj{injChild = ()} - Pair - (Inj_ inj@Inj{injChild = App_ firstHead firstChildren}) - (Inj_ inj'@Inj{injChild = App_ secondHead secondChildren}) - | injFrom inj /= injFrom inj' -> -- this case should have been handled by now - unifyOverloadingCommonOverload - overloadSimplifier - (Application firstHead firstChildren) + firstHead + firstTerm (Application secondHead secondChildren) inj{injChild = ()} - Pair firstTerm secondTerm -> - case worker firstTerm secondTerm of - Nothing -> worker secondTerm firstTerm - Just result -> Just result + Pair + (Inj_ inj@Inj{injChild = App_ firstHead firstChildren}) + (Inj_ inj'@Inj{injChild = App_ secondHead secondChildren}) + | injFrom inj /= injFrom inj' -> -- this case should have been handled by now + unifyOverloadingCommonOverload + overloadSimplifier + (Application firstHead firstChildren) + (Application secondHead secondChildren) + inj{injChild = ()} + Pair firstTerm secondTerm -> + case worker firstTerm secondTerm of + Nothing -> worker secondTerm firstTerm + Just result -> Just result where Pair term1 term2 = termPair worker :: diff --git a/kore/test/Test/Kore/Step/Simplification/AndTerms.hs b/kore/test/Test/Kore/Step/Simplification/AndTerms.hs index eafa0305f3..b8022bf209 100644 --- a/kore/test/Test/Kore/Step/Simplification/AndTerms.hs +++ b/kore/test/Test/Kore/Step/Simplification/AndTerms.hs @@ -56,10 +56,10 @@ import Kore.Step.Simplification.And ( termAnd, ) import Kore.Step.Simplification.AndTerms ( + FunctionAnd (..), functionAnd, matchFunctionAnd, termUnification, - FunctionAnd (..), ) import Kore.Step.Simplification.Equals ( termEquals, From 9039cdfba43a1f0fa9671834cd580e63f1faef0d Mon Sep 17 00:00:00 2001 From: emarzion Date: Thu, 15 Jul 2021 02:25:39 -0500 Subject: [PATCH 82/86] adding documentation, cleaning up some match/unification code --- kore/src/Kore/Builtin/Bool.hs | 21 ++++--- kore/src/Kore/Builtin/KEqual.hs | 17 ++++-- kore/src/Kore/Builtin/Map.hs | 29 +++------ kore/src/Kore/Step/Simplification/AndTerms.hs | 61 ++++++++++--------- 4 files changed, 67 insertions(+), 61 deletions(-) diff --git a/kore/src/Kore/Builtin/Bool.hs b/kore/src/Kore/Builtin/Bool.hs index 7e3ab3a74a..038e015e6e 100644 --- a/kore/src/Kore/Builtin/Bool.hs +++ b/kore/src/Kore/Builtin/Bool.hs @@ -332,8 +332,7 @@ unifyBoolOr unifyChildren unifyData = data UnifyBoolNot = UnifyBoolNot { boolNot :: !BoolNot - , value :: !Bool - , term :: !(TermLike RewritingVariableName) + , value :: !InternalBool } {- | Matches @@ -357,12 +356,12 @@ matchUnifyBoolNot :: matchUnifyBoolNot first second | Just boolNot <- matchBoolNot first , isFunctionPattern first - , Just value <- matchBool second = - Just UnifyBoolNot{boolNot, value, term = second} + , Just value <- matchInternalBool second = + Just UnifyBoolNot{boolNot, value} | Just boolNot <- matchBoolNot second , isFunctionPattern second - , Just value <- matchBool first = - Just UnifyBoolNot{boolNot, value, term = first} + , Just value <- matchInternalBool first = + Just UnifyBoolNot{boolNot, value} | otherwise = Nothing {-# INLINE matchUnifyBoolNot #-} @@ -372,12 +371,18 @@ unifyBoolNot :: UnifyBoolNot -> unifier (Pattern RewritingVariableName) unifyBoolNot unifyChildren unifyData = - let notValue = asInternal (termLikeSort term) (not value) + let notValue = asInternal internalBoolSort (not internalBoolValue) in unifyChildren notValue operand where - UnifyBoolNot{boolNot, value, term} = unifyData + UnifyBoolNot{boolNot, value} = unifyData + InternalBool{internalBoolValue, internalBoolSort} = value BoolNot{operand} = boolNot +matchInternalBool :: TermLike variable -> Maybe InternalBool +matchInternalBool (InternalBool_ internalBool) = + Just internalBool +matchInternalBool _ = Nothing + -- | Match a @BOOL.Bool@ builtin value. matchBool :: TermLike variable -> Maybe Bool matchBool (InternalBool_ InternalBool{internalBoolValue}) = diff --git a/kore/src/Kore/Builtin/KEqual.hs b/kore/src/Kore/Builtin/KEqual.hs index d6f6efe25f..0c6e2f2753 100644 --- a/kore/src/Kore/Builtin/KEqual.hs +++ b/kore/src/Kore/Builtin/KEqual.hs @@ -289,23 +289,30 @@ data UnifyIfThenElse = UnifyIfThenElse term :: TermLike RewritingVariableName } --- | Match the @KEQUAL.eq@ hooked symbol. +{- | Matches + +@ +\\and{_}(ite(_,_,_), _) +@ + +symmetric in the two arguments. +-} matchIfThenElse :: TermLike RewritingVariableName -> TermLike RewritingVariableName -> Maybe UnifyIfThenElse matchIfThenElse first second - | Just ifThenElse <- match first = + | Just ifThenElse <- matchITE first = Just $ UnifyIfThenElse{ifThenElse, term = second} - | Just ifThenElse <- match second = + | Just ifThenElse <- matchITE second = Just $ UnifyIfThenElse{ifThenElse, term = first} | otherwise = Nothing where - match (App_ symbol [condition, branch1, branch2]) = do + matchITE (App_ symbol [condition, branch1, branch2]) = do hook' <- (getHook . symbolHook) symbol Monad.guard (hook' == iteKey) return IfThenElse{symbol, condition, branch1, branch2} - match _ = Nothing + matchITE _ = Nothing {-# INLINE matchIfThenElse #-} unifyIfThenElse :: diff --git a/kore/src/Kore/Builtin/Map.hs b/kore/src/Kore/Builtin/Map.hs index 5bde547c2a..5b0629e637 100644 --- a/kore/src/Kore/Builtin/Map.hs +++ b/kore/src/Kore/Builtin/Map.hs @@ -624,9 +624,8 @@ matchInKeys = retract data UnifyNotInKeys = UnifyNotInKeys { inKeys :: !(InKeys (TermLike RewritingVariableName)) - , keyTerm, mapTerm :: !(TermLike RewritingVariableName) , concreteKeys, mapKeys, opaqueElements :: ![TermLike RewritingVariableName] - , isFirstMatched :: !Bool + , term :: !(TermLike RewritingVariableName) } data UnifyNotInKeysResult @@ -647,7 +646,7 @@ matchUnifyNotInKeys :: Maybe UnifyNotInKeysResult matchUnifyNotInKeys first second | Just False <- Bool.matchBool first - , Just inKeys@InKeys{keyTerm, mapTerm} <- matchInKeys second + , Just inKeys@InKeys{mapTerm} <- matchInKeys second , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm = let symbolicKeys = getSymbolicKeysOfAc normalizedMap concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap @@ -657,12 +656,10 @@ matchUnifyNotInKeys first second NonNullKeysOrMultipleOpaques UnifyNotInKeys { inKeys - , keyTerm - , mapTerm , concreteKeys , mapKeys , opaqueElements - , isFirstMatched = True + , term = first } in case (mapKeys, opaqueElements) of -- null mapKeys && null opaqueElements @@ -673,7 +670,7 @@ matchUnifyNotInKeys first second -- otherwise _ -> Nothing | Just False <- Bool.matchBool second - , Just inKeys@InKeys{keyTerm, mapTerm} <- matchInKeys first + , Just inKeys@InKeys{mapTerm} <- matchInKeys first , Ac.Normalized normalizedMap <- normalizedOrBottom mapTerm = let symbolicKeys = getSymbolicKeysOfAc normalizedMap concreteKeys = from @Key <$> getConcreteKeysOfAc normalizedMap @@ -683,12 +680,10 @@ matchUnifyNotInKeys first second NonNullKeysOrMultipleOpaques UnifyNotInKeys { inKeys - , keyTerm - , mapTerm , concreteKeys , mapKeys , opaqueElements - , isFirstMatched = False + , term = second } in case (mapKeys, opaqueElements) of -- null mapKeys && null opaqueElements @@ -712,11 +707,9 @@ unifyNotInKeys :: MonadUnify unifier => TermSimplifier RewritingVariableName unifier -> NotSimplifier unifier -> - TermLike RewritingVariableName -> - TermLike RewritingVariableName -> UnifyNotInKeysResult -> unifier (Pattern RewritingVariableName) -unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 termLike2 unifyData = +unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) unifyData = case unifyData of NullKeysNullOpaques -> return Pattern.top NonNullKeysOrMultipleOpaques unifyData' -> @@ -728,11 +721,11 @@ unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 termLike2 u keyConditions <- traverse (unifyAndNegate keyTerm) mapKeys let keyInKeysOpaque = - (\term -> inject @(TermLike _) (inKeys :: InKeys (TermLike RewritingVariableName)){mapTerm = term}) + (\term' -> inject @(TermLike _) (inKeys :: InKeys (TermLike RewritingVariableName)){mapTerm = term'}) <$> opaqueElements opaqueConditions <- - traverse (unifyChildren termLike) keyInKeysOpaque + traverse (unifyChildren term) keyInKeysOpaque let conditions = fmap Pattern.withoutTerm (keyConditions <> opaqueConditions) <> [definedKey, definedMap] @@ -740,14 +733,12 @@ unifyNotInKeys unifyChildren (NotSimplifier notSimplifier) termLike1 termLike2 u where UnifyNotInKeys { inKeys - , keyTerm - , mapTerm , concreteKeys , mapKeys , opaqueElements - , isFirstMatched + , term } = unifyData' - termLike = if isFirstMatched then termLike1 else termLike2 + InKeys{keyTerm, mapTerm} = inKeys where defineTerm :: TermLike RewritingVariableName -> diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index 3de180fa50..e65dade4a7 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -192,7 +192,7 @@ maybeTermEquals notSimplifier childTransformers first second = do | Just unifyData <- Builtin.Map.matchUnifyEquals tools first second = lift $ Builtin.Map.unifyEquals childTransformers tools unifyData | Just unifyData <- Builtin.Map.matchUnifyNotInKeys first second = - lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier first second unifyData + lift $ Builtin.Map.unifyNotInKeys childTransformers notSimplifier unifyData | Just unifyData <- Builtin.Set.matchUnifyEquals tools first second = lift $ Builtin.Set.unifyEquals childTransformers tools unifyData | Just unifyData <- Builtin.List.matchUnifyEqualsList tools first second = @@ -309,7 +309,7 @@ type TermTransformationOld variable unifier = MaybeT unifier (Pattern variable) data UnifyBoolAnd - = UnifyBoolAndBottom !(TermLike RewritingVariableName) !(TermLike RewritingVariableName) + = UnifyBoolAndBottom !Sort !(TermLike RewritingVariableName) | UnifyBoolAndTop !(TermLike RewritingVariableName) {- | Matches @@ -332,11 +332,13 @@ matchBoolAnd :: Maybe UnifyBoolAnd matchBoolAnd term1 term2 | Pattern.isBottom term1 = - Just $ UnifyBoolAndBottom term1 term2 --first, second + let sort = termLikeSort term1 in + Just $ UnifyBoolAndBottom sort term2 | Pattern.isTop term1 = Just $ UnifyBoolAndTop term2 | Pattern.isBottom term2 = - Just $ UnifyBoolAndBottom term2 term1 --second, first + let sort = termLikeSort term2 in + Just $ UnifyBoolAndBottom sort term1 | Pattern.isTop term2 = Just $ UnifyBoolAndTop term1 | otherwise = @@ -350,19 +352,19 @@ boolAnd :: unifier (Pattern RewritingVariableName) boolAnd unifyData = case unifyData of - UnifyBoolAndBottom term1 term2 -> do - explainBoolAndBottom term1 term2 - return $ Pattern.fromTermLike term1 + UnifyBoolAndBottom sort term -> do + explainBoolAndBottom term sort + return $ Pattern.fromTermLike $ mkBottom sort UnifyBoolAndTop term -> do return $ Pattern.fromTermLike term explainBoolAndBottom :: MonadUnify unifier => TermLike RewritingVariableName -> - TermLike RewritingVariableName -> + Sort -> unifier () -explainBoolAndBottom term1 term2 = - explainBottom "Cannot unify bottom." term1 term2 +explainBoolAndBottom term sort = + explainBottom "Cannot unify bottom." (mkBottom sort) term {- | Matches @@ -396,7 +398,8 @@ equalAndEquals term = return (Pattern.fromTermLike term) data BottomTermEquals = BottomTermEquals - { term1, term2 :: !(TermLike RewritingVariableName) + { sort :: !Sort + , term :: !(TermLike RewritingVariableName) } {- | Matches @@ -412,10 +415,10 @@ matchBottomTermEquals :: TermLike RewritingVariableName -> Maybe BottomTermEquals matchBottomTermEquals first second - | Bottom_ _ <- first = - Just BottomTermEquals{term1 = first, term2 = second} - | Bottom_ _ <- second = - Just BottomTermEquals{term1 = second, term2 = first} + | Bottom_ sort <- first = + Just BottomTermEquals{sort, term = second} + | Bottom_ sort <- second = + Just BottomTermEquals{sort, term = first} | otherwise = Nothing {-# INLINE matchBottomTermEquals #-} @@ -430,15 +433,15 @@ bottomTermEquals unifyData = do -- MonadUnify - secondCeil <- makeEvaluateTermCeil sideCondition term2 + secondCeil <- makeEvaluateTermCeil sideCondition term case toList secondCeil of [] -> return Pattern.top [Conditional{predicate = PredicateTrue, substitution}] | substitution == mempty -> do explainBottom "Cannot unify bottom with non-bottom pattern." - term1 - term2 + (mkBottom sort) + term empty _ -> return @@ -451,7 +454,7 @@ bottomTermEquals , substitution = mempty } where - BottomTermEquals{term1, term2} = unifyData + BottomTermEquals{sort, term} = unifyData data UnifyVariables = UnifyVariables {variable1, variable2 :: !(ElementVariable RewritingVariableName)} @@ -640,24 +643,24 @@ data ConstructorSortInjectionAndEquals = ConstructorSortInjectionAndEquals {- | Matches @ -\\equals{_, _}(inj{_,_}(_), f(_)) +\\equals{_, _}(inj{_,_}(_), c(_)) @ @ -\\equals{_, _}(f(_), inj{_,_}(_)) +\\equals{_, _}(c(_), inj{_,_}(_)) @ and @ -\\and{_}(inj{_,_}(_), f(_)) +\\and{_}(inj{_,_}(_), c(_)) @ @ -\\and{_}(f(_), inj{_,_}(_)) +\\and{_}(c(_), inj{_,_}(_)) @ -when @f@ has the @constructor@ attribute. +when @c@ has the @constructor@ attribute. -} matchConstructorSortInjectionAndEquals :: TermLike RewritingVariableName -> @@ -746,22 +749,22 @@ data DVConstrError {- | Matches @ -\\equals{_, _}(\\dv{_}(_), f(_)) +\\equals{_, _}(\\dv{_}(_), c(_)) @ @ -\\equals{_, _}(f(_), \\dv{_}(_)) +\\equals{_, _}(c(_), \\dv{_}(_)) @ @ -\\and{_}(\\dv{_}(_), f(_)) +\\and{_}(\\dv{_}(_), c(_)) @ @ -\\and{_}(f(_), \\dv{_}(_)) +\\and{_}(c(_), \\dv{_}(_)) @ -when @f@ is a constructor. +when @c@ is a constructor. -} matchDomainValueAndConstructorErrors :: TermLike RewritingVariableName -> From eca65c0e20f03b550e824e4f3a2589e8f2cf88d8 Mon Sep 17 00:00:00 2001 From: github-actions Date: Thu, 15 Jul 2021 07:35:26 +0000 Subject: [PATCH 83/86] Format with fourmolu --- kore/src/Kore/Step/Simplification/AndTerms.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/kore/src/Kore/Step/Simplification/AndTerms.hs b/kore/src/Kore/Step/Simplification/AndTerms.hs index e65dade4a7..ed8058bfa0 100644 --- a/kore/src/Kore/Step/Simplification/AndTerms.hs +++ b/kore/src/Kore/Step/Simplification/AndTerms.hs @@ -332,13 +332,13 @@ matchBoolAnd :: Maybe UnifyBoolAnd matchBoolAnd term1 term2 | Pattern.isBottom term1 = - let sort = termLikeSort term1 in - Just $ UnifyBoolAndBottom sort term2 + let sort = termLikeSort term1 + in Just $ UnifyBoolAndBottom sort term2 | Pattern.isTop term1 = Just $ UnifyBoolAndTop term2 | Pattern.isBottom term2 = - let sort = termLikeSort term2 in - Just $ UnifyBoolAndBottom sort term1 + let sort = termLikeSort term2 + in Just $ UnifyBoolAndBottom sort term1 | Pattern.isTop term2 = Just $ UnifyBoolAndTop term1 | otherwise = From 2c6b748c615690e197f8afffcc0d04be2b35dc1b Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 20 Jul 2021 02:36:29 -0500 Subject: [PATCH 84/86] adding back missing calls and making matchUnifyStringEq symmetric again --- kore/src/Kore/Builtin/String.hs | 4 ++++ kore/src/Kore/Simplify/AndTerms.hs | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/kore/src/Kore/Builtin/String.hs b/kore/src/Kore/Builtin/String.hs index e048ba4aaf..ca84bee763 100644 --- a/kore/src/Kore/Builtin/String.hs +++ b/kore/src/Kore/Builtin/String.hs @@ -549,6 +549,10 @@ matchUnifyStringEq first second , isFunctionPattern first , InternalBool_ internalBool <- second = Just UnifyStringEq{eqTerm, internalBool} + | Just eqTerm <- matchStringEqual second + , isFunctionPattern second + , InternalBool_ internalBool <- first = + Just UnifyStringEq{eqTerm, internalBool} | otherwise = Nothing {-# INLINE matchUnifyStringEq #-} diff --git a/kore/src/Kore/Simplify/AndTerms.hs b/kore/src/Kore/Simplify/AndTerms.hs index bcd38feb47..7fe6f8830e 100644 --- a/kore/src/Kore/Simplify/AndTerms.hs +++ b/kore/src/Kore/Simplify/AndTerms.hs @@ -267,6 +267,10 @@ maybeTermAnd notSimplifier childTransformers first second = do lift $ Builtin.Bool.unifyBoolNot childTransformers boolNotData | Just unifyData <- Builtin.KEqual.matchUnifyKequalsEq first second = lift $ Builtin.KEqual.unifyKequalsEq childTransformers notSimplifier unifyData + | Just unifyData <- Builtin.Int.matchUnifyIntEq first second = + lift $ Builtin.Int.unifyIntEq childTransformers notSimplifier unifyData + | Just unifyData <- Builtin.String.matchUnifyStringEq first second = + lift $ Builtin.String.unifyStringEq childTransformers notSimplifier unifyData | Just unifyData <- Builtin.KEqual.matchIfThenElse first second = lift $ Builtin.KEqual.unifyIfThenElse childTransformers unifyData | Just unifyData <- Builtin.Endianness.matchUnifyEqualsEndianness first second = From 5d163b58208eb17faf47aa598665f354e3029081 Mon Sep 17 00:00:00 2001 From: github-actions Date: Tue, 20 Jul 2021 07:38:45 +0000 Subject: [PATCH 85/86] Format with fourmolu --- kore/src/Kore/Builtin/AssociativeCommutative.hs | 6 +++--- kore/src/Kore/Builtin/Endianness.hs | 2 +- kore/src/Kore/Builtin/List.hs | 2 +- kore/src/Kore/Builtin/Signedness.hs | 2 +- kore/src/Kore/Simplify/NoConfusion.hs | 10 +++++----- kore/test/Test/Kore/Simplify/AndTerms.hs | 2 +- 6 files changed, 12 insertions(+), 12 deletions(-) diff --git a/kore/src/Kore/Builtin/AssociativeCommutative.hs b/kore/src/Kore/Builtin/AssociativeCommutative.hs index 426f2c0e5e..7e9b4b0fa5 100644 --- a/kore/src/Kore/Builtin/AssociativeCommutative.hs +++ b/kore/src/Kore/Builtin/AssociativeCommutative.hs @@ -767,9 +767,9 @@ unifyEqualsNormalized case toNormalized patt of Bottom -> debugUnifyBottomAndReturnBottom - "Duplicated elements in normalization." - first - second + "Duplicated elements in normalization." + first + second Normalized n -> return n data UnifyEqualsElementListsData normalized = UnifyEqualsElementListsData diff --git a/kore/src/Kore/Builtin/Endianness.hs b/kore/src/Kore/Builtin/Endianness.hs index 9c211cb511..d3c38779fe 100644 --- a/kore/src/Kore/Builtin/Endianness.hs +++ b/kore/src/Kore/Builtin/Endianness.hs @@ -26,10 +26,10 @@ import Kore.Internal.Pattern ( import qualified Kore.Internal.Pattern as Pattern import Kore.Internal.Symbol import Kore.Internal.TermLike -import Kore.Rewrite.RewritingVariable import Kore.Log.DebugUnifyBottom ( debugUnifyBottomAndReturnBottom, ) +import Kore.Rewrite.RewritingVariable import Kore.Unification.Unify ( MonadUnify, ) diff --git a/kore/src/Kore/Builtin/List.hs b/kore/src/Kore/Builtin/List.hs index fe34ea77e7..89b7aa9b8b 100644 --- a/kore/src/Kore/Builtin/List.hs +++ b/kore/src/Kore/Builtin/List.hs @@ -457,7 +457,7 @@ matchUnifyEqualsList tools first second [var@(Var_ _), InternalList_ builtin2] -> Just $ FramedLeft FramedData{builtin1, builtin2, term1, term2, var} [_, _] -> Nothing - _ -> Just WrongArity + _ -> Just WrongArity | otherwise -> Nothing _ -> Nothing worker _ _ _ _ = Nothing diff --git a/kore/src/Kore/Builtin/Signedness.hs b/kore/src/Kore/Builtin/Signedness.hs index 574e11874c..65984f4c27 100644 --- a/kore/src/Kore/Builtin/Signedness.hs +++ b/kore/src/Kore/Builtin/Signedness.hs @@ -26,10 +26,10 @@ import Kore.Internal.Pattern ( import qualified Kore.Internal.Pattern as Pattern import Kore.Internal.Symbol import Kore.Internal.TermLike -import Kore.Rewrite.RewritingVariable import Kore.Log.DebugUnifyBottom ( debugUnifyBottomAndReturnBottom, ) +import Kore.Rewrite.RewritingVariable import Kore.Unification.Unify ( MonadUnify, ) diff --git a/kore/src/Kore/Simplify/NoConfusion.hs b/kore/src/Kore/Simplify/NoConfusion.hs index 375c0f482b..16c0684257 100644 --- a/kore/src/Kore/Simplify/NoConfusion.hs +++ b/kore/src/Kore/Simplify/NoConfusion.hs @@ -22,8 +22,8 @@ import Kore.Log.DebugUnifyBottom ( import Kore.Rewrite.RewritingVariable ( RewritingVariableName, ) -import Kore.Simplify.Simplify as Simplifier import Kore.Simplify.OverloadSimplifier +import Kore.Simplify.Simplify as Simplifier import Kore.Unification.Unify as Unify import Prelude.Kore hiding ( concat, @@ -151,9 +151,9 @@ constructorAndEqualsAssumesDifferentHeads :: constructorAndEqualsAssumesDifferentHeads unifyData = debugUnifyBottomAndReturnBottom - "Cannot unify different constructors or incompatible \ - \sort injections." - term1 - term2 + "Cannot unify different constructors or incompatible \ + \sort injections." + term1 + term2 where DifferentConstructors{term1, term2} = unifyData diff --git a/kore/test/Test/Kore/Simplify/AndTerms.hs b/kore/test/Test/Kore/Simplify/AndTerms.hs index 0b2993e5d6..4a856c8bae 100644 --- a/kore/test/Test/Kore/Simplify/AndTerms.hs +++ b/kore/test/Test/Kore/Simplify/AndTerms.hs @@ -56,8 +56,8 @@ import Kore.Simplify.And ( termAnd, ) import Kore.Simplify.AndTerms ( - functionAnd, FunctionAnd (..), + functionAnd, matchFunctionAnd, termUnification, ) From 1bcb33217313da9dfe85a9d15afe42d35297ff38 Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 20 Jul 2021 02:41:20 -0500 Subject: [PATCH 86/86] trigger build