Add disjointness heuristic with the help of partitioning (#107)

* Try to detect disjointness in oneOf via partitioning

* Split OpenAPI.Checker.Validate.Schema into modules

* Refactor schema code

* Tweak error messages for NoContradiction

* Refined reports

Co-authored-by: iko <ilyakooo0@gmail.com>

openapi-diff.cabal

@@ -130,6 +130,13 @@ library
                   , OpenAPI.Checker.Validate.RequestBody
                   , OpenAPI.Checker.Validate.Responses
                   , OpenAPI.Checker.Validate.Schema
+                  , OpenAPI.Checker.Validate.Schema.TypedJson
+                  , OpenAPI.Checker.Validate.Schema.DNF
+                  , OpenAPI.Checker.Validate.Schema.Issues
+                  , OpenAPI.Checker.Validate.Schema.JsonFormula
+                  , OpenAPI.Checker.Validate.Schema.Partition
+                  , OpenAPI.Checker.Validate.Schema.Process
+                  , OpenAPI.Checker.Validate.Schema.Traced
                   , OpenAPI.Checker.Validate.SecurityRequirement
                   , OpenAPI.Checker.Validate.Server
                   , OpenAPI.Checker.Validate.Sums

src/OpenAPI/Checker/Report.hs

@@ -37,7 +37,8 @@ import qualified OpenAPI.Checker.PathsPrefixTree as P hiding (empty)
 import OpenAPI.Checker.Report.Jet
 import OpenAPI.Checker.Subtree (invertIssueOrientationP)
 import OpenAPI.Checker.Validate.OpenApi
-import OpenAPI.Checker.Validate.Schema
+import OpenAPI.Checker.Validate.Schema.TypedJson
+import OpenAPI.Checker.Validate.Schema.Issues
 import Text.Pandoc.Builder
 
 type Changes = P.PathsPrefixTree Behave AnIssue 'APILevel

src/OpenAPI/Checker/Validate/Schema/DNF.hs

@@ -0,0 +1,101 @@
+module OpenAPI.Checker.Validate.Schema.DNF
+  ( DNF (..)
+  , Disjunct (..)
+  , pattern SingleDisjunct
+  , pattern TopDNF
+  , pattern BottomDNF
+  , pattern LiteralDNF
+  , foldDNF
+  , forDNF
+  )
+where
+
+import Algebra.Lattice
+import Control.Applicative
+import Data.Foldable
+import qualified Data.Set as S
+
+-- | A boolean formula (without "not") represented as a Disjunctive Normal Form:
+-- the formula is a disjunction of a set of clauses, each of which is a
+-- conjunction of a set of some elementary formulas.
+-- Invariant: no two disjuncts imply eachother
+newtype DNF a = DNF (S.Set (Disjunct a))
+  deriving stock (Eq, Ord, Show)
+
+-- A disjunct is a thing that is to be disjuncted. Itself it is a conjunction of some literals.
+newtype Disjunct a = Disjunct (S.Set a)
+  deriving stock (Eq, Ord, Show)
+
+disjImplies :: Ord a => Disjunct a -> Disjunct a -> Bool
+disjImplies (Disjunct xs) (Disjunct ys) = ys `S.isSubsetOf` xs
+
+disjConjunction :: Ord a => Disjunct a -> Disjunct a -> Disjunct a
+disjConjunction (Disjunct xs) (Disjunct ys) = Disjunct $ xs `S.union` ys
+
+disjAdd :: Ord a => DNF a -> Disjunct a -> DNF a
+disjAdd (DNF yss) xs
+  | any (xs `disjImplies`) yss = DNF yss
+  | otherwise = DNF $ S.insert xs $ S.filter (not . (`disjImplies` xs)) yss
+
+instance Ord a => Lattice (DNF a) where
+  xss \/ DNF yss = S.foldl' disjAdd xss yss
+  DNF xss /\ DNF yss =
+    foldl' disjAdd bottom $
+      liftA2 disjConjunction (S.toList xss) (S.toList yss)
+
+pattern BottomDNF :: DNF a
+pattern BottomDNF <-
+  DNF (S.null -> True)
+  where
+    BottomDNF = DNF S.empty
+
+isSingleton :: S.Set a -> Maybe a
+isSingleton s
+  | S.size s == 1 = S.lookupMin s
+  | otherwise = Nothing
+
+pattern SingleDisjunct :: Ord a => Disjunct a -> DNF a
+pattern SingleDisjunct xs <-
+  DNF (isSingleton -> Just xs)
+  where
+    SingleDisjunct xs = DNF $ S.singleton xs
+
+pattern TopDNF :: DNF a
+pattern TopDNF <-
+  DNF (isSingleton -> Just (Disjunct (S.null -> True)))
+  where
+    TopDNF = DNF $ S.singleton $ Disjunct S.empty
+
+pattern LiteralDNF :: Ord a => a -> DNF a
+pattern LiteralDNF x <-
+  SingleDisjunct (Disjunct (isSingleton -> Just x))
+  where
+    LiteralDNF x = SingleDisjunct $ Disjunct $ S.singleton x
+
+instance Ord a => BoundedJoinSemiLattice (DNF a) where
+  bottom = BottomDNF
+
+instance Ord a => BoundedMeetSemiLattice (DNF a) where
+  top = TopDNF
+
+foldDisjunct :: BoundedMeetSemiLattice l => (a -> l) -> Disjunct a -> l
+foldDisjunct f (Disjunct xs) = S.foldl' (\y l -> y /\ f l) top xs
+
+foldDNF :: BoundedLattice l => (a -> l) -> DNF a -> l
+foldDNF f (DNF xss) = S.foldl' (\y xs -> y \/ foldDisjunct f xs) bottom xss
+
+newtype LiftA f a = LiftA {getLiftA :: f a}
+  deriving newtype (Functor, Applicative)
+
+instance (Lattice a, Applicative f) => Lattice (LiftA f a) where
+  (/\) = liftA2 (/\)
+  (\/) = liftA2 (\/)
+
+instance (BoundedJoinSemiLattice a, Applicative f) => BoundedJoinSemiLattice (LiftA f a) where
+  bottom = pure bottom
+
+instance (BoundedMeetSemiLattice a, Applicative f) => BoundedMeetSemiLattice (LiftA f a) where
+  top = pure top
+
+forDNF :: (BoundedLattice l, Applicative f) => (a -> f l) -> DNF a -> f l
+forDNF f = getLiftA . foldDNF (LiftA . f)

src/OpenAPI/Checker/Validate/Schema/Issues.hs

@@ -0,0 +1,222 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module OpenAPI.Checker.Validate.Schema.Issues
+  ( Issue (..)
+  , Behave (..)
+  )
+where
+
+import qualified Data.Aeson as A
+import Data.OpenApi
+import Data.Scientific
+import Data.Text (Text)
+import qualified Data.Text as T
+import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Validate.Schema.JsonFormula
+import OpenAPI.Checker.Validate.Schema.Partition
+import OpenAPI.Checker.Validate.Schema.TypedJson
+import Text.Pandoc.Builder hiding (Format, Null)
+
+instance Issuable 'TypedSchemaLevel where
+  data Issue 'TypedSchemaLevel
+    = -- | producer produces a specific value ($1), consumer has a condition that is not satisfied by said value
+      EnumDoesntSatisfy A.Value
+    | -- | consumer only expects a specific value which the producer does not produce.
+      NoMatchingEnum A.Value
+    | -- | consumer declares a maximum numeric value ($1), producer doesn't
+      NoMatchingMaximum (Bound Scientific)
+    | -- | consumer declares a maximum numeric value ($1), producer declares a weaker (higher) limit ($2)
+      MatchingMaximumWeak (ProdCons (Bound Scientific))
+    | -- | consumer declares a minimum numeric value, producer doesn't
+      NoMatchingMinimum (Bound Scientific)
+    | -- | consumer declares a minimum numeric value ($1), producer declares a weaker (lower) limit ($2)
+      MatchingMinimumWeak (ProdCons (Bound Scientific))
+    | -- | consumer declares that the numeric value must be a multiple of $1, producer doesn't
+      NoMatchingMultipleOf Scientific
+    | -- | consumer declares that the numeric value must be a multiple of $1, producer declares a weaker condition (multiple of $2)
+      MatchingMultipleOfWeak (ProdCons Scientific)
+    | -- | consumer declares a string/number format, producer declares none or a different format (TODO: improve via regex #32)
+      NoMatchingFormat Format
+    | -- | consumer declares a maximum length of the string ($1), producer doesn't.
+      NoMatchingMaxLength Integer
+    | -- | consumer declares a maximum length of the string ($1), producer declares a weaker (higher) limit ($2)
+      MatchingMaxLengthWeak (ProdCons Integer)
+    | -- | consumer declares a minimum length of the string ($1), producer doesn't.
+      NoMatchingMinLength Integer
+    | -- | consumer declares a minimum length of the string ($1), producer declares a weaker (lower) limit ($2)
+      MatchingMinLengthWeak (ProdCons Integer)
+    | -- | consumer declares the string value must match a regex ($1), producer doesn't declare or declares different regex (TODO: #32)
+      NoMatchingPattern Pattern
+    | -- | consumer declares the items of an array must satisfy some condition, producer doesn't
+      NoMatchingItems
+    | -- | consumer declares a maximum length of the array ($1), producer doesn't.
+      NoMatchingMaxItems Integer
+    | -- | consumer declares a maximum length of the array ($1), producer declares a weaker (higher) limit ($2)
+      MatchingMaxItemsWeak (ProdCons Integer)
+    | -- | consumer declares a minimum length of the array ($1), producer doesn't.
+      NoMatchingMinItems Integer
+    | -- | consumer declares a minimum length of the array ($1), producer declares a weaker (lower) limit ($2)
+      MatchingMinItemsWeak (ProdCons Integer)
+    | -- | consumer declares that items must be unique, producer doesn't
+      NoMatchingUniqueItems
+    | -- | consumer declares the properties of an object must satisfy some condition, producer doesn't
+      NoMatchingProperties
+    | -- | producer allows additional properties, consumer doesn't
+      NoAdditionalProperties
+    | -- | consumer declares a maximum number of properties in the object ($1), producer doesn't.
+      NoMatchingMaxProperties Integer
+    | -- | consumer declares a maximum number of properties in the object ($1), producer declares a weaker (higher) limit ($2)
+      MatchingMaxPropertiesWeak (ProdCons Integer)
+    | -- | consumer declares a minimum number of properties in the object ($1), producer doesn't.
+      NoMatchingMinProperties Integer
+    | -- | consumer declares a minimum number of properties in the object ($1), producer declares a weaker (lower) limit ($2)
+      MatchingMinPropertiesWeak (ProdCons Integer)
+    | -- | producer declares that the value must satisfy a disjunction of some conditions, but consumer's requirements couldn't be matched against any single one of them (TODO: split heuristic #71)
+      NoMatchingCondition (Maybe Partition) [SomeCondition]
+    | -- | consumer indicates that no values of this type are allowed, but we weren't able to conclude that in the producer (currently only immediate contradictions are checked, c.f. #70)
+      TypeBecomesEmpty
+    | -- | consumer indicates that no values in a particular partition are allowed, but we weren't able to conclude this in the producer
+      PartitionBecomesEmpty Partition
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported _ = False
+  describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v
+  describeIssue Backward (EnumDoesntSatisfy v) = para "The following enum value was added:" <> showJSONValue v
+  describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v
+  describeIssue Backward (NoMatchingEnum v) = para "The following enum value has been removed:" <> showJSONValue v
+  describeIssue Forward (NoMatchingMaximum b) = para $ "Upper bound has been added:" <> showBound b <> "."
+  describeIssue Backward (NoMatchingMaximum b) = para $ "Upper bound has been removed:" <> showBound b <> "."
+  describeIssue _ (MatchingMaximumWeak (ProdCons p c)) = para $ "Upper bound changed from " <> showBound p <> " to " <> showBound c <> "."
+  describeIssue Forward (NoMatchingMinimum b) = para $ "Lower bound has been added: " <> showBound b <> "."
+  describeIssue Backward (NoMatchingMinimum b) = para $ "Lower bound has been removed: " <> showBound b <> "."
+  describeIssue _ (MatchingMinimumWeak (ProdCons p c)) = para $ "Lower bound changed from " <> showBound p <> " to " <> showBound c <> "."
+  describeIssue Forward (NoMatchingMultipleOf n) = para $ "Value is now a multiple of " <> show' n <> "."
+  describeIssue Backward (NoMatchingMultipleOf n) = para $ "Value is no longer a multiple of " <> show' n <> "."
+  describeIssue _ (MatchingMultipleOfWeak (ProdCons p c)) = para $ "Value changed from being a multiple of " <> show' p <> " to being a multiple of " <> show' c <> "."
+  describeIssue Forward (NoMatchingFormat f) = para $ "Format added: " <> code f <> "."
+  describeIssue Backward (NoMatchingFormat f) = para $ "Format removed: " <> code f <> "."
+  describeIssue Forward (NoMatchingMaxLength n) = para $ "Maximum length added: " <> show' n <> "."
+  describeIssue Backward (NoMatchingMaxLength n) = para $ "Maximum length removed: " <> show' n <> "."
+  describeIssue _ (MatchingMaxLengthWeak (ProdCons p c)) = para $ "Maximum length of the string changed from " <> show' p <> " to " <> show' c <> "."
+  describeIssue Forward (NoMatchingMinLength n) = para $ "Minimum length of the string added: " <> show' n <> "."
+  describeIssue Backward (NoMatchingMinLength n) = para $ "Minimum length of the string removed: " <> show' n <> "."
+  describeIssue _ (MatchingMinLengthWeak (ProdCons p c)) = para $ "Minimum length of the string changed from " <> show' p <> " to " <> show' c <> "."
+  describeIssue Forward (NoMatchingPattern p) = para "Pattern (regular expression) added: " <> codeBlock p
+  describeIssue Backward (NoMatchingPattern p) = para "Pattern (regular expression) removed: " <> codeBlock p
+  describeIssue Forward NoMatchingItems = para "Array item schema has been added."
+  describeIssue Backward NoMatchingItems = para "Array item schema has been removed."
+  describeIssue Forward (NoMatchingMaxItems n) = para $ "Maximum length of the array has been added " <> show' n <> "."
+  describeIssue Backward (NoMatchingMaxItems n) = para $ "Maximum length of the array has been removed " <> show' n <> "."
+  describeIssue _ (MatchingMaxItemsWeak (ProdCons p c)) = para $ "Maximum length of the array changed from " <> show' p <> " to " <> show' c <> "."
+  describeIssue Forward (NoMatchingMinItems n) = para $ "Minimum length of the array added: " <> show' n <> "."
+  describeIssue Backward (NoMatchingMinItems n) = para $ "Minimum length of the array removed: " <> show' n <> "."
+  describeIssue _ (MatchingMinItemsWeak (ProdCons p c)) = para $ "Minimum length of the array changed from " <> show' p <> " to " <> show' c <> "."
+  describeIssue Forward NoMatchingUniqueItems = para "Items are now required to be unique."
+  describeIssue Backward NoMatchingUniqueItems = para "Items are no longer required to be unique."
+  describeIssue Forward NoMatchingProperties = para "Property added."
+  describeIssue Backward NoMatchingProperties = para "Property removed."
+  describeIssue Forward NoAdditionalProperties = para "Additional properties have been removed."
+  describeIssue Backward NoAdditionalProperties = para "Additional properties have been added."
+  describeIssue Forward (NoMatchingMaxProperties n) = para $ "Maximum number of properties has been added: " <> show' n <> "."
+  describeIssue Backward (NoMatchingMaxProperties n) = para $ "Maximum number of properties has been removed: " <> show' n <> "."
+  describeIssue _ (MatchingMaxPropertiesWeak (ProdCons p c)) = para $ "Maximum number of properties has changed from " <> show' p <> " to " <> show' c <> "."
+  describeIssue Forward (NoMatchingMinProperties n) = para $ "Minimum number of properties added: " <> show' n <> "."
+  describeIssue Backward (NoMatchingMinProperties n) = para $ "Minimum number of properties removed: " <> show' n <> "."
+  describeIssue _ (MatchingMinPropertiesWeak (ProdCons p c)) = para $ "Minimum number of properties has changed from " <> show' p <> " to " <> show' c <> "."
+  describeIssue _ (NoMatchingCondition mPart conds) =
+    para
+      (case mPart of
+         Nothing -> "Could not verify that the following conditions hold (please file a bug if you see this):"
+         Just locPart ->
+           "In cases where " <> showPartition locPart
+             <> " – could not verify that the following conditions hold (please file a bug if you see this):")
+      <> bulletList ((\(SomeCondition c) -> showCondition c) <$> conds)
+  describeIssue Forward TypeBecomesEmpty = para "The type has been removed."
+  describeIssue Backward TypeBecomesEmpty = para "The type has been added."
+  describeIssue Forward (PartitionBecomesEmpty part) = para $ "The case where " <> showPartition part <> " – has been removed."
+  describeIssue Backward (PartitionBecomesEmpty part) = para $ "The case where " <> showPartition part <> " – has been added."
+
+show' :: Show x => x -> Inlines
+show' = str . T.pack . show
+
+instance Issuable 'SchemaLevel where
+  data Issue 'SchemaLevel
+    = -- | Some (openapi-supported) feature that we do not support was encountered in the schema
+      NotSupported Text
+    | -- | We couldn't prove that the branches of a oneOf are disjoint, and we will treat it as an anyOf, meaning we don't check whether the overlaps are excluded in a compatible way
+      OneOfNotDisjoint
+    | -- | The schema is actually invalid
+      InvalidSchema Text
+    | -- | The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".
+      UnguardedRecursion
+    | -- | Producer doesn't place any restrictions on the types, but the consumer does. List what types remain available in the consumer.
+      TypesRestricted [JsonType]
+    | -- | in the producer this field used to be handled as part of "additionalProperties", and the consumer this is a specific "properties" entry. Only thrown when this change actually causes other issues
+      AdditionalToProperty
+    | -- | in the consumer this field used to be handled as part of "additionalProperties", and the producer this is a specific "properties" entry. Only thrown when this change actually causes other issues
+      PropertyToAdditional
+    | -- | consumer requires a property that is not required/allowed in the producer
+      PropertyNowRequired
+    | -- | producer allows a property that is not allowed in the consumer
+      UnexpectedProperty
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported = \case
+    NotSupported _ -> True
+    OneOfNotDisjoint -> True
+    InvalidSchema _ -> True
+    UnguardedRecursion -> True
+    _ -> False
+
+  describeIssue _ (NotSupported i) =
+    para (emph "Encountered a feature that OpenApi Diff does not support: " <> text i <> ".")
+  describeIssue _ OneOfNotDisjoint =
+    para $
+      "Could not deduce that " <> code "oneOf"
+        <> " cases don't overlap. Treating the "
+        <> code "oneOf"
+        <> " as an "
+        <> code "anyOf"
+        <> ". Reported errors might not be accurate."
+  describeIssue _ (InvalidSchema i) =
+    para (emph "The schema is invalid: " <> text i <> ".")
+  describeIssue _ UnguardedRecursion =
+    para "Encountered recursion that is too complex for OpenApi Diff to untangle."
+  describeIssue Forward (TypesRestricted tys) = case tys of
+    [] -> para "No longer has any valid values." -- weird
+    _ -> para "Values are now limited to the following types: " <> bulletList (para . describeJSONType <$> tys)
+  describeIssue Backward (TypesRestricted tys) = case tys of
+    [] -> para "Any value of any type is now allowed." -- weird
+    _ -> para "Values are no longer limited to the following types: " <> bulletList (para . describeJSONType <$> tys)
+  describeIssue Forward AdditionalToProperty = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."
+  describeIssue Backward AdditionalToProperty = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."
+  describeIssue Forward PropertyToAdditional = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."
+  describeIssue Backward PropertyToAdditional = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."
+  describeIssue Forward PropertyNowRequired = para "The property has become required."
+  describeIssue Backward PropertyNowRequired = para "The property may not be present."
+  describeIssue Forward UnexpectedProperty = para "The property has been removed."
+  describeIssue Backward UnexpectedProperty = para "The property has been added."
+
+instance Behavable 'SchemaLevel 'TypedSchemaLevel where
+  data Behave 'SchemaLevel 'TypedSchemaLevel
+    = OfType JsonType
+    deriving stock (Eq, Ord, Show)
+
+  describeBehaviour (OfType t) = describeJSONType t
+
+instance Behavable 'TypedSchemaLevel 'TypedSchemaLevel where
+  data Behave 'TypedSchemaLevel 'TypedSchemaLevel
+    = InPartition Partition
+    deriving stock (Eq, Ord, Show)
+
+  describeBehaviour (InPartition partition) = "In cases where " <> showPartition partition
+
+instance Behavable 'TypedSchemaLevel 'SchemaLevel where
+  data Behave 'TypedSchemaLevel 'SchemaLevel
+    = InItems
+    | InProperty Text
+    | InAdditionalProperty
+    deriving stock (Eq, Ord, Show)
+
+  describeBehaviour InItems = "Items"
+  describeBehaviour (InProperty p) = "Property " <> code p
+  describeBehaviour InAdditionalProperty = "Additional properties"

src/OpenAPI/Checker/Validate/Schema/JsonFormula.hs

@@ -0,0 +1,224 @@
+module OpenAPI.Checker.Validate.Schema.JsonFormula
+  ( Bound (..)
+  , showBound
+  , Property (..)
+  , Condition (..)
+  , showCondition
+  , satisfiesTyped
+  , checkStringFormat
+  , checkNumberFormat
+  , SomeCondition (..)
+  , JsonFormula (..)
+  , satisfiesFormula
+  , satisfies
+  , showJSONValue
+  , showJSONValueInline
+  )
+where
+
+import Algebra.Lattice
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Foldable as F
+import qualified Data.HashMap.Strict as HM
+import Data.Functor
+import Data.Int
+import Data.Kind
+import qualified Data.Map as M
+import Data.Maybe
+import Data.OpenApi
+import Data.Ord
+import Data.Ratio
+import Data.Scientific
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Data.Typeable
+import OpenAPI.Checker.Orphans ()
+import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Validate.Schema.DNF
+import OpenAPI.Checker.Validate.Schema.TypedJson
+import Text.Pandoc.Builder hiding (Format, Null)
+import Text.Regex.Pcre2
+
+data Bound a = Exclusive !a | Inclusive !a
+  deriving stock (Eq, Show, Functor)
+
+-- | The order is lexicographical on @a * Bool@.
+instance Ord a => Ord (Bound a) where
+  Exclusive a `compare` Exclusive b = compare a b
+  Exclusive a `compare` Inclusive b = if a <= b then LT else GT
+  Inclusive a `compare` Exclusive b = if a < b then LT else GT
+  Inclusive a `compare` Inclusive b = compare a b
+
+showBound :: Show a => Bound a -> Inlines
+showBound (Inclusive x) = show' x <> " inclusive"
+showBound (Exclusive x) = show' x <> " exclusive"
+
+data Property = Property
+  { propRequired :: Bool
+  , propFormula :: ForeachType JsonFormula
+  , propRefSchema :: Traced (Referenced Schema)
+  }
+  deriving stock (Eq, Ord, Show)
+
+-- | A primitive structural condition for the "top level" of a JSON value (of a specific type)
+data Condition :: JsonType -> Type where
+  Exactly :: TypedValue t -> Condition t
+  Maximum :: !(Bound Scientific) -> Condition 'Number
+  Minimum
+    :: !(Down (Bound (Down Scientific)))
+    -> Condition 'Number -- ^ this has the right Ord
+  MultipleOf :: !Scientific -> Condition 'Number
+  NumberFormat :: !Format -> Condition 'Number
+  MaxLength :: !Integer -> Condition 'String
+  MinLength :: !Integer -> Condition 'String
+  Pattern :: !Pattern -> Condition 'String
+  StringFormat :: !Format -> Condition 'String
+  Items
+    :: !(ForeachType JsonFormula)
+    -> !(Traced (Referenced Schema))
+    -> Condition 'Array
+  MaxItems :: !Integer -> Condition 'Array
+  MinItems :: !Integer -> Condition 'Array
+  UniqueItems :: Condition 'Array
+  Properties
+    :: !(M.Map Text Property)
+    -> !(ForeachType JsonFormula) -- ^ formula for additional properties
+    -> !(Maybe (Traced (Referenced Schema))) -- ^ schema for additional properties, Nothing means bottom
+    -> Condition 'Object
+  MaxProperties :: !Integer -> Condition 'Object
+  MinProperties :: !Integer -> Condition 'Object
+
+deriving stock instance Eq (Condition t)
+
+deriving stock instance Ord (Condition t)
+
+deriving stock instance Show (Condition t)
+
+showCondition :: Condition a -> Blocks
+showCondition = \case
+  (Exactly v) -> para "The value should be:" <> showJSONValue (untypeValue v)
+  (Maximum b) -> para $ "The value should be less than " <> showBound b <> "."
+  (Minimum (Down b)) -> para $ "The value should be more than " <> showBound (getDown <$> b) <> "."
+  (MultipleOf n) -> para $ "The value should be a multiple of " <> show' n <> "."
+  (NumberFormat p) -> para $ "The number should have the following format:" <> code p <> "."
+  (Pattern p) -> para "The value should satisfy the following pattern (regular expression):" <> codeBlock p
+  (StringFormat p) -> para $ "The string should have the following format:" <> code p <> "."
+  (MaxLength p) -> para $ "The length of the string should be less than or equal to " <> show' p <> "."
+  (MinLength p) -> para $ "The length of the string should be more than or equal to " <> show' p <> "."
+  (Items i _) -> para "The items of the array should satisfy:" <> showForEachJsonFormula i
+  (MaxItems n) -> para $ "The length of the array should be less than or equal to " <> show' n <> "."
+  (MinItems n) -> para $ "The length of the array should be more than or equal to " <> show' n <> "."
+  UniqueItems -> para "The elements in the array should be unique."
+  (Properties props additional _) ->
+    bulletList $
+      (M.toList props
+         <&> (\(k, p) ->
+                para (code k)
+                  <> para (strong $ if propRequired p then "Required" else "Optional")
+                  <> showForEachJsonFormula (propFormula p)))
+        <> [ para (emph "Additional properties")
+               <> showForEachJsonFormula additional
+           ]
+  (MaxProperties n) -> para $ "The maximum number of fields should be " <> show' n <> "."
+  (MinProperties n) -> para $ "The minimum number of fields should be " <> show' n <> "."
+  where
+    showForEachJsonFormula :: ForeachType JsonFormula -> Blocks
+    showForEachJsonFormula i =
+      bulletList $
+        foldType
+          (\t f -> case getJsonFormula $ f i of
+             BottomDNF -> mempty
+             (DNF conds) ->
+                [ para (describeJSONType t)
+                    <> bulletList
+                      (S.toList conds <&> \case
+                         Disjunct (S.toList -> []) -> para "Empty"
+                         Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond))
+                ])
+
+showJSONValue :: A.Value -> Blocks
+showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)
+
+showJSONValueInline :: A.Value -> Inlines
+showJSONValueInline v = code (T.decodeUtf8 . BSL.toStrict . A.encode $ v)
+
+show' :: Show x => x -> Inlines
+show' = str . T.pack . show
+
+satisfiesTyped :: TypedValue t -> Condition t -> Bool
+satisfiesTyped e (Exactly e') = e == e'
+satisfiesTyped (TNumber n) (Maximum (Exclusive m)) = n < m
+satisfiesTyped (TNumber n) (Maximum (Inclusive m)) = n <= m
+satisfiesTyped (TNumber n) (Minimum (Down (Exclusive (Down m)))) = n > m
+satisfiesTyped (TNumber n) (Minimum (Down (Inclusive (Down m)))) = n >= m
+satisfiesTyped (TNumber n) (MultipleOf m) = denominator (toRational n / toRational m) == 1 -- TODO: could be better #36
+satisfiesTyped (TNumber n) (NumberFormat f) = checkNumberFormat f n
+satisfiesTyped (TString s) (MaxLength m) = fromIntegral (T.length s) <= m
+satisfiesTyped (TString s) (MinLength m) = fromIntegral (T.length s) >= m
+satisfiesTyped (TString s) (Pattern p) = isJust $ match p s -- TODO: regex stuff #32
+satisfiesTyped (TString s) (StringFormat f) = checkStringFormat f s
+satisfiesTyped (TArray a) (Items f _) = all (`satisfies` f) a
+satisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m
+satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m
+satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better #36
+satisfiesTyped (TObject o) (Properties props additional _) =
+  all (`HM.member` o) (M.keys (M.filter propRequired props))
+    && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)
+satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m
+satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m
+
+checkNumberFormat :: Format -> Scientific -> Bool
+checkNumberFormat "int32" (toRational -> n) =
+  denominator n == 1
+    && n >= toRational (minBound :: Int32)
+    && n <= toRational (maxBound :: Int32)
+checkNumberFormat "int64" (toRational -> n) =
+  denominator n == 1
+    && n >= toRational (minBound :: Int64)
+    && n <= toRational (maxBound :: Int64)
+checkNumberFormat "float" _n = True
+checkNumberFormat "double" _n = True
+checkNumberFormat f _n = error $ "Invalid number format: " <> T.unpack f
+
+checkStringFormat :: Format -> Text -> Bool
+checkStringFormat "byte" _s = True -- TODO: regex stuff #32
+checkStringFormat "binary" _s = True
+checkStringFormat "date" _s = True
+checkStringFormat "date-time" _s = True
+checkStringFormat "password" _s = True
+checkStringFormat "uuid" _s = True
+checkStringFormat f _s = error $ "Invalid string format: " <> T.unpack f
+
+data SomeCondition where
+  SomeCondition :: Typeable t => Condition t -> SomeCondition
+
+instance Eq SomeCondition where
+  SomeCondition x == SomeCondition y = case cast x of
+    Just x' -> x' == y
+    Nothing -> False
+
+instance Ord SomeCondition where
+  compare (SomeCondition x) (SomeCondition y) = case cast x of
+    Just x' -> compare x' y
+    Nothing -> compare (typeRep x) (typeRep y)
+
+deriving stock instance Show SomeCondition
+
+newtype JsonFormula t = JsonFormula {getJsonFormula :: DNF (Condition t)}
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (Lattice, BoundedJoinSemiLattice, BoundedMeetSemiLattice)
+
+satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool
+satisfiesFormula val = foldDNF (satisfiesTyped val) . getJsonFormula
+
+satisfies :: A.Value -> ForeachType JsonFormula -> Bool
+satisfies val p = case val of
+  A.Null -> satisfiesFormula TNull $ forNull p
+  A.Bool b -> satisfiesFormula (TBool b) $ forBoolean p
+  A.Number n -> satisfiesFormula (TNumber n) $ forNumber p
+  A.String s -> satisfiesFormula (TString s) $ forString p
+  A.Array a -> satisfiesFormula (TArray a) $ forArray p
+  A.Object o -> satisfiesFormula (TObject o) $ forObject p

src/OpenAPI/Checker/Validate/Schema/Partition.hs

@@ -0,0 +1,316 @@
+module OpenAPI.Checker.Validate.Schema.Partition
+  ( partitionSchema
+  , partitionRefSchema
+  , selectPartition
+  , runPartitionM
+  , tryPartition
+  , showPartition
+  , intersectSchema
+  , intersectRefSchema
+  , IntersectionResult (..)
+  , runIntersectionM
+  , Partition
+  )
+where
+
+import Algebra.Lattice
+import Algebra.Lattice.Lifted
+import Control.Applicative
+import Control.Monad.Reader hiding (ask)
+import qualified Control.Monad.Reader as R
+import Control.Monad.State
+import qualified Control.Monad.Trans.Reader as R (liftCatch)
+import qualified Control.Monad.Trans.Writer as W (liftCatch)
+import Control.Monad.Writer
+import qualified Data.Aeson as A
+import Data.Foldable
+import Data.Functor.Identity
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import Data.List (sortBy)
+import qualified Data.List as L
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map as M
+import Data.Maybe
+import Data.OpenApi
+import Data.Ord
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import OpenAPI.Checker.Memo
+import OpenAPI.Checker.References
+import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Validate.Schema.DNF
+import OpenAPI.Checker.Validate.Schema.JsonFormula
+import OpenAPI.Checker.Validate.Schema.Traced
+import OpenAPI.Checker.Validate.Schema.TypedJson
+import Text.Pandoc.Builder hiding (Format, Null)
+
+data PartitionData
+  = DByEnumValue (DNF (S.Set A.Value))
+  | DByProperties (DNF (S.Set Text, S.Set Text)) -- optional, required
+  deriving stock (Eq, Ord, Show)
+
+conjPart :: PartitionData -> PartitionData -> Maybe PartitionData
+conjPart (DByEnumValue xss) (DByEnumValue yss) = Just . DByEnumValue $ xss /\ yss
+conjPart (DByProperties xss) (DByProperties yss) = Just . DByProperties $ xss /\ yss
+conjPart _ _ = Nothing
+
+disjPart :: PartitionData -> PartitionData -> Maybe PartitionData
+disjPart (DByEnumValue xss) (DByEnumValue yss) = Just . DByEnumValue $ xss \/ yss
+disjPart (DByProperties xss) (DByProperties yss) = Just . DByProperties $ xss \/ yss
+disjPart _ _ = Nothing
+
+newtype Partitions = Partitions (M.Map PartitionLocation (S.Set PartitionData))
+  deriving stock (Eq, Ord, Show)
+
+instance Lattice Partitions where
+  Partitions xss /\ Partitions yss = Partitions $ M.unionWith conj xss yss
+    where
+      conj xs ys = S.fromList . catMaybes $ liftA2 conjPart (S.toList xs) (S.toList ys)
+  Partitions xss \/ Partitions yss = Partitions $ M.intersectionWith disj xss yss
+    where
+      disj xs ys = S.fromList . catMaybes $ liftA2 disjPart (S.toList xs) (S.toList ys)
+
+instance BoundedMeetSemiLattice Partitions where
+  top = Partitions M.empty
+
+-- The lattice has no bottom, but we use 'Lifted' to adjoin a free bottom element
+
+type PartitionM = ReaderT (Traced (Definitions Schema)) (State (MemoState ()))
+
+ignoreKnot :: KnotTier (Lifted Partitions) () PartitionM
+ignoreKnot =
+  KnotTier
+    { onKnotFound = pure ()
+    , onKnotUsed = \_ -> pure bottom
+    , tieKnot = \_ -> pure
+    }
+
+singletonPart :: PartitionData -> Lifted Partitions
+singletonPart = Lift . Partitions . M.singleton PHere . S.singleton
+
+partitionSchema :: Traced Schema -> PartitionM (Lifted Partitions)
+partitionSchema sch = do
+  allClauses <- case tracedAllOf sch of
+    Nothing -> pure []
+    Just xs -> mapM partitionRefSchema xs
+
+  anyClause <- case tracedAnyOf sch of
+    Nothing -> pure top
+    Just xs -> joins <$> mapM partitionRefSchema xs
+
+  oneClause <- case tracedOneOf sch of
+    Nothing -> pure top
+    Just xs -> joins <$> mapM partitionRefSchema xs
+
+  byEnumClause <- case _schemaEnum $ extract sch of
+    Nothing -> pure top
+    Just xs ->
+      pure . singletonPart $
+        DByEnumValue $ LiteralDNF (S.fromList xs)
+
+  -- We can only partition by presence of a property if additional properties
+  -- are disallowed, and the property is not optional
+  let reqd = S.fromList $ _schemaRequired $ extract sch
+  byPropertiesClause <- case _schemaAdditionalProperties $ extract sch of
+    Just (AdditionalPropertiesAllowed False) -> do
+      let props = S.fromList . IOHM.keys . _schemaProperties $ extract sch
+      pure . singletonPart $
+        DByProperties $ LiteralDNF (props S.\\ reqd, props `S.intersection` reqd)
+    _ -> pure top
+
+  -- We can partition on something nested in a property only if the property is
+  -- required
+  let reqdProps = IOHM.filterWithKey (\k _ -> k `S.member` reqd) $ tracedProperties sch
+  inPropertiesClauses <- forM (IOHM.toList reqdProps) $ \(k, rs) -> do
+    f <- partitionRefSchema rs
+    pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f
+
+  pure $ meets $ allClauses <> [anyClause, oneClause, byEnumClause, byPropertiesClause] <> inPropertiesClauses
+
+partitionRefSchema :: Traced (Referenced Schema) -> PartitionM (Lifted Partitions)
+partitionRefSchema x = do
+  defs <- R.ask
+  memoWithKnot ignoreKnot (partitionSchema $ dereference defs x) (ask x)
+
+partitionCondition :: Condition t -> PartitionM (Lifted Partitions)
+partitionCondition = \case
+  Exactly x ->
+    pure . singletonPart $
+      DByEnumValue $ LiteralDNF (S.singleton $ untypeValue x)
+  Properties props _ madd -> do
+    let byProps = case madd of
+          Just _ -> top
+          Nothing ->
+            singletonPart $
+              DByProperties $ LiteralDNF
+                ( M.keysSet $ M.filter (not . propRequired) props
+                , M.keysSet $ M.filter propRequired props
+                )
+    inProps <- forM (M.toList $ M.filter propRequired props) $ \(k, prop) -> do
+      f <- partitionRefSchema $ propRefSchema prop
+      pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f
+    pure $ byProps /\ meets inProps
+  _ -> pure top
+
+runPartitionM :: Traced (Definitions Schema) -> PartitionM a -> a
+runPartitionM defs = runIdentity . runMemo () . (`runReaderT` defs)
+
+partitionJsonFormulas
+  :: ProdCons (Traced (Definitions Schema))
+  -> ProdCons (JsonFormula t)
+  -> Lifted Partitions
+partitionJsonFormulas defs pc = producer pcPart \/ consumer pcPart
+  where
+    pcPart = partitionFormula <$> defs <*> pc
+    partitionFormula def (JsonFormula xss) = runPartitionM def $ forDNF partitionCondition xss
+
+selectPartition :: Lifted Partitions -> Maybe (PartitionLocation, S.Set PartitionChoice)
+selectPartition Bottom = Nothing
+selectPartition (Lift (Partitions m)) =
+  go [(loc, part) | (loc, parts) <- sortBy (comparing $ locLength . fst) $ M.toList m, part <- S.toList parts]
+  where
+    locLength :: PartitionLocation -> Int
+    locLength = walk 0
+      where
+        walk !n PHere = n
+        walk !n (PInProperty _ l) = walk (n + 1) l
+    go [] = Nothing
+    -- Skip partitioning by property for now
+    go ((_, DByProperties _) : ps) = go ps
+    -- Don't partition by enum value at the root (this reports removed enum values as contradictions in their respective partitions)
+    go ((PHere, DByEnumValue _) : ps) = go ps
+    go ((loc, DByEnumValue (DNF xss)) : ps)
+      -- Check that no disjunction branches are unresticted
+      | Just enums <- traverse (\(Disjunct xs) -> fmap (foldr1 S.intersection) . NE.nonEmpty . S.toList $ xs) . S.toList $ xss =
+        -- TODO: improve
+        Just (loc, S.map (CByEnumValue . S.singleton) $ S.unions enums)
+      | otherwise = go ps
+
+-- This essentially has 3 cases:
+-- Nothing -- we have produced a bottom schema
+-- Just (False, _) -- there's been no change to the schema
+-- Just (True, x) -- x is a new schema
+type IntersectionM = ReaderT (Traced (Definitions Schema)) (WriterT Any Maybe)
+
+mBottom :: IntersectionM a
+mBottom = lift . lift $ Nothing
+
+catchBottom :: IntersectionM a -> IntersectionM a -> IntersectionM a
+catchBottom act handler = R.liftCatch (W.liftCatch (\a h -> a <|> h ())) act (\_ -> handler)
+
+mChange :: IntersectionM ()
+mChange = tell $ Any True
+
+data IntersectionResult a = Disjoint | Same a | New a
+  deriving stock (Eq, Ord, Show)
+
+runIntersectionM :: Traced (Definitions Schema) -> IntersectionM a -> IntersectionResult a
+runIntersectionM defs act = case runWriterT $ runReaderT act defs of
+  Nothing -> Disjoint
+  Just (x, Any False) -> Same x
+  Just (x, Any True) -> New x
+
+intersectSchema
+  :: PartitionLocation
+  -> PartitionChoice
+  -> Traced Schema
+  -> IntersectionM Schema
+intersectSchema loc part sch = do
+  allOf' <- forM (tracedAllOf sch) $ \rss ->
+    -- Assuming i ranges over a nonempty set (checked in processSchema)
+    -- (⋂_i A[i]) ∩ X = ⋂_i (A[i] ∩ X)
+    -- If any intersections are empty, the result is empty. If any intersections are a change, the result is a change.
+    traverse (intersectRefSchema loc part) rss
+  anyOf' <- forM (tracedAnyOf sch) $ \rss -> do
+    -- (⋃_i A[i]) ∩ X = ⋃_i (A[i] ∩ X)
+    -- Collect only the nonempty A[i] ∩ X, unless there are none, in which case the result is empty.
+    -- If any schema is empty, we remove it from the list which constitutes a change.
+    mSchemas <- forM rss $ \rs -> catchBottom (Just <$> intersectRefSchema loc part rs) (mChange >> pure Nothing)
+    case catMaybes mSchemas of
+      [] -> mBottom
+      schs -> pure schs
+  oneOf' <- forM (tracedOneOf sch) $ \rss -> do
+    -- Same as anyOf'. By intersecting we're only making them more disjoint if anything.
+    mSchemas <- forM rss $ \rs -> catchBottom (Just <$> intersectRefSchema loc part rs) (mChange >> pure Nothing)
+    case catMaybes mSchemas of
+      [] -> mBottom
+      schs -> pure schs
+  let sch' = (extract sch) {_schemaAllOf = allOf', _schemaAnyOf = anyOf', _schemaOneOf = oneOf'}
+  -- Now the local changes:
+  case loc of
+    PInProperty k loc' -> case IOHM.lookup k $ tracedProperties sch of
+      Nothing -> error $ "Partitioning via absent property: " <> T.unpack k
+      Just prop -> do
+        prop' <- intersectRefSchema loc' part prop
+        pure $ sch' {_schemaProperties = IOHM.adjust (const prop') k $ _schemaProperties sch'}
+    PHere -> case part of
+      CByEnumValue vals -> do
+        enum' <- case _schemaEnum sch' of
+          Nothing -> do
+            mChange
+            pure $ S.toList vals
+          Just xs -> do
+            when (any (`S.notMember` vals) xs) mChange
+            case filter (`S.member` vals) xs of
+              [] -> mBottom
+              xs' -> pure xs'
+        pure $ sch' {_schemaEnum = Just enum'}
+      CByProperties {} -> error "CByProperties not implemented"
+
+intersectRefSchema
+  :: PartitionLocation
+  -> PartitionChoice
+  -> Traced (Referenced Schema)
+  -> IntersectionM (Referenced Schema)
+intersectRefSchema loc part rs = do
+  defs <- R.ask
+  Inline <$> intersectSchema loc part (dereference defs rs)
+
+intersectCondition :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> Condition t -> DNF (Condition t)
+intersectCondition _defs PHere (CByEnumValue values) cond@(Exactly x) =
+  if untypeValue x `S.member` values then LiteralDNF cond else bottom
+intersectCondition defs (PInProperty k loc) part cond@(Properties props add madd) = case M.lookup k props of
+  Nothing -> LiteralDNF cond -- shouldn't happen
+  Just prop -> case runIntersectionM defs $ intersectRefSchema loc part $ propRefSchema prop of
+    New rs' ->
+      let trs' = traced (ask (propRefSchema prop) >>> step (Partitioned (loc, part))) rs'
+       in LiteralDNF $ Properties (M.insert k prop {propRefSchema = trs'} props) add madd
+    Same _ -> LiteralDNF cond
+    Disjoint -> bottom
+intersectCondition _defs _loc _part cond = LiteralDNF cond
+
+intersectFormula :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> JsonFormula t -> JsonFormula t
+intersectFormula defs loc part = JsonFormula . foldDNF (intersectCondition defs loc part) . getJsonFormula
+
+tryPartition :: ProdCons (Traced (Definitions Schema)) -> ProdCons (JsonFormula t) -> [(Maybe Partition, ProdCons (JsonFormula t))]
+tryPartition defs pc = case selectPartition $ partitionJsonFormulas defs pc of
+  Nothing -> [(Nothing, pc)]
+  Just (loc, parts) -> [(Just (loc, part), intersectFormula <$> defs <*> pure loc <*> pure part <*> pc) | part <- S.toList parts]
+
+showPartition :: Partition -> Inlines
+showPartition = \case
+  (partition, CByEnumValue (S.toList -> [v])) ->
+    renderPartitionLocation partition <> " is " <> showJSONValueInline v
+  (partition, CByEnumValue (S.toList -> vs)) ->
+    renderPartitionLocation partition <> " has values: "
+      <> (fold . L.intersperse ", " . fmap showJSONValueInline $ vs)
+  (partition, CByProperties (S.toList -> incl) (S.toList -> [])) ->
+    renderPartitionLocation partition <> " contains the properties: " <> listCodes incl
+  (partition, CByProperties (S.toList -> []) (S.toList -> excl)) ->
+    renderPartitionLocation partition <> " does not contain the properties: " <> listCodes excl
+  (partition, CByProperties (S.toList -> incl) (S.toList -> excl)) ->
+    renderPartitionLocation partition
+      <> " contains the properties "
+      <> listCodes incl
+      <> " and does not contain the properties "
+      <> listCodes excl
+  where
+    listCodes :: [Text] -> Inlines
+    listCodes = fold . L.intersperse ", " . fmap code
+    renderPartitionLocation :: PartitionLocation -> Inlines
+    renderPartitionLocation p = code $ "$" <> renderPartitionLocation' p
+      where
+        renderPartitionLocation' :: PartitionLocation -> Text
+        renderPartitionLocation' PHere = mempty
+        renderPartitionLocation' (PInProperty prop rest) = "." <> prop <> renderPartitionLocation' rest

src/OpenAPI/Checker/Validate/Schema/Process.hs

@@ -0,0 +1,372 @@
+module OpenAPI.Checker.Validate.Schema.Process
+  ( schemaToFormula
+  )
+where
+
+import Algebra.Lattice
+import qualified Control.Monad.Reader as R
+import Control.Monad.Reader hiding (ask)
+import Control.Monad.State
+import Control.Monad.Writer
+import qualified Data.Aeson as A
+import Data.Functor.Identity
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import qualified Data.Map as M
+import Data.Maybe
+import Data.OpenApi hiding (get)
+import Data.Ord
+import qualified Data.Set as S
+import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.Memo
+import OpenAPI.Checker.Paths
+import qualified OpenAPI.Checker.PathsPrefixTree as P
+import OpenAPI.Checker.References
+import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Validate.Schema.DNF
+import OpenAPI.Checker.Validate.Schema.Issues
+import OpenAPI.Checker.Validate.Schema.JsonFormula
+import OpenAPI.Checker.Validate.Schema.Partition
+import OpenAPI.Checker.Validate.Schema.Traced
+import OpenAPI.Checker.Validate.Schema.TypedJson
+
+-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.
+newtype Silent w a = Silent {runSilent :: a}
+  deriving stock (Functor)
+  deriving (Applicative, Monad) via Identity
+
+instance Monoid w => MonadWriter w (Silent w) where
+  tell _ = Silent ()
+  listen (Silent x) = Silent (x, mempty)
+  pass (Silent (x, _)) = Silent x
+
+instance MonadState (MemoState ()) (Silent w) where
+  get = Silent $ runIdentity $ runMemo () get
+  put _ = pure ()
+
+type ProcessM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))
+
+type SilentM = ReaderT (Traced (Definitions Schema)) (Silent (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))
+
+-- Either SilentM or ProcessM
+type MonadProcess m =
+  ( MonadReader (Traced (Definitions Schema)) m
+  , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m
+  , MonadState (MemoState ()) m
+  )
+
+warn :: MonadProcess m => Issue 'SchemaLevel -> m ()
+warn issue = tell $ P.singleton $ AnItem Root $ anIssue issue
+
+-- | Ignore warnings but allow a recursive loop that lazily computes a recursive 'Condition'.
+silently :: MonadProcess m => SilentM a -> m a
+silently m = do
+  defs <- R.ask
+  pure . runSilent $ runReaderT m defs
+
+warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m
+warnKnot =
+  KnotTier
+    { onKnotFound = warn UnguardedRecursion
+    , onKnotUsed = \_ -> pure bottom
+    , tieKnot = \_ -> pure
+    }
+
+processRefSchema
+  :: MonadProcess m
+  => Traced (Referenced Schema)
+  -> m (ForeachType JsonFormula)
+processRefSchema x = do
+  defs <- R.ask
+  memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)
+
+-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition
+-- for every possible type of a JSON value. The conditions are independent, and
+-- are thus checked independently.
+processSchema
+  :: MonadProcess m
+  => Traced Schema
+  -> m (ForeachType JsonFormula)
+processSchema sch@(extract -> Schema {..}) = do
+  let singletonFormula :: Condition t -> JsonFormula t
+      singletonFormula = JsonFormula . LiteralDNF
+
+  allClauses <- case tracedAllOf sch of
+    Nothing -> pure []
+    Just [] -> [] <$ warn (InvalidSchema "no items in allOf")
+    Just xs -> mapM processRefSchema xs
+
+  anyClause <- case tracedAnyOf sch of
+    Nothing -> pure top
+    Just [] -> bottom <$ warn (InvalidSchema "no items in anyOf")
+    Just xs -> joins <$> mapM processRefSchema xs
+
+  oneClause <- case tracedOneOf sch of
+    Nothing -> pure top
+    Just [] -> bottom <$ warn (InvalidSchema "no items in oneOf")
+    Just xs -> do
+      checkOneOfDisjoint xs >>= \case
+        True -> pure ()
+        False -> warn OneOfNotDisjoint
+      joins <$> mapM processRefSchema xs
+
+  case _schemaNot of
+    Nothing -> pure ()
+    Just _ -> warn (NotSupported "not clause is unsupported")
+
+  let typeClause = case _schemaType of
+        Nothing -> top
+        Just OpenApiNull ->
+          bottom
+            { forNull = top
+            }
+        Just OpenApiBoolean ->
+          bottom
+            { forBoolean = top
+            }
+        Just OpenApiNumber ->
+          bottom
+            { forNumber = top
+            }
+        Just OpenApiInteger ->
+          bottom
+            { forNumber = singletonFormula $ MultipleOf 1
+            }
+        Just OpenApiString ->
+          bottom
+            { forString = top
+            }
+        Just OpenApiArray ->
+          bottom
+            { forArray = top
+            }
+        Just OpenApiObject ->
+          bottom
+            { forObject = top
+            }
+
+  let valueEnum A.Null =
+        bottom
+          { forNull = singletonFormula $ Exactly TNull
+          }
+      valueEnum (A.Bool b) =
+        bottom
+          { forBoolean = singletonFormula $ Exactly $ TBool b
+          }
+      valueEnum (A.Number n) =
+        bottom
+          { forNumber = singletonFormula $ Exactly $ TNumber n
+          }
+      valueEnum (A.String s) =
+        bottom
+          { forString = singletonFormula $ Exactly $ TString s
+          }
+      valueEnum (A.Array a) =
+        bottom
+          { forArray = singletonFormula $ Exactly $ TArray a
+          }
+      valueEnum (A.Object o) =
+        bottom
+          { forObject = singletonFormula $ Exactly $ TObject o
+          }
+  enumClause <- case _schemaEnum of
+    Nothing -> pure top
+    Just [] -> bottom <$ warn (InvalidSchema "no items in enum")
+    Just xs -> pure $ joins (valueEnum <$> xs)
+
+  let maximumClause = case _schemaMaximum of
+        Nothing -> top
+        Just n ->
+          top
+            { forNumber = singletonFormula $
+                Maximum $
+                  case _schemaExclusiveMaximum of
+                    Just True -> Exclusive n
+                    _ -> Inclusive n
+            }
+
+      minimumClause = case _schemaMinimum of
+        Nothing -> top
+        Just n ->
+          top
+            { forNumber = singletonFormula $
+                Minimum $
+                  Down $
+                    case _schemaExclusiveMinimum of
+                      Just True -> Exclusive $ Down n
+                      _ -> Inclusive $ Down n
+            }
+
+      multipleOfClause = case _schemaMultipleOf of
+        Nothing -> top
+        Just n ->
+          top
+            { forNumber = singletonFormula $ MultipleOf n
+            }
+
+  formatClause <- case _schemaFormat of
+    Nothing -> pure top
+    Just f
+      | f `elem` ["int32", "int64", "float", "double"] ->
+        pure
+          top
+            { forNumber = singletonFormula $ NumberFormat f
+            }
+    Just f
+      | f `elem` ["byte", "binary", "date", "date-time", "password", "uuid"] ->
+        pure
+          top
+            { forString = singletonFormula $ StringFormat f
+            }
+    Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)
+
+  let maxLengthClause = case _schemaMaxLength of
+        Nothing -> top
+        Just n ->
+          top
+            { forString = singletonFormula $ MaxLength n
+            }
+
+      minLengthClause = case _schemaMinLength of
+        Nothing -> top
+        Just n ->
+          top
+            { forString = singletonFormula $ MinLength n
+            }
+
+      patternClause = case _schemaPattern of
+        Nothing -> top
+        Just p ->
+          top
+            { forString = singletonFormula $ Pattern p
+            }
+
+  itemsClause <- case tracedItems sch of
+    Nothing -> pure top
+    Just (Left rs) -> do
+      f <- silently $ processRefSchema rs
+      pure top {forArray = singletonFormula $ Items f rs}
+    Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")
+
+  let maxItemsClause = case _schemaMaxItems of
+        Nothing -> top
+        Just n ->
+          top
+            { forArray = singletonFormula $ MaxItems n
+            }
+
+      minItemsClause = case _schemaMinItems of
+        Nothing -> top
+        Just n ->
+          top
+            { forArray = singletonFormula $ MinItems n
+            }
+
+      uniqueItemsClause = case _schemaUniqueItems of
+        Just True ->
+          top
+            { forArray = singletonFormula UniqueItems
+            }
+        _ -> top
+
+  (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
+    Just (Right rs) -> (,Just rs) <$> silently (processRefSchema rs)
+    Just (Left False) -> pure (bottom, Nothing)
+    _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)
+  propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
+    (f, psch) <- case IOHM.lookup k $ tracedProperties sch of
+      Just rs -> (,rs) <$> silently (processRefSchema rs)
+      Nothing ->
+        let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
+         in -- The mempty here is incorrect, but if addPropSchema was Nothing, then
+            -- addProps is bottom, and k is in _schemaRequired. We handle this situation
+            -- below and short-circuit the entire Properties condition to bottom
+            pure (addProps, fromMaybe fakeSchema addPropSchema)
+    pure (k, Property (k `elem` _schemaRequired) f psch)
+  let allBottom f = getAll $
+        foldType $ \_ ty -> case getJsonFormula $ ty f of
+          BottomDNF -> All True
+          _ -> All False
+      allTop f = getAll $
+        foldType $ \_ ty -> case getJsonFormula $ ty f of
+          TopDNF -> All True
+          _ -> All False
+      -- remove optional fields whose schemata match that of additional props
+      propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList
+      propertiesClause
+        | any (\p -> propRequired p && allBottom (propFormula p)) propMap =
+          bottom -- if any required field has unsatisfiable schema
+        | M.null propMap
+          , allTop addProps =
+          top -- if all fields are optional and have trivial schemata
+        | otherwise =
+          top
+            { forObject = singletonFormula $ Properties propMap addProps addPropSchema
+            }
+
+      maxPropertiesClause = case _schemaMaxProperties of
+        Nothing -> top
+        Just n ->
+          top
+            { forObject = singletonFormula $ MaxProperties n
+            }
+
+      minPropertiesClause = case _schemaMinProperties of
+        Nothing -> top
+        Just n ->
+          top
+            { forObject = singletonFormula $ MinProperties n
+            }
+
+      nullableClause
+        | Just True <- _schemaNullable =
+          bottom
+            { forNull = singletonFormula $ Exactly TNull
+            }
+        | otherwise = bottom
+
+  pure $
+    nullableClause
+      \/ meets
+        (allClauses
+           <> [ anyClause
+              , oneClause
+              , typeClause
+              , enumClause
+              , maximumClause
+              , minimumClause
+              , multipleOfClause
+              , formatClause
+              , maxLengthClause
+              , minLengthClause
+              , patternClause
+              , itemsClause
+              , maxItemsClause
+              , minItemsClause
+              , uniqueItemsClause
+              , propertiesClause
+              , maxPropertiesClause
+              , minPropertiesClause
+              ])
+
+{- TODO: ReadOnly/WriteOnly #68 -}
+
+checkOneOfDisjoint :: MonadProcess m => [Traced (Referenced Schema)] -> m Bool
+checkOneOfDisjoint schs = do
+  defs <- R.ask
+  pure $ case selectPartition $ joins $ runPartitionM defs $ traverse partitionRefSchema schs of
+    Nothing -> False
+    Just (loc, parts) ->
+      let intersects part sch = case runIntersectionM defs $ intersectRefSchema loc part sch of
+            Disjoint -> False
+            _ -> True
+       in all (\part -> 1 >= length (filter (intersects part) schs)) parts
+  where
+
+runProcessM :: Traced (Definitions Schema) -> ProcessM a -> (a, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
+runProcessM defs = runWriter . (`runReaderT` defs) . runMemo ()
+
+schemaToFormula
+  :: Traced (Definitions Schema)
+  -> Traced Schema
+  -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
+schemaToFormula defs rs = runProcessM defs $ processSchema rs

src/OpenAPI/Checker/Validate/Schema/Traced.hs

@@ -0,0 +1,114 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module OpenAPI.Checker.Validate.Schema.Traced
+  ( Step (..)
+  , tracedAllOf
+  , tracedAnyOf
+  , tracedOneOf
+  , tracedItems
+  , tracedAdditionalProperties
+  , tracedDiscriminator
+  , tracedProperties
+  , tracedConjunct
+  , PartitionLocation (..)
+  , PartitionChoice (..)
+  , Partition
+  )
+where
+
+import qualified Data.Aeson as A
+import Data.Functor
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import qualified Data.List.NonEmpty as NE
+import Data.OpenApi
+import qualified Data.Set as S
+import Data.Text (Text)
+import OpenAPI.Checker.Subtree
+
+data PartitionChoice
+  = CByEnumValue (S.Set A.Value)
+  | CByProperties (S.Set Text) (S.Set Text) -- included, excluded
+  deriving stock (Eq, Ord, Show)
+
+data PartitionLocation
+  = PHere
+  | PInProperty Text PartitionLocation
+  deriving stock (Eq, Ord, Show)
+
+type Partition = (PartitionLocation, PartitionChoice)
+
+instance Steppable Schema (Referenced Schema) where
+  data Step Schema (Referenced Schema)
+    = AllOfStep Int
+    | OneOfStep Int
+    | AnyOfStep Int
+    | ItemsObjectStep
+    | ItemsArrayStep Int
+    | AdditionalPropertiesStep
+    | NotStep
+    deriving stock (Eq, Ord, Show)
+
+instance Steppable (Referenced Schema) (Referenced Schema) where
+  data Step (Referenced Schema) (Referenced Schema)
+    = -- | Invariant (for better memoization only): the "tail" of the trace is
+      -- the "least" of the traces of the conjuncted schemata
+      ConjunctedWith (NE.NonEmpty (Trace (Referenced Schema)))
+    | Partitioned Partition
+    deriving stock (Eq, Ord, Show)
+
+instance Steppable Schema (Definitions (Referenced Schema)) where
+  data Step Schema (Definitions (Referenced Schema)) = PropertiesStep
+    deriving stock (Eq, Ord, Show)
+
+instance Steppable Schema Discriminator where
+  data Step Schema Discriminator = DiscriminatorStep
+    deriving stock (Eq, Ord, Show)
+
+instance Steppable Discriminator (Definitions (Referenced Schema)) where
+  data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping
+    deriving stock (Eq, Ord, Show)
+
+tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
+tracedAllOf sch =
+  _schemaAllOf (extract sch) <&> \xs ->
+    [traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0 ..] xs]
+
+tracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
+tracedAnyOf sch =
+  _schemaAnyOf (extract sch) <&> \xs ->
+    [traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0 ..] xs]
+
+tracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
+tracedOneOf sch =
+  _schemaOneOf (extract sch) <&> \xs ->
+    [traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0 ..] xs]
+
+tracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
+tracedItems sch =
+  _schemaItems (extract sch) <&> \case
+    OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x
+    OpenApiItemsArray xs ->
+      Right
+        [traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0 ..] xs]
+
+tracedAdditionalProperties :: Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))
+tracedAdditionalProperties sch =
+  _schemaAdditionalProperties (extract sch) <&> \case
+    AdditionalPropertiesAllowed b -> Left b
+    AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x
+
+tracedDiscriminator :: Traced Schema -> Maybe (Traced Discriminator)
+tracedDiscriminator = sequence . stepTraced DiscriminatorStep . fmap _schemaDiscriminator
+
+tracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))
+tracedProperties sch =
+  IOHM.mapWithKey
+    (\k -> traced (ask sch >>> step PropertiesStep >>> step (InsOrdHashMapKeyStep k)))
+    (_schemaProperties $ extract sch)
+
+tracedConjunct :: NE.NonEmpty (Traced (Referenced Schema)) -> Traced (Referenced Schema)
+tracedConjunct refSchemas = case NE.sortWith ask refSchemas of
+  (rs NE.:| []) -> rs
+  (rs1 NE.:| rs2 : rss) ->
+    traced (ask rs1 >>> step (ConjunctedWith $ ask <$> rs2 NE.:| rss)) $
+      Inline mempty {_schemaAllOf = Just $ extract <$> rs1 : rs2 : rss}

src/OpenAPI/Checker/Validate/Schema/TypedJson.hs

@@ -0,0 +1,118 @@
+module OpenAPI.Checker.Validate.Schema.TypedJson
+  ( JsonType (..)
+  , describeJSONType
+  , TypedValue (..)
+  , untypeValue
+  , ForeachType (..)
+  , foldType
+  , forType_
+  )
+where
+
+import Algebra.Lattice
+import qualified Data.Aeson as A
+import Data.Kind
+import Data.Monoid
+import Data.Scientific
+import Data.String
+import Data.Text (Text)
+import Data.Typeable
+
+-- | Type of a JSON value
+data JsonType
+  = Null
+  | Boolean
+  | Number
+  | String
+  | Array
+  | Object
+  deriving stock (Eq, Ord, Show)
+
+describeJSONType :: IsString s => JsonType -> s
+describeJSONType = \case
+  Null -> "Null"
+  Boolean -> "Boolean"
+  Number -> "Number"
+  String -> "String"
+  Array -> "Array"
+  Object -> "Object"
+
+-- | A 'A.Value' whose type we know
+data TypedValue :: JsonType -> Type where
+  TNull :: TypedValue 'Null
+  TBool :: !Bool -> TypedValue 'Boolean
+  TNumber :: !Scientific -> TypedValue 'Number
+  TString :: !Text -> TypedValue 'String
+  TArray :: !A.Array -> TypedValue 'Array
+  TObject :: !A.Object -> TypedValue 'Object
+
+deriving stock instance Eq (TypedValue t)
+
+deriving stock instance Ord (TypedValue t)
+
+deriving stock instance Show (TypedValue t)
+
+untypeValue :: TypedValue t -> A.Value
+untypeValue TNull = A.Null
+untypeValue (TBool b) = A.Bool b
+untypeValue (TNumber n) = A.Number n
+untypeValue (TString s) = A.String s
+untypeValue (TArray a) = A.Array a
+untypeValue (TObject o) = A.Object o
+
+data ForeachType (f :: JsonType -> Type) = ForeachType
+  { forNull :: f 'Null
+  , forBoolean :: f 'Boolean
+  , forNumber :: f 'Number
+  , forString :: f 'String
+  , forArray :: f 'Array
+  , forObject :: f 'Object
+  }
+
+deriving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)
+
+deriving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)
+
+deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)
+
+foldType :: Monoid m => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m) -> m
+foldType k =
+  k Null forNull
+    <> k Boolean forBoolean
+    <> k Number forNumber
+    <> k String forString
+    <> k Array forArray
+    <> k Object forObject
+
+forType_ :: Applicative m => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m ()) -> m ()
+forType_ k = getAp $ foldType (\ty proj -> Ap $ k ty proj)
+
+broadcastType :: (forall x. Typeable x => f x) -> ForeachType f
+broadcastType k = ForeachType
+  { forNull = k
+  , forBoolean = k
+  , forNumber = k
+  , forString = k
+  , forArray = k
+  , forObject = k
+  }
+
+zipType :: (forall x. Typeable x => f x -> g x -> h x) -> ForeachType f -> ForeachType g -> ForeachType h
+zipType k f1 f2 = ForeachType
+  { forNull = k (forNull f1) (forNull f2)
+  , forBoolean = k (forBoolean f1) (forBoolean f2)
+  , forNumber = k (forNumber f1) (forNumber f2)
+  , forString = k (forString f1) (forString f2)
+  , forArray = k (forArray f1) (forArray f2)
+  , forObject = k (forObject f1) (forObject f2)
+  }
+
+instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where
+  (\/) = zipType (\/)
+  (/\) = zipType (/\)
+
+instance (forall x. BoundedJoinSemiLattice (f x)) => BoundedJoinSemiLattice (ForeachType f) where
+  bottom = broadcastType bottom
+
+instance (forall x. BoundedMeetSemiLattice (f x)) => BoundedMeetSemiLattice (ForeachType f) where
+  top = broadcastType top

test/golden/common/bad-oneof-unchanged/a.yaml

@@ -0,0 +1,39 @@
+openapi: "3.0.0"
+info:
+  version: 1.0.0
+  title: Test
+servers:
+  - url: http://localhost/
+paths:
+  /test:
+    post:
+      requestBody:
+        content:
+          application/json:
+            schema:
+              $ref: "#/components/schemas/Test"
+      responses:
+        '200':
+          description: test
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Test"
+components:
+  schemas:
+    Test:
+      oneOf:
+        - type: object
+          required: ["tag", "prop_A"]
+          properties:
+            tag:
+              enum: ["A"]
+            prop_A:
+              type: string
+        - type: object
+          required: ["tag", "prop_B"]
+          properties:
+            tag:
+              enum: ["A"]
+            prop_B:
+              type: number

test/golden/common/bad-oneof-unchanged/b.yaml

@@ -0,0 +1,39 @@
+openapi: "3.0.0"
+info:
+  version: 1.0.0
+  title: Test
+servers:
+  - url: http://localhost/
+paths:
+  /test:
+    post:
+      requestBody:
+        content:
+          application/json:
+            schema:
+              $ref: "#/components/schemas/Test"
+      responses:
+        '200':
+          description: test
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Test"
+components:
+  schemas:
+    Test:
+      oneOf:
+        - type: object
+          required: ["tag", "prop_B"]
+          properties:
+            tag:
+              enum: ["A"]
+            prop_B:
+              type: number
+        - type: object
+          required: ["tag", "prop_A"]
+          properties:
+            tag:
+              enum: ["A"]
+            prop_A:
+              type: string

test/golden/common/bad-oneof-unchanged/report.md

@@ -0,0 +1,19 @@
+# Summary
+
+| ⚠️ Breaking changes | 🙆 Non-breaking changes | [🤷 Unsupported feature changes](#unsupported-changes) |
+|---------------------|------------------------|-------------------------------------------------------|
+| 0                   | 0                      | 2                                                     |
+
+# <span id="unsupported-changes"></span>🤷 Unsupported feature changes
+
+## **POST** /test
+
+### 📱➡️ JSON Request
+
+Could not deduce that `oneOf` cases don't overlap. Treating the `oneOf`
+as an `anyOf`. Reported errors might not be accurate.
+
+### 📱⬅️ JSON Response – 200
+
+Could not deduce that `oneOf` cases don't overlap. Treating the `oneOf`
+as an `anyOf`. Reported errors might not be accurate.

test/golden/common/bad-oneof-unchanged/trace-tree.yaml

@@ -0,0 +1,18 @@
+breakingChanges:
+  AtPath "/test":
+    InOperation PostMethod:
+      InRequest:
+        InPayload:
+          PayloadSchema: OneOfNotDisjoint
+      WithStatusCode 200:
+        ResponsePayload:
+          PayloadSchema: OneOfNotDisjoint
+nonBreakingChanges:
+  AtPath "/test":
+    InOperation PostMethod:
+      InRequest:
+        InPayload:
+          PayloadSchema: OneOfNotDisjoint
+      WithStatusCode 200:
+        ResponsePayload:
+          PayloadSchema: OneOfNotDisjoint

test/golden/common/pathItem/operation/parameters/change/report.md

@@ -14,7 +14,7 @@
 
 ##### `$(String)`
 
-The value has been removed.
+The type has been removed.
 
 # <span id="non-breaking-changes"></span>🙆 Non-breaking changes
 
@@ -26,4 +26,4 @@ The value has been removed.
 
 ##### `$(Number)`
 
-The value has been added.
+The type has been added.

test/golden/common/pathItem/operation/parameters/change/trace-tree.yaml

@@ -3,10 +3,10 @@ breakingChanges:
     InOperation PostMethod:
       InParam "test":
         InParamSchema:
-          OfType String: NoContradiction
+          OfType String: TypeBecomesEmpty
 nonBreakingChanges:
   AtPath "/test":
     InOperation PostMethod:
       InParam "test":
         InParamSchema:
-          OfType Number: NoContradiction
+          OfType Number: TypeBecomesEmpty

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md

@@ -12,7 +12,7 @@
 
 #### `$(String)`
 
-The value has been removed.
+The type has been removed.
 
 # <span id="non-breaking-changes"></span>🙆 Non-breaking changes
 
@@ -22,4 +22,4 @@ The value has been removed.
 
 #### `$(Number)`
 
-The value has been added.
+The type has been added.

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/trace-tree.yaml

@@ -4,11 +4,11 @@ breakingChanges:
       InRequest:
         InPayload:
           PayloadSchema:
-            OfType String: NoContradiction
+            OfType String: TypeBecomesEmpty
 nonBreakingChanges:
   AtPath "/test":
     InOperation PostMethod:
       InRequest:
         InPayload:
           PayloadSchema:
-            OfType Number: NoContradiction
+            OfType Number: TypeBecomesEmpty

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md

@@ -12,7 +12,7 @@
 
 #### `$(Number)`
 
-The value has been added.
+The type has been added.
 
 # <span id="non-breaking-changes"></span>🙆 Non-breaking changes
 
@@ -22,4 +22,4 @@ The value has been added.
 
 #### `$(String)`
 
-The value has been removed.
+The type has been removed.

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/trace-tree.yaml

@@ -4,11 +4,11 @@ breakingChanges:
       WithStatusCode 200:
         ResponsePayload:
           PayloadSchema:
-            OfType Number: NoContradiction
+            OfType Number: TypeBecomesEmpty
 nonBreakingChanges:
   AtPath "/test":
     InOperation PostMethod:
       WithStatusCode 200:
         ResponsePayload:
           PayloadSchema:
-            OfType String: NoContradiction
+            OfType String: TypeBecomesEmpty

test/golden/common/type-changing/report.md

@@ -32,7 +32,7 @@ Values are now limited to the following types:
 
 #### `$(Array)`
 
-The value has been removed.
+The type has been removed.
 
 ## **POST** /test4
 
@@ -40,7 +40,7 @@ The value has been removed.
 
 #### `$(Object)`
 
-The value has been removed.
+The type has been removed.
 
 ## **POST** /test5
 
@@ -82,7 +82,7 @@ Values are now limited to the following types:
 
 #### `$(Array)`
 
-The value has been removed.
+The type has been removed.
 
 ## **POST** /test4
 
@@ -90,7 +90,7 @@ The value has been removed.
 
 #### `$(Object)`
 
-The value has been removed.
+The type has been removed.
 
 ## **POST** /test5
 

test/golden/common/type-changing/trace-tree.yaml

@@ -11,13 +11,13 @@ breakingChanges:
       InRequest:
         InPayload:
           PayloadSchema:
-            OfType Array: NoContradiction
+            OfType Array: TypeBecomesEmpty
   AtPath "/test4":
     InOperation PostMethod:
       InRequest:
         InPayload:
           PayloadSchema:
-            OfType Object: NoContradiction
+            OfType Object: TypeBecomesEmpty
   AtPath "/test1":
     InOperation PostMethod:
       InRequest:
@@ -41,13 +41,13 @@ nonBreakingChanges:
       WithStatusCode 200:
         ResponsePayload:
           PayloadSchema:
-            OfType Array: NoContradiction
+            OfType Array: TypeBecomesEmpty
   AtPath "/test4":
     InOperation PostMethod:
       WithStatusCode 200:
         ResponsePayload:
           PayloadSchema:
-            OfType Object: NoContradiction
+            OfType Object: TypeBecomesEmpty
   AtPath "/test1":
     InOperation PostMethod:
       WithStatusCode 200:

test/golden/common/variant-added/report.md

@@ -10,9 +10,9 @@
 
 ### 📱⬅️ JSON Response – 200
 
-#### In cases where `$.tag` is `"C"`
+#### `$(Object)`
 
-The value has been added.
+The case where `$.tag` is `"C"` – has been added.
 
 # <span id="non-breaking-changes"></span>🙆 Non-breaking changes
 
@@ -20,6 +20,6 @@ The value has been added.
 
 ### 📱➡️ JSON Request
 
-#### In cases where `$.tag` is `"C"`
+#### `$(Object)`
 
-The value has been added.
+The case where `$.tag` is `"C"` – has been added.

test/golden/common/variant-added/trace-tree.yaml

@@ -4,13 +4,13 @@ breakingChanges:
       WithStatusCode 200:
         ResponsePayload:
           PayloadSchema:
-            OfType Object:
-              InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "C"])): NoContradiction
+            OfType Object: PartitionBecomesEmpty (PInProperty "tag" PHere,CByEnumValue
+              (fromList [String "C"]))
 nonBreakingChanges:
   AtPath "/test":
     InOperation PostMethod:
       InRequest:
         InPayload:
           PayloadSchema:
-            OfType Object:
-              InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "C"])): NoContradiction
+            OfType Object: PartitionBecomesEmpty (PInProperty "tag" PHere,CByEnumValue
+              (fromList [String "C"]))

test/golden/common/variant-changed/report.md

@@ -14,7 +14,7 @@
 
 ##### `$.prop_B(Number)`
 
-The value has been removed.
+The type has been removed.
 
 ### 📱⬅️ JSON Response – 200
 
@@ -22,7 +22,7 @@ The value has been removed.
 
 ##### `$.prop_B(String)`
 
-The value has been added.
+The type has been added.
 
 # <span id="non-breaking-changes"></span>🙆 Non-breaking changes
 
@@ -34,7 +34,7 @@ The value has been added.
 
 ##### `$.prop_B(String)`
 
-The value has been added.
+The type has been added.
 
 ### 📱⬅️ JSON Response – 200
 
@@ -42,4 +42,4 @@ The value has been added.
 
 ##### `$.prop_B(Number)`
 
-The value has been removed.
+The type has been removed.

test/golden/common/variant-changed/trace-tree.yaml

@@ -7,14 +7,14 @@ breakingChanges:
             OfType Object:
               InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "B"])):
                 InProperty "prop_B":
-                  OfType Number: NoContradiction
+                  OfType Number: TypeBecomesEmpty
       WithStatusCode 200:
         ResponsePayload:
           PayloadSchema:
             OfType Object:
               InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "B"])):
                 InProperty "prop_B":
-                  OfType String: NoContradiction
+                  OfType String: TypeBecomesEmpty
 nonBreakingChanges:
   AtPath "/test":
     InOperation PostMethod:
@@ -24,11 +24,11 @@ nonBreakingChanges:
             OfType Object:
               InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "B"])):
                 InProperty "prop_B":
-                  OfType String: NoContradiction
+                  OfType String: TypeBecomesEmpty
       WithStatusCode 200:
         ResponsePayload:
           PayloadSchema:
             OfType Object:
               InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "B"])):
                 InProperty "prop_B":
-                  OfType Number: NoContradiction
+                  OfType Number: TypeBecomesEmpty

test/golden/common/variant-deep-changed/report.md

@@ -14,7 +14,7 @@
 
 ##### `$.prop_B(Number)`
 
-The value has been removed.
+The type has been removed.
 
 ### 📱⬅️ JSON Response – 200
 
@@ -22,7 +22,7 @@ The value has been removed.
 
 ##### `$.prop_B(String)`
 
-The value has been added.
+The type has been added.
 
 # <span id="non-breaking-changes"></span>🙆 Non-breaking changes
 
@@ -34,7 +34,7 @@ The value has been added.
 
 ##### `$.prop_B(String)`
 
-The value has been added.
+The type has been added.
 
 ### 📱⬅️ JSON Response – 200
 
@@ -42,4 +42,4 @@ The value has been added.
 
 ##### `$.prop_B(Number)`
 
-The value has been removed.
+The type has been removed.

test/golden/common/variant-deep-changed/trace-tree.yaml

@@ -7,14 +7,14 @@ breakingChanges:
             OfType Object:
               InPartition (PInProperty "desc" (PInProperty "name" PHere),CByEnumValue (fromList [String "B"])):
                 InProperty "prop_B":
-                  OfType Number: NoContradiction
+                  OfType Number: TypeBecomesEmpty
       WithStatusCode 200:
         ResponsePayload:
           PayloadSchema:
             OfType Object:
               InPartition (PInProperty "desc" (PInProperty "name" PHere),CByEnumValue (fromList [String "B"])):
                 InProperty "prop_B":
-                  OfType String: NoContradiction
+                  OfType String: TypeBecomesEmpty
 nonBreakingChanges:
   AtPath "/test":
     InOperation PostMethod:
@@ -24,11 +24,11 @@ nonBreakingChanges:
             OfType Object:
               InPartition (PInProperty "desc" (PInProperty "name" PHere),CByEnumValue (fromList [String "B"])):
                 InProperty "prop_B":
-                  OfType String: NoContradiction
+                  OfType String: TypeBecomesEmpty
       WithStatusCode 200:
         ResponsePayload:
           PayloadSchema:
             OfType Object:
               InPartition (PInProperty "desc" (PInProperty "name" PHere),CByEnumValue (fromList [String "B"])):
                 InProperty "prop_B":
-                  OfType Number: NoContradiction
+                  OfType Number: TypeBecomesEmpty