@@ -0,0 +1,1627 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+module OpenAPI.Checker.Validate.Schema
18+import Algebra.Lattice
19+import Algebra.Lattice.Lifted
20+import Control.Applicative
22+import Control.Comonad.Env hiding (env)
23+import Control.Monad.Reader hiding (ask)
24+import qualified Control.Monad.Reader as R
25+import Control.Monad.State
26+import qualified Control.Monad.Trans.Reader as R (liftCatch)
27+import qualified Control.Monad.Trans.Writer as W (liftCatch)
28+import Control.Monad.Writer
29+import qualified Data.Aeson as A
30+import qualified Data.ByteString.Lazy as BSL
33+import qualified Data.Foldable as F
35+import Data.Functor.Identity
37+import qualified Data.HashMap.Strict as HM
38+import qualified Data.HashMap.Strict.InsOrd as IOHM
41+import Data.List (sortBy)
42+import qualified Data.List as L
43+import qualified Data.List.NonEmpty as NE
44+import qualified Data.Map as M
46+import Data.OpenApi hiding (get)
49+import Data.Scientific
50+import qualified Data.Set as S
52+import Data.Text (Text)
53+import qualified Data.Text as T hiding (singleton)
54+import qualified Data.Text.Encoding as T
56+import OpenAPI.Checker.Behavior
57+import OpenAPI.Checker.Memo
58+import OpenAPI.Checker.Orphans ()
59+import OpenAPI.Checker.Paths
60+import qualified OpenAPI.Checker.PathsPrefixTree as P
61+import OpenAPI.Checker.References
62+import OpenAPI.Checker.Subtree
63+import Text.Pandoc.Builder hiding (Format, Null)
64+import Text.Regex.Pcre2
66+-- | Type of a JSON value
74+ deriving stock (Eq, Ord, Show)
76+-- | A 'A.Value' whose type we know
77+data TypedValue :: JsonType -> Type where
78+ TNull :: TypedValue 'Null
79+ TBool :: !Bool -> TypedValue 'Boolean
80+ TNumber :: !Scientific -> TypedValue 'Number
81+ TString :: !Text -> TypedValue 'String
82+ TArray :: !A.Array -> TypedValue 'Array
83+ TObject :: !A.Object -> TypedValue 'Object
85+deriving stock instance Eq (TypedValue t)
87+deriving stock instance Ord (TypedValue t)
89+deriving stock instance Show (TypedValue t)
91+untypeValue :: TypedValue t -> A.Value
92+untypeValue TNull = A.Null
93+untypeValue (TBool b) = A.Bool b
94+untypeValue (TNumber n) = A.Number n
95+untypeValue (TString s) = A.String s
96+untypeValue (TArray a) = A.Array a
97+untypeValue (TObject o) = A.Object o
99+data Bound a = Exclusive !a | Inclusive !a
100+ deriving stock (Eq, Show, Functor)
102+-- | The order is lexicographical on @a * Bool@.
103+instance Ord a => Ord (Bound a) where
104+ Exclusive a `compare` Exclusive b = compare a b
105+ Exclusive a `compare` Inclusive b = if a <= b then LT else GT
106+ Inclusive a `compare` Exclusive b = if a < b then LT else GT
107+ Inclusive a `compare` Inclusive b = compare a b
109+data Property = Property
110+ { propRequired :: Bool
111+ , propFormula :: ForeachType JsonFormula
112+ , propRefSchema :: Traced (Referenced Schema)
114+ deriving stock (Eq, Ord, Show)
116+-- | A primitive structural condition for the "top level" of a JSON value (of a specific type)
117+data Condition :: JsonType -> Type where
118+ Exactly :: TypedValue t -> Condition t
119+ Maximum :: !(Bound Scientific) -> Condition 'Number
121+ :: !(Down (Bound (Down Scientific)))
122+ -> Condition 'Number -- ^ this has the right Ord
123+ MultipleOf :: !Scientific -> Condition 'Number
124+ NumberFormat :: !Format -> Condition 'Number
125+ MaxLength :: !Integer -> Condition 'String
126+ MinLength :: !Integer -> Condition 'String
127+ Pattern :: !Pattern -> Condition 'String
128+ StringFormat :: !Format -> Condition 'String
130+ :: !(ForeachType JsonFormula)
131+ -> !(Traced (Referenced Schema))
133+ MaxItems :: !Integer -> Condition 'Array
134+ MinItems :: !Integer -> Condition 'Array
135+ UniqueItems :: Condition 'Array
137+ :: !(M.Map Text Property)
138+ -> !(ForeachType JsonFormula) -- ^ formula for additional properties
139+ -> !(Maybe (Traced (Referenced Schema))) -- ^ schema for additional properties, Nothing means bottom
140+ -> Condition 'Object
141+ MaxProperties :: !Integer -> Condition 'Object
142+ MinProperties :: !Integer -> Condition 'Object
144+showCondition :: Condition a -> Blocks
145+showCondition = \case
146+ (Exactly v) -> para "The value should be:" <> showJSONValue (untypeValue v)
147+ (Maximum b) -> para $ "The value should be less than " <> showBound b <> "."
148+ (Minimum (Down b)) -> para $ "The value should be more than " <> showBound (getDown <$> b) <> "."
149+ (MultipleOf n) -> para $ "The value should be a multiple of " <> show' n <> "."
150+ (NumberFormat p) -> para $ "The number should have the following format:" <> code p <> "."
151+ (Pattern p) -> para "The value should satisfy the following pattern (regular expression):" <> codeBlock p
152+ (StringFormat p) -> para $ "The string should have the following format:" <> code p <> "."
153+ (MaxLength p) -> para $ "The length of the string should be less than or equal to " <> show' p <> "."
154+ (MinLength p) -> para $ "The length of the string should be more than or equal to " <> show' p <> "."
155+ (Items i _) -> para "The items of the array should satisfy:" <> showForEachJsonFormula i
156+ (MaxItems n) -> para $ "The length of the array should be less than or equal to " <> show' n <> "."
157+ (MinItems n) -> para $ "The length of the array should be more than or equal to " <> show' n <> "."
158+ UniqueItems -> para "The elements in the array should be unique."
159+ (Properties props additional _) ->
164+ <> para (strong $ if propRequired p then "Required" else "Optional")
165+ <> showForEachJsonFormula (propFormula p)))
166+ <> [ para (emph "Additional properties")
167+ <> showForEachJsonFormula additional
169+ (MaxProperties n) -> para $ "The maximum number of fields should be " <> show' n <> "."
170+ (MinProperties n) -> para $ "The minimum number of fields should be " <> show' n <> "."
172+ showForEachJsonFormula :: ForeachType JsonFormula -> Blocks
173+ showForEachJsonFormula i =
176+ (\t f -> case getJsonFormula $ f i of
177+ BottomFormula -> mempty
179+ let conds = S.toList <$> S.toList conds'
180+ in [ para (describeJSONType t)
184+ cond -> bulletList (showCondition <$> cond))
187+satisfiesTyped :: TypedValue t -> Condition t -> Bool
188+satisfiesTyped e (Exactly e') = e == e'
189+satisfiesTyped (TNumber n) (Maximum (Exclusive m)) = n < m
190+satisfiesTyped (TNumber n) (Maximum (Inclusive m)) = n <= m
191+satisfiesTyped (TNumber n) (Minimum (Down (Exclusive (Down m)))) = n > m
192+satisfiesTyped (TNumber n) (Minimum (Down (Inclusive (Down m)))) = n >= m
193+satisfiesTyped (TNumber n) (MultipleOf m) = denominator (toRational n / toRational m) == 1 -- TODO: could be better #36
194+satisfiesTyped (TNumber n) (NumberFormat f) = checkNumberFormat f n
195+satisfiesTyped (TString s) (MaxLength m) = fromIntegral (T.length s) <= m
196+satisfiesTyped (TString s) (MinLength m) = fromIntegral (T.length s) >= m
197+satisfiesTyped (TString s) (Pattern p) = isJust $ match p s -- TODO: regex stuff #32
198+satisfiesTyped (TString s) (StringFormat f) = checkStringFormat f s
199+satisfiesTyped (TArray a) (Items f _) = all (`satisfies` f) a
200+satisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m
201+satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m
202+satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better #36
203+satisfiesTyped (TObject o) (Properties props additional _) =
204+ all (`HM.member` o) (M.keys (M.filter propRequired props))
205+ && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)
206+satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m
207+satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m
209+checkNumberFormat :: Format -> Scientific -> Bool
210+checkNumberFormat "int32" (toRational -> n) =
212+ && n >= toRational (minBound :: Int32)
213+ && n <= toRational (maxBound :: Int32)
214+checkNumberFormat "int64" (toRational -> n) =
216+ && n >= toRational (minBound :: Int64)
217+ && n <= toRational (maxBound :: Int64)
218+checkNumberFormat "float" _n = True
219+checkNumberFormat "double" _n = True
220+checkNumberFormat f _n = error $ "Invalid number format: " <> T.unpack f
222+checkStringFormat :: Format -> Text -> Bool
223+checkStringFormat "byte" _s = True -- TODO: regex stuff #32
224+checkStringFormat "binary" _s = True
225+checkStringFormat "date" _s = True
226+checkStringFormat "date-time" _s = True
227+checkStringFormat "password" _s = True
228+checkStringFormat "uuid" _s = True
229+checkStringFormat f _s = error $ "Invalid string format: " <> T.unpack f
231+deriving stock instance Eq (Condition t)
233+deriving stock instance Ord (Condition t)
235+deriving stock instance Show (Condition t)
237+data SomeCondition where
238+ SomeCondition :: Typeable t => Condition t -> SomeCondition
240+instance Eq SomeCondition where
241+ SomeCondition x == SomeCondition y = case cast x of
245+instance Ord SomeCondition where
246+ compare (SomeCondition x) (SomeCondition y) = case cast x of
247+ Just x' -> compare x' y
248+ Nothing -> compare (typeRep x) (typeRep y)
250+deriving stock instance Show SomeCondition
252+-- | A boolean formula (without "not") represented as a Disjunctive Normal Form:
253+-- the formula is a disjunction of a set of conjuncts, each of which is a
254+-- conjunction of a set of some elementary formulas.
256+ = DNF (S.Set (S.Set a))
257+ deriving stock (Eq, Ord, Show)
259+disjAdd :: Ord a => DNF a -> S.Set a -> DNF a
261+ | any (`S.isSubsetOf` xs) yss = DNF yss
262+ | otherwise = DNF $ S.insert xs $ S.filter (not . S.isSubsetOf xs) yss
264+instance Ord a => Lattice (DNF a) where
265+ xss \/ DNF yss = S.foldl' disjAdd xss yss
266+ DNF xss /\ DNF yss =
267+ F.foldl' disjAdd bottom $
268+ liftA2 S.union (S.toList xss) (S.toList yss)
270+pattern BottomFormula :: DNF a
271+pattern BottomFormula <-
272+ DNF (S.null -> True)
274+ BottomFormula = DNF S.empty
276+isSingleton :: S.Set a -> Maybe a
278+ | S.size s == 1 = S.lookupMin s
279+ | otherwise = Nothing
281+pattern Conjunct :: Ord a => [a] -> S.Set a
282+pattern Conjunct xs <-
285+ Conjunct = S.fromList
287+{-# COMPLETE Conjunct #-}
289+pattern SingleConjunct :: Ord a => [a] -> DNF a
290+pattern SingleConjunct xs <-
291+ DNF (isSingleton -> Just (Conjunct xs))
293+ SingleConjunct xs = DNF $ S.singleton $ Conjunct xs
295+pattern TopFormula :: DNF a
296+pattern TopFormula <-
297+ DNF (isSingleton -> Just (S.null -> True))
299+ TopFormula = DNF $ S.singleton S.empty
301+instance Ord a => BoundedJoinSemiLattice (DNF a) where
302+ bottom = BottomFormula
304+instance Ord a => BoundedMeetSemiLattice (DNF a) where
312+foldLattice f (DNF xss) =
315+ z \/ S.foldl' (\x y -> x /\ f y) top w)
319+newtype JsonFormula t = JsonFormula {getJsonFormula :: DNF (Condition t)}
320+ deriving stock (Eq, Ord, Show)
321+ deriving newtype (Lattice, BoundedJoinSemiLattice, BoundedMeetSemiLattice)
323+satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool
324+satisfiesFormula val = foldLattice (satisfiesTyped val) . getJsonFormula
326+data ForeachType (f :: JsonType -> Type) = ForeachType
327+ { forNull :: f 'Null
328+ , forBoolean :: f 'Boolean
329+ , forNumber :: f 'Number
330+ , forString :: f 'String
331+ , forArray :: f 'Array
332+ , forObject :: f 'Object
335+satisfies :: A.Value -> ForeachType JsonFormula -> Bool
336+satisfies val p = case val of
337+ A.Null -> satisfiesFormula TNull $ forNull p
338+ A.Bool b -> satisfiesFormula (TBool b) $ forBoolean p
339+ A.Number n -> satisfiesFormula (TNumber n) $ forNumber p
340+ A.String s -> satisfiesFormula (TString s) $ forString p
341+ A.Array a -> satisfiesFormula (TArray a) $ forArray p
342+ A.Object o -> satisfiesFormula (TObject o) $ forObject p
344+deriving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)
346+deriving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)
348+deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)
352+ => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m)
356+ <> k Boolean forBoolean
357+ <> k Number forNumber
358+ <> k String forString
360+ <> k Object forObject
364+ => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m ())
368+ k Boolean forBoolean
375+instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where
378+ { forNull = forNull f1 \/ forNull f2
379+ , forBoolean = forBoolean f1 \/ forBoolean f2
380+ , forNumber = forNumber f1 \/ forNumber f2
381+ , forString = forString f1 \/ forString f2
382+ , forArray = forArray f1 \/ forArray f2
383+ , forObject = forObject f1 \/ forObject f2
387+ { forNull = forNull f1 /\ forNull f2
388+ , forBoolean = forBoolean f1 /\ forBoolean f2
389+ , forNumber = forNumber f1 /\ forNumber f2
390+ , forString = forString f1 /\ forString f2
391+ , forArray = forArray f1 /\ forArray f2
392+ , forObject = forObject f1 /\ forObject f2
396+ (forall x. BoundedJoinSemiLattice (f x))
397+ => BoundedJoinSemiLattice (ForeachType f)
402+ , forBoolean = bottom
403+ , forNumber = bottom
404+ , forString = bottom
406+ , forObject = bottom
410+ (forall x. BoundedMeetSemiLattice (f x))
411+ => BoundedMeetSemiLattice (ForeachType f)
423+instance Steppable Schema (Referenced Schema) where
424+ data Step Schema (Referenced Schema)
429+ | ItemsArrayStep Int
430+ | AdditionalPropertiesStep
432+ deriving stock (Eq, Ord, Show)
434+instance Steppable (Referenced Schema) (Referenced Schema) where
435+ data Step (Referenced Schema) (Referenced Schema)
436+ = -- | Invariant (for better memoization only): the "tail" of the trace is
437+ -- the "least" of the traces of the conjuncted schemata
438+ ConjunctedWith (NE.NonEmpty (Trace (Referenced Schema)))
439+ | Partitioned PartitionLocation PartitionChoice
440+ deriving stock (Eq, Ord, Show)
442+instance Steppable Schema (Definitions (Referenced Schema)) where
443+ data Step Schema (Definitions (Referenced Schema)) = PropertiesStep
444+ deriving stock (Eq, Ord, Show)
446+instance Steppable Schema Discriminator where
447+ data Step Schema Discriminator = DiscriminatorStep
448+ deriving stock (Eq, Ord, Show)
450+instance Steppable Discriminator (Definitions (Referenced Schema)) where
451+ data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping
452+ deriving stock (Eq, Ord, Show)
454+parseDiscriminatorValue :: Text -> Referenced Schema
455+parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of
457+ A.Error _ -> Ref $ Reference v
459+-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.
460+newtype Silent q f r a = Silent {runSilent :: a}
461+ deriving stock (Functor)
462+ deriving (Applicative, Monad) via Identity
464+instance MonadWriter (P.PathsPrefixTree q f r) (Silent q f r) where
466+ listen (Silent x) = Silent (x, P.empty)
467+ pass (Silent (x, _)) = Silent x
469+instance MonadState (MemoState ()) (Silent q f r) where
470+ get = Silent $ runIdentity $ runMemo () get
473+type MonadProcess m =
474+ ( MonadReader (Traced (Definitions Schema)) m
475+ , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m
476+ , MonadState (MemoState ()) m
479+type SilentM = ReaderT (Traced (Definitions Schema)) (Silent Behave AnIssue 'SchemaLevel)
481+warn :: MonadProcess m => Issue 'SchemaLevel -> m ()
482+warn issue = tell $ P.singleton $ AnItem Root $ anIssue issue
484+-- | Ignore warnings but allow a recursive loop that lazily computes a recursive 'Condition'.
485+silently :: MonadProcess m => SilentM a -> m a
488+ pure . runSilent $ runReaderT m defs
490+warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m
493+ { onKnotFound = warn UnguardedRecursion
494+ , onKnotUsed = \_ -> pure bottom
495+ , tieKnot = \_ -> pure
500+ => Traced (Referenced Schema)
501+ -> m (ForeachType JsonFormula)
502+processRefSchema x = do
504+ memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)
506+tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
508+ _schemaAllOf (extract sch) <&> \xs ->
509+ [traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0 ..] xs]
511+tracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
513+ _schemaAnyOf (extract sch) <&> \xs ->
514+ [traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0 ..] xs]
516+tracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
518+ _schemaOneOf (extract sch) <&> \xs ->
519+ [traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0 ..] xs]
521+tracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
523+ _schemaItems (extract sch) <&> \case
524+ OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x
525+ OpenApiItemsArray xs ->
527+ [traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0 ..] xs]
529+tracedAdditionalProperties :: Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))
530+tracedAdditionalProperties sch =
531+ _schemaAdditionalProperties (extract sch) <&> \case
532+ AdditionalPropertiesAllowed b -> Left b
533+ AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x
535+tracedDiscriminator :: Traced Schema -> Maybe (Traced Discriminator)
536+tracedDiscriminator = sequence . stepTraced DiscriminatorStep . fmap _schemaDiscriminator
538+tracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))
539+tracedProperties sch =
541+ (\k -> traced (ask sch >>> step PropertiesStep >>> step (InsOrdHashMapKeyStep k)))
542+ (_schemaProperties $ extract sch)
544+-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition
545+-- for every possible type of a JSON value. The conditions are independent, and
546+-- are thus checked independently.
550+ -> m (ForeachType JsonFormula)
551+processSchema sch@(extract -> Schema {..}) = do
552+ let singletonFormula :: Condition t -> JsonFormula t
553+ singletonFormula f = JsonFormula $ SingleConjunct [f]
555+ allClauses <- case tracedAllOf sch of
557+ Just [] -> [] <$ warn (InvalidSchema "no items in allOf")
558+ Just xs -> mapM processRefSchema xs
560+ anyClause <- case tracedAnyOf sch of
562+ Just [] -> bottom <$ warn (InvalidSchema "no items in anyOf")
563+ Just xs -> joins <$> mapM processRefSchema xs
565+ oneClause <- case tracedOneOf sch of
567+ Just [] -> bottom <$ warn (InvalidSchema "no items in oneOf")
569+ checkOneOfDisjoint xs >>= \case
571+ False -> warn (NotSupported "Could not determine that oneOf branches are disjoint")
572+ joins <$> mapM processRefSchema xs
576+ Just _ -> warn (NotSupported "not clause is unsupported")
578+ let typeClause = case _schemaType of
584+ Just OpenApiBoolean ->
588+ Just OpenApiNumber ->
592+ Just OpenApiInteger ->
594+ { forNumber = singletonFormula $ MultipleOf 1
596+ Just OpenApiString ->
600+ Just OpenApiArray ->
604+ Just OpenApiObject ->
609+ let valueEnum A.Null =
611+ { forNull = singletonFormula $ Exactly TNull
613+ valueEnum (A.Bool b) =
615+ { forBoolean = singletonFormula $ Exactly $ TBool b
617+ valueEnum (A.Number n) =
619+ { forNumber = singletonFormula $ Exactly $ TNumber n
621+ valueEnum (A.String s) =
623+ { forString = singletonFormula $ Exactly $ TString s
625+ valueEnum (A.Array a) =
627+ { forArray = singletonFormula $ Exactly $ TArray a
629+ valueEnum (A.Object o) =
631+ { forObject = singletonFormula $ Exactly $ TObject o
633+ enumClause <- case _schemaEnum of
635+ Just [] -> bottom <$ warn (InvalidSchema "no items in enum")
636+ Just xs -> pure $ joins (valueEnum <$> xs)
638+ let maximumClause = case _schemaMaximum of
642+ { forNumber = singletonFormula $
644+ case _schemaExclusiveMaximum of
645+ Just True -> Exclusive n
649+ minimumClause = case _schemaMinimum of
653+ { forNumber = singletonFormula $
656+ case _schemaExclusiveMinimum of
657+ Just True -> Exclusive $ Down n
658+ _ -> Inclusive $ Down n
661+ multipleOfClause = case _schemaMultipleOf of
665+ { forNumber = singletonFormula $ MultipleOf n
668+ formatClause <- case _schemaFormat of
671+ | f `elem` ["int32", "int64", "float", "double"] ->
674+ { forNumber = singletonFormula $ NumberFormat f
677+ | f `elem` ["byte", "binary", "date", "date-time", "password", "uuid"] ->
680+ { forString = singletonFormula $ StringFormat f
682+ Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)
684+ let maxLengthClause = case _schemaMaxLength of
688+ { forString = singletonFormula $ MaxLength n
691+ minLengthClause = case _schemaMinLength of
695+ { forString = singletonFormula $ MinLength n
698+ patternClause = case _schemaPattern of
702+ { forString = singletonFormula $ Pattern p
705+ itemsClause <- case tracedItems sch of
707+ Just (Left rs) -> do
708+ f <- silently $ processRefSchema rs
709+ pure top {forArray = singletonFormula $ Items f rs}
710+ Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")
712+ let maxItemsClause = case _schemaMaxItems of
716+ { forArray = singletonFormula $ MaxItems n
719+ minItemsClause = case _schemaMinItems of
723+ { forArray = singletonFormula $ MinItems n
726+ uniqueItemsClause = case _schemaUniqueItems of
729+ { forArray = singletonFormula UniqueItems
733+ (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
734+ Just (Right rs) -> (,Just rs) <$> silently (processRefSchema rs)
735+ Just (Left False) -> pure (bottom, Nothing)
736+ _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)
737+ propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
738+ (f, psch) <- case IOHM.lookup k $ tracedProperties sch of
739+ Just rs -> (,rs) <$> silently (processRefSchema rs)
741+ let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
742+ in -- The mempty here is incorrect, but if addPropSchema was Nothing, then
743+ -- addProps is bottom, and k is in _schemaRequired. We handle this situation
744+ -- below and short-circuit the entire Properties condition to bottom
745+ pure (addProps, fromMaybe fakeSchema addPropSchema)
746+ pure (k, Property (k `elem` _schemaRequired) f psch)
747+ let allBottom f = getAll $
748+ foldType $ \_ ty -> case getJsonFormula $ ty f of
749+ BottomFormula -> All True
752+ foldType $ \_ ty -> case getJsonFormula $ ty f of
753+ TopFormula -> All True
755+ -- remove optional fields whose schemata match that of additional props
756+ propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList
758+ | any (\p -> propRequired p && allBottom (propFormula p)) propMap =
759+ bottom -- if any required field has unsatisfiable schema
762+ top -- if all fields are optional and have trivial schemata
765+ { forObject = singletonFormula $ Properties propMap addProps addPropSchema
768+ maxPropertiesClause = case _schemaMaxProperties of
772+ { forObject = singletonFormula $ MaxProperties n
775+ minPropertiesClause = case _schemaMinProperties of
779+ { forObject = singletonFormula $ MinProperties n
783+ | Just True <- _schemaNullable =
785+ { forNull = singletonFormula $ Exactly TNull
787+ | otherwise = bottom
809+ , maxPropertiesClause
810+ , minPropertiesClause
813+{- TODO: ReadOnly/WriteOnly #68 -}
815+checkOneOfDisjoint :: MonadProcess m => [Traced (Referenced Schema)] -> m Bool
816+checkOneOfDisjoint = const $ pure True -- TODO #69
819+ :: Traced (Definitions Schema)
821+ -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
822+schemaToFormula defs rs = runWriter . (`runReaderT` defs) . runMemo () $ processSchema rs
825+ :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
827+ -> Behavior 'SchemaLevel
828+ -> ProdCons (Traced (Definitions Schema))
829+ -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
830+ -> SemanticCompatFormula ()
831+checkFormulas env beh defs (ProdCons (fp, ep) (fc, ec)) =
832+ case P.toList ep ++ P.toList ec of
833+ issues@(_ : _) -> F.for_ issues $ embedFormula beh . anItem
835+ -- We have the following isomorphisms:
836+ -- (A ⊂ X ∪ Y) = (A ⊂ X) \/ (A ⊂ Y)
837+ -- (A ⊂ X ∩ Y) = (A ⊂ X) /\ (A ⊂ Y)
839+ -- (X ∪ Y ⊂ B) = (X ⊂ B) /\ (Y ⊂ B)
841+ -- The remaining cases are, notably, not isomorphisms:
843+ -- 2) (X ∩ Y ⊂ B) <= (X ⊂ B) \/ (Y ⊂ B)
845+ -- Therefore we have the isomorphisms with (∃ and ∀ being the N-ary
846+ -- versions of \/ and /\ respectively):
847+ -- (⋃_i ⋂_j A[i,j]) ⊂ (⋃_k ⋂_l B[k,l])
848+ -- = ∃k ∀l ∀i, (⋂_j A[i,j]) ⊂ B[k,l]
849+ -- = ∀i ∃k ∀l, (⋂_j A[i,j]) ⊂ B[k,l]
850+ -- with the caveat that the the set over which k ranges is nonempty.
851+ -- This is because 1) is not an isomorphism.
852+ -- Our disjunction loses information, so it makes sense to nest it as
853+ -- deeply as possible, hence we choose the latter representation.
855+ -- We delegate the verification of (⋂_j A[j]) ⊂ B to a separate heuristic
856+ -- function, with the understanding that ∃j, A[j] ⊂ B is a sufficient,
857+ -- but not necessary condition (because of 2) and 3)).
859+ -- If k ranges over an empty set, we have the isomorphism:
860+ -- (⋃_i ⋂_j A[i,j]) ⊂ ∅ = ∀i, (⋂_j A[i,j]) ⊂ ∅
861+ -- where we again delegate (⋂_j A[j]) ⊂ ∅ to a heuristic, though here the
862+ -- shortcut of ∃j, A[j] ⊂ ∅ hardly helps.
864+ -- Disjunctions tend to erase informative error messages, so we may want
865+ -- to avoid them. This can be formally done as follows: if we can
866+ -- partition the universal set into a disjoint union of some parts:
868+ -- such that the conjuncts in our disjunctive normal form are subordinate
869+ -- to the partition:
870+ -- ∀i ∃α, (⋂_j A[i,j]) ⊂ P[α]
871+ -- ∀k ∃α, (⋂_l B[k,l]) ⊂ P[α]
872+ -- then we can partition the sets over which i and k range into partitions
873+ -- I[α] and K[α], and then in each "bucket" verify the inclusion in the
874+ -- aforementioned way:
875+ -- ∀α, (⋃_i∈I[α] ⋂_j A[i,j]) ⊂ (⋃_k∈K[α] ⋂_l B[k,l])
876+ -- = ∀α ∀i∈I[α] ∃k∈K[α] ∀l, (⋂_j A[i,j]) ⊂ B[k,l]
877+ -- We already somewhat do this by partitioning JSON into types, but we can
878+ -- additionally partition e.g. "enum" fields or existence of particular
879+ -- properties. This works especially well if we manage to ensure K[α] are
883+ -- (⋃_i∈I[α] ⋂_j A[i,j]) = (⋃_i ⋂_j A[i,j]) ∩ P[α]
884+ -- does not actually appear in the source schema, we need to construct it
885+ -- ourselves and come up with a name for it.
886+ let typesRestricted = not (anyBottomTypes fp) && anyBottomTypes fc
887+ -- Specifically handle the case when a schema's type has been
888+ -- restricted from "all" to specific types: if all types were allowed
889+ -- in the producer and not all types are allowed in the consumer, it's
890+ -- usually easier to say what's left than what's removed
891+ when typesRestricted $ issueAt beh $ TypesRestricted $ nonBottomTypes fc
892+ forType_ $ \tyName ty -> do
893+ let beh' = beh >>> step (OfType tyName)
894+ case (getJsonFormula $ ty fp, getJsonFormula $ ty fc) of
895+ (DNF pss, BottomFormula) -> unless typesRestricted $ do
896+ -- don't repeat the TypesRestricted issue
897+ F.for_ pss $ \(Conjunct ps) -> checkContradiction beh' ps
898+ (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do
899+ F.for_ cs $ checkImplication env beh' ps -- avoid disjunction if there's only one conjunct
900+ (TopFormula, DNF css) ->
901+ -- producer is "open" (allows any value), but consumer has restrictions.
902+ -- In this case we want to show which restrictions were added. (instead
903+ -- of showing an empty list restrictions that couldn't be satisfied.)
904+ F.for_ css $ \(Conjunct cs) -> F.for_ cs $ checkImplication env beh' []
905+ (pss', css') -> F.for_ (tryPartition defs $ ProdCons (JsonFormula pss') (JsonFormula css')) $ \case
906+ (mPart, ProdCons pf cf) -> do
907+ let beh'' = foldr ((<<<) . step . InPartition) beh' mPart
908+ case (getJsonFormula pf, getJsonFormula cf) of
909+ (DNF pss, BottomFormula) -> F.for_ pss $ \(Conjunct ps) -> checkContradiction beh'' ps
910+ (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do
911+ F.for_ cs $ checkImplication env beh'' ps
913+ (DNF pss, DNF css) -> F.for_ pss $ \(Conjunct ps) -> do
916+ (issueFromConjunct Nothing ps)
917+ [F.for_ cs $ checkImplication env beh' ps | Conjunct cs <- S.toList css]
920+ anyBottomTypes f = getAny $
921+ foldType $ \_ ty -> case getJsonFormula $ ty f of
922+ BottomFormula -> Any True
924+ nonBottomTypes f = foldType $ \tyName ty -> case getJsonFormula $ ty f of
925+ BottomFormula -> mempty
927+ issueFromConjunct :: Typeable t => Partition -> [Condition t] -> Issue 'TypedSchemaLevel
928+ issueFromConjunct _ ps
929+ | Just e <- findExactly ps
930+ , all (satisfiesTyped e) ps =
931+ EnumDoesntSatisfy $ untypeValue e -- what does this look like when partitioned?
932+ issueFromConjunct mPart ps = NoMatchingCondition mPart $ SomeCondition <$> ps
935+ = DByEnumValue (DNF (S.Set A.Value))
936+ | DByProperties (DNF (S.Set Text, S.Set Text)) -- optional, required
937+ deriving stock (Eq, Ord, Show)
940+ = CByEnumValue (S.Set A.Value)
941+ | CByProperties (S.Set Text) (S.Set Text) -- included, excluded
942+ deriving stock (Eq, Ord, Show)
944+conjPart :: PartitionData -> PartitionData -> Maybe PartitionData
945+conjPart (DByEnumValue xss) (DByEnumValue yss) = Just . DByEnumValue $ xss /\ yss
946+conjPart (DByProperties xss) (DByProperties yss) = Just . DByProperties $ xss /\ yss
947+conjPart _ _ = Nothing
949+disjPart :: PartitionData -> PartitionData -> Maybe PartitionData
950+disjPart (DByEnumValue xss) (DByEnumValue yss) = Just . DByEnumValue $ xss \/ yss
951+disjPart (DByProperties xss) (DByProperties yss) = Just . DByProperties $ xss \/ yss
952+disjPart _ _ = Nothing
954+data PartitionLocation
956+ | PInProperty Text PartitionLocation
957+ deriving stock (Eq, Ord, Show)
959+newtype Partitions = Partitions (M.Map PartitionLocation (S.Set PartitionData))
960+ deriving stock (Eq, Ord, Show)
962+instance Lattice Partitions where
963+ Partitions xss /\ Partitions yss = Partitions $ M.unionWith conj xss yss
965+ conj xs ys = S.fromList . catMaybes $ liftA2 conjPart (S.toList xs) (S.toList ys)
966+ Partitions xss \/ Partitions yss = Partitions $ M.intersectionWith disj xss yss
968+ disj xs ys = S.fromList . catMaybes $ liftA2 disjPart (S.toList xs) (S.toList ys)
970+instance BoundedMeetSemiLattice Partitions where
971+ top = Partitions M.empty
973+-- The lattice has no bottom, but we use 'Lifted' to adjoin a free bottom element
975+type PartitionM = ReaderT (Traced (Definitions Schema)) (State (MemoState ()))
977+ignoreKnot :: KnotTier (Lifted Partitions) () PartitionM
980+ { onKnotFound = pure ()
981+ , onKnotUsed = \_ -> pure bottom
982+ , tieKnot = \_ -> pure
985+singletonPart :: PartitionData -> Lifted Partitions
986+singletonPart = Lift . Partitions . M.singleton PHere . S.singleton
988+partitionSchema :: Traced Schema -> PartitionM (Lifted Partitions)
989+partitionSchema sch = do
990+ allClauses <- case tracedAllOf sch of
992+ Just xs -> mapM partitionRefSchema xs
994+ anyClause <- case tracedAnyOf sch of
996+ Just xs -> joins <$> mapM partitionRefSchema xs
998+ oneClause <- case tracedOneOf sch of
1000+ Just xs -> joins <$> mapM partitionRefSchema xs
1002+ byEnumClause <- case _schemaEnum $ extract sch of
1003+ Nothing -> pure top
1005+ pure . singletonPart $
1006+ DByEnumValue $ SingleConjunct [S.fromList xs]
1008+ -- We can only partition by presence of a property if additional properties
1009+ -- are disallowed, and the property is not optional
1010+ let reqd = S.fromList $ _schemaRequired $ extract sch
1011+ byPropertiesClause <- case _schemaAdditionalProperties $ extract sch of
1012+ Just (AdditionalPropertiesAllowed False) -> do
1013+ let props = S.fromList . IOHM.keys . _schemaProperties $ extract sch
1014+ pure . singletonPart $
1015+ DByProperties $ SingleConjunct [(props S.\\ reqd, props `S.intersection` reqd)]
1018+ -- We can partition on something nested in a property only if the property is
1020+ let reqdProps = IOHM.filterWithKey (\k _ -> k `S.member` reqd) $ tracedProperties sch
1021+ inPropertiesClauses <- forM (IOHM.toList reqdProps) $ \(k, rs) -> do
1022+ f <- partitionRefSchema rs
1023+ pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f
1025+ pure $ meets $ allClauses <> [anyClause, oneClause, byEnumClause, byPropertiesClause] <> inPropertiesClauses
1027+partitionRefSchema :: Traced (Referenced Schema) -> PartitionM (Lifted Partitions)
1028+partitionRefSchema x = do
1030+ memoWithKnot ignoreKnot (partitionSchema $ dereference defs x) (ask x)
1032+newtype LiftA f a = LiftA {getLiftA :: f a}
1033+ deriving newtype (Functor, Applicative)
1035+instance (Lattice a, Applicative f) => Lattice (LiftA f a) where
1039+instance (BoundedJoinSemiLattice a, Applicative f) => BoundedJoinSemiLattice (LiftA f a) where
1040+ bottom = pure bottom
1042+instance (BoundedMeetSemiLattice a, Applicative f) => BoundedMeetSemiLattice (LiftA f a) where
1045+partitionCondition :: Condition t -> PartitionM (Lifted Partitions)
1046+partitionCondition = \case
1048+ pure . singletonPart $
1049+ DByEnumValue $ SingleConjunct [S.singleton $ untypeValue x]
1050+ Properties props _ madd -> do
1051+ let byProps = case madd of
1057+ [ ( M.keysSet $ M.filter (not . propRequired) props
1058+ , M.keysSet $ M.filter propRequired props
1061+ inProps <- forM (M.toList $ M.filter propRequired props) $ \(k, prop) -> do
1062+ f <- partitionRefSchema $ propRefSchema prop
1063+ pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f
1064+ pure $ byProps /\ meets inProps
1067+partitionJsonFormulas
1068+ :: ProdCons (Traced (Definitions Schema))
1069+ -> ProdCons (JsonFormula t)
1070+ -> Lifted Partitions
1071+partitionJsonFormulas defs pc = producer pcPart \/ consumer pcPart
1073+ pcPart = partitionFormula <$> defs <*> pc
1074+ partitionFormula def (JsonFormula xss) = runIdentity . runMemo () . (`runReaderT` def) $ do
1075+ getLiftA . foldLattice (LiftA . partitionCondition) $ xss
1077+selectPartition :: Lifted Partitions -> Maybe (PartitionLocation, S.Set PartitionChoice)
1078+selectPartition Bottom = Nothing
1079+selectPartition (Lift (Partitions m)) =
1080+ go [(loc, part) | (loc, parts) <- sortBy (comparing $ locLength . fst) $ M.toList m, part <- S.toList parts]
1082+ locLength :: PartitionLocation -> Int
1086+ walk !n (PInProperty _ l) = walk (n + 1) l
1088+ -- Skip partitioning by property for now
1089+ go ((_, DByProperties _) : ps) = go ps
1090+ -- Don't partition by enum value at the root (this reports removed enum values as contradictions in their respective partitions)
1091+ go ((PHere, DByEnumValue _) : ps) = go ps
1092+ go ((loc, DByEnumValue (DNF xss)) : ps)
1093+ -- Check that no disjunction branches are unresticted
1094+ | Just enums <- traverse (fmap (foldr1 S.intersection) . NE.nonEmpty . S.toList) . S.toList $ xss =
1096+ Just (loc, S.map (CByEnumValue . S.singleton) $ S.unions enums)
1097+ | otherwise = go ps
1099+-- This essentially has 3 cases:
1100+-- Nothing -- we have produced a bottom schema
1101+-- Just (False, _) -- there's been no change to the schema
1102+-- Just (True, x) -- x is a new schema
1103+type IntersectionM = ReaderT (Traced (Definitions Schema)) (WriterT Any Maybe)
1105+mBottom :: IntersectionM a
1106+mBottom = lift . lift $ Nothing
1108+catchBottom :: IntersectionM a -> IntersectionM a -> IntersectionM a
1109+catchBottom act handler = R.liftCatch (W.liftCatch (\a h -> a <|> h ())) act (\_ -> handler)
1111+mChange :: IntersectionM ()
1112+mChange = tell $ Any True
1115+ :: PartitionLocation
1118+ -> IntersectionM Schema
1119+intersectSchema loc part sch = do
1120+ allOf' <- forM (tracedAllOf sch) $ \rss ->
1121+ -- Assuming i ranges over a nonempty set (checked in processSchema)
1122+ -- (⋂_i A[i]) ∩ X = ⋂_i (A[i] ∩ X)
1123+ -- If any intersections are empty, the result is empty. If any intersections are a change, the result is a change.
1124+ traverse (intersectRefSchema loc part) rss
1125+ anyOf' <- forM (tracedAnyOf sch) $ \rss -> do
1126+ -- (⋃_i A[i]) ∩ X = ⋃_i (A[i] ∩ X)
1127+ -- Collect only the nonempty A[i] ∩ X, unless there are none, in which case the result is empty.
1128+ -- If any schema is empty, we remove it from the list which constitutes a change.
1129+ mSchemas <- forM rss $ \rs -> catchBottom (Just <$> intersectRefSchema loc part rs) (mChange >> pure Nothing)
1130+ case catMaybes mSchemas of
1133+ oneOf' <- forM (tracedOneOf sch) $ \rss -> do
1134+ -- Same as anyOf'. By intersecting we're only making them more disjoint if anything.
1135+ mSchemas <- forM rss $ \rs -> catchBottom (Just <$> intersectRefSchema loc part rs) (mChange >> pure Nothing)
1136+ case catMaybes mSchemas of
1139+ let sch' = (extract sch) {_schemaAllOf = allOf', _schemaAnyOf = anyOf', _schemaOneOf = oneOf'}
1140+ -- Now the local changes:
1142+ PInProperty k loc' -> case IOHM.lookup k $ tracedProperties sch of
1143+ Nothing -> error $ "Partitioning via absent property: " <> T.unpack k
1145+ prop' <- intersectRefSchema loc' part prop
1146+ pure $ sch' {_schemaProperties = IOHM.adjust (const prop') k $ _schemaProperties sch'}
1147+ PHere -> case part of
1148+ CByEnumValue vals -> do
1149+ enum' <- case _schemaEnum sch' of
1152+ pure $ S.toList vals
1154+ when (any (`S.notMember` vals) xs) mChange
1155+ case filter (`S.member` vals) xs of
1158+ pure $ sch' {_schemaEnum = Just enum'}
1159+ CByProperties {} -> error "CByProperties not implemented"
1162+ :: PartitionLocation
1164+ -> Traced (Referenced Schema)
1165+ -> IntersectionM (Referenced Schema)
1166+intersectRefSchema loc part rs = do
1168+ Inline <$> intersectSchema loc part (dereference defs rs)
1170+intersectCondition :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> Condition t -> DNF (Condition t)
1171+intersectCondition _defs PHere (CByEnumValue values) cond@(Exactly x) =
1172+ if untypeValue x `S.member` values then SingleConjunct [cond] else bottom
1173+intersectCondition defs (PInProperty k loc) part cond@(Properties props add madd) = case M.lookup k props of
1174+ Nothing -> SingleConjunct [cond] -- shouldn't happen
1175+ Just prop -> case runWriterT . (`runReaderT` defs) $ intersectRefSchema loc part $ propRefSchema prop of
1176+ Just (rs', Any True) ->
1177+ let trs' = traced (ask (propRefSchema prop) >>> step (Partitioned loc part)) rs'
1178+ in SingleConjunct [Properties (M.insert k prop {propRefSchema = trs'} props) add madd]
1179+ Just (_, Any False) -> SingleConjunct [cond]
1181+intersectCondition _defs _loc _part cond = SingleConjunct [cond]
1183+intersectFormula :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> JsonFormula t -> JsonFormula t
1184+intersectFormula defs loc part = JsonFormula . foldLattice (intersectCondition defs loc part) . getJsonFormula
1186+type Partition = Maybe (PartitionLocation, PartitionChoice)
1188+tryPartition :: ProdCons (Traced (Definitions Schema)) -> ProdCons (JsonFormula t) -> [(Partition, ProdCons (JsonFormula t))]
1189+tryPartition defs pc = case selectPartition $ partitionJsonFormulas defs pc of
1190+ Nothing -> [(Nothing, pc)]
1191+ Just (loc, parts) -> [(Just (loc, part), intersectFormula <$> defs <*> pure loc <*> pure part <*> pc) | part <- S.toList parts]
1194+ :: Behavior 'TypedSchemaLevel
1196+ -> SemanticCompatFormula ()
1197+checkContradiction beh _ = issueAt beh NoContradiction -- TODO #70
1199+tracedConjunct :: NE.NonEmpty (Traced (Referenced Schema)) -> Traced (Referenced Schema)
1200+tracedConjunct refSchemas = case NE.sortWith ask refSchemas of
1201+ (rs NE.:| []) -> rs
1202+ (rs1 NE.:| rs2 : rss) ->
1203+ traced (ask rs1 >>> step (ConjunctedWith $ ask <$> rs2 NE.:| rss)) $
1204+ Inline mempty {_schemaAllOf = Just $ extract <$> rs1 : rs2 : rss}
1207+ :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
1209+ -> Behavior 'TypedSchemaLevel
1212+ -> SemanticCompatFormula ()
1213+checkImplication env beh prods cons = case findExactly prods of
1215+ | all (satisfiesTyped e) prods ->
1216+ if satisfiesTyped e cons
1218+ else issueAt beh (EnumDoesntSatisfy $ untypeValue e)
1219+ | otherwise -> pure () -- vacuously true
1220+ Nothing -> case cons of
1221+ -- the above code didn't catch it, so there's no Exactly condition on the lhs
1222+ Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)
1223+ Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of
1227+ else issueAt beh (MatchingMaximumWeak $ ProdCons {producer = m', consumer = m})
1228+ Nothing -> issueAt beh (NoMatchingMaximum m)
1229+ Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of
1233+ else issueAt beh (MatchingMinimumWeak ProdCons {producer = coerce m', consumer = coerce m})
1234+ Nothing -> issueAt beh (NoMatchingMinimum (coerce m))
1235+ MultipleOf m -> case findRelevant lcmScientific (\case MultipleOf m' -> Just m'; _ -> Nothing) prods of
1237+ if lcmScientific m m' == m'
1239+ else issueAt beh (MatchingMultipleOfWeak $ ProdCons {producer = m', consumer = m})
1240+ Nothing -> issueAt beh (NoMatchingMultipleOf m)
1242+ if any (\case NumberFormat f' -> f == f'; _ -> False) prods
1244+ else issueAt beh (NoMatchingFormat f)
1245+ MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of
1249+ else issueAt beh (MatchingMaxLengthWeak $ ProdCons {producer = m', consumer = m})
1250+ Nothing -> issueAt beh (NoMatchingMaxLength m)
1251+ MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of
1255+ else issueAt beh (MatchingMinLengthWeak $ ProdCons {producer = m', consumer = m})
1256+ Nothing -> issueAt beh (NoMatchingMinLength m)
1258+ if any (\case Pattern p' -> p == p'; _ -> False) prods
1260+ else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32
1262+ if any (\case StringFormat f' -> f == f'; _ -> False) prods
1264+ else issueAt beh (NoMatchingFormat f)
1265+ Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of
1266+ Just (tracedConjunct -> rs) -> checkCompatibility (beh >>> step InItems) env $ ProdCons rs cons'
1267+ Nothing -> issueAt beh NoMatchingItems
1268+ MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of
1272+ else issueAt beh (MatchingMaxItemsWeak ProdCons {producer = m', consumer = m})
1273+ Nothing -> issueAt beh (NoMatchingMaxItems m)
1274+ MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of
1278+ else issueAt beh (MatchingMinItemsWeak ProdCons {producer = m', consumer = m})
1279+ Nothing -> issueAt beh (NoMatchingMinItems m)
1281+ if any (== UniqueItems) $ prods
1283+ else issueAt beh NoMatchingUniqueItems
1284+ Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of
1286+ anyOfAt beh NoMatchingProperties $
1287+ NE.toList pm <&> \(props', madd') -> do
1288+ F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do
1289+ let beh' = beh >>> step (InProperty k)
1290+ go sch sch' = checkCompatibility beh' env (ProdCons sch sch')
1291+ case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of
1292+ -- producer does not require field, but consumer does (can fail)
1293+ (False, True) -> issueAt beh' PropertyNowRequired
1295+ case (M.lookup k props', madd', M.lookup k props, madd) of
1296+ -- (producer, additional producer, consumer, additional consumer)
1297+ (Nothing, Nothing, _, _) -> pure () -- vacuously: the producer asserts that this field cannot exist,
1298+ -- and the consumer either doesn't require it, or it does and we've already raised an error about it.
1299+ (_, _, Nothing, Nothing) -> issueAt beh' UnexpectedProperty
1300+ (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)
1301+ (Nothing, Just add', Just p, _) ->
1302+ clarifyIssue (AnItem beh' (anIssue AdditionalToProperty)) $
1303+ go add' (propRefSchema p)
1304+ (Just p', _, Nothing, Just add) ->
1305+ clarifyIssue (AnItem beh' (anIssue PropertyToAdditional)) $
1306+ go (propRefSchema p') add
1307+ (Nothing, Just _, Nothing, Just _) -> pure ()
1309+ case (madd', madd) of
1310+ (Nothing, _) -> pure () -- vacuously
1311+ (_, Nothing) -> issueAt beh NoAdditionalProperties
1312+ (Just add', Just add) -> checkCompatibility (beh >>> step InAdditionalProperty) env (ProdCons add' add)
1314+ Nothing -> issueAt beh NoMatchingProperties
1315+ MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of
1319+ else issueAt beh (MatchingMaxPropertiesWeak ProdCons {producer = m', consumer = m})
1320+ Nothing -> issueAt beh (NoMatchingMaxProperties m)
1321+ MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of
1325+ else issueAt beh (MatchingMinPropertiesWeak ProdCons {producer = m', consumer = m})
1326+ Nothing -> issueAt beh (NoMatchingMinProperties m)
1328+ findRelevant combine extr =
1329+ fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr
1330+ lcmScientific (toRational -> a) (toRational -> b) =
1331+ fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
1333+findExactly :: [Condition t] -> Maybe (TypedValue t)
1334+findExactly (Exactly x : _) = Just x
1335+findExactly (_ : xs) = findExactly xs
1336+findExactly [] = Nothing
1338+instance Issuable 'TypedSchemaLevel where
1339+ data Issue 'TypedSchemaLevel
1340+ = -- | producer produces a specific value ($1), consumer has a condition that is not satisfied by said value
1341+ EnumDoesntSatisfy A.Value
1342+ | -- | consumer only expects a specific value which the producer does not produce.
1343+ NoMatchingEnum A.Value
1344+ | -- | consumer declares a maximum numeric value ($1), producer doesn't
1345+ NoMatchingMaximum (Bound Scientific)
1346+ | -- | consumer declares a maximum numeric value ($1), producer declares a weaker (higher) limit ($2)
1347+ MatchingMaximumWeak (ProdCons (Bound Scientific))
1348+ | -- | consumer declares a minimum numeric value, producer doesn't
1349+ NoMatchingMinimum (Bound Scientific)
1350+ | -- | consumer declares a minimum numeric value ($1), producer declares a weaker (lower) limit ($2)
1351+ MatchingMinimumWeak (ProdCons (Bound Scientific))
1352+ | -- | consumer declares that the numeric value must be a multiple of $1, producer doesn't
1353+ NoMatchingMultipleOf Scientific
1354+ | -- | consumer declares that the numeric value must be a multiple of $1, producer declares a weaker condition (multiple of $2)
1355+ MatchingMultipleOfWeak (ProdCons Scientific)
1356+ | -- | consumer declares a string/number format, producer declares none or a different format (TODO: improve via regex #32)
1357+ NoMatchingFormat Format
1358+ | -- | consumer declares a maximum length of the string ($1), producer doesn't.
1359+ NoMatchingMaxLength Integer
1360+ | -- | consumer declares a maximum length of the string ($1), producer declares a weaker (higher) limit ($2)
1361+ MatchingMaxLengthWeak (ProdCons Integer)
1362+ | -- | consumer declares a minimum length of the string ($1), producer doesn't.
1363+ NoMatchingMinLength Integer
1364+ | -- | consumer declares a minimum length of the string ($1), producer declares a weaker (lower) limit ($2)
1365+ MatchingMinLengthWeak (ProdCons Integer)
1366+ | -- | consumer declares the string value must match a regex ($1), producer doesn't declare or declares different regex (TODO: #32)
1367+ NoMatchingPattern Pattern
1368+ | -- | consumer declares the items of an array must satisfy some condition, producer doesn't
1370+ | -- | consumer declares a maximum length of the array ($1), producer doesn't.
1371+ NoMatchingMaxItems Integer
1372+ | -- | consumer declares a maximum length of the array ($1), producer declares a weaker (higher) limit ($2)
1373+ MatchingMaxItemsWeak (ProdCons Integer)
1374+ | -- | consumer declares a minimum length of the array ($1), producer doesn't.
1375+ NoMatchingMinItems Integer
1376+ | -- | consumer declares a minimum length of the array ($1), producer declares a weaker (lower) limit ($2)
1377+ MatchingMinItemsWeak (ProdCons Integer)
1378+ | -- | consumer declares that items must be unique, producer doesn't
1379+ NoMatchingUniqueItems
1380+ | -- | consumer declares the properties of an object must satisfy some condition, producer doesn't
1381+ NoMatchingProperties
1382+ | -- | producer allows additional properties, consumer doesn't
1383+ NoAdditionalProperties
1384+ | -- | consumer declares a maximum number of properties in the object ($1), producer doesn't.
1385+ NoMatchingMaxProperties Integer
1386+ | -- | consumer declares a maximum number of properties in the object ($1), producer declares a weaker (higher) limit ($2)
1387+ MatchingMaxPropertiesWeak (ProdCons Integer)
1388+ | -- | consumer declares a minimum number of properties in the object ($1), producer doesn't.
1389+ NoMatchingMinProperties Integer
1390+ | -- | consumer declares a minimum number of properties in the object ($1), producer declares a weaker (lower) limit ($2)
1391+ MatchingMinPropertiesWeak (ProdCons Integer)
1392+ | -- | 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)
1393+ NoMatchingCondition Partition [SomeCondition]
1394+ | -- | producer indicates that values of this type are now allowed, but the consumer does not do so (currently we only check immediate contradictions, c.f. #70)
1395+ -- AKA consumer does not have the type
1397+ deriving stock (Eq, Ord, Show)
1398+ issueIsUnsupported _ = False
1399+ describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v
1400+ describeIssue Backward (EnumDoesntSatisfy v) = para "The following enum value was added:" <> showJSONValue v
1401+ describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v
1402+ describeIssue Backward (NoMatchingEnum v) = para "The following enum value has been removed:" <> showJSONValue v
1403+ describeIssue Forward (NoMatchingMaximum b) = para $ "Upper bound has been added:" <> showBound b <> "."
1404+ describeIssue Backward (NoMatchingMaximum b) = para $ "Upper bound has been removed:" <> showBound b <> "."
1405+ describeIssue _ (MatchingMaximumWeak (ProdCons p c)) = para $ "Upper bound changed from " <> showBound p <> " to " <> showBound c <> "."
1406+ describeIssue Forward (NoMatchingMinimum b) = para $ "Lower bound has been added: " <> showBound b <> "."
1407+ describeIssue Backward (NoMatchingMinimum b) = para $ "Lower bound has been removed: " <> showBound b <> "."
1408+ describeIssue _ (MatchingMinimumWeak (ProdCons p c)) = para $ "Lower bound changed from " <> showBound p <> " to " <> showBound c <> "."
1409+ describeIssue Forward (NoMatchingMultipleOf n) = para $ "Value is now a multiple of " <> show' n <> "."
1410+ describeIssue Backward (NoMatchingMultipleOf n) = para $ "Value is no longer a multiple of " <> show' n <> "."
1411+ describeIssue _ (MatchingMultipleOfWeak (ProdCons p c)) = para $ "Value changed from being a multiple of " <> show' p <> " to being a multiple of " <> show' c <> "."
1412+ describeIssue Forward (NoMatchingFormat f) = para $ "Format added: " <> code f <> "."
1413+ describeIssue Backward (NoMatchingFormat f) = para $ "Format removed: " <> code f <> "."
1414+ describeIssue Forward (NoMatchingMaxLength n) = para $ "Maximum length added: " <> show' n <> "."
1415+ describeIssue Backward (NoMatchingMaxLength n) = para $ "Maximum length removed: " <> show' n <> "."
1416+ describeIssue _ (MatchingMaxLengthWeak (ProdCons p c)) = para $ "Maximum length of the string changed from " <> show' p <> " to " <> show' c <> "."
1417+ describeIssue Forward (NoMatchingMinLength n) = para $ "Minimum length of the string added: " <> show' n <> "."
1418+ describeIssue Backward (NoMatchingMinLength n) = para $ "Minimum length of the string removed: " <> show' n <> "."
1419+ describeIssue _ (MatchingMinLengthWeak (ProdCons p c)) = para $ "Minimum length of the string changed from " <> show' p <> " to " <> show' c <> "."
1420+ describeIssue Forward (NoMatchingPattern p) = para "Pattern (regular expression) added: " <> codeBlock p
1421+ describeIssue Backward (NoMatchingPattern p) = para "Pattern (regular expression) removed: " <> codeBlock p
1422+ describeIssue Forward NoMatchingItems = para "Array item schema has been added."
1423+ describeIssue Backward NoMatchingItems = para "Array item schema has been removed."
1424+ describeIssue Forward (NoMatchingMaxItems n) = para $ "Maximum length of the array has been added " <> show' n <> "."
1425+ describeIssue Backward (NoMatchingMaxItems n) = para $ "Maximum length of the array has been removed " <> show' n <> "."
1426+ describeIssue _ (MatchingMaxItemsWeak (ProdCons p c)) = para $ "Maximum length of the array changed from " <> show' p <> " to " <> show' c <> "."
1427+ describeIssue Forward (NoMatchingMinItems n) = para $ "Minimum length of the array added: " <> show' n <> "."
1428+ describeIssue Backward (NoMatchingMinItems n) = para $ "Minimum length of the array removed: " <> show' n <> "."
1429+ describeIssue _ (MatchingMinItemsWeak (ProdCons p c)) = para $ "Minimum length of the array changed from " <> show' p <> " to " <> show' c <> "."
1430+ describeIssue Forward NoMatchingUniqueItems = para "Items are now required to be unique."
1431+ describeIssue Backward NoMatchingUniqueItems = para "Items are no longer required to be unique."
1432+ describeIssue Forward NoMatchingProperties = para "Property added."
1433+ describeIssue Backward NoMatchingProperties = para "Property removed."
1434+ describeIssue Forward NoAdditionalProperties = para "Additional properties have been removed."
1435+ describeIssue Backward NoAdditionalProperties = para "Additional properties have been added."
1436+ describeIssue Forward (NoMatchingMaxProperties n) = para $ "Maximum number of properties has been added: " <> show' n <> "."
1437+ describeIssue Backward (NoMatchingMaxProperties n) = para $ "Maximum number of properties has been removed: " <> show' n <> "."
1438+ describeIssue _ (MatchingMaxPropertiesWeak (ProdCons p c)) = para $ "Maximum number of properties has changed from " <> show' p <> " to " <> show' c <> "."
1439+ describeIssue Forward (NoMatchingMinProperties n) = para $ "Minimum number of properties added: " <> show' n <> "."
1440+ describeIssue Backward (NoMatchingMinProperties n) = para $ "Minimum number of properties removed: " <> show' n <> "."
1441+ describeIssue _ (MatchingMinPropertiesWeak (ProdCons p c)) = para $ "Minimum number of properties has changed from " <> show' p <> " to " <> show' c <> "."
1442+ describeIssue _ (NoMatchingCondition mPart conds) =
1445+ Nothing -> "Could not verify that the following conditions hold (please file a bug if you see this)"
1447+ showPartition locPart
1448+ <> " – could not verify that the following conditions hold (please file a bug if you see this):")
1449+ <> bulletList ((\(SomeCondition c) -> showCondition c) <$> conds)
1450+ describeIssue Forward NoContradiction = para "The value has been removed."
1451+ describeIssue Backward NoContradiction = para "The value has been added."
1453+showJSONValue :: A.Value -> Blocks
1454+showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)
1456+showJSONValueInline :: A.Value -> Inlines
1457+showJSONValueInline v = code (T.decodeUtf8 . BSL.toStrict . A.encode $ v)
1459+showBound :: Show a => Bound a -> Inlines
1460+showBound (Inclusive x) = show' x <> " inclusive"
1461+showBound (Exclusive x) = show' x <> " exclusive"
1463+show' :: Show x => x -> Inlines
1464+show' = str . T.pack . show
1466+instance Issuable 'SchemaLevel where
1467+ data Issue 'SchemaLevel
1468+ = -- | Some (openapi-supported) feature that we do not support was encountered in the schema
1470+ | -- | The schema is actually invalid
1472+ | -- | The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".
1474+ | -- | Producer doesn't place any restrictions on the types, but the consumer does. List what types remain available in the consumer.
1475+ TypesRestricted [JsonType]
1476+ | -- | 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
1477+ AdditionalToProperty
1478+ | -- | 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
1479+ PropertyToAdditional
1480+ | -- | consumer requires a property that is not required/allowed in the producer
1481+ PropertyNowRequired
1482+ | -- | producer allows a property that is not allowed in the consumer
1484+ deriving stock (Eq, Ord, Show)
1485+ issueIsUnsupported = \case
1486+ NotSupported _ -> True
1487+ InvalidSchema _ -> True
1488+ UnguardedRecursion -> True
1491+ describeIssue _ (NotSupported i) =
1492+ para (emph "Encountered a feature that OpenApi Diff does not support: " <> text i <> ".")
1493+ describeIssue _ (InvalidSchema i) =
1494+ para (emph "The schema is invalid: " <> text i <> ".")
1495+ describeIssue _ UnguardedRecursion =
1496+ para "Encountered recursion that is too complex for OpenApi Diff to untangle."
1497+ describeIssue Forward (TypesRestricted tys) = case tys of
1498+ [] -> para "No longer has any valid values." -- weird
1499+ _ -> para "Values are now limited to the following types: " <> bulletList (para . describeJSONType <$> tys)
1500+ describeIssue Backward (TypesRestricted tys) = case tys of
1501+ [] -> para "Any value of any type is now allowed." -- weird
1502+ _ -> para "Values are no longer limited to the following types: " <> bulletList (para . describeJSONType <$> tys)
1503+ describeIssue Forward AdditionalToProperty = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."
1504+ describeIssue Backward AdditionalToProperty = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."
1505+ describeIssue Forward PropertyToAdditional = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."
1506+ describeIssue Backward PropertyToAdditional = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."
1507+ describeIssue Forward PropertyNowRequired = para "The property has become required."
1508+ describeIssue Backward PropertyNowRequired = para "The property may not be present."
1509+ describeIssue Forward UnexpectedProperty = para "The property has been removed."
1510+ describeIssue Backward UnexpectedProperty = para "The property has been added."
1512+instance Behavable 'SchemaLevel 'TypedSchemaLevel where
1513+ data Behave 'SchemaLevel 'TypedSchemaLevel
1515+ deriving stock (Eq, Ord, Show)
1517+ describeBehaviour (OfType t) = describeJSONType t
1519+describeJSONType :: IsString s => JsonType -> s
1520+describeJSONType = \case
1522+ Boolean -> "Boolean"
1528+instance Behavable 'TypedSchemaLevel 'TypedSchemaLevel where
1529+ data Behave 'TypedSchemaLevel 'TypedSchemaLevel
1530+ = InPartition (PartitionLocation, PartitionChoice)
1531+ deriving stock (Eq, Ord, Show)
1533+ describeBehaviour (InPartition partition) = showPartition partition
1535+showPartition :: (PartitionLocation, PartitionChoice) -> Inlines
1536+showPartition = \case
1537+ (partition, CByEnumValue (S.toList -> [v])) ->
1538+ "In cases where " <> renderPartitionLocation partition <> " is " <> showJSONValueInline v
1539+ (partition, CByEnumValue (S.toList -> vs)) ->
1540+ "In cases where " <> renderPartitionLocation partition <> " has values: "
1541+ <> (fold . L.intersperse ", " . fmap showJSONValueInline $ vs)
1542+ (partition, CByProperties (S.toList -> incl) (S.toList -> [])) ->
1543+ "In cases where " <> renderPartitionLocation partition <> " contains the properties: " <> listCodes incl
1544+ (partition, CByProperties (S.toList -> []) (S.toList -> excl)) ->
1545+ "In cases where " <> renderPartitionLocation partition <> " does not contain the properties: " <> listCodes excl
1546+ (partition, CByProperties (S.toList -> incl) (S.toList -> excl)) ->
1547+ "In cases where " <> renderPartitionLocation partition
1548+ <> " contains the properties "
1550+ <> " and does not contain the properties "
1553+ listCodes :: [Text] -> Inlines
1554+ listCodes = fold . L.intersperse ", " . fmap code
1555+ renderPartitionLocation :: PartitionLocation -> Inlines
1556+ renderPartitionLocation p = code $ "$" <> renderPartitionLocation' p
1558+ renderPartitionLocation' :: PartitionLocation -> Text
1559+ renderPartitionLocation' PHere = mempty
1560+ renderPartitionLocation' (PInProperty prop rest) = "." <> prop <> renderPartitionLocation' rest
1562+instance Behavable 'TypedSchemaLevel 'SchemaLevel where
1563+ data Behave 'TypedSchemaLevel 'SchemaLevel
1566+ | InAdditionalProperty
1567+ deriving stock (Eq, Ord, Show)
1569+ describeBehaviour InItems = "Items"
1570+ describeBehaviour (InProperty p) = "Property " <> code p
1571+ describeBehaviour InAdditionalProperty = "Additional properties"
1573+instance Subtree Schema where
1574+ type SubtreeLevel Schema = 'SchemaLevel
1575+ type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]
1576+ checkStructuralCompatibility env pc = do
1577+ structuralEq $ fmap _schemaRequired <$> pc
1578+ structuralEq $ fmap _schemaNullable <$> pc
1579+ structuralMaybeWith (structuralList env) $ tracedAllOf <$> pc
1580+ structuralMaybeWith (structuralList env) $ tracedOneOf <$> pc
1581+ structuralMaybe env $ sequence . stepTraced NotStep . fmap _schemaNot <$> pc
1582+ structuralMaybeWith (structuralList env) $ tracedAnyOf <$> pc
1583+ iohmStructural env $ stepTraced PropertiesStep . fmap _schemaProperties <$> pc
1584+ structuralMaybeWith structuralAdditionalProperties $ tracedAdditionalProperties <$> pc
1585+ structuralMaybeWith structuralDiscriminator $ tracedDiscriminator <$> pc
1586+ structuralEq $ fmap _schemaReadOnly <$> pc
1587+ structuralEq $ fmap _schemaWriteOnly <$> pc
1588+ structuralEq $ fmap _schemaXml <$> pc
1589+ structuralEq $ fmap _schemaMaxProperties <$> pc
1590+ structuralEq $ fmap _schemaMinProperties <$> pc
1591+ structuralEq $ fmap _schemaDefault <$> pc
1592+ structuralEq $ fmap _schemaType <$> pc
1593+ structuralEq $ fmap _schemaFormat <$> pc
1594+ structuralMaybeWith structuralItems $ tracedItems <$> pc
1595+ structuralEq $ fmap _schemaMaximum <$> pc
1596+ structuralEq $ fmap _schemaExclusiveMaximum <$> pc
1597+ structuralEq $ fmap _schemaMinimum <$> pc
1598+ structuralEq $ fmap _schemaExclusiveMinimum <$> pc
1599+ structuralEq $ fmap _schemaMaxLength <$> pc
1600+ structuralEq $ fmap _schemaMinLength <$> pc
1601+ structuralEq $ fmap _schemaPattern <$> pc
1602+ structuralEq $ fmap _schemaMaxItems <$> pc
1603+ structuralEq $ fmap _schemaMinItems <$> pc
1604+ structuralEq $ fmap _schemaUniqueItems <$> pc
1605+ structuralEq $ fmap _schemaEnum <$> pc
1606+ structuralEq $ fmap _schemaMultipleOf <$> pc
1609+ structuralAdditionalProperties
1610+ (ProdCons (Left x) (Left y)) = unless (x == y) structuralIssue
1611+ structuralAdditionalProperties
1612+ (ProdCons (Right x) (Right y)) =
1613+ checkSubstructure env $ ProdCons x y
1614+ structuralAdditionalProperties _ = structuralIssue
1615+ structuralDiscriminator pc' = do
1616+ structuralEq $ fmap _discriminatorPropertyName <$> pc'
1617+ iohmStructural env $
1618+ stepTraced DiscriminatorMapping . fmap (fmap parseDiscriminatorValue . _discriminatorMapping) <$> pc'
1620+ structuralItems (ProdCons (Left a) (Left b)) =
1621+ checkSubstructure env $ ProdCons a b
1622+ structuralItems (ProdCons (Right a) (Right b)) =
1623+ structuralList env $ ProdCons a b
1624+ structuralItems _ = structuralIssue
1625+ checkSemanticCompatibility env beh schs = do
1626+ let defs = getH env
1627+ checkFormulas env beh defs $ schemaToFormula <$> defs <*> schs