{-# OPTIONS_GHC -Wno-orphans #-}

module Data.OpenApi.Compare.Validate.Schema
  (
  )
where

import Control.Monad.Writer
import qualified Data.Aeson as A
import Data.Coerce
import Data.Foldable (for_, toList)
import Data.Functor
import Data.HList
import Data.List (genericIndex, genericLength, group)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Maybe
import Data.OpenApi
import Data.OpenApi.Compare.Behavior
import Data.OpenApi.Compare.Paths
import qualified Data.OpenApi.Compare.PathsPrefixTree as P
import Data.OpenApi.Compare.Subtree
import Data.OpenApi.Compare.Validate.Schema.DNF
import Data.OpenApi.Compare.Validate.Schema.Issues
import Data.OpenApi.Compare.Validate.Schema.JsonFormula
import Data.OpenApi.Compare.Validate.Schema.Partition
import Data.OpenApi.Compare.Validate.Schema.Process
import Data.OpenApi.Compare.Validate.Schema.Traced
import Data.OpenApi.Compare.Validate.Schema.TypedJson
import Data.Ord
import Data.Ratio
import Data.Semigroup
import qualified Data.Set as S
import Data.Text (Text)

checkFormulas ::
  (ReassembleHList xs (CheckEnv (Referenced Schema))) =>
  HList xs ->
  Behavior 'SchemaLevel ->
  ProdCons (Trace Schema) ->
  ProdCons (Traced (Definitions Schema)) ->
  ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel) ->
  SemanticCompatFormula ()
checkFormulas :: HList xs
-> Behavior 'SchemaLevel
-> ProdCons (Trace Schema)
-> ProdCons (Traced (Definitions Schema))
-> ProdCons
     (ForeachType JsonFormula,
      PathsPrefixTree Behave AnIssue 'SchemaLevel)
-> SemanticCompatFormula ()
checkFormulas HList xs
env Behavior 'SchemaLevel
beh ProdCons (Trace Schema)
trs ProdCons (Traced (Definitions Schema))
defs (ProdCons (ForeachType JsonFormula
fp, PathsPrefixTree Behave AnIssue 'SchemaLevel
ep) (ForeachType JsonFormula
fc, PathsPrefixTree Behave AnIssue 'SchemaLevel
ec)) =
  case PathsPrefixTree Behave AnIssue 'SchemaLevel
-> [AnItem Behave AnIssue 'SchemaLevel]
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> [AnItem q f r]
P.toList PathsPrefixTree Behave AnIssue 'SchemaLevel
ep [AnItem Behave AnIssue 'SchemaLevel]
-> [AnItem Behave AnIssue 'SchemaLevel]
-> [AnItem Behave AnIssue 'SchemaLevel]
forall a. [a] -> [a] -> [a]
++ PathsPrefixTree Behave AnIssue 'SchemaLevel
-> [AnItem Behave AnIssue 'SchemaLevel]
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> [AnItem q f r]
P.toList PathsPrefixTree Behave AnIssue 'SchemaLevel
ec of
    issues :: [AnItem Behave AnIssue 'SchemaLevel]
issues@(AnItem Behave AnIssue 'SchemaLevel
_ : [AnItem Behave AnIssue 'SchemaLevel]
_) -> [AnItem Behave AnIssue 'SchemaLevel]
-> (AnItem Behave AnIssue 'SchemaLevel
    -> Compose CompatM (FormulaF Behave AnIssue 'APILevel) Any)
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [AnItem Behave AnIssue 'SchemaLevel]
issues ((AnItem Behave AnIssue 'SchemaLevel
  -> Compose CompatM (FormulaF Behave AnIssue 'APILevel) Any)
 -> SemanticCompatFormula ())
-> (AnItem Behave AnIssue 'SchemaLevel
    -> Compose CompatM (FormulaF Behave AnIssue 'APILevel) Any)
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Behavior 'SchemaLevel
-> CompatFormula' Behave AnIssue 'SchemaLevel Any
-> Compose CompatM (FormulaF Behave AnIssue 'APILevel) Any
forall k (q :: k -> k -> *) (r :: k) (l :: k) (f :: k -> *) a.
Paths q r l -> CompatFormula' q f l a -> CompatFormula' q f r a
embedFormula Behavior 'SchemaLevel
beh (CompatFormula' Behave AnIssue 'SchemaLevel Any
 -> Compose CompatM (FormulaF Behave AnIssue 'APILevel) Any)
-> (AnItem Behave AnIssue 'SchemaLevel
    -> CompatFormula' Behave AnIssue 'SchemaLevel Any)
-> AnItem Behave AnIssue 'SchemaLevel
-> Compose CompatM (FormulaF Behave AnIssue 'APILevel) Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnItem Behave AnIssue 'SchemaLevel
-> CompatFormula' Behave AnIssue 'SchemaLevel Any
forall (q :: BehaviorLevel -> BehaviorLevel -> *)
       (r :: BehaviorLevel) a.
AnItem q AnIssue r -> CompatFormula' q AnIssue r a
anItem
    [] -> do
      -- We have the following isomorphisms:
      --   (A ⊂ X ∩ Y) = (A ⊂ X) /\ (A ⊂ Y)
      --   (A ⊂ ⊤) = 1
      --   (X ∪ Y ⊂ B) = (X ⊂ B) /\ (Y ⊂ B)
      --   (∅ ⊂ B) = 1
      -- The remaining cases are, notably, not isomorphisms:
      --   1) (A ⊂ X ∪ Y) <= (A ⊂ X) \/ (A ⊂ Y)
      --   2) (A ⊂ ∅) <= 0
      --   3) (X ∩ Y ⊂ B) <= (X ⊂ B) \/ (Y ⊂ B)
      --   4) (⊤ ⊂ B) <= 0
      -- Therefore we have the implications with (∃ and ∀ being the N-ary
      -- versions of \/ and /\ respectively):
      --   (⋃_i ⋂_j A[i,j]) ⊂ (⋃_k ⋂_l B[k,l])
      --   <= ∃k ∀l ∀i, (⋂_j A[i,j]) ⊂ B[k,l]
      --   = ∀i ∃k ∀l, (⋂_j A[i,j]) ⊂ B[k,l]
      -- with the caveat that the the set over which k ranges is nonempty.
      -- (because 2) is not an isomorphism), and that this is a sufficient
      -- but not necessary condition (because 1) is not an isomorphism).
      -- Our disjunction loses information, so it makes sense to nest it as
      -- deeply as possible, hence we choose the latter representation.
      --
      -- We delegate the verification of (⋂_j A[j]) ⊂ B to a separate heuristic
      -- function, with the understanding that ∃j, A[j] ⊂ B is a sufficient,
      -- but not necessary condition (because of 3) and 4)).
      --
      -- If k ranges over an empty set, we have the isomorphism:
      --   (⋃_i ⋂_j A[i,j]) ⊂ ∅ = ∀i, (⋂_j A[i,j]) ⊂ ∅
      -- where we again delegate (⋂_j A[j]) ⊂ ∅ to a heuristic, though here the
      -- shortcut of ∃j, A[j] ⊂ ∅ hardly helps.
      --
      -- Disjunctions tend to erase informative error messages, so we may want
      -- to avoid them. This can be formally done as follows: if we can
      -- partition the universal set into a disjoint union of some parts:
      --   ⊤ = ⊔_α P[α]
      -- such that the conjuncts in our disjunctive normal form are subordinate
      -- to the partition:
      --   ∀i ∃α, (⋂_j A[i,j]) ⊂ P[α]
      --   ∀k ∃α, (⋂_l B[k,l]) ⊂ P[α]
      -- then we can partition the sets over which i and k range into partitions
      -- I[α] and K[α], and then in each "bucket" verify the inclusion in the
      -- aforementioned way:
      --   ∀α, (⋃_i∈I[α] ⋂_j A[i,j]) ⊂ (⋃_k∈K[α] ⋂_l B[k,l])
      --   = ∀α ∀i∈I[α] ∃k∈K[α] ∀l, (⋂_j A[i,j]) ⊂ B[k,l]
      -- We already somewhat do this by partitioning JSON into types, but we can
      -- additionally partition e.g. "enum" fields or existence of particular
      -- properties. This works especially well if we manage to ensure K[α] are
      -- 1-element sets.
      --
      -- Since the set:
      --   (⋃_i∈I[α] ⋂_j A[i,j]) = (⋃_i ⋂_j A[i,j]) ∩ P[α]
      -- does not actually appear in the source schema, we need to construct it
      -- ourselves and come up with a name for it.
      let typesRestricted :: Bool
typesRestricted = Bool -> Bool
not (ForeachType JsonFormula -> Bool
anyBottomTypes ForeachType JsonFormula
fp) Bool -> Bool -> Bool
&& ForeachType JsonFormula -> Bool
anyBottomTypes ForeachType JsonFormula
fc
      -- Specifically handle the case when a schema's type has been
      -- restricted from "all" to specific types: if all types were allowed
      -- in the producer and not all types are allowed in the consumer, it's
      -- usually easier to say what's left than what's removed
      Bool -> SemanticCompatFormula () -> SemanticCompatFormula ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
typesRestricted (SemanticCompatFormula () -> SemanticCompatFormula ())
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Behavior 'SchemaLevel
-> Issue 'SchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Behavior 'SchemaLevel
beh (Issue 'SchemaLevel -> SemanticCompatFormula ())
-> Issue 'SchemaLevel -> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ [JsonType] -> Issue 'SchemaLevel
TypesRestricted ([JsonType] -> Issue 'SchemaLevel)
-> [JsonType] -> Issue 'SchemaLevel
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula -> [JsonType]
nonBottomTypes ForeachType JsonFormula
fc
      (forall (x :: JsonType).
 Typeable x =>
 JsonType
 -> (ForeachType JsonFormula -> JsonFormula x)
 -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (m :: * -> *) (f :: JsonType -> *).
Applicative m =>
(forall (x :: JsonType).
 Typeable x =>
 JsonType -> (ForeachType f -> f x) -> m ())
-> m ()
forType_ ((forall (x :: JsonType).
  Typeable x =>
  JsonType
  -> (ForeachType JsonFormula -> JsonFormula x)
  -> SemanticCompatFormula ())
 -> SemanticCompatFormula ())
-> (forall (x :: JsonType).
    Typeable x =>
    JsonType
    -> (ForeachType JsonFormula -> JsonFormula x)
    -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \JsonType
tyName ForeachType JsonFormula -> JsonFormula x
ty -> do
        let beh' :: Paths Behave 'APILevel 'TypedSchemaLevel
beh' = Behavior 'SchemaLevel
beh Behavior 'SchemaLevel
-> Paths Behave 'SchemaLevel 'TypedSchemaLevel
-> Paths Behave 'APILevel 'TypedSchemaLevel
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Behave 'SchemaLevel 'TypedSchemaLevel
-> Paths Behave 'SchemaLevel 'TypedSchemaLevel
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step (JsonType -> Behave 'SchemaLevel 'TypedSchemaLevel
OfType JsonType
tyName)
        case (JsonFormula x -> DNF (Condition x)
forall (t :: JsonType). JsonFormula t -> DNF (Condition t)
getJsonFormula (JsonFormula x -> DNF (Condition x))
-> JsonFormula x -> DNF (Condition x)
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula -> JsonFormula x
ty ForeachType JsonFormula
fp, JsonFormula x -> DNF (Condition x)
forall (t :: JsonType). JsonFormula t -> DNF (Condition t)
getJsonFormula (JsonFormula x -> DNF (Condition x))
-> JsonFormula x -> DNF (Condition x)
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula -> JsonFormula x
ty ForeachType JsonFormula
fc) of
          (DNF Set (Disjunct (Condition x))
pss, DNF (Condition x)
BottomDNF) -> Bool -> SemanticCompatFormula () -> SemanticCompatFormula ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
typesRestricted (SemanticCompatFormula () -> SemanticCompatFormula ())
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ do
            -- don't repeat the TypesRestricted issue
            Set (Disjunct (Condition x))
-> (Disjunct (Condition x) -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set (Disjunct (Condition x))
pss ((Disjunct (Condition x) -> SemanticCompatFormula ())
 -> SemanticCompatFormula ())
-> (Disjunct (Condition x) -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \(Disjunct Set (Condition x)
ps) -> Paths Behave 'APILevel 'TypedSchemaLevel
-> Maybe Partition -> Set (Condition x) -> SemanticCompatFormula ()
forall (t :: JsonType).
Paths Behave 'APILevel 'TypedSchemaLevel
-> Maybe Partition -> Set (Condition t) -> SemanticCompatFormula ()
checkContradiction Paths Behave 'APILevel 'TypedSchemaLevel
beh' Maybe Partition
forall a. Maybe a
Nothing Set (Condition x)
ps
          (DNF Set (Disjunct (Condition x))
pss, SingleDisjunct (Disjunct Set (Condition x)
cs)) -> Set (Disjunct (Condition x))
-> (Disjunct (Condition x) -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set (Disjunct (Condition x))
pss ((Disjunct (Condition x) -> SemanticCompatFormula ())
 -> SemanticCompatFormula ())
-> (Disjunct (Condition x) -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \(Disjunct Set (Condition x)
ps) -> do
            Set (Condition x)
-> (Condition x -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set (Condition x)
cs ((Condition x -> SemanticCompatFormula ())
 -> SemanticCompatFormula ())
-> (Condition x -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ HList xs
-> Paths Behave 'APILevel 'TypedSchemaLevel
-> ProdCons (Trace Schema)
-> Set (Condition x)
-> Condition x
-> SemanticCompatFormula ()
forall (xs :: [*]) (t :: JsonType).
ReassembleHList xs (CheckEnv (Referenced Schema)) =>
HList xs
-> Paths Behave 'APILevel 'TypedSchemaLevel
-> ProdCons (Trace Schema)
-> Set (Condition t)
-> Condition t
-> SemanticCompatFormula ()
checkImplication HList xs
env Paths Behave 'APILevel 'TypedSchemaLevel
beh' ProdCons (Trace Schema)
trs Set (Condition x)
ps -- avoid disjunction if there's only one conjunct
          (DNF (Condition x)
TopDNF, DNF Set (Disjunct (Condition x))
css) ->
            -- producer is "open" (allows any value), but consumer has restrictions.
            -- In this case we want to show which restrictions were added. (instead
            -- of showing an empty list restrictions that couldn't be satisfied.)
            Set (Disjunct (Condition x))
-> (Disjunct (Condition x) -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set (Disjunct (Condition x))
css ((Disjunct (Condition x) -> SemanticCompatFormula ())
 -> SemanticCompatFormula ())
-> (Disjunct (Condition x) -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \(Disjunct Set (Condition x)
cs) -> Set (Condition x)
-> (Condition x -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set (Condition x)
cs ((Condition x -> SemanticCompatFormula ())
 -> SemanticCompatFormula ())
-> (Condition x -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ HList xs
-> Paths Behave 'APILevel 'TypedSchemaLevel
-> ProdCons (Trace Schema)
-> Set (Condition x)
-> Condition x
-> SemanticCompatFormula ()
forall (xs :: [*]) (t :: JsonType).
ReassembleHList xs (CheckEnv (Referenced Schema)) =>
HList xs
-> Paths Behave 'APILevel 'TypedSchemaLevel
-> ProdCons (Trace Schema)
-> Set (Condition t)
-> Condition t
-> SemanticCompatFormula ()
checkImplication HList xs
env Paths Behave 'APILevel 'TypedSchemaLevel
beh' ProdCons (Trace Schema)
trs Set (Condition x)
forall a. Set a
S.empty
          (DNF (Condition x)
pss', DNF (Condition x)
css') -> [(Maybe Partition, ProdCons (JsonFormula x))]
-> ((Maybe Partition, ProdCons (JsonFormula x))
    -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ProdCons (Traced (Definitions Schema))
-> ProdCons (JsonFormula x)
-> [(Maybe Partition, ProdCons (JsonFormula x))]
forall (t :: JsonType).
ProdCons (Traced (Definitions Schema))
-> ProdCons (JsonFormula t)
-> [(Maybe Partition, ProdCons (JsonFormula t))]
tryPartition ProdCons (Traced (Definitions Schema))
defs (ProdCons (JsonFormula x)
 -> [(Maybe Partition, ProdCons (JsonFormula x))])
-> ProdCons (JsonFormula x)
-> [(Maybe Partition, ProdCons (JsonFormula x))]
forall a b. (a -> b) -> a -> b
$ JsonFormula x -> JsonFormula x -> ProdCons (JsonFormula x)
forall a. a -> a -> ProdCons a
ProdCons (DNF (Condition x) -> JsonFormula x
forall (t :: JsonType). DNF (Condition t) -> JsonFormula t
JsonFormula DNF (Condition x)
pss') (DNF (Condition x) -> JsonFormula x
forall (t :: JsonType). DNF (Condition t) -> JsonFormula t
JsonFormula DNF (Condition x)
css')) (((Maybe Partition, ProdCons (JsonFormula x))
  -> SemanticCompatFormula ())
 -> SemanticCompatFormula ())
-> ((Maybe Partition, ProdCons (JsonFormula x))
    -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \case
            (Maybe Partition
mPart, ProdCons JsonFormula x
pf JsonFormula x
cf) -> do
              let beh'' :: Paths Behave 'APILevel 'TypedSchemaLevel
beh'' = (Partition
 -> Paths Behave 'APILevel 'TypedSchemaLevel
 -> Paths Behave 'APILevel 'TypedSchemaLevel)
-> Paths Behave 'APILevel 'TypedSchemaLevel
-> Maybe Partition
-> Paths Behave 'APILevel 'TypedSchemaLevel
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Paths Behave 'TypedSchemaLevel 'TypedSchemaLevel
-> Paths Behave 'APILevel 'TypedSchemaLevel
-> Paths Behave 'APILevel 'TypedSchemaLevel
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(<<<) (Paths Behave 'TypedSchemaLevel 'TypedSchemaLevel
 -> Paths Behave 'APILevel 'TypedSchemaLevel
 -> Paths Behave 'APILevel 'TypedSchemaLevel)
-> (Partition -> Paths Behave 'TypedSchemaLevel 'TypedSchemaLevel)
-> Partition
-> Paths Behave 'APILevel 'TypedSchemaLevel
-> Paths Behave 'APILevel 'TypedSchemaLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Behave 'TypedSchemaLevel 'TypedSchemaLevel
-> Paths Behave 'TypedSchemaLevel 'TypedSchemaLevel
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step (Behave 'TypedSchemaLevel 'TypedSchemaLevel
 -> Paths Behave 'TypedSchemaLevel 'TypedSchemaLevel)
-> (Partition -> Behave 'TypedSchemaLevel 'TypedSchemaLevel)
-> Partition
-> Paths Behave 'TypedSchemaLevel 'TypedSchemaLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Partition -> Behave 'TypedSchemaLevel 'TypedSchemaLevel
InPartition) Paths Behave 'APILevel 'TypedSchemaLevel
beh' Maybe Partition
mPart
              case (JsonFormula x -> DNF (Condition x)
forall (t :: JsonType). JsonFormula t -> DNF (Condition t)
getJsonFormula JsonFormula x
pf, JsonFormula x -> DNF (Condition x)
forall (t :: JsonType). JsonFormula t -> DNF (Condition t)
getJsonFormula JsonFormula x
cf) of
                (DNF Set (Disjunct (Condition x))
pss, DNF (Condition x)
BottomDNF) -> Set (Disjunct (Condition x))
-> (Disjunct (Condition x) -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set (Disjunct (Condition x))
pss ((Disjunct (Condition x) -> SemanticCompatFormula ())
 -> SemanticCompatFormula ())
-> (Disjunct (Condition x) -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \(Disjunct Set (Condition x)
ps) -> Paths Behave 'APILevel 'TypedSchemaLevel
-> Maybe Partition -> Set (Condition x) -> SemanticCompatFormula ()
forall (t :: JsonType).
Paths Behave 'APILevel 'TypedSchemaLevel
-> Maybe Partition -> Set (Condition t) -> SemanticCompatFormula ()
checkContradiction Paths Behave 'APILevel 'TypedSchemaLevel
beh' Maybe Partition
mPart Set (Condition x)
ps
                (DNF Set (Disjunct (Condition x))
pss, SingleDisjunct (Disjunct Set (Condition x)
cs)) -> Set (Disjunct (Condition x))
-> (Disjunct (Condition x) -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set (Disjunct (Condition x))
pss ((Disjunct (Condition x) -> SemanticCompatFormula ())
 -> SemanticCompatFormula ())
-> (Disjunct (Condition x) -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \(Disjunct Set (Condition x)
ps) -> do
                  Set (Condition x)
-> (Condition x -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set (Condition x)
cs ((Condition x -> SemanticCompatFormula ())
 -> SemanticCompatFormula ())
-> (Condition x -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ HList xs
-> Paths Behave 'APILevel 'TypedSchemaLevel
-> ProdCons (Trace Schema)
-> Set (Condition x)
-> Condition x
-> SemanticCompatFormula ()
forall (xs :: [*]) (t :: JsonType).
ReassembleHList xs (CheckEnv (Referenced Schema)) =>
HList xs
-> Paths Behave 'APILevel 'TypedSchemaLevel
-> ProdCons (Trace Schema)
-> Set (Condition t)
-> Condition t
-> SemanticCompatFormula ()
checkImplication HList xs
env Paths Behave 'APILevel 'TypedSchemaLevel
beh'' ProdCons (Trace Schema)
trs Set (Condition x)
ps
                -- unlucky:
                (DNF Set (Disjunct (Condition x))
pss, DNF Set (Disjunct (Condition x))
css) -> Set (Disjunct (Condition x))
-> (Disjunct (Condition x) -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set (Disjunct (Condition x))
pss ((Disjunct (Condition x) -> SemanticCompatFormula ())
 -> SemanticCompatFormula ())
-> (Disjunct (Condition x) -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \(Disjunct Set (Condition x)
ps) -> do
                  Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel
-> [SemanticCompatFormula ()]
-> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l
-> Issue l
-> [CompatFormula' q AnIssue r a]
-> CompatFormula' q AnIssue r a
anyOfAt
                    Paths Behave 'APILevel 'TypedSchemaLevel
beh'
                    (Maybe Partition -> Set (Condition x) -> Issue 'TypedSchemaLevel
forall (t :: JsonType).
Typeable t =>
Maybe Partition -> Set (Condition t) -> Issue 'TypedSchemaLevel
issueFromDisjunct Maybe Partition
forall a. Maybe a
Nothing Set (Condition x)
ps)
                    [Set (Condition x)
-> (Condition x -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set (Condition x)
cs ((Condition x -> SemanticCompatFormula ())
 -> SemanticCompatFormula ())
-> (Condition x -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ HList xs
-> Paths Behave 'APILevel 'TypedSchemaLevel
-> ProdCons (Trace Schema)
-> Set (Condition x)
-> Condition x
-> SemanticCompatFormula ()
forall (xs :: [*]) (t :: JsonType).
ReassembleHList xs (CheckEnv (Referenced Schema)) =>
HList xs
-> Paths Behave 'APILevel 'TypedSchemaLevel
-> ProdCons (Trace Schema)
-> Set (Condition t)
-> Condition t
-> SemanticCompatFormula ()
checkImplication HList xs
env Paths Behave 'APILevel 'TypedSchemaLevel
beh' ProdCons (Trace Schema)
trs Set (Condition x)
ps | Disjunct Set (Condition x)
cs <- Set (Disjunct (Condition x)) -> [Disjunct (Condition x)]
forall a. Set a -> [a]
S.toList Set (Disjunct (Condition x))
css]
      pure ()
  where
    anyBottomTypes :: ForeachType JsonFormula -> Bool
anyBottomTypes ForeachType JsonFormula
f = Any -> Bool
getAny (Any -> Bool) -> Any -> Bool
forall a b. (a -> b) -> a -> b
$
      (forall (x :: JsonType).
 Typeable x =>
 JsonType -> (ForeachType JsonFormula -> JsonFormula x) -> Any)
-> Any
forall m (f :: JsonType -> *).
Monoid m =>
(forall (x :: JsonType).
 Typeable x =>
 JsonType -> (ForeachType f -> f x) -> m)
-> m
foldType ((forall (x :: JsonType).
  Typeable x =>
  JsonType -> (ForeachType JsonFormula -> JsonFormula x) -> Any)
 -> Any)
-> (forall (x :: JsonType).
    Typeable x =>
    JsonType -> (ForeachType JsonFormula -> JsonFormula x) -> Any)
-> Any
forall a b. (a -> b) -> a -> b
$ \JsonType
_ ForeachType JsonFormula -> JsonFormula x
ty -> case JsonFormula x -> DNF (Condition x)
forall (t :: JsonType). JsonFormula t -> DNF (Condition t)
getJsonFormula (JsonFormula x -> DNF (Condition x))
-> JsonFormula x -> DNF (Condition x)
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula -> JsonFormula x
ty ForeachType JsonFormula
f of
        DNF (Condition x)
BottomDNF -> Bool -> Any
Any Bool
True
        DNF (Condition x)
_ -> Any
forall a. Monoid a => a
mempty
    nonBottomTypes :: ForeachType JsonFormula -> [JsonType]
nonBottomTypes ForeachType JsonFormula
f = (forall (x :: JsonType).
 Typeable x =>
 JsonType
 -> (ForeachType JsonFormula -> JsonFormula x) -> [JsonType])
-> [JsonType]
forall m (f :: JsonType -> *).
Monoid m =>
(forall (x :: JsonType).
 Typeable x =>
 JsonType -> (ForeachType f -> f x) -> m)
-> m
foldType ((forall (x :: JsonType).
  Typeable x =>
  JsonType
  -> (ForeachType JsonFormula -> JsonFormula x) -> [JsonType])
 -> [JsonType])
-> (forall (x :: JsonType).
    Typeable x =>
    JsonType
    -> (ForeachType JsonFormula -> JsonFormula x) -> [JsonType])
-> [JsonType]
forall a b. (a -> b) -> a -> b
$ \JsonType
tyName ForeachType JsonFormula -> JsonFormula x
ty -> case JsonFormula x -> DNF (Condition x)
forall (t :: JsonType). JsonFormula t -> DNF (Condition t)
getJsonFormula (JsonFormula x -> DNF (Condition x))
-> JsonFormula x -> DNF (Condition x)
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula -> JsonFormula x
ty ForeachType JsonFormula
f of
      DNF (Condition x)
BottomDNF -> [JsonType]
forall a. Monoid a => a
mempty
      DNF (Condition x)
_ -> [JsonType
tyName]
    issueFromDisjunct :: Typeable t => Maybe Partition -> S.Set (Condition t) -> Issue 'TypedSchemaLevel
    issueFromDisjunct :: Maybe Partition -> Set (Condition t) -> Issue 'TypedSchemaLevel
issueFromDisjunct Maybe Partition
_ Set (Condition t)
ps
      | Just TypedValue t
e <- Set (Condition t) -> Maybe (TypedValue t)
forall (t :: JsonType). Set (Condition t) -> Maybe (TypedValue t)
findExactly Set (Condition t)
ps
        , (Condition t -> Bool) -> Set (Condition t) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TypedValue t -> Condition t -> Bool
forall (t :: JsonType). TypedValue t -> Condition t -> Bool
satisfiesTyped TypedValue t
e) Set (Condition t)
ps =
        Value -> Issue 'TypedSchemaLevel
EnumDoesntSatisfy (Value -> Issue 'TypedSchemaLevel)
-> Value -> Issue 'TypedSchemaLevel
forall a b. (a -> b) -> a -> b
$ TypedValue t -> Value
forall (t :: JsonType). TypedValue t -> Value
untypeValue TypedValue t
e -- what does this look like when partitioned?
    issueFromDisjunct Maybe Partition
mPart Set (Condition t)
ps = Maybe Partition -> [SomeCondition] -> Issue 'TypedSchemaLevel
NoMatchingCondition Maybe Partition
mPart ([SomeCondition] -> Issue 'TypedSchemaLevel)
-> [SomeCondition] -> Issue 'TypedSchemaLevel
forall a b. (a -> b) -> a -> b
$ Condition t -> SomeCondition
forall (t :: JsonType). Typeable t => Condition t -> SomeCondition
SomeCondition (Condition t -> SomeCondition) -> [Condition t] -> [SomeCondition]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (Condition t) -> [Condition t]
forall a. Set a -> [a]
S.toList Set (Condition t)
ps

checkContradiction ::
  Behavior 'TypedSchemaLevel ->
  Maybe Partition ->
  S.Set (Condition t) ->
  SemanticCompatFormula ()
checkContradiction :: Paths Behave 'APILevel 'TypedSchemaLevel
-> Maybe Partition -> Set (Condition t) -> SemanticCompatFormula ()
checkContradiction Paths Behave 'APILevel 'TypedSchemaLevel
beh Maybe Partition
mPart Set (Condition t)
_ = Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh (Issue 'TypedSchemaLevel -> SemanticCompatFormula ())
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Issue 'TypedSchemaLevel
-> (Partition -> Issue 'TypedSchemaLevel)
-> Maybe Partition
-> Issue 'TypedSchemaLevel
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Issue 'TypedSchemaLevel
TypeBecomesEmpty Partition -> Issue 'TypedSchemaLevel
PartitionBecomesEmpty Maybe Partition
mPart -- TODO #70

checkImplication ::
  (ReassembleHList xs (CheckEnv (Referenced Schema))) =>
  HList xs ->
  Behavior 'TypedSchemaLevel ->
  ProdCons (Trace Schema) -> -- the traces of the root schemas used in this comparison
  S.Set (Condition t) ->
  Condition t ->
  SemanticCompatFormula ()
checkImplication :: HList xs
-> Paths Behave 'APILevel 'TypedSchemaLevel
-> ProdCons (Trace Schema)
-> Set (Condition t)
-> Condition t
-> SemanticCompatFormula ()
checkImplication HList xs
env Paths Behave 'APILevel 'TypedSchemaLevel
beh ProdCons (Trace Schema)
trs Set (Condition t)
prods Condition t
cons = case Set (Condition t) -> Maybe (TypedValue t)
forall (t :: JsonType). Set (Condition t) -> Maybe (TypedValue t)
findExactly Set (Condition t)
prods of
  Just TypedValue t
e
    | (Condition t -> Bool) -> Set (Condition t) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TypedValue t -> Condition t -> Bool
forall (t :: JsonType). TypedValue t -> Condition t -> Bool
satisfiesTyped TypedValue t
e) Set (Condition t)
prods ->
      if TypedValue t -> Condition t -> Bool
forall (t :: JsonType). TypedValue t -> Condition t -> Bool
satisfiesTyped TypedValue t
e Condition t
cons
        then () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        else Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh (Value -> Issue 'TypedSchemaLevel
EnumDoesntSatisfy (Value -> Issue 'TypedSchemaLevel)
-> Value -> Issue 'TypedSchemaLevel
forall a b. (a -> b) -> a -> b
$ TypedValue t -> Value
forall (t :: JsonType). TypedValue t -> Value
untypeValue TypedValue t
e)
    | Bool
otherwise -> () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- vacuously true
  Maybe (TypedValue t)
Nothing -> case Condition t
cons of
    -- the above code didn't catch it, so there's no Exactly condition on the lhs
    Exactly TypedValue t
e -> Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh (Value -> Issue 'TypedSchemaLevel
NoMatchingEnum (Value -> Issue 'TypedSchemaLevel)
-> Value -> Issue 'TypedSchemaLevel
forall a b. (a -> b) -> a -> b
$ TypedValue t -> Value
forall (t :: JsonType). TypedValue t -> Value
untypeValue TypedValue t
e)
    Maximum Bound Scientific
m -> (Bound Scientific -> Bound Scientific -> Bound Scientific)
-> Bound Scientific
-> (Bound Scientific -> Issue 'TypedSchemaLevel)
-> (ProdCons (Bound Scientific) -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType).
    Condition t -> Maybe (Bound Scientific))
-> SemanticCompatFormula ()
forall a.
Eq a =>
(a -> a -> a)
-> a
-> (a -> Issue 'TypedSchemaLevel)
-> (ProdCons a -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe a)
-> SemanticCompatFormula ()
foldCheck Bound Scientific -> Bound Scientific -> Bound Scientific
forall a. Ord a => a -> a -> a
min Bound Scientific
m Bound Scientific -> Issue 'TypedSchemaLevel
NoMatchingMaximum ProdCons (Bound Scientific) -> Issue 'TypedSchemaLevel
MatchingMaximumWeak ((forall (t :: JsonType). Condition t -> Maybe (Bound Scientific))
 -> SemanticCompatFormula ())
-> (forall (t :: JsonType).
    Condition t -> Maybe (Bound Scientific))
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \case
      Maximum Bound Scientific
m' -> Bound Scientific -> Maybe (Bound Scientific)
forall a. a -> Maybe a
Just Bound Scientific
m'
      Condition t
_ -> Maybe (Bound Scientific)
forall a. Maybe a
Nothing
    Minimum Down (Bound (Down Scientific))
m -> (Down (Bound (Down Scientific))
 -> Down (Bound (Down Scientific))
 -> Down (Bound (Down Scientific)))
-> Down (Bound (Down Scientific))
-> (Down (Bound (Down Scientific)) -> Issue 'TypedSchemaLevel)
-> (ProdCons (Down (Bound (Down Scientific)))
    -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType).
    Condition t -> Maybe (Down (Bound (Down Scientific))))
-> SemanticCompatFormula ()
forall a.
Eq a =>
(a -> a -> a)
-> a
-> (a -> Issue 'TypedSchemaLevel)
-> (ProdCons a -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe a)
-> SemanticCompatFormula ()
foldCheck Down (Bound (Down Scientific))
-> Down (Bound (Down Scientific)) -> Down (Bound (Down Scientific))
forall a. Ord a => a -> a -> a
max Down (Bound (Down Scientific))
m (Bound Scientific -> Issue 'TypedSchemaLevel
NoMatchingMinimum (Bound Scientific -> Issue 'TypedSchemaLevel)
-> (Down (Bound (Down Scientific)) -> Bound Scientific)
-> Down (Bound (Down Scientific))
-> Issue 'TypedSchemaLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Down (Bound (Down Scientific)) -> Bound Scientific
coerce) (ProdCons (Bound Scientific) -> Issue 'TypedSchemaLevel
MatchingMinimumWeak (ProdCons (Bound Scientific) -> Issue 'TypedSchemaLevel)
-> (ProdCons (Down (Bound (Down Scientific)))
    -> ProdCons (Bound Scientific))
-> ProdCons (Down (Bound (Down Scientific)))
-> Issue 'TypedSchemaLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProdCons (Down (Bound (Down Scientific)))
-> ProdCons (Bound Scientific)
coerce) ((forall (t :: JsonType).
  Condition t -> Maybe (Down (Bound (Down Scientific))))
 -> SemanticCompatFormula ())
-> (forall (t :: JsonType).
    Condition t -> Maybe (Down (Bound (Down Scientific))))
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \case
      Minimum Down (Bound (Down Scientific))
m' -> Down (Bound (Down Scientific))
-> Maybe (Down (Bound (Down Scientific)))
forall a. a -> Maybe a
Just Down (Bound (Down Scientific))
m'
      Condition t
_ -> Maybe (Down (Bound (Down Scientific)))
forall a. Maybe a
Nothing
    MultipleOf Scientific
m -> (Scientific -> Scientific -> Scientific)
-> Scientific
-> (Scientific -> Issue 'TypedSchemaLevel)
-> (ProdCons Scientific -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe Scientific)
-> SemanticCompatFormula ()
forall a.
Eq a =>
(a -> a -> a)
-> a
-> (a -> Issue 'TypedSchemaLevel)
-> (ProdCons a -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe a)
-> SemanticCompatFormula ()
foldCheck Scientific -> Scientific -> Scientific
forall a a a. (Real a, Real a, Fractional a) => a -> a -> a
lcmScientific Scientific
m Scientific -> Issue 'TypedSchemaLevel
NoMatchingMultipleOf ProdCons Scientific -> Issue 'TypedSchemaLevel
MatchingMultipleOfWeak ((forall (t :: JsonType). Condition t -> Maybe Scientific)
 -> SemanticCompatFormula ())
-> (forall (t :: JsonType). Condition t -> Maybe Scientific)
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \case
      MultipleOf Scientific
m' -> Scientific -> Maybe Scientific
forall a. a -> Maybe a
Just Scientific
m'
      Condition t
_ -> Maybe Scientific
forall a. Maybe a
Nothing
    NumberFormat Format
f -> case ((Condition t -> Bool) -> Set (Condition t) -> Bool)
-> Set (Condition t) -> (Condition t -> Bool) -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Condition t -> Bool) -> Set (Condition t) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Set (Condition t)
prods ((Condition t -> Bool) -> Bool) -> (Condition t -> Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ \case
      NumberFormat Format
f' -> Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
f'
      Condition t
_ -> Bool
False of
      Bool
True -> () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Bool
False -> Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh (Format -> Issue 'TypedSchemaLevel
NoMatchingFormat Format
f)
    MaxLength Integer
m -> (Integer -> Integer -> Integer)
-> Integer
-> (Integer -> Issue 'TypedSchemaLevel)
-> (ProdCons Integer -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe Integer)
-> SemanticCompatFormula ()
forall a.
Eq a =>
(a -> a -> a)
-> a
-> (a -> Issue 'TypedSchemaLevel)
-> (ProdCons a -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe a)
-> SemanticCompatFormula ()
foldCheck Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min Integer
m Integer -> Issue 'TypedSchemaLevel
NoMatchingMaxLength ProdCons Integer -> Issue 'TypedSchemaLevel
MatchingMaxLengthWeak ((forall (t :: JsonType). Condition t -> Maybe Integer)
 -> SemanticCompatFormula ())
-> (forall (t :: JsonType). Condition t -> Maybe Integer)
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \case
      MaxLength Integer
m' -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
m'
      Condition t
_ -> Maybe Integer
forall a. Maybe a
Nothing
    MinLength Integer
m -> (Integer -> Integer -> Integer)
-> Integer
-> (Integer -> Issue 'TypedSchemaLevel)
-> (ProdCons Integer -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe Integer)
-> SemanticCompatFormula ()
forall a.
Eq a =>
(a -> a -> a)
-> a
-> (a -> Issue 'TypedSchemaLevel)
-> (ProdCons a -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe a)
-> SemanticCompatFormula ()
foldCheck Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
m Integer -> Issue 'TypedSchemaLevel
NoMatchingMinLength ProdCons Integer -> Issue 'TypedSchemaLevel
MatchingMinLengthWeak ((forall (t :: JsonType). Condition t -> Maybe Integer)
 -> SemanticCompatFormula ())
-> (forall (t :: JsonType). Condition t -> Maybe Integer)
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \case
      MinLength Integer
m' -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
m'
      Condition t
_ -> Maybe Integer
forall a. Maybe a
Nothing
    Pattern Format
p -> case ((Condition t -> Bool) -> Set (Condition t) -> Bool)
-> Set (Condition t) -> (Condition t -> Bool) -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Condition t -> Bool) -> Set (Condition t) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Set (Condition t)
prods ((Condition t -> Bool) -> Bool) -> (Condition t -> Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ \case
      Pattern Format
p' -> Format
p Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
p'
      Condition t
_ -> Bool
False of
      Bool
True -> () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Bool
False -> Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh (Format -> Issue 'TypedSchemaLevel
NoMatchingPattern Format
p) -- TODO: regex comparison #32
    StringFormat Format
f -> case ((Condition t -> Bool) -> Set (Condition t) -> Bool)
-> Set (Condition t) -> (Condition t -> Bool) -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Condition t -> Bool) -> Set (Condition t) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Set (Condition t)
prods ((Condition t -> Bool) -> Bool) -> (Condition t -> Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ \case
      StringFormat Format
f' -> Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
f'
      Condition t
_ -> Bool
False of
      Bool
True -> () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Bool
False -> Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh (Format -> Issue 'TypedSchemaLevel
NoMatchingFormat Format
f)
    Items ForeachType JsonFormula
_ Traced (Referenced Schema)
cons' -> case ((Maybe (NonEmpty (Traced (Referenced Schema))),
  Maybe (NonEmpty [Traced (Referenced Schema)]))
 -> (Maybe (NonEmpty (Traced (Referenced Schema))),
     Maybe (NonEmpty [Traced (Referenced Schema)]))
 -> (Maybe (NonEmpty (Traced (Referenced Schema))),
     Maybe (NonEmpty [Traced (Referenced Schema)])))
-> Set (Condition t)
-> (Condition t
    -> Maybe
         (Maybe (NonEmpty (Traced (Referenced Schema))),
          Maybe (NonEmpty [Traced (Referenced Schema)])))
-> Maybe
     (Maybe (NonEmpty (Traced (Referenced Schema))),
      Maybe (NonEmpty [Traced (Referenced Schema)]))
forall b a. (b -> b -> b) -> Set a -> (a -> Maybe b) -> Maybe b
foldSome (Maybe (NonEmpty (Traced (Referenced Schema))),
 Maybe (NonEmpty [Traced (Referenced Schema)]))
-> (Maybe (NonEmpty (Traced (Referenced Schema))),
    Maybe (NonEmpty [Traced (Referenced Schema)]))
-> (Maybe (NonEmpty (Traced (Referenced Schema))),
    Maybe (NonEmpty [Traced (Referenced Schema)]))
forall a. Semigroup a => a -> a -> a
(<>) Set (Condition t)
prods ((Condition t
  -> Maybe
       (Maybe (NonEmpty (Traced (Referenced Schema))),
        Maybe (NonEmpty [Traced (Referenced Schema)])))
 -> Maybe
      (Maybe (NonEmpty (Traced (Referenced Schema))),
       Maybe (NonEmpty [Traced (Referenced Schema)])))
-> (Condition t
    -> Maybe
         (Maybe (NonEmpty (Traced (Referenced Schema))),
          Maybe (NonEmpty [Traced (Referenced Schema)])))
-> Maybe
     (Maybe (NonEmpty (Traced (Referenced Schema))),
      Maybe (NonEmpty [Traced (Referenced Schema)]))
forall a b. (a -> b) -> a -> b
$ \case
      Items ForeachType JsonFormula
_ Traced (Referenced Schema)
rs -> (Maybe (NonEmpty (Traced (Referenced Schema))),
 Maybe (NonEmpty [Traced (Referenced Schema)]))
-> Maybe
     (Maybe (NonEmpty (Traced (Referenced Schema))),
      Maybe (NonEmpty [Traced (Referenced Schema)]))
forall a. a -> Maybe a
Just (NonEmpty (Traced (Referenced Schema))
-> Maybe (NonEmpty (Traced (Referenced Schema)))
forall a. a -> Maybe a
Just (Traced (Referenced Schema)
rs Traced (Referenced Schema)
-> [Traced (Referenced Schema)]
-> NonEmpty (Traced (Referenced Schema))
forall a. a -> [a] -> NonEmpty a
NE.:| []), Maybe (NonEmpty [Traced (Referenced Schema)])
forall a. Monoid a => a
mempty)
      TupleItems (((ForeachType JsonFormula, Traced (Referenced Schema))
 -> Traced (Referenced Schema))
-> [(ForeachType JsonFormula, Traced (Referenced Schema))]
-> [Traced (Referenced Schema)]
forall a b. (a -> b) -> [a] -> [b]
map (ForeachType JsonFormula, Traced (Referenced Schema))
-> Traced (Referenced Schema)
forall a b. (a, b) -> b
snd -> [Traced (Referenced Schema)]
fs) -> (Maybe (NonEmpty (Traced (Referenced Schema))),
 Maybe (NonEmpty [Traced (Referenced Schema)]))
-> Maybe
     (Maybe (NonEmpty (Traced (Referenced Schema))),
      Maybe (NonEmpty [Traced (Referenced Schema)]))
forall a. a -> Maybe a
Just (Maybe (NonEmpty (Traced (Referenced Schema)))
forall a. Monoid a => a
mempty, NonEmpty [Traced (Referenced Schema)]
-> Maybe (NonEmpty [Traced (Referenced Schema)])
forall a. a -> Maybe a
Just ([Traced (Referenced Schema)]
fs [Traced (Referenced Schema)]
-> [[Traced (Referenced Schema)]]
-> NonEmpty [Traced (Referenced Schema)]
forall a. a -> [a] -> NonEmpty a
NE.:| []))
      Condition t
_ -> Maybe
  (Maybe (NonEmpty (Traced (Referenced Schema))),
   Maybe (NonEmpty [Traced (Referenced Schema)]))
forall a. Maybe a
Nothing of
      Just (Maybe (NonEmpty (Traced (Referenced Schema)))
mItems, Just NonEmpty [Traced (Referenced Schema)]
pfs)
        | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ NonEmpty Int -> Bool
forall (f :: * -> *) a. (Foldable f, Eq a) => f a -> Bool
allSame ([Traced (Referenced Schema)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Traced (Referenced Schema)] -> Int)
-> NonEmpty [Traced (Referenced Schema)] -> NonEmpty Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty [Traced (Referenced Schema)]
pfs) -> () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- vacuously
        | let plen :: Integer
plen = [Traced (Referenced Schema)] -> Integer
forall i a. Num i => [a] -> i
genericLength (NonEmpty [Traced (Referenced Schema)]
-> [Traced (Referenced Schema)]
forall a. NonEmpty a -> a
NE.head NonEmpty [Traced (Referenced Schema)]
pfs) ->
          AnItem Behave AnIssue 'APILevel
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall (q :: BehaviorLevel -> BehaviorLevel -> *)
       (r :: BehaviorLevel) a.
AnItem q AnIssue r
-> CompatFormula' q AnIssue r a -> CompatFormula' q AnIssue r a
clarifyIssue (Paths Behave 'APILevel 'TypedSchemaLevel
-> AnIssue 'TypedSchemaLevel -> AnItem Behave AnIssue 'APILevel
forall k (f :: k -> *) (a :: k) (q :: k -> k -> *) (r :: k).
Ord (f a) =>
Paths q r a -> f a -> AnItem q f r
AnItem Paths Behave 'APILevel 'TypedSchemaLevel
beh (Issue 'TypedSchemaLevel -> AnIssue 'TypedSchemaLevel
forall (l :: BehaviorLevel). Issuable l => Issue l -> AnIssue l
anIssue Issue 'TypedSchemaLevel
TupleToArray)) (SemanticCompatFormula () -> SemanticCompatFormula ())
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$
            [Integer]
-> (Integer -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Integer
0 .. Integer
plen Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1] ((Integer -> SemanticCompatFormula ()) -> SemanticCompatFormula ())
-> (Integer -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \Integer
i -> do
              let prod' :: Traced (Referenced Schema)
prod' = NonEmpty (Traced (Referenced Schema)) -> Traced (Referenced Schema)
tracedConjunct (NonEmpty (Traced (Referenced Schema))
 -> Traced (Referenced Schema))
-> NonEmpty (Traced (Referenced Schema))
-> Traced (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ case Maybe (NonEmpty (Traced (Referenced Schema)))
mItems of
                    Just NonEmpty (Traced (Referenced Schema))
prods' -> (([Traced (Referenced Schema)]
-> Integer -> Traced (Referenced Schema)
forall i a. Integral i => [a] -> i -> a
`genericIndex` Integer
i) ([Traced (Referenced Schema)] -> Traced (Referenced Schema))
-> NonEmpty [Traced (Referenced Schema)]
-> NonEmpty (Traced (Referenced Schema))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty [Traced (Referenced Schema)]
pfs) NonEmpty (Traced (Referenced Schema))
-> NonEmpty (Traced (Referenced Schema))
-> NonEmpty (Traced (Referenced Schema))
forall a. Semigroup a => a -> a -> a
<> NonEmpty (Traced (Referenced Schema))
prods'
                    Maybe (NonEmpty (Traced (Referenced Schema)))
Nothing -> ([Traced (Referenced Schema)]
-> Integer -> Traced (Referenced Schema)
forall i a. Integral i => [a] -> i -> a
`genericIndex` Integer
i) ([Traced (Referenced Schema)] -> Traced (Referenced Schema))
-> NonEmpty [Traced (Referenced Schema)]
-> NonEmpty (Traced (Referenced Schema))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty [Traced (Referenced Schema)]
pfs
              Behavior (SubtreeLevel (Referenced Schema))
-> HList xs
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall t (xs :: [*]).
(ReassembleHList xs (CheckEnv t), Subtree t) =>
Behavior (SubtreeLevel t)
-> HList xs -> ProdCons (Traced t) -> SemanticCompatFormula ()
checkCompatibility (Paths Behave 'APILevel 'TypedSchemaLevel
beh Paths Behave 'APILevel 'TypedSchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
-> Behavior 'SchemaLevel
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Behave 'TypedSchemaLevel 'SchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step (Integer -> Behave 'TypedSchemaLevel 'SchemaLevel
InItem Integer
i)) HList xs
env (ProdCons (Traced (Referenced Schema)) -> SemanticCompatFormula ())
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced (Referenced Schema)
-> Traced (Referenced Schema)
-> ProdCons (Traced (Referenced Schema))
forall a. a -> a -> ProdCons a
ProdCons Traced (Referenced Schema)
prod' Traced (Referenced Schema)
cons'
      Just (Just NonEmpty (Traced (Referenced Schema))
prods', Maybe (NonEmpty [Traced (Referenced Schema)])
Nothing) -> do
        let prod' :: Traced (Referenced Schema)
prod' = NonEmpty (Traced (Referenced Schema)) -> Traced (Referenced Schema)
tracedConjunct NonEmpty (Traced (Referenced Schema))
prods'
        Behavior (SubtreeLevel (Referenced Schema))
-> HList xs
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall t (xs :: [*]).
(ReassembleHList xs (CheckEnv t), Subtree t) =>
Behavior (SubtreeLevel t)
-> HList xs -> ProdCons (Traced t) -> SemanticCompatFormula ()
checkCompatibility (Paths Behave 'APILevel 'TypedSchemaLevel
beh Paths Behave 'APILevel 'TypedSchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
-> Behavior 'SchemaLevel
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Behave 'TypedSchemaLevel 'SchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step Behave 'TypedSchemaLevel 'SchemaLevel
InItems) HList xs
env (ProdCons (Traced (Referenced Schema)) -> SemanticCompatFormula ())
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced (Referenced Schema)
-> Traced (Referenced Schema)
-> ProdCons (Traced (Referenced Schema))
forall a. a -> a -> ProdCons a
ProdCons Traced (Referenced Schema)
prod' Traced (Referenced Schema)
cons'
      Maybe
  (Maybe (NonEmpty (Traced (Referenced Schema))),
   Maybe (NonEmpty [Traced (Referenced Schema)]))
_ -> AnItem Behave AnIssue 'APILevel
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall (q :: BehaviorLevel -> BehaviorLevel -> *)
       (r :: BehaviorLevel) a.
AnItem q AnIssue r
-> CompatFormula' q AnIssue r a -> CompatFormula' q AnIssue r a
clarifyIssue (Paths Behave 'APILevel 'TypedSchemaLevel
-> AnIssue 'TypedSchemaLevel -> AnItem Behave AnIssue 'APILevel
forall k (f :: k -> *) (a :: k) (q :: k -> k -> *) (r :: k).
Ord (f a) =>
Paths q r a -> f a -> AnItem q f r
AnItem Paths Behave 'APILevel 'TypedSchemaLevel
beh (Issue 'TypedSchemaLevel -> AnIssue 'TypedSchemaLevel
forall (l :: BehaviorLevel). Issuable l => Issue l -> AnIssue l
anIssue Issue 'TypedSchemaLevel
NoMatchingItems)) (SemanticCompatFormula () -> SemanticCompatFormula ())
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ do
        Behavior (SubtreeLevel (Referenced Schema))
-> HList xs
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall t (xs :: [*]).
(ReassembleHList xs (CheckEnv t), Subtree t) =>
Behavior (SubtreeLevel t)
-> HList xs -> ProdCons (Traced t) -> SemanticCompatFormula ()
checkCompatibility (Paths Behave 'APILevel 'TypedSchemaLevel
beh Paths Behave 'APILevel 'TypedSchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
-> Behavior 'SchemaLevel
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Behave 'TypedSchemaLevel 'SchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step Behave 'TypedSchemaLevel 'SchemaLevel
InItems) HList xs
env (ProdCons (Traced (Referenced Schema)) -> SemanticCompatFormula ())
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced (Referenced Schema)
-> Traced (Referenced Schema)
-> ProdCons (Traced (Referenced Schema))
forall a. a -> a -> ProdCons a
ProdCons Traced (Referenced Schema)
prodTopSchema Traced (Referenced Schema)
cons'
    TupleItems (((ForeachType JsonFormula, Traced (Referenced Schema))
 -> Traced (Referenced Schema))
-> [(ForeachType JsonFormula, Traced (Referenced Schema))]
-> [Traced (Referenced Schema)]
forall a b. (a -> b) -> [a] -> [b]
map (ForeachType JsonFormula, Traced (Referenced Schema))
-> Traced (Referenced Schema)
forall a b. (a, b) -> b
snd -> [Traced (Referenced Schema)]
fs) -> case ((Maybe (NonEmpty [Traced (Referenced Schema)]),
  Maybe (Max Integer), Maybe (Min Integer),
  Maybe (NonEmpty (Traced (Referenced Schema))))
 -> (Maybe (NonEmpty [Traced (Referenced Schema)]),
     Maybe (Max Integer), Maybe (Min Integer),
     Maybe (NonEmpty (Traced (Referenced Schema))))
 -> (Maybe (NonEmpty [Traced (Referenced Schema)]),
     Maybe (Max Integer), Maybe (Min Integer),
     Maybe (NonEmpty (Traced (Referenced Schema)))))
-> Set (Condition t)
-> (Condition t
    -> Maybe
         (Maybe (NonEmpty [Traced (Referenced Schema)]),
          Maybe (Max Integer), Maybe (Min Integer),
          Maybe (NonEmpty (Traced (Referenced Schema)))))
-> Maybe
     (Maybe (NonEmpty [Traced (Referenced Schema)]),
      Maybe (Max Integer), Maybe (Min Integer),
      Maybe (NonEmpty (Traced (Referenced Schema))))
forall b a. (b -> b -> b) -> Set a -> (a -> Maybe b) -> Maybe b
foldSome (Maybe (NonEmpty [Traced (Referenced Schema)]),
 Maybe (Max Integer), Maybe (Min Integer),
 Maybe (NonEmpty (Traced (Referenced Schema))))
-> (Maybe (NonEmpty [Traced (Referenced Schema)]),
    Maybe (Max Integer), Maybe (Min Integer),
    Maybe (NonEmpty (Traced (Referenced Schema))))
-> (Maybe (NonEmpty [Traced (Referenced Schema)]),
    Maybe (Max Integer), Maybe (Min Integer),
    Maybe (NonEmpty (Traced (Referenced Schema))))
forall a. Semigroup a => a -> a -> a
(<>) Set (Condition t)
prods ((Condition t
  -> Maybe
       (Maybe (NonEmpty [Traced (Referenced Schema)]),
        Maybe (Max Integer), Maybe (Min Integer),
        Maybe (NonEmpty (Traced (Referenced Schema)))))
 -> Maybe
      (Maybe (NonEmpty [Traced (Referenced Schema)]),
       Maybe (Max Integer), Maybe (Min Integer),
       Maybe (NonEmpty (Traced (Referenced Schema)))))
-> (Condition t
    -> Maybe
         (Maybe (NonEmpty [Traced (Referenced Schema)]),
          Maybe (Max Integer), Maybe (Min Integer),
          Maybe (NonEmpty (Traced (Referenced Schema)))))
-> Maybe
     (Maybe (NonEmpty [Traced (Referenced Schema)]),
      Maybe (Max Integer), Maybe (Min Integer),
      Maybe (NonEmpty (Traced (Referenced Schema))))
forall a b. (a -> b) -> a -> b
$ \case
      TupleItems (((ForeachType JsonFormula, Traced (Referenced Schema))
 -> Traced (Referenced Schema))
-> [(ForeachType JsonFormula, Traced (Referenced Schema))]
-> [Traced (Referenced Schema)]
forall a b. (a -> b) -> [a] -> [b]
map (ForeachType JsonFormula, Traced (Referenced Schema))
-> Traced (Referenced Schema)
forall a b. (a, b) -> b
snd -> [Traced (Referenced Schema)]
fs') -> (Maybe (NonEmpty [Traced (Referenced Schema)]),
 Maybe (Max Integer), Maybe (Min Integer),
 Maybe (NonEmpty (Traced (Referenced Schema))))
-> Maybe
     (Maybe (NonEmpty [Traced (Referenced Schema)]),
      Maybe (Max Integer), Maybe (Min Integer),
      Maybe (NonEmpty (Traced (Referenced Schema))))
forall a. a -> Maybe a
Just (NonEmpty [Traced (Referenced Schema)]
-> Maybe (NonEmpty [Traced (Referenced Schema)])
forall a. a -> Maybe a
Just (NonEmpty [Traced (Referenced Schema)]
 -> Maybe (NonEmpty [Traced (Referenced Schema)]))
-> NonEmpty [Traced (Referenced Schema)]
-> Maybe (NonEmpty [Traced (Referenced Schema)])
forall a b. (a -> b) -> a -> b
$ [Traced (Referenced Schema)]
fs' [Traced (Referenced Schema)]
-> [[Traced (Referenced Schema)]]
-> NonEmpty [Traced (Referenced Schema)]
forall a. a -> [a] -> NonEmpty a
NE.:| [], Max Integer -> Maybe (Max Integer)
forall a. a -> Maybe a
Just (Max Integer -> Maybe (Max Integer))
-> (Integer -> Max Integer) -> Integer -> Maybe (Max Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Max Integer
forall a. a -> Max a
Max (Integer -> Maybe (Max Integer)) -> Integer -> Maybe (Max Integer)
forall a b. (a -> b) -> a -> b
$ [Traced (Referenced Schema)] -> Integer
forall i a. Num i => [a] -> i
genericLength [Traced (Referenced Schema)]
fs', Min Integer -> Maybe (Min Integer)
forall a. a -> Maybe a
Just (Min Integer -> Maybe (Min Integer))
-> (Integer -> Min Integer) -> Integer -> Maybe (Min Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Min Integer
forall a. a -> Min a
Min (Integer -> Maybe (Min Integer)) -> Integer -> Maybe (Min Integer)
forall a b. (a -> b) -> a -> b
$ [Traced (Referenced Schema)] -> Integer
forall i a. Num i => [a] -> i
genericLength [Traced (Referenced Schema)]
fs', Maybe (NonEmpty (Traced (Referenced Schema)))
forall a. Monoid a => a
mempty)
      MinItems Integer
m' -> (Maybe (NonEmpty [Traced (Referenced Schema)]),
 Maybe (Max Integer), Maybe (Min Integer),
 Maybe (NonEmpty (Traced (Referenced Schema))))
-> Maybe
     (Maybe (NonEmpty [Traced (Referenced Schema)]),
      Maybe (Max Integer), Maybe (Min Integer),
      Maybe (NonEmpty (Traced (Referenced Schema))))
forall a. a -> Maybe a
Just (Maybe (NonEmpty [Traced (Referenced Schema)])
forall a. Monoid a => a
mempty, Max Integer -> Maybe (Max Integer)
forall a. a -> Maybe a
Just (Max Integer -> Maybe (Max Integer))
-> (Integer -> Max Integer) -> Integer -> Maybe (Max Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Max Integer
forall a. a -> Max a
Max (Integer -> Maybe (Max Integer)) -> Integer -> Maybe (Max Integer)
forall a b. (a -> b) -> a -> b
$ Integer
m', Maybe (Min Integer)
forall a. Monoid a => a
mempty, Maybe (NonEmpty (Traced (Referenced Schema)))
forall a. Monoid a => a
mempty)
      MaxItems Integer
m' -> (Maybe (NonEmpty [Traced (Referenced Schema)]),
 Maybe (Max Integer), Maybe (Min Integer),
 Maybe (NonEmpty (Traced (Referenced Schema))))
-> Maybe
     (Maybe (NonEmpty [Traced (Referenced Schema)]),
      Maybe (Max Integer), Maybe (Min Integer),
      Maybe (NonEmpty (Traced (Referenced Schema))))
forall a. a -> Maybe a
Just (Maybe (NonEmpty [Traced (Referenced Schema)])
forall a. Monoid a => a
mempty, Maybe (Max Integer)
forall a. Monoid a => a
mempty, Min Integer -> Maybe (Min Integer)
forall a. a -> Maybe a
Just (Min Integer -> Maybe (Min Integer))
-> (Integer -> Min Integer) -> Integer -> Maybe (Min Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Min Integer
forall a. a -> Min a
Min (Integer -> Maybe (Min Integer)) -> Integer -> Maybe (Min Integer)
forall a b. (a -> b) -> a -> b
$ Integer
m', Maybe (NonEmpty (Traced (Referenced Schema)))
forall a. Monoid a => a
mempty)
      Items ForeachType JsonFormula
_ Traced (Referenced Schema)
rs -> (Maybe (NonEmpty [Traced (Referenced Schema)]),
 Maybe (Max Integer), Maybe (Min Integer),
 Maybe (NonEmpty (Traced (Referenced Schema))))
-> Maybe
     (Maybe (NonEmpty [Traced (Referenced Schema)]),
      Maybe (Max Integer), Maybe (Min Integer),
      Maybe (NonEmpty (Traced (Referenced Schema))))
forall a. a -> Maybe a
Just (Maybe (NonEmpty [Traced (Referenced Schema)])
forall a. Monoid a => a
mempty, Maybe (Max Integer)
forall a. Monoid a => a
mempty, Maybe (Min Integer)
forall a. Monoid a => a
mempty, NonEmpty (Traced (Referenced Schema))
-> Maybe (NonEmpty (Traced (Referenced Schema)))
forall a. a -> Maybe a
Just (Traced (Referenced Schema)
rs Traced (Referenced Schema)
-> [Traced (Referenced Schema)]
-> NonEmpty (Traced (Referenced Schema))
forall a. a -> [a] -> NonEmpty a
NE.:| []))
      Condition t
_ -> Maybe
  (Maybe (NonEmpty [Traced (Referenced Schema)]),
   Maybe (Max Integer), Maybe (Min Integer),
   Maybe (NonEmpty (Traced (Referenced Schema))))
forall a. Maybe a
Nothing of
      -- if the length constraints in the producer are contradictory:
      Just (Maybe (NonEmpty [Traced (Referenced Schema)])
_, Just (Max Integer
lowest), Just (Min Integer
highest), Maybe (NonEmpty (Traced (Referenced Schema)))
_) | Integer
lowest Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
highest -> () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      -- We have an explicit tuple items clause...
      Just (Just NonEmpty [Traced (Referenced Schema)]
pfs, Just (Max Integer
plen), Maybe (Min Integer)
_, Maybe (NonEmpty (Traced (Referenced Schema)))
_)
        | Integer
plen Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= [Traced (Referenced Schema)] -> Integer
forall i a. Num i => [a] -> i
genericLength [Traced (Referenced Schema)]
fs -> -- ...of wrong length
          Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh (ProdCons Integer -> Issue 'TypedSchemaLevel
TupleItemsLengthChanged ProdCons :: forall a. a -> a -> ProdCons a
ProdCons {$sel:producer:ProdCons :: Integer
producer = Integer
plen, $sel:consumer:ProdCons :: Integer
consumer = [Traced (Referenced Schema)] -> Integer
forall i a. Num i => [a] -> i
genericLength [Traced (Referenced Schema)]
fs})
        | Bool
otherwise ->
          [Integer]
-> (Integer -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Integer
0 .. Integer
plen Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1] ((Integer -> SemanticCompatFormula ()) -> SemanticCompatFormula ())
-> (Integer -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \Integer
i -> do
            Behavior (SubtreeLevel (Referenced Schema))
-> HList xs
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall t (xs :: [*]).
(ReassembleHList xs (CheckEnv t), Subtree t) =>
Behavior (SubtreeLevel t)
-> HList xs -> ProdCons (Traced t) -> SemanticCompatFormula ()
checkCompatibility (Paths Behave 'APILevel 'TypedSchemaLevel
beh Paths Behave 'APILevel 'TypedSchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
-> Behavior 'SchemaLevel
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Behave 'TypedSchemaLevel 'SchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step (Integer -> Behave 'TypedSchemaLevel 'SchemaLevel
InItem Integer
i)) HList xs
env (ProdCons (Traced (Referenced Schema)) -> SemanticCompatFormula ())
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced (Referenced Schema)
-> Traced (Referenced Schema)
-> ProdCons (Traced (Referenced Schema))
forall a. a -> a -> ProdCons a
ProdCons (NonEmpty (Traced (Referenced Schema)) -> Traced (Referenced Schema)
tracedConjunct (NonEmpty (Traced (Referenced Schema))
 -> Traced (Referenced Schema))
-> NonEmpty (Traced (Referenced Schema))
-> Traced (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ ([Traced (Referenced Schema)]
-> Integer -> Traced (Referenced Schema)
forall i a. Integral i => [a] -> i -> a
`genericIndex` Integer
i) ([Traced (Referenced Schema)] -> Traced (Referenced Schema))
-> NonEmpty [Traced (Referenced Schema)]
-> NonEmpty (Traced (Referenced Schema))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty [Traced (Referenced Schema)]
pfs) ([Traced (Referenced Schema)]
fs [Traced (Referenced Schema)]
-> Integer -> Traced (Referenced Schema)
forall i a. Integral i => [a] -> i -> a
`genericIndex` Integer
i)
      -- We have a fixed length array in the producer...
      Just (Maybe (NonEmpty [Traced (Referenced Schema)])
Nothing, Just (Max Integer
plen), Just (Min Integer
plen'), Maybe (NonEmpty (Traced (Referenced Schema)))
mProd)
        | Integer
plen Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
plen' ->
          AnItem Behave AnIssue 'APILevel
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall (q :: BehaviorLevel -> BehaviorLevel -> *)
       (r :: BehaviorLevel) a.
AnItem q AnIssue r
-> CompatFormula' q AnIssue r a -> CompatFormula' q AnIssue r a
clarifyIssue (Paths Behave 'APILevel 'TypedSchemaLevel
-> AnIssue 'TypedSchemaLevel -> AnItem Behave AnIssue 'APILevel
forall k (f :: k -> *) (a :: k) (q :: k -> k -> *) (r :: k).
Ord (f a) =>
Paths q r a -> f a -> AnItem q f r
AnItem Paths Behave 'APILevel 'TypedSchemaLevel
beh (Issue 'TypedSchemaLevel -> AnIssue 'TypedSchemaLevel
forall (l :: BehaviorLevel). Issuable l => Issue l -> AnIssue l
anIssue Issue 'TypedSchemaLevel
ArrayToTuple)) (SemanticCompatFormula () -> SemanticCompatFormula ())
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ case Maybe (NonEmpty (Traced (Referenced Schema)))
mProd of
            Maybe (NonEmpty (Traced (Referenced Schema)))
_
              | Integer
plen Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= [Traced (Referenced Schema)] -> Integer
forall i a. Num i => [a] -> i
genericLength [Traced (Referenced Schema)]
fs -> -- ...of wrong length
                Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh (ProdCons Integer -> Issue 'TypedSchemaLevel
TupleItemsLengthChanged ProdCons :: forall a. a -> a -> ProdCons a
ProdCons {$sel:producer:ProdCons :: Integer
producer = Integer
plen, $sel:consumer:ProdCons :: Integer
consumer = [Traced (Referenced Schema)] -> Integer
forall i a. Num i => [a] -> i
genericLength [Traced (Referenced Schema)]
fs})
            Just NonEmpty (Traced (Referenced Schema))
rs -> [Integer]
-> (Integer -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Integer
0 .. Integer
plen Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1] ((Integer -> SemanticCompatFormula ()) -> SemanticCompatFormula ())
-> (Integer -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \Integer
i -> do
              Behavior (SubtreeLevel (Referenced Schema))
-> HList xs
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall t (xs :: [*]).
(ReassembleHList xs (CheckEnv t), Subtree t) =>
Behavior (SubtreeLevel t)
-> HList xs -> ProdCons (Traced t) -> SemanticCompatFormula ()
checkCompatibility (Paths Behave 'APILevel 'TypedSchemaLevel
beh Paths Behave 'APILevel 'TypedSchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
-> Behavior 'SchemaLevel
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Behave 'TypedSchemaLevel 'SchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step (Integer -> Behave 'TypedSchemaLevel 'SchemaLevel
InItem Integer
i)) HList xs
env (ProdCons (Traced (Referenced Schema)) -> SemanticCompatFormula ())
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced (Referenced Schema)
-> Traced (Referenced Schema)
-> ProdCons (Traced (Referenced Schema))
forall a. a -> a -> ProdCons a
ProdCons (NonEmpty (Traced (Referenced Schema)) -> Traced (Referenced Schema)
tracedConjunct NonEmpty (Traced (Referenced Schema))
rs) ([Traced (Referenced Schema)]
fs [Traced (Referenced Schema)]
-> Integer -> Traced (Referenced Schema)
forall i a. Integral i => [a] -> i -> a
`genericIndex` Integer
i)
            -- ...and no "items" schema
            Maybe (NonEmpty (Traced (Referenced Schema)))
Nothing -> AnItem Behave AnIssue 'APILevel
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall (q :: BehaviorLevel -> BehaviorLevel -> *)
       (r :: BehaviorLevel) a.
AnItem q AnIssue r
-> CompatFormula' q AnIssue r a -> CompatFormula' q AnIssue r a
clarifyIssue (Paths Behave 'APILevel 'TypedSchemaLevel
-> AnIssue 'TypedSchemaLevel -> AnItem Behave AnIssue 'APILevel
forall k (f :: k -> *) (a :: k) (q :: k -> k -> *) (r :: k).
Ord (f a) =>
Paths q r a -> f a -> AnItem q f r
AnItem Paths Behave 'APILevel 'TypedSchemaLevel
beh (Issue 'TypedSchemaLevel -> AnIssue 'TypedSchemaLevel
forall (l :: BehaviorLevel). Issuable l => Issue l -> AnIssue l
anIssue Issue 'TypedSchemaLevel
NoMatchingTupleItems)) (SemanticCompatFormula () -> SemanticCompatFormula ())
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ do
              [Integer]
-> (Integer -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Integer
0 .. Integer
plen Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1] ((Integer -> SemanticCompatFormula ()) -> SemanticCompatFormula ())
-> (Integer -> SemanticCompatFormula ())
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \Integer
i -> do
                Behavior (SubtreeLevel (Referenced Schema))
-> HList xs
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall t (xs :: [*]).
(ReassembleHList xs (CheckEnv t), Subtree t) =>
Behavior (SubtreeLevel t)
-> HList xs -> ProdCons (Traced t) -> SemanticCompatFormula ()
checkCompatibility (Paths Behave 'APILevel 'TypedSchemaLevel
beh Paths Behave 'APILevel 'TypedSchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
-> Behavior 'SchemaLevel
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Behave 'TypedSchemaLevel 'SchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step (Integer -> Behave 'TypedSchemaLevel 'SchemaLevel
InItem Integer
i)) HList xs
env (ProdCons (Traced (Referenced Schema)) -> SemanticCompatFormula ())
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced (Referenced Schema)
-> Traced (Referenced Schema)
-> ProdCons (Traced (Referenced Schema))
forall a. a -> a -> ProdCons a
ProdCons Traced (Referenced Schema)
prodTopSchema ([Traced (Referenced Schema)]
fs [Traced (Referenced Schema)]
-> Integer -> Traced (Referenced Schema)
forall i a. Integral i => [a] -> i -> a
`genericIndex` Integer
i)
      Maybe
  (Maybe (NonEmpty [Traced (Referenced Schema)]),
   Maybe (Max Integer), Maybe (Min Integer),
   Maybe (NonEmpty (Traced (Referenced Schema))))
_ -> Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh Issue 'TypedSchemaLevel
NoMatchingTupleItems
    MaxItems Integer
m -> (Integer -> Integer -> Integer)
-> Integer
-> (Integer -> Issue 'TypedSchemaLevel)
-> (ProdCons Integer -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe Integer)
-> SemanticCompatFormula ()
forall a.
Eq a =>
(a -> a -> a)
-> a
-> (a -> Issue 'TypedSchemaLevel)
-> (ProdCons a -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe a)
-> SemanticCompatFormula ()
foldCheck Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min Integer
m Integer -> Issue 'TypedSchemaLevel
NoMatchingMaxItems ProdCons Integer -> Issue 'TypedSchemaLevel
MatchingMaxItemsWeak ((forall (t :: JsonType). Condition t -> Maybe Integer)
 -> SemanticCompatFormula ())
-> (forall (t :: JsonType). Condition t -> Maybe Integer)
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \case
      MaxItems Integer
m' -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
m'
      TupleItems [(ForeachType JsonFormula, Traced (Referenced Schema))]
fs -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [(ForeachType JsonFormula, Traced (Referenced Schema))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ForeachType JsonFormula, Traced (Referenced Schema))]
fs
      Condition t
_ -> Maybe Integer
forall a. Maybe a
Nothing
    MinItems Integer
m -> (Integer -> Integer -> Integer)
-> Integer
-> (Integer -> Issue 'TypedSchemaLevel)
-> (ProdCons Integer -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe Integer)
-> SemanticCompatFormula ()
forall a.
Eq a =>
(a -> a -> a)
-> a
-> (a -> Issue 'TypedSchemaLevel)
-> (ProdCons a -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe a)
-> SemanticCompatFormula ()
foldCheck Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
m Integer -> Issue 'TypedSchemaLevel
NoMatchingMinItems ProdCons Integer -> Issue 'TypedSchemaLevel
MatchingMinItemsWeak ((forall (t :: JsonType). Condition t -> Maybe Integer)
 -> SemanticCompatFormula ())
-> (forall (t :: JsonType). Condition t -> Maybe Integer)
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \case
      MinItems Integer
m' -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
m'
      TupleItems [(ForeachType JsonFormula, Traced (Referenced Schema))]
fs -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [(ForeachType JsonFormula, Traced (Referenced Schema))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ForeachType JsonFormula, Traced (Referenced Schema))]
fs
      Condition t
_ -> Maybe Integer
forall a. Maybe a
Nothing
    Condition t
UniqueItems -> case ((Condition t -> Bool) -> Set (Condition t) -> Bool)
-> Set (Condition t) -> (Condition t -> Bool) -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Condition t -> Bool) -> Set (Condition t) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Set (Condition t)
prods ((Condition t -> Bool) -> Bool) -> (Condition t -> Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ \case
      Condition t
UniqueItems -> Bool
True
      MaxItems Integer
1 -> Bool
True
      TupleItems [(ForeachType JsonFormula, Traced (Referenced Schema))]
fs | [(ForeachType JsonFormula, Traced (Referenced Schema))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ForeachType JsonFormula, Traced (Referenced Schema))]
fs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Bool
True
      Condition t
_ -> Bool
False of
      Bool
True -> () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Bool
False -> Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh Issue 'TypedSchemaLevel
NoMatchingUniqueItems
    Properties Map Format Property
props ForeachType JsonFormula
_ Maybe (Traced (Referenced Schema))
madd -> case (NonEmpty (Map Format Property, Maybe (Traced (Referenced Schema)))
 -> NonEmpty
      (Map Format Property, Maybe (Traced (Referenced Schema)))
 -> NonEmpty
      (Map Format Property, Maybe (Traced (Referenced Schema))))
-> Set (Condition t)
-> (Condition t
    -> Maybe
         (NonEmpty
            (Map Format Property, Maybe (Traced (Referenced Schema)))))
-> Maybe
     (NonEmpty
        (Map Format Property, Maybe (Traced (Referenced Schema))))
forall b a. (b -> b -> b) -> Set a -> (a -> Maybe b) -> Maybe b
foldSome NonEmpty (Map Format Property, Maybe (Traced (Referenced Schema)))
-> NonEmpty
     (Map Format Property, Maybe (Traced (Referenced Schema)))
-> NonEmpty
     (Map Format Property, Maybe (Traced (Referenced Schema)))
forall a. Semigroup a => a -> a -> a
(<>) Set (Condition t)
prods ((Condition t
  -> Maybe
       (NonEmpty
          (Map Format Property, Maybe (Traced (Referenced Schema)))))
 -> Maybe
      (NonEmpty
         (Map Format Property, Maybe (Traced (Referenced Schema)))))
-> (Condition t
    -> Maybe
         (NonEmpty
            (Map Format Property, Maybe (Traced (Referenced Schema)))))
-> Maybe
     (NonEmpty
        (Map Format Property, Maybe (Traced (Referenced Schema))))
forall a b. (a -> b) -> a -> b
$ \case
      Properties Map Format Property
props' ForeachType JsonFormula
_ Maybe (Traced (Referenced Schema))
madd' -> NonEmpty (Map Format Property, Maybe (Traced (Referenced Schema)))
-> Maybe
     (NonEmpty
        (Map Format Property, Maybe (Traced (Referenced Schema))))
forall a. a -> Maybe a
Just (NonEmpty (Map Format Property, Maybe (Traced (Referenced Schema)))
 -> Maybe
      (NonEmpty
         (Map Format Property, Maybe (Traced (Referenced Schema)))))
-> NonEmpty
     (Map Format Property, Maybe (Traced (Referenced Schema)))
-> Maybe
     (NonEmpty
        (Map Format Property, Maybe (Traced (Referenced Schema))))
forall a b. (a -> b) -> a -> b
$ (Map Format Property
props', Maybe (Traced (Referenced Schema))
madd') (Map Format Property, Maybe (Traced (Referenced Schema)))
-> [(Map Format Property, Maybe (Traced (Referenced Schema)))]
-> NonEmpty
     (Map Format Property, Maybe (Traced (Referenced Schema)))
forall a. a -> [a] -> NonEmpty a
NE.:| []
      Condition t
_ -> Maybe
  (NonEmpty
     (Map Format Property, Maybe (Traced (Referenced Schema))))
forall a. Maybe a
Nothing of
      Just NonEmpty (Map Format Property, Maybe (Traced (Referenced Schema)))
pm ->
        Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel
-> [SemanticCompatFormula ()]
-> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l
-> Issue l
-> [CompatFormula' q AnIssue r a]
-> CompatFormula' q AnIssue r a
anyOfAt Paths Behave 'APILevel 'TypedSchemaLevel
beh Issue 'TypedSchemaLevel
NoMatchingProperties ([SemanticCompatFormula ()] -> SemanticCompatFormula ())
-> [SemanticCompatFormula ()] -> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ -- TODO: could first "concat" the lists
          NonEmpty (Map Format Property, Maybe (Traced (Referenced Schema)))
-> [(Map Format Property, Maybe (Traced (Referenced Schema)))]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Map Format Property, Maybe (Traced (Referenced Schema)))
pm [(Map Format Property, Maybe (Traced (Referenced Schema)))]
-> ((Map Format Property, Maybe (Traced (Referenced Schema)))
    -> SemanticCompatFormula ())
-> [SemanticCompatFormula ()]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Map Format Property
props', Maybe (Traced (Referenced Schema))
madd') -> do
            Set Format
-> (Format -> SemanticCompatFormula ()) -> SemanticCompatFormula ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Format] -> Set Format
forall a. Ord a => [a] -> Set a
S.fromList ([Format] -> Set Format) -> [Format] -> Set Format
forall a b. (a -> b) -> a -> b
$ Map Format Property -> [Format]
forall k a. Map k a -> [k]
M.keys Map Format Property
props [Format] -> [Format] -> [Format]
forall a. Semigroup a => a -> a -> a
<> Map Format Property -> [Format]
forall k a. Map k a -> [k]
M.keys Map Format Property
props') ((Format -> SemanticCompatFormula ()) -> SemanticCompatFormula ())
-> (Format -> SemanticCompatFormula ()) -> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \Format
k -> do
              let beh' :: Behavior 'SchemaLevel
beh' = Paths Behave 'APILevel 'TypedSchemaLevel
beh Paths Behave 'APILevel 'TypedSchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
-> Behavior 'SchemaLevel
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Behave 'TypedSchemaLevel 'SchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step (Format -> Behave 'TypedSchemaLevel 'SchemaLevel
InProperty Format
k)
                  go :: Traced (Referenced Schema)
-> Traced (Referenced Schema) -> SemanticCompatFormula ()
go Traced (Referenced Schema)
sch Traced (Referenced Schema)
sch' = Behavior (SubtreeLevel (Referenced Schema))
-> HList xs
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall t (xs :: [*]).
(ReassembleHList xs (CheckEnv t), Subtree t) =>
Behavior (SubtreeLevel t)
-> HList xs -> ProdCons (Traced t) -> SemanticCompatFormula ()
checkCompatibility Behavior 'SchemaLevel
Behavior (SubtreeLevel (Referenced Schema))
beh' HList xs
env (Traced (Referenced Schema)
-> Traced (Referenced Schema)
-> ProdCons (Traced (Referenced Schema))
forall a. a -> a -> ProdCons a
ProdCons Traced (Referenced Schema)
sch Traced (Referenced Schema)
sch')
              case (Bool -> (Property -> Bool) -> Maybe Property -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Property -> Bool
propRequired (Maybe Property -> Bool) -> Maybe Property -> Bool
forall a b. (a -> b) -> a -> b
$ Format -> Map Format Property -> Maybe Property
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Format
k Map Format Property
props', Bool -> (Property -> Bool) -> Maybe Property -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Property -> Bool
propRequired (Maybe Property -> Bool) -> Maybe Property -> Bool
forall a b. (a -> b) -> a -> b
$ Format -> Map Format Property -> Maybe Property
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Format
k Map Format Property
props) of
                -- producer does not require field, but consumer does (can fail)
                (Bool
False, Bool
True) -> Behavior 'SchemaLevel
-> Issue 'SchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Behavior 'SchemaLevel
beh' Issue 'SchemaLevel
PropertyNowRequired
                (Bool, Bool)
_ -> () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              case (Format -> Map Format Property -> Maybe Property
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Format
k Map Format Property
props', Maybe (Traced (Referenced Schema))
madd', Format -> Map Format Property -> Maybe Property
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Format
k Map Format Property
props, Maybe (Traced (Referenced Schema))
madd) of
                -- (producer, additional producer, consumer, additional consumer)
                (Maybe Property
Nothing, Maybe (Traced (Referenced Schema))
Nothing, Maybe Property
_, Maybe (Traced (Referenced Schema))
_) -> () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- vacuously: the producer asserts that this field cannot exist,
                -- and the consumer either doesn't require it, or it does and we've already raised an error about it.
                (Maybe Property
_, Maybe (Traced (Referenced Schema))
_, Maybe Property
Nothing, Maybe (Traced (Referenced Schema))
Nothing) -> Behavior 'SchemaLevel
-> Issue 'SchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Behavior 'SchemaLevel
beh' Issue 'SchemaLevel
UnexpectedProperty
                (Just Property
p', Maybe (Traced (Referenced Schema))
_, Just Property
p, Maybe (Traced (Referenced Schema))
_) -> Traced (Referenced Schema)
-> Traced (Referenced Schema) -> SemanticCompatFormula ()
go (Property -> Traced (Referenced Schema)
propRefSchema Property
p') (Property -> Traced (Referenced Schema)
propRefSchema Property
p)
                (Maybe Property
Nothing, Just Traced (Referenced Schema)
add', Just Property
p, Maybe (Traced (Referenced Schema))
_) ->
                  AnItem Behave AnIssue 'APILevel
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall (q :: BehaviorLevel -> BehaviorLevel -> *)
       (r :: BehaviorLevel) a.
AnItem q AnIssue r
-> CompatFormula' q AnIssue r a -> CompatFormula' q AnIssue r a
clarifyIssue (Behavior 'SchemaLevel
-> AnIssue 'SchemaLevel -> AnItem Behave AnIssue 'APILevel
forall k (f :: k -> *) (a :: k) (q :: k -> k -> *) (r :: k).
Ord (f a) =>
Paths q r a -> f a -> AnItem q f r
AnItem Behavior 'SchemaLevel
beh' (Issue 'SchemaLevel -> AnIssue 'SchemaLevel
forall (l :: BehaviorLevel). Issuable l => Issue l -> AnIssue l
anIssue Issue 'SchemaLevel
AdditionalToProperty)) (SemanticCompatFormula () -> SemanticCompatFormula ())
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$
                    Traced (Referenced Schema)
-> Traced (Referenced Schema) -> SemanticCompatFormula ()
go Traced (Referenced Schema)
add' (Property -> Traced (Referenced Schema)
propRefSchema Property
p)
                (Just Property
p', Maybe (Traced (Referenced Schema))
_, Maybe Property
Nothing, Just Traced (Referenced Schema)
add) ->
                  AnItem Behave AnIssue 'APILevel
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall (q :: BehaviorLevel -> BehaviorLevel -> *)
       (r :: BehaviorLevel) a.
AnItem q AnIssue r
-> CompatFormula' q AnIssue r a -> CompatFormula' q AnIssue r a
clarifyIssue (Behavior 'SchemaLevel
-> AnIssue 'SchemaLevel -> AnItem Behave AnIssue 'APILevel
forall k (f :: k -> *) (a :: k) (q :: k -> k -> *) (r :: k).
Ord (f a) =>
Paths q r a -> f a -> AnItem q f r
AnItem Behavior 'SchemaLevel
beh' (Issue 'SchemaLevel -> AnIssue 'SchemaLevel
forall (l :: BehaviorLevel). Issuable l => Issue l -> AnIssue l
anIssue Issue 'SchemaLevel
PropertyToAdditional)) (SemanticCompatFormula () -> SemanticCompatFormula ())
-> SemanticCompatFormula () -> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$
                    Traced (Referenced Schema)
-> Traced (Referenced Schema) -> SemanticCompatFormula ()
go (Property -> Traced (Referenced Schema)
propRefSchema Property
p') Traced (Referenced Schema)
add
                (Maybe Property
Nothing, Just Traced (Referenced Schema)
_, Maybe Property
Nothing, Just Traced (Referenced Schema)
_) -> () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              pure ()
            case (Maybe (Traced (Referenced Schema))
madd', Maybe (Traced (Referenced Schema))
madd) of
              (Maybe (Traced (Referenced Schema))
Nothing, Maybe (Traced (Referenced Schema))
_) -> () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- vacuously
              (Maybe (Traced (Referenced Schema))
_, Maybe (Traced (Referenced Schema))
Nothing) -> Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh Issue 'TypedSchemaLevel
NoAdditionalProperties
              (Just Traced (Referenced Schema)
add', Just Traced (Referenced Schema)
add) -> Behavior (SubtreeLevel (Referenced Schema))
-> HList xs
-> ProdCons (Traced (Referenced Schema))
-> SemanticCompatFormula ()
forall t (xs :: [*]).
(ReassembleHList xs (CheckEnv t), Subtree t) =>
Behavior (SubtreeLevel t)
-> HList xs -> ProdCons (Traced t) -> SemanticCompatFormula ()
checkCompatibility (Paths Behave 'APILevel 'TypedSchemaLevel
beh Paths Behave 'APILevel 'TypedSchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
-> Behavior 'SchemaLevel
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Behave 'TypedSchemaLevel 'SchemaLevel
-> Paths Behave 'TypedSchemaLevel 'SchemaLevel
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step Behave 'TypedSchemaLevel 'SchemaLevel
InAdditionalProperty) HList xs
env (Traced (Referenced Schema)
-> Traced (Referenced Schema)
-> ProdCons (Traced (Referenced Schema))
forall a. a -> a -> ProdCons a
ProdCons Traced (Referenced Schema)
add' Traced (Referenced Schema)
add)
            pure ()
      Maybe
  (NonEmpty
     (Map Format Property, Maybe (Traced (Referenced Schema))))
Nothing -> Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh Issue 'TypedSchemaLevel
NoMatchingProperties
    MaxProperties Integer
m -> (Integer -> Integer -> Integer)
-> Integer
-> (Integer -> Issue 'TypedSchemaLevel)
-> (ProdCons Integer -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe Integer)
-> SemanticCompatFormula ()
forall a.
Eq a =>
(a -> a -> a)
-> a
-> (a -> Issue 'TypedSchemaLevel)
-> (ProdCons a -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe a)
-> SemanticCompatFormula ()
foldCheck Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min Integer
m Integer -> Issue 'TypedSchemaLevel
NoMatchingMaxProperties ProdCons Integer -> Issue 'TypedSchemaLevel
MatchingMaxPropertiesWeak ((forall (t :: JsonType). Condition t -> Maybe Integer)
 -> SemanticCompatFormula ())
-> (forall (t :: JsonType). Condition t -> Maybe Integer)
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \case
      MaxProperties Integer
m' -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
m'
      Condition t
_ -> Maybe Integer
forall a. Maybe a
Nothing
    MinProperties Integer
m -> (Integer -> Integer -> Integer)
-> Integer
-> (Integer -> Issue 'TypedSchemaLevel)
-> (ProdCons Integer -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe Integer)
-> SemanticCompatFormula ()
forall a.
Eq a =>
(a -> a -> a)
-> a
-> (a -> Issue 'TypedSchemaLevel)
-> (ProdCons a -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe a)
-> SemanticCompatFormula ()
foldCheck Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
m Integer -> Issue 'TypedSchemaLevel
NoMatchingMinProperties ProdCons Integer -> Issue 'TypedSchemaLevel
MatchingMinPropertiesWeak ((forall (t :: JsonType). Condition t -> Maybe Integer)
 -> SemanticCompatFormula ())
-> (forall (t :: JsonType). Condition t -> Maybe Integer)
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ \case
      MinProperties Integer
m' -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
m'
      Condition t
_ -> Maybe Integer
forall a. Maybe a
Nothing
  where
    lcmScientific :: a -> a -> a
lcmScientific (a -> Rational
forall a. Real a => a -> Rational
toRational -> Rational
a) (a -> Rational
forall a. Real a => a -> Rational
toRational -> Rational
b) =
      Rational -> a
forall a. Fractional a => Rational -> a
fromRational (Rational -> a) -> Rational -> a
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
lcm (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
a) (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
b) Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
gcd (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
a) (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
b)

    foldCheck ::
      Eq a =>
      (a -> a -> a) ->
      a ->
      (a -> Issue 'TypedSchemaLevel) ->
      (ProdCons a -> Issue 'TypedSchemaLevel) ->
      (forall t. Condition t -> Maybe a) ->
      SemanticCompatFormula ()
    foldCheck :: (a -> a -> a)
-> a
-> (a -> Issue 'TypedSchemaLevel)
-> (ProdCons a -> Issue 'TypedSchemaLevel)
-> (forall (t :: JsonType). Condition t -> Maybe a)
-> SemanticCompatFormula ()
foldCheck a -> a -> a
f a
m a -> Issue 'TypedSchemaLevel
missing ProdCons a -> Issue 'TypedSchemaLevel
weak forall (t :: JsonType). Condition t -> Maybe a
extr = case (a -> a -> a)
-> Set (Condition t) -> (Condition t -> Maybe a) -> Maybe a
forall b a. (b -> b -> b) -> Set a -> (a -> Maybe b) -> Maybe b
foldSome a -> a -> a
f Set (Condition t)
prods Condition t -> Maybe a
forall (t :: JsonType). Condition t -> Maybe a
extr of
      Just a
m'
        | a -> a -> a
f a
m' a
m a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
m' -> () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise -> Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh (ProdCons a -> Issue 'TypedSchemaLevel
weak ProdCons :: forall a. a -> a -> ProdCons a
ProdCons {$sel:producer:ProdCons :: a
producer = a
m', $sel:consumer:ProdCons :: a
consumer = a
m})
      Maybe a
Nothing -> Paths Behave 'APILevel 'TypedSchemaLevel
-> Issue 'TypedSchemaLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'TypedSchemaLevel
beh (a -> Issue 'TypedSchemaLevel
missing a
m)

    prodTopSchema :: Traced (Referenced Schema)
prodTopSchema = Trace (Referenced Schema)
-> Referenced Schema -> Traced (Referenced Schema)
forall a. Trace a -> a -> Traced a
traced (ProdCons (Trace Schema) -> Trace Schema
forall a. ProdCons a -> a
producer ProdCons (Trace Schema)
trs Trace Schema
-> Paths Step Schema (Referenced Schema)
-> Trace (Referenced Schema)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Step Schema (Referenced Schema)
-> Paths Step Schema (Referenced Schema)
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step Step Schema (Referenced Schema)
ImplicitTopSchema) (Referenced Schema -> Traced (Referenced Schema))
-> Referenced Schema -> Traced (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
forall a. Monoid a => a
mempty

allSame :: (Foldable f, Eq a) => f a -> Bool
allSame :: f a -> Bool
allSame f a
xs = case [a] -> [[a]]
forall a. Eq a => [a] -> [[a]]
group (f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
xs) of
  [] -> Bool
True
  [[a]
_] -> Bool
True
  [[a]]
_ -> Bool
False

foldSome :: (b -> b -> b) -> S.Set a -> (a -> Maybe b) -> Maybe b
foldSome :: (b -> b -> b) -> Set a -> (a -> Maybe b) -> Maybe b
foldSome b -> b -> b
combine Set a
xs a -> Maybe b
extr =
  (NonEmpty b -> b) -> Maybe (NonEmpty b) -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> b -> b) -> NonEmpty b -> b
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 b -> b -> b
combine) (Maybe (NonEmpty b) -> Maybe b)
-> (Set a -> Maybe (NonEmpty b)) -> Set a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> Maybe (NonEmpty b)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([b] -> Maybe (NonEmpty b))
-> (Set a -> [b]) -> Set a -> Maybe (NonEmpty b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe b) -> [a] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe b
extr ([a] -> [b]) -> (Set a -> [a]) -> Set a -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> Maybe b) -> Set a -> Maybe b
forall a b. (a -> b) -> a -> b
$ Set a
xs

findExactly :: S.Set (Condition t) -> Maybe (TypedValue t)
findExactly :: Set (Condition t) -> Maybe (TypedValue t)
findExactly Set (Condition t)
xs = (TypedValue t -> TypedValue t -> TypedValue t)
-> Set (Condition t)
-> (Condition t -> Maybe (TypedValue t))
-> Maybe (TypedValue t)
forall b a. (b -> b -> b) -> Set a -> (a -> Maybe b) -> Maybe b
foldSome TypedValue t -> TypedValue t -> TypedValue t
forall a b. a -> b -> a
const Set (Condition t)
xs ((Condition t -> Maybe (TypedValue t)) -> Maybe (TypedValue t))
-> (Condition t -> Maybe (TypedValue t)) -> Maybe (TypedValue t)
forall a b. (a -> b) -> a -> b
$ \case
  Exactly TypedValue t
x -> TypedValue t -> Maybe (TypedValue t)
forall a. a -> Maybe a
Just TypedValue t
x
  Condition t
_ -> Maybe (TypedValue t)
forall a. Maybe a
Nothing

instance Subtree Schema where
  type SubtreeLevel Schema = 'SchemaLevel
  type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]
  checkStructuralCompatibility :: HList (CheckEnv Schema)
-> ProdCons (Traced Schema) -> StructuralCompatFormula ()
checkStructuralCompatibility HList (CheckEnv Schema)
env ProdCons (Traced Schema)
pc = do
    ProdCons (EnvT (Trace Schema) Identity [Format])
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity [Format])
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity [Format])
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> [Format])
-> Traced Schema -> EnvT (Trace Schema) Identity [Format]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> [Format]
_schemaRequired (Traced Schema -> EnvT (Trace Schema) Identity [Format])
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity [Format])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Bool)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Bool
_schemaNullable (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Bool))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    (ProdCons [Traced (Referenced Schema)]
 -> StructuralCompatFormula ())
-> ProdCons (Maybe [Traced (Referenced Schema)])
-> StructuralCompatFormula ()
forall a.
(ProdCons a -> StructuralCompatFormula ())
-> ProdCons (Maybe a) -> StructuralCompatFormula ()
structuralMaybeWith (HList '[ProdCons (Traced (Definitions Schema))]
-> ProdCons [Traced (Referenced Schema)]
-> StructuralCompatFormula ()
forall a (xs :: [*]).
(Subtree a, ReassembleHList xs (CheckEnv a)) =>
HList xs -> ProdCons [Traced a] -> StructuralCompatFormula ()
structuralList HList '[ProdCons (Traced (Definitions Schema))]
HList (CheckEnv Schema)
env) (ProdCons (Maybe [Traced (Referenced Schema)])
 -> StructuralCompatFormula ())
-> ProdCons (Maybe [Traced (Referenced Schema)])
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced Schema -> Maybe [Traced (Referenced Schema)]
tracedAllOf (Traced Schema -> Maybe [Traced (Referenced Schema)])
-> ProdCons (Traced Schema)
-> ProdCons (Maybe [Traced (Referenced Schema)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    (ProdCons [Traced (Referenced Schema)]
 -> StructuralCompatFormula ())
-> ProdCons (Maybe [Traced (Referenced Schema)])
-> StructuralCompatFormula ()
forall a.
(ProdCons a -> StructuralCompatFormula ())
-> ProdCons (Maybe a) -> StructuralCompatFormula ()
structuralMaybeWith (HList '[ProdCons (Traced (Definitions Schema))]
-> ProdCons [Traced (Referenced Schema)]
-> StructuralCompatFormula ()
forall a (xs :: [*]).
(Subtree a, ReassembleHList xs (CheckEnv a)) =>
HList xs -> ProdCons [Traced a] -> StructuralCompatFormula ()
structuralList HList '[ProdCons (Traced (Definitions Schema))]
HList (CheckEnv Schema)
env) (ProdCons (Maybe [Traced (Referenced Schema)])
 -> StructuralCompatFormula ())
-> ProdCons (Maybe [Traced (Referenced Schema)])
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced Schema -> Maybe [Traced (Referenced Schema)]
tracedOneOf (Traced Schema -> Maybe [Traced (Referenced Schema)])
-> ProdCons (Traced Schema)
-> ProdCons (Maybe [Traced (Referenced Schema)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    HList '[ProdCons (Traced (Definitions Schema))]
-> ProdCons (Maybe (Traced (Referenced Schema)))
-> StructuralCompatFormula ()
forall a (xs :: [*]).
(Subtree a, ReassembleHList xs (CheckEnv a)) =>
HList xs
-> ProdCons (Maybe (Traced a)) -> StructuralCompatFormula ()
structuralMaybe HList '[ProdCons (Traced (Definitions Schema))]
HList (CheckEnv Schema)
env (ProdCons (Maybe (Traced (Referenced Schema)))
 -> StructuralCompatFormula ())
-> ProdCons (Maybe (Traced (Referenced Schema)))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ EnvT
  (Trace (Referenced Schema)) Identity (Maybe (Referenced Schema))
-> Maybe (Traced (Referenced Schema))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (EnvT
   (Trace (Referenced Schema)) Identity (Maybe (Referenced Schema))
 -> Maybe (Traced (Referenced Schema)))
-> (Traced Schema
    -> EnvT
         (Trace (Referenced Schema)) Identity (Maybe (Referenced Schema)))
-> Traced Schema
-> Maybe (Traced (Referenced Schema))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Step Schema (Referenced Schema)
-> Traced' Schema (Maybe (Referenced Schema))
-> EnvT
     (Trace (Referenced Schema)) Identity (Maybe (Referenced Schema))
forall a a' b.
Steppable a a' =>
Step a a' -> Traced' a b -> Traced' a' b
stepTraced Step Schema (Referenced Schema)
NotStep (Traced' Schema (Maybe (Referenced Schema))
 -> EnvT
      (Trace (Referenced Schema)) Identity (Maybe (Referenced Schema)))
-> (Traced Schema -> Traced' Schema (Maybe (Referenced Schema)))
-> Traced Schema
-> EnvT
     (Trace (Referenced Schema)) Identity (Maybe (Referenced Schema))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Schema -> Maybe (Referenced Schema))
-> Traced Schema -> Traced' Schema (Maybe (Referenced Schema))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe (Referenced Schema)
_schemaNot (Traced Schema -> Maybe (Traced (Referenced Schema)))
-> ProdCons (Traced Schema)
-> ProdCons (Maybe (Traced (Referenced Schema)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    (ProdCons [Traced (Referenced Schema)]
 -> StructuralCompatFormula ())
-> ProdCons (Maybe [Traced (Referenced Schema)])
-> StructuralCompatFormula ()
forall a.
(ProdCons a -> StructuralCompatFormula ())
-> ProdCons (Maybe a) -> StructuralCompatFormula ()
structuralMaybeWith (HList '[ProdCons (Traced (Definitions Schema))]
-> ProdCons [Traced (Referenced Schema)]
-> StructuralCompatFormula ()
forall a (xs :: [*]).
(Subtree a, ReassembleHList xs (CheckEnv a)) =>
HList xs -> ProdCons [Traced a] -> StructuralCompatFormula ()
structuralList HList '[ProdCons (Traced (Definitions Schema))]
HList (CheckEnv Schema)
env) (ProdCons (Maybe [Traced (Referenced Schema)])
 -> StructuralCompatFormula ())
-> ProdCons (Maybe [Traced (Referenced Schema)])
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced Schema -> Maybe [Traced (Referenced Schema)]
tracedAnyOf (Traced Schema -> Maybe [Traced (Referenced Schema)])
-> ProdCons (Traced Schema)
-> ProdCons (Maybe [Traced (Referenced Schema)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    HList '[ProdCons (Traced (Definitions Schema))]
-> ProdCons (Traced (InsOrdHashMap Format (Referenced Schema)))
-> StructuralCompatFormula ()
forall k (xs :: [*]) v.
(ReassembleHList (k : xs) (CheckEnv v), Ord k, Subtree v,
 Hashable k, Typeable k, Show k) =>
HList xs
-> ProdCons (Traced (InsOrdHashMap k v))
-> StructuralCompatFormula ()
iohmStructural HList '[ProdCons (Traced (Definitions Schema))]
HList (CheckEnv Schema)
env (ProdCons (Traced (InsOrdHashMap Format (Referenced Schema)))
 -> StructuralCompatFormula ())
-> ProdCons (Traced (InsOrdHashMap Format (Referenced Schema)))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Step Schema (InsOrdHashMap Format (Referenced Schema))
-> Traced' Schema (InsOrdHashMap Format (Referenced Schema))
-> Traced (InsOrdHashMap Format (Referenced Schema))
forall a a' b.
Steppable a a' =>
Step a a' -> Traced' a b -> Traced' a' b
stepTraced Step Schema (InsOrdHashMap Format (Referenced Schema))
PropertiesStep (Traced' Schema (InsOrdHashMap Format (Referenced Schema))
 -> Traced (InsOrdHashMap Format (Referenced Schema)))
-> (Traced Schema
    -> Traced' Schema (InsOrdHashMap Format (Referenced Schema)))
-> Traced Schema
-> Traced (InsOrdHashMap Format (Referenced Schema))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Schema -> InsOrdHashMap Format (Referenced Schema))
-> Traced Schema
-> Traced' Schema (InsOrdHashMap Format (Referenced Schema))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> InsOrdHashMap Format (Referenced Schema)
_schemaProperties (Traced Schema
 -> Traced (InsOrdHashMap Format (Referenced Schema)))
-> ProdCons (Traced Schema)
-> ProdCons (Traced (InsOrdHashMap Format (Referenced Schema)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    (ProdCons (Either Bool (Traced (Referenced Schema)))
 -> StructuralCompatFormula ())
-> ProdCons (Maybe (Either Bool (Traced (Referenced Schema))))
-> StructuralCompatFormula ()
forall a.
(ProdCons a -> StructuralCompatFormula ())
-> ProdCons (Maybe a) -> StructuralCompatFormula ()
structuralMaybeWith ProdCons (Either Bool (Traced (Referenced Schema)))
-> StructuralCompatFormula ()
structuralAdditionalProperties (ProdCons (Maybe (Either Bool (Traced (Referenced Schema))))
 -> StructuralCompatFormula ())
-> ProdCons (Maybe (Either Bool (Traced (Referenced Schema))))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))
tracedAdditionalProperties (Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema))))
-> ProdCons (Traced Schema)
-> ProdCons (Maybe (Either Bool (Traced (Referenced Schema))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    (ProdCons (EnvT (Trace Discriminator) Identity Discriminator)
 -> StructuralCompatFormula ())
-> ProdCons
     (Maybe (EnvT (Trace Discriminator) Identity Discriminator))
-> StructuralCompatFormula ()
forall a.
(ProdCons a -> StructuralCompatFormula ())
-> ProdCons (Maybe a) -> StructuralCompatFormula ()
structuralMaybeWith ProdCons (EnvT (Trace Discriminator) Identity Discriminator)
-> StructuralCompatFormula ()
structuralDiscriminator (ProdCons
   (Maybe (EnvT (Trace Discriminator) Identity Discriminator))
 -> StructuralCompatFormula ())
-> ProdCons
     (Maybe (EnvT (Trace Discriminator) Identity Discriminator))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced Schema
-> Maybe (EnvT (Trace Discriminator) Identity Discriminator)
tracedDiscriminator (Traced Schema
 -> Maybe (EnvT (Trace Discriminator) Identity Discriminator))
-> ProdCons (Traced Schema)
-> ProdCons
     (Maybe (EnvT (Trace Discriminator) Identity Discriminator))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Bool)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Bool
_schemaReadOnly (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Bool))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Bool)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Bool
_schemaWriteOnly (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Bool))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Xml))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Xml))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Xml))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Xml)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Xml)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Xml
_schemaXml (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Xml))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Xml))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Integer)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Integer
_schemaMaxProperties (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Integer))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Integer)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Integer
_schemaMinProperties (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Integer))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Value))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Value))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Value))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Value)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Value
_schemaDefault (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Value))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe OpenApiType))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe OpenApiType))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe OpenApiType))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe OpenApiType)
-> Traced Schema
-> EnvT (Trace Schema) Identity (Maybe OpenApiType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe OpenApiType
_schemaType (Traced Schema -> EnvT (Trace Schema) Identity (Maybe OpenApiType))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe OpenApiType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Format))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Format))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Format))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Format)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Format)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Format
_schemaFormat (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Format))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Format))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    (ProdCons
   (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
 -> StructuralCompatFormula ())
-> ProdCons
     (Maybe
        (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)]))
-> StructuralCompatFormula ()
forall a.
(ProdCons a -> StructuralCompatFormula ())
-> ProdCons (Maybe a) -> StructuralCompatFormula ()
structuralMaybeWith ProdCons
  (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
-> StructuralCompatFormula ()
structuralItems (ProdCons
   (Maybe
      (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)]))
 -> StructuralCompatFormula ())
-> ProdCons
     (Maybe
        (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)]))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced Schema
-> Maybe
     (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
tracedItems (Traced Schema
 -> Maybe
      (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)]))
-> ProdCons (Traced Schema)
-> ProdCons
     (Maybe
        (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Scientific))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Scientific))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Scientific))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Scientific)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Scientific)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Scientific
_schemaMaximum (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Scientific))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Scientific))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Bool)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Bool
_schemaExclusiveMaximum (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Bool))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Scientific))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Scientific))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Scientific))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Scientific)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Scientific)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Scientific
_schemaMinimum (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Scientific))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Scientific))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Bool)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Bool
_schemaExclusiveMinimum (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Bool))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Integer)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Integer
_schemaMaxLength (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Integer))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Integer)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Integer
_schemaMinLength (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Integer))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Format))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Format))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Format))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Format)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Format)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Format
_schemaPattern (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Format))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Format))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Integer)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Integer
_schemaMaxItems (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Integer))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Integer)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Integer
_schemaMinItems (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Integer))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Bool)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Bool
_schemaUniqueItems (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Bool))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe [Value]))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe [Value]))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe [Value]))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe [Value])
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe [Value])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe [Value]
_schemaEnum (Traced Schema -> EnvT (Trace Schema) Identity (Maybe [Value]))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe [Value]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    ProdCons (EnvT (Trace Schema) Identity (Maybe Scientific))
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Schema) Identity (Maybe Scientific))
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Scientific))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Schema -> Maybe Scientific)
-> Traced Schema -> EnvT (Trace Schema) Identity (Maybe Scientific)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Schema -> Maybe Scientific
_schemaMultipleOf (Traced Schema -> EnvT (Trace Schema) Identity (Maybe Scientific))
-> ProdCons (Traced Schema)
-> ProdCons (EnvT (Trace Schema) Identity (Maybe Scientific))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
pc
    pure ()
    where
      structuralAdditionalProperties :: ProdCons (Either Bool (Traced (Referenced Schema)))
-> StructuralCompatFormula ()
structuralAdditionalProperties
        (ProdCons (Left Bool
x) (Left Bool
y)) = Bool -> StructuralCompatFormula () -> StructuralCompatFormula ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
y) StructuralCompatFormula ()
forall a. StructuralCompatFormula a
structuralIssue
      structuralAdditionalProperties
        (ProdCons (Right Traced (Referenced Schema)
x) (Right Traced (Referenced Schema)
y)) =
          HList '[ProdCons (Traced (Definitions Schema))]
-> ProdCons (Traced (Referenced Schema))
-> StructuralCompatFormula ()
forall (xs :: [*]) t.
(ReassembleHList xs (CheckEnv t), Subtree t) =>
HList xs -> ProdCons (Traced t) -> StructuralCompatFormula ()
checkSubstructure HList '[ProdCons (Traced (Definitions Schema))]
HList (CheckEnv Schema)
env (ProdCons (Traced (Referenced Schema))
 -> StructuralCompatFormula ())
-> ProdCons (Traced (Referenced Schema))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced (Referenced Schema)
-> Traced (Referenced Schema)
-> ProdCons (Traced (Referenced Schema))
forall a. a -> a -> ProdCons a
ProdCons Traced (Referenced Schema)
x Traced (Referenced Schema)
y
      structuralAdditionalProperties ProdCons (Either Bool (Traced (Referenced Schema)))
_ = StructuralCompatFormula ()
forall a. StructuralCompatFormula a
structuralIssue
      structuralDiscriminator :: ProdCons (EnvT (Trace Discriminator) Identity Discriminator)
-> StructuralCompatFormula ()
structuralDiscriminator ProdCons (EnvT (Trace Discriminator) Identity Discriminator)
pc' = do
        ProdCons (EnvT (Trace Discriminator) Identity Format)
-> StructuralCompatFormula ()
forall a (w :: * -> *).
(Eq a, Comonad w) =>
ProdCons (w a) -> StructuralCompatFormula ()
structuralEq (ProdCons (EnvT (Trace Discriminator) Identity Format)
 -> StructuralCompatFormula ())
-> ProdCons (EnvT (Trace Discriminator) Identity Format)
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ (Discriminator -> Format)
-> EnvT (Trace Discriminator) Identity Discriminator
-> EnvT (Trace Discriminator) Identity Format
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Discriminator -> Format
_discriminatorPropertyName (EnvT (Trace Discriminator) Identity Discriminator
 -> EnvT (Trace Discriminator) Identity Format)
-> ProdCons (EnvT (Trace Discriminator) Identity Discriminator)
-> ProdCons (EnvT (Trace Discriminator) Identity Format)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (EnvT (Trace Discriminator) Identity Discriminator)
pc'
        HList '[ProdCons (Traced (Definitions Schema))]
-> ProdCons (Traced (InsOrdHashMap Format (Referenced Schema)))
-> StructuralCompatFormula ()
forall k (xs :: [*]) v.
(ReassembleHList (k : xs) (CheckEnv v), Ord k, Subtree v,
 Hashable k, Typeable k, Show k) =>
HList xs
-> ProdCons (Traced (InsOrdHashMap k v))
-> StructuralCompatFormula ()
iohmStructural HList '[ProdCons (Traced (Definitions Schema))]
HList (CheckEnv Schema)
env (ProdCons (Traced (InsOrdHashMap Format (Referenced Schema)))
 -> StructuralCompatFormula ())
-> ProdCons (Traced (InsOrdHashMap Format (Referenced Schema)))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$
          Step Discriminator (InsOrdHashMap Format (Referenced Schema))
-> Traced' Discriminator (InsOrdHashMap Format (Referenced Schema))
-> Traced (InsOrdHashMap Format (Referenced Schema))
forall a a' b.
Steppable a a' =>
Step a a' -> Traced' a b -> Traced' a' b
stepTraced Step Discriminator (InsOrdHashMap Format (Referenced Schema))
DiscriminatorMapping (Traced' Discriminator (InsOrdHashMap Format (Referenced Schema))
 -> Traced (InsOrdHashMap Format (Referenced Schema)))
-> (EnvT (Trace Discriminator) Identity Discriminator
    -> Traced'
         Discriminator (InsOrdHashMap Format (Referenced Schema)))
-> EnvT (Trace Discriminator) Identity Discriminator
-> Traced (InsOrdHashMap Format (Referenced Schema))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Discriminator -> InsOrdHashMap Format (Referenced Schema))
-> EnvT (Trace Discriminator) Identity Discriminator
-> Traced' Discriminator (InsOrdHashMap Format (Referenced Schema))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Format -> Referenced Schema)
-> InsOrdHashMap Format Format
-> InsOrdHashMap Format (Referenced Schema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Format -> Referenced Schema
parseDiscriminatorValue (InsOrdHashMap Format Format
 -> InsOrdHashMap Format (Referenced Schema))
-> (Discriminator -> InsOrdHashMap Format Format)
-> Discriminator
-> InsOrdHashMap Format (Referenced Schema)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Discriminator -> InsOrdHashMap Format Format
_discriminatorMapping) (EnvT (Trace Discriminator) Identity Discriminator
 -> Traced (InsOrdHashMap Format (Referenced Schema)))
-> ProdCons (EnvT (Trace Discriminator) Identity Discriminator)
-> ProdCons (Traced (InsOrdHashMap Format (Referenced Schema)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (EnvT (Trace Discriminator) Identity Discriminator)
pc'
        pure ()
      structuralItems :: ProdCons
  (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
-> StructuralCompatFormula ()
structuralItems (ProdCons (Left Traced (Referenced Schema)
a) (Left Traced (Referenced Schema)
b)) =
        HList '[ProdCons (Traced (Definitions Schema))]
-> ProdCons (Traced (Referenced Schema))
-> StructuralCompatFormula ()
forall (xs :: [*]) t.
(ReassembleHList xs (CheckEnv t), Subtree t) =>
HList xs -> ProdCons (Traced t) -> StructuralCompatFormula ()
checkSubstructure HList '[ProdCons (Traced (Definitions Schema))]
HList (CheckEnv Schema)
env (ProdCons (Traced (Referenced Schema))
 -> StructuralCompatFormula ())
-> ProdCons (Traced (Referenced Schema))
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced (Referenced Schema)
-> Traced (Referenced Schema)
-> ProdCons (Traced (Referenced Schema))
forall a. a -> a -> ProdCons a
ProdCons Traced (Referenced Schema)
a Traced (Referenced Schema)
b
      structuralItems (ProdCons (Right [Traced (Referenced Schema)]
a) (Right [Traced (Referenced Schema)]
b)) =
        HList '[ProdCons (Traced (Definitions Schema))]
-> ProdCons [Traced (Referenced Schema)]
-> StructuralCompatFormula ()
forall a (xs :: [*]).
(Subtree a, ReassembleHList xs (CheckEnv a)) =>
HList xs -> ProdCons [Traced a] -> StructuralCompatFormula ()
structuralList HList '[ProdCons (Traced (Definitions Schema))]
HList (CheckEnv Schema)
env (ProdCons [Traced (Referenced Schema)]
 -> StructuralCompatFormula ())
-> ProdCons [Traced (Referenced Schema)]
-> StructuralCompatFormula ()
forall a b. (a -> b) -> a -> b
$ [Traced (Referenced Schema)]
-> [Traced (Referenced Schema)]
-> ProdCons [Traced (Referenced Schema)]
forall a. a -> a -> ProdCons a
ProdCons [Traced (Referenced Schema)]
a [Traced (Referenced Schema)]
b
      structuralItems ProdCons
  (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
_ = StructuralCompatFormula ()
forall a. StructuralCompatFormula a
structuralIssue
  checkSemanticCompatibility :: HList (CheckEnv Schema)
-> Behavior (SubtreeLevel Schema)
-> ProdCons (Traced Schema)
-> SemanticCompatFormula ()
checkSemanticCompatibility HList (CheckEnv Schema)
env Behavior (SubtreeLevel Schema)
beh ProdCons (Traced Schema)
schs = do
    let defs :: ProdCons (Traced (Definitions Schema))
defs = HList '[ProdCons (Traced (Definitions Schema))]
-> ProdCons (Traced (Definitions Schema))
forall x (xs :: [*]) (t :: Bool). Has' x xs t => HList xs -> x
getH HList '[ProdCons (Traced (Definitions Schema))]
HList (CheckEnv Schema)
env
    HList '[ProdCons (Traced (Definitions Schema))]
-> Behavior 'SchemaLevel
-> ProdCons (Trace Schema)
-> ProdCons (Traced (Definitions Schema))
-> ProdCons
     (ForeachType JsonFormula,
      PathsPrefixTree Behave AnIssue 'SchemaLevel)
-> SemanticCompatFormula ()
forall (xs :: [*]).
ReassembleHList xs (CheckEnv (Referenced Schema)) =>
HList xs
-> Behavior 'SchemaLevel
-> ProdCons (Trace Schema)
-> ProdCons (Traced (Definitions Schema))
-> ProdCons
     (ForeachType JsonFormula,
      PathsPrefixTree Behave AnIssue 'SchemaLevel)
-> SemanticCompatFormula ()
checkFormulas HList '[ProdCons (Traced (Definitions Schema))]
HList (CheckEnv Schema)
env Behavior 'SchemaLevel
Behavior (SubtreeLevel Schema)
beh (Traced Schema -> Trace Schema
forall e (w :: * -> *) a. ComonadEnv e w => w a -> e
ask (Traced Schema -> Trace Schema)
-> ProdCons (Traced Schema) -> ProdCons (Trace Schema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced Schema)
schs) ProdCons (Traced (Definitions Schema))
defs (ProdCons
   (ForeachType JsonFormula,
    PathsPrefixTree Behave AnIssue 'SchemaLevel)
 -> SemanticCompatFormula ())
-> ProdCons
     (ForeachType JsonFormula,
      PathsPrefixTree Behave AnIssue 'SchemaLevel)
-> SemanticCompatFormula ()
forall a b. (a -> b) -> a -> b
$ Traced (Definitions Schema)
-> Traced Schema
-> (ForeachType JsonFormula,
    PathsPrefixTree Behave AnIssue 'SchemaLevel)
schemaToFormula (Traced (Definitions Schema)
 -> Traced Schema
 -> (ForeachType JsonFormula,
     PathsPrefixTree Behave AnIssue 'SchemaLevel))
-> ProdCons (Traced (Definitions Schema))
-> ProdCons
     (Traced Schema
      -> (ForeachType JsonFormula,
          PathsPrefixTree Behave AnIssue 'SchemaLevel))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced (Definitions Schema))
defs ProdCons
  (Traced Schema
   -> (ForeachType JsonFormula,
       PathsPrefixTree Behave AnIssue 'SchemaLevel))
-> ProdCons (Traced Schema)
-> ProdCons
     (ForeachType JsonFormula,
      PathsPrefixTree Behave AnIssue 'SchemaLevel)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProdCons (Traced Schema)
schs

parseDiscriminatorValue :: Text -> Referenced Schema
parseDiscriminatorValue :: Format -> Referenced Schema
parseDiscriminatorValue Format
v = case FromJSON (Referenced Schema) => Value -> Result (Referenced Schema)
forall a. FromJSON a => Value -> Result a
A.fromJSON @(Referenced Schema) (Value -> Result (Referenced Schema))
-> Value -> Result (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
A.object [Format
"$ref" Format -> Format -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Format -> v -> kv
A..= Format
v] of
  A.Success Referenced Schema
x -> Referenced Schema
x
  A.Error String
_ -> Reference -> Referenced Schema
forall a. Reference -> Referenced a
Ref (Reference -> Referenced Schema) -> Reference -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Format -> Reference
Reference Format
v