module Data.OpenApi.Compare.Validate.Schema.Partition
  ( partitionSchema,
    partitionRefSchema,
    selectPartition,
    runPartitionM,
    tryPartition,
    showPartition,
    intersectSchema,
    intersectRefSchema,
    IntersectionResult (..),
    runIntersectionM,
    Partition,
  )
where

import Algebra.Lattice
import Algebra.Lattice.Lifted
import Control.Applicative
import Control.Monad.Reader hiding (ask)
import qualified Control.Monad.Reader as R
import Control.Monad.State
import qualified Control.Monad.Trans.Reader as R (liftCatch)
import qualified Control.Monad.Trans.Writer as W (liftCatch)
import Control.Monad.Writer
import qualified Data.Aeson as A
import Data.Foldable
import Data.Functor.Identity
import qualified Data.HashMap.Strict.InsOrd as IOHM
import Data.List (sortBy)
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Maybe
import Data.OpenApi
import Data.OpenApi.Compare.Memo
import Data.OpenApi.Compare.References
import Data.OpenApi.Compare.Subtree
import Data.OpenApi.Compare.Validate.Schema.DNF
import Data.OpenApi.Compare.Validate.Schema.JsonFormula
import Data.OpenApi.Compare.Validate.Schema.Traced
import Data.OpenApi.Compare.Validate.Schema.TypedJson
import Data.Ord
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Text.Pandoc.Builder hiding (Format, Null)

data PartitionData
  = DByEnumValue (DNF (S.Set A.Value))
  | DByProperties (DNF (S.Set Text, S.Set Text)) -- optional, required
  deriving stock (PartitionData -> PartitionData -> Bool
(PartitionData -> PartitionData -> Bool)
-> (PartitionData -> PartitionData -> Bool) -> Eq PartitionData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PartitionData -> PartitionData -> Bool
$c/= :: PartitionData -> PartitionData -> Bool
== :: PartitionData -> PartitionData -> Bool
$c== :: PartitionData -> PartitionData -> Bool
Eq, Eq PartitionData
Eq PartitionData
-> (PartitionData -> PartitionData -> Ordering)
-> (PartitionData -> PartitionData -> Bool)
-> (PartitionData -> PartitionData -> Bool)
-> (PartitionData -> PartitionData -> Bool)
-> (PartitionData -> PartitionData -> Bool)
-> (PartitionData -> PartitionData -> PartitionData)
-> (PartitionData -> PartitionData -> PartitionData)
-> Ord PartitionData
PartitionData -> PartitionData -> Bool
PartitionData -> PartitionData -> Ordering
PartitionData -> PartitionData -> PartitionData
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PartitionData -> PartitionData -> PartitionData
$cmin :: PartitionData -> PartitionData -> PartitionData
max :: PartitionData -> PartitionData -> PartitionData
$cmax :: PartitionData -> PartitionData -> PartitionData
>= :: PartitionData -> PartitionData -> Bool
$c>= :: PartitionData -> PartitionData -> Bool
> :: PartitionData -> PartitionData -> Bool
$c> :: PartitionData -> PartitionData -> Bool
<= :: PartitionData -> PartitionData -> Bool
$c<= :: PartitionData -> PartitionData -> Bool
< :: PartitionData -> PartitionData -> Bool
$c< :: PartitionData -> PartitionData -> Bool
compare :: PartitionData -> PartitionData -> Ordering
$ccompare :: PartitionData -> PartitionData -> Ordering
$cp1Ord :: Eq PartitionData
Ord, Int -> PartitionData -> ShowS
[PartitionData] -> ShowS
PartitionData -> String
(Int -> PartitionData -> ShowS)
-> (PartitionData -> String)
-> ([PartitionData] -> ShowS)
-> Show PartitionData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PartitionData] -> ShowS
$cshowList :: [PartitionData] -> ShowS
show :: PartitionData -> String
$cshow :: PartitionData -> String
showsPrec :: Int -> PartitionData -> ShowS
$cshowsPrec :: Int -> PartitionData -> ShowS
Show)

conjPart :: PartitionData -> PartitionData -> Maybe PartitionData
conjPart :: PartitionData -> PartitionData -> Maybe PartitionData
conjPart (DByEnumValue DNF (Set Value)
xss) (DByEnumValue DNF (Set Value)
yss) = PartitionData -> Maybe PartitionData
forall a. a -> Maybe a
Just (PartitionData -> Maybe PartitionData)
-> (DNF (Set Value) -> PartitionData)
-> DNF (Set Value)
-> Maybe PartitionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNF (Set Value) -> PartitionData
DByEnumValue (DNF (Set Value) -> Maybe PartitionData)
-> DNF (Set Value) -> Maybe PartitionData
forall a b. (a -> b) -> a -> b
$ DNF (Set Value)
xss DNF (Set Value) -> DNF (Set Value) -> DNF (Set Value)
forall a. Lattice a => a -> a -> a
/\ DNF (Set Value)
yss
conjPart (DByProperties DNF (Set Text, Set Text)
xss) (DByProperties DNF (Set Text, Set Text)
yss) = PartitionData -> Maybe PartitionData
forall a. a -> Maybe a
Just (PartitionData -> Maybe PartitionData)
-> (DNF (Set Text, Set Text) -> PartitionData)
-> DNF (Set Text, Set Text)
-> Maybe PartitionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNF (Set Text, Set Text) -> PartitionData
DByProperties (DNF (Set Text, Set Text) -> Maybe PartitionData)
-> DNF (Set Text, Set Text) -> Maybe PartitionData
forall a b. (a -> b) -> a -> b
$ DNF (Set Text, Set Text)
xss DNF (Set Text, Set Text)
-> DNF (Set Text, Set Text) -> DNF (Set Text, Set Text)
forall a. Lattice a => a -> a -> a
/\ DNF (Set Text, Set Text)
yss
conjPart PartitionData
_ PartitionData
_ = Maybe PartitionData
forall a. Maybe a
Nothing

disjPart :: PartitionData -> PartitionData -> Maybe PartitionData
disjPart :: PartitionData -> PartitionData -> Maybe PartitionData
disjPart (DByEnumValue DNF (Set Value)
xss) (DByEnumValue DNF (Set Value)
yss) = PartitionData -> Maybe PartitionData
forall a. a -> Maybe a
Just (PartitionData -> Maybe PartitionData)
-> (DNF (Set Value) -> PartitionData)
-> DNF (Set Value)
-> Maybe PartitionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNF (Set Value) -> PartitionData
DByEnumValue (DNF (Set Value) -> Maybe PartitionData)
-> DNF (Set Value) -> Maybe PartitionData
forall a b. (a -> b) -> a -> b
$ DNF (Set Value)
xss DNF (Set Value) -> DNF (Set Value) -> DNF (Set Value)
forall a. Lattice a => a -> a -> a
\/ DNF (Set Value)
yss
disjPart (DByProperties DNF (Set Text, Set Text)
xss) (DByProperties DNF (Set Text, Set Text)
yss) = PartitionData -> Maybe PartitionData
forall a. a -> Maybe a
Just (PartitionData -> Maybe PartitionData)
-> (DNF (Set Text, Set Text) -> PartitionData)
-> DNF (Set Text, Set Text)
-> Maybe PartitionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNF (Set Text, Set Text) -> PartitionData
DByProperties (DNF (Set Text, Set Text) -> Maybe PartitionData)
-> DNF (Set Text, Set Text) -> Maybe PartitionData
forall a b. (a -> b) -> a -> b
$ DNF (Set Text, Set Text)
xss DNF (Set Text, Set Text)
-> DNF (Set Text, Set Text) -> DNF (Set Text, Set Text)
forall a. Lattice a => a -> a -> a
\/ DNF (Set Text, Set Text)
yss
disjPart PartitionData
_ PartitionData
_ = Maybe PartitionData
forall a. Maybe a
Nothing

newtype Partitions = Partitions (M.Map PartitionLocation (S.Set PartitionData))
  deriving stock (Partitions -> Partitions -> Bool
(Partitions -> Partitions -> Bool)
-> (Partitions -> Partitions -> Bool) -> Eq Partitions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Partitions -> Partitions -> Bool
$c/= :: Partitions -> Partitions -> Bool
== :: Partitions -> Partitions -> Bool
$c== :: Partitions -> Partitions -> Bool
Eq, Eq Partitions
Eq Partitions
-> (Partitions -> Partitions -> Ordering)
-> (Partitions -> Partitions -> Bool)
-> (Partitions -> Partitions -> Bool)
-> (Partitions -> Partitions -> Bool)
-> (Partitions -> Partitions -> Bool)
-> (Partitions -> Partitions -> Partitions)
-> (Partitions -> Partitions -> Partitions)
-> Ord Partitions
Partitions -> Partitions -> Bool
Partitions -> Partitions -> Ordering
Partitions -> Partitions -> Partitions
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Partitions -> Partitions -> Partitions
$cmin :: Partitions -> Partitions -> Partitions
max :: Partitions -> Partitions -> Partitions
$cmax :: Partitions -> Partitions -> Partitions
>= :: Partitions -> Partitions -> Bool
$c>= :: Partitions -> Partitions -> Bool
> :: Partitions -> Partitions -> Bool
$c> :: Partitions -> Partitions -> Bool
<= :: Partitions -> Partitions -> Bool
$c<= :: Partitions -> Partitions -> Bool
< :: Partitions -> Partitions -> Bool
$c< :: Partitions -> Partitions -> Bool
compare :: Partitions -> Partitions -> Ordering
$ccompare :: Partitions -> Partitions -> Ordering
$cp1Ord :: Eq Partitions
Ord, Int -> Partitions -> ShowS
[Partitions] -> ShowS
Partitions -> String
(Int -> Partitions -> ShowS)
-> (Partitions -> String)
-> ([Partitions] -> ShowS)
-> Show Partitions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Partitions] -> ShowS
$cshowList :: [Partitions] -> ShowS
show :: Partitions -> String
$cshow :: Partitions -> String
showsPrec :: Int -> Partitions -> ShowS
$cshowsPrec :: Int -> Partitions -> ShowS
Show)

instance Lattice Partitions where
  Partitions Map PartitionLocation (Set PartitionData)
xss /\ :: Partitions -> Partitions -> Partitions
/\ Partitions Map PartitionLocation (Set PartitionData)
yss = Map PartitionLocation (Set PartitionData) -> Partitions
Partitions (Map PartitionLocation (Set PartitionData) -> Partitions)
-> Map PartitionLocation (Set PartitionData) -> Partitions
forall a b. (a -> b) -> a -> b
$ (Set PartitionData -> Set PartitionData -> Set PartitionData)
-> Map PartitionLocation (Set PartitionData)
-> Map PartitionLocation (Set PartitionData)
-> Map PartitionLocation (Set PartitionData)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Set PartitionData -> Set PartitionData -> Set PartitionData
conj Map PartitionLocation (Set PartitionData)
xss Map PartitionLocation (Set PartitionData)
yss
    where
      conj :: Set PartitionData -> Set PartitionData -> Set PartitionData
conj Set PartitionData
xs Set PartitionData
ys = [PartitionData] -> Set PartitionData
forall a. Ord a => [a] -> Set a
S.fromList ([PartitionData] -> Set PartitionData)
-> ([Maybe PartitionData] -> [PartitionData])
-> [Maybe PartitionData]
-> Set PartitionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe PartitionData] -> [PartitionData]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe PartitionData] -> Set PartitionData)
-> [Maybe PartitionData] -> Set PartitionData
forall a b. (a -> b) -> a -> b
$ (PartitionData -> PartitionData -> Maybe PartitionData)
-> [PartitionData] -> [PartitionData] -> [Maybe PartitionData]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 PartitionData -> PartitionData -> Maybe PartitionData
conjPart (Set PartitionData -> [PartitionData]
forall a. Set a -> [a]
S.toList Set PartitionData
xs) (Set PartitionData -> [PartitionData]
forall a. Set a -> [a]
S.toList Set PartitionData
ys)
  Partitions Map PartitionLocation (Set PartitionData)
xss \/ :: Partitions -> Partitions -> Partitions
\/ Partitions Map PartitionLocation (Set PartitionData)
yss = Map PartitionLocation (Set PartitionData) -> Partitions
Partitions (Map PartitionLocation (Set PartitionData) -> Partitions)
-> Map PartitionLocation (Set PartitionData) -> Partitions
forall a b. (a -> b) -> a -> b
$ (Set PartitionData -> Set PartitionData -> Set PartitionData)
-> Map PartitionLocation (Set PartitionData)
-> Map PartitionLocation (Set PartitionData)
-> Map PartitionLocation (Set PartitionData)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith Set PartitionData -> Set PartitionData -> Set PartitionData
disj Map PartitionLocation (Set PartitionData)
xss Map PartitionLocation (Set PartitionData)
yss
    where
      disj :: Set PartitionData -> Set PartitionData -> Set PartitionData
disj Set PartitionData
xs Set PartitionData
ys = [PartitionData] -> Set PartitionData
forall a. Ord a => [a] -> Set a
S.fromList ([PartitionData] -> Set PartitionData)
-> ([Maybe PartitionData] -> [PartitionData])
-> [Maybe PartitionData]
-> Set PartitionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe PartitionData] -> [PartitionData]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe PartitionData] -> Set PartitionData)
-> [Maybe PartitionData] -> Set PartitionData
forall a b. (a -> b) -> a -> b
$ (PartitionData -> PartitionData -> Maybe PartitionData)
-> [PartitionData] -> [PartitionData] -> [Maybe PartitionData]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 PartitionData -> PartitionData -> Maybe PartitionData
disjPart (Set PartitionData -> [PartitionData]
forall a. Set a -> [a]
S.toList Set PartitionData
xs) (Set PartitionData -> [PartitionData]
forall a. Set a -> [a]
S.toList Set PartitionData
ys)

instance BoundedMeetSemiLattice Partitions where
  top :: Partitions
top = Map PartitionLocation (Set PartitionData) -> Partitions
Partitions Map PartitionLocation (Set PartitionData)
forall k a. Map k a
M.empty

-- The lattice has no bottom, but we use 'Lifted' to adjoin a free bottom element

type PartitionM = ReaderT (Traced (Definitions Schema)) (State (MemoState ()))

ignoreKnot :: KnotTier (Lifted Partitions) () PartitionM
ignoreKnot :: KnotTier (Lifted Partitions) () PartitionM
ignoreKnot =
  KnotTier :: forall v d (m :: * -> *).
m d -> (d -> m v) -> (d -> v -> m v) -> KnotTier v d m
KnotTier
    { $sel:onKnotFound:KnotTier :: PartitionM ()
onKnotFound = () -> PartitionM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , $sel:onKnotUsed:KnotTier :: () -> PartitionM (Lifted Partitions)
onKnotUsed = \()
_ -> Lifted Partitions -> PartitionM (Lifted Partitions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lifted Partitions
forall a. BoundedJoinSemiLattice a => a
bottom
    , $sel:tieKnot:KnotTier :: () -> Lifted Partitions -> PartitionM (Lifted Partitions)
tieKnot = \()
_ -> Lifted Partitions -> PartitionM (Lifted Partitions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    }

singletonPart :: PartitionData -> Lifted Partitions
singletonPart :: PartitionData -> Lifted Partitions
singletonPart = Partitions -> Lifted Partitions
forall a. a -> Lifted a
Lift (Partitions -> Lifted Partitions)
-> (PartitionData -> Partitions)
-> PartitionData
-> Lifted Partitions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PartitionLocation (Set PartitionData) -> Partitions
Partitions (Map PartitionLocation (Set PartitionData) -> Partitions)
-> (PartitionData -> Map PartitionLocation (Set PartitionData))
-> PartitionData
-> Partitions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartitionLocation
-> Set PartitionData -> Map PartitionLocation (Set PartitionData)
forall k a. k -> a -> Map k a
M.singleton PartitionLocation
PHere (Set PartitionData -> Map PartitionLocation (Set PartitionData))
-> (PartitionData -> Set PartitionData)
-> PartitionData
-> Map PartitionLocation (Set PartitionData)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartitionData -> Set PartitionData
forall a. a -> Set a
S.singleton

partitionSchema :: Traced Schema -> PartitionM (Lifted Partitions)
partitionSchema :: Traced Schema -> PartitionM (Lifted Partitions)
partitionSchema Traced Schema
sch = do
  [Lifted Partitions]
allClauses <- case Traced Schema -> Maybe [Traced (Referenced Schema)]
tracedAllOf Traced Schema
sch of
    Maybe [Traced (Referenced Schema)]
Nothing -> [Lifted Partitions]
-> ReaderT
     (Traced (Definitions Schema))
     (State (MemoState ()))
     [Lifted Partitions]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just [Traced (Referenced Schema)]
xs -> (Traced (Referenced Schema) -> PartitionM (Lifted Partitions))
-> [Traced (Referenced Schema)]
-> ReaderT
     (Traced (Definitions Schema))
     (State (MemoState ()))
     [Lifted Partitions]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Traced (Referenced Schema) -> PartitionM (Lifted Partitions)
partitionRefSchema [Traced (Referenced Schema)]
xs

  Lifted Partitions
anyClause <- case Traced Schema -> Maybe [Traced (Referenced Schema)]
tracedAnyOf Traced Schema
sch of
    Maybe [Traced (Referenced Schema)]
Nothing -> Lifted Partitions -> PartitionM (Lifted Partitions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lifted Partitions
forall a. BoundedMeetSemiLattice a => a
top
    Just [Traced (Referenced Schema)]
xs -> [Lifted Partitions] -> Lifted Partitions
forall a (f :: * -> *).
(BoundedJoinSemiLattice a, Foldable f) =>
f a -> a
joins ([Lifted Partitions] -> Lifted Partitions)
-> ReaderT
     (Traced (Definitions Schema))
     (State (MemoState ()))
     [Lifted Partitions]
-> PartitionM (Lifted Partitions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Traced (Referenced Schema) -> PartitionM (Lifted Partitions))
-> [Traced (Referenced Schema)]
-> ReaderT
     (Traced (Definitions Schema))
     (State (MemoState ()))
     [Lifted Partitions]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Traced (Referenced Schema) -> PartitionM (Lifted Partitions)
partitionRefSchema [Traced (Referenced Schema)]
xs

  Lifted Partitions
oneClause <- case Traced Schema -> Maybe [Traced (Referenced Schema)]
tracedOneOf Traced Schema
sch of
    Maybe [Traced (Referenced Schema)]
Nothing -> Lifted Partitions -> PartitionM (Lifted Partitions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lifted Partitions
forall a. BoundedMeetSemiLattice a => a
top
    Just [Traced (Referenced Schema)]
xs -> [Lifted Partitions] -> Lifted Partitions
forall a (f :: * -> *).
(BoundedJoinSemiLattice a, Foldable f) =>
f a -> a
joins ([Lifted Partitions] -> Lifted Partitions)
-> ReaderT
     (Traced (Definitions Schema))
     (State (MemoState ()))
     [Lifted Partitions]
-> PartitionM (Lifted Partitions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Traced (Referenced Schema) -> PartitionM (Lifted Partitions))
-> [Traced (Referenced Schema)]
-> ReaderT
     (Traced (Definitions Schema))
     (State (MemoState ()))
     [Lifted Partitions]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Traced (Referenced Schema) -> PartitionM (Lifted Partitions)
partitionRefSchema [Traced (Referenced Schema)]
xs

  Lifted Partitions
byEnumClause <- case Schema -> Maybe [Value]
_schemaEnum (Schema -> Maybe [Value]) -> Schema -> Maybe [Value]
forall a b. (a -> b) -> a -> b
$ Traced Schema -> Schema
forall (w :: * -> *) a. Comonad w => w a -> a
extract Traced Schema
sch of
    Maybe [Value]
Nothing -> Lifted Partitions -> PartitionM (Lifted Partitions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lifted Partitions
forall a. BoundedMeetSemiLattice a => a
top
    Just [Value]
xs ->
      Lifted Partitions -> PartitionM (Lifted Partitions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lifted Partitions -> PartitionM (Lifted Partitions))
-> (PartitionData -> Lifted Partitions)
-> PartitionData
-> PartitionM (Lifted Partitions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartitionData -> Lifted Partitions
singletonPart (PartitionData -> PartitionM (Lifted Partitions))
-> PartitionData -> PartitionM (Lifted Partitions)
forall a b. (a -> b) -> a -> b
$
        DNF (Set Value) -> PartitionData
DByEnumValue (DNF (Set Value) -> PartitionData)
-> DNF (Set Value) -> PartitionData
forall a b. (a -> b) -> a -> b
$ Set Value -> DNF (Set Value)
forall a. Ord a => a -> DNF a
LiteralDNF ([Value] -> Set Value
forall a. Ord a => [a] -> Set a
S.fromList [Value]
xs)

  -- We can only partition by presence of a property if additional properties
  -- are disallowed, and the property is not optional
  let reqd :: Set Text
reqd = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ Schema -> [Text]
_schemaRequired (Schema -> [Text]) -> Schema -> [Text]
forall a b. (a -> b) -> a -> b
$ Traced Schema -> Schema
forall (w :: * -> *) a. Comonad w => w a -> a
extract Traced Schema
sch
  Lifted Partitions
byPropertiesClause <- case Schema -> Maybe AdditionalProperties
_schemaAdditionalProperties (Schema -> Maybe AdditionalProperties)
-> Schema -> Maybe AdditionalProperties
forall a b. (a -> b) -> a -> b
$ Traced Schema -> Schema
forall (w :: * -> *) a. Comonad w => w a -> a
extract Traced Schema
sch of
    Just (AdditionalPropertiesAllowed Bool
False) -> do
      let props :: Set Text
props = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> (Schema -> [Text]) -> Schema -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InsOrdHashMap Text (Referenced Schema) -> [Text]
forall k v. InsOrdHashMap k v -> [k]
IOHM.keys (InsOrdHashMap Text (Referenced Schema) -> [Text])
-> (Schema -> InsOrdHashMap Text (Referenced Schema))
-> Schema
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> InsOrdHashMap Text (Referenced Schema)
_schemaProperties (Schema -> Set Text) -> Schema -> Set Text
forall a b. (a -> b) -> a -> b
$ Traced Schema -> Schema
forall (w :: * -> *) a. Comonad w => w a -> a
extract Traced Schema
sch
      Lifted Partitions -> PartitionM (Lifted Partitions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lifted Partitions -> PartitionM (Lifted Partitions))
-> (PartitionData -> Lifted Partitions)
-> PartitionData
-> PartitionM (Lifted Partitions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartitionData -> Lifted Partitions
singletonPart (PartitionData -> PartitionM (Lifted Partitions))
-> PartitionData -> PartitionM (Lifted Partitions)
forall a b. (a -> b) -> a -> b
$
        DNF (Set Text, Set Text) -> PartitionData
DByProperties (DNF (Set Text, Set Text) -> PartitionData)
-> DNF (Set Text, Set Text) -> PartitionData
forall a b. (a -> b) -> a -> b
$ (Set Text, Set Text) -> DNF (Set Text, Set Text)
forall a. Ord a => a -> DNF a
LiteralDNF (Set Text
props Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set Text
reqd, Set Text
props Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` Set Text
reqd)
    Maybe AdditionalProperties
_ -> Lifted Partitions -> PartitionM (Lifted Partitions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lifted Partitions
forall a. BoundedMeetSemiLattice a => a
top

  -- We can partition on something nested in a property only if the property is
  -- required
  let reqdProps :: InsOrdHashMap Text (Traced (Referenced Schema))
reqdProps = (Text -> Traced (Referenced Schema) -> Bool)
-> InsOrdHashMap Text (Traced (Referenced Schema))
-> InsOrdHashMap Text (Traced (Referenced Schema))
forall k v.
(k -> v -> Bool) -> InsOrdHashMap k v -> InsOrdHashMap k v
IOHM.filterWithKey (\Text
k Traced (Referenced Schema)
_ -> Text
k Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
reqd) (InsOrdHashMap Text (Traced (Referenced Schema))
 -> InsOrdHashMap Text (Traced (Referenced Schema)))
-> InsOrdHashMap Text (Traced (Referenced Schema))
-> InsOrdHashMap Text (Traced (Referenced Schema))
forall a b. (a -> b) -> a -> b
$ Traced Schema -> InsOrdHashMap Text (Traced (Referenced Schema))
tracedProperties Traced Schema
sch
  [Lifted Partitions]
inPropertiesClauses <- [(Text, Traced (Referenced Schema))]
-> ((Text, Traced (Referenced Schema))
    -> PartitionM (Lifted Partitions))
-> ReaderT
     (Traced (Definitions Schema))
     (State (MemoState ()))
     [Lifted Partitions]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (InsOrdHashMap Text (Traced (Referenced Schema))
-> [(Text, Traced (Referenced Schema))]
forall k v. InsOrdHashMap k v -> [(k, v)]
IOHM.toList InsOrdHashMap Text (Traced (Referenced Schema))
reqdProps) (((Text, Traced (Referenced Schema))
  -> PartitionM (Lifted Partitions))
 -> ReaderT
      (Traced (Definitions Schema))
      (State (MemoState ()))
      [Lifted Partitions])
-> ((Text, Traced (Referenced Schema))
    -> PartitionM (Lifted Partitions))
-> ReaderT
     (Traced (Definitions Schema))
     (State (MemoState ()))
     [Lifted Partitions]
forall a b. (a -> b) -> a -> b
$ \(Text
k, Traced (Referenced Schema)
rs) -> do
    Lifted Partitions
f <- Traced (Referenced Schema) -> PartitionM (Lifted Partitions)
partitionRefSchema Traced (Referenced Schema)
rs
    pure $ (Partitions -> Partitions)
-> Lifted Partitions -> Lifted Partitions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Partitions Map PartitionLocation (Set PartitionData)
m) -> Map PartitionLocation (Set PartitionData) -> Partitions
Partitions (Map PartitionLocation (Set PartitionData) -> Partitions)
-> Map PartitionLocation (Set PartitionData) -> Partitions
forall a b. (a -> b) -> a -> b
$ (PartitionLocation -> PartitionLocation)
-> Map PartitionLocation (Set PartitionData)
-> Map PartitionLocation (Set PartitionData)
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeysMonotonic (Text -> PartitionLocation -> PartitionLocation
PInProperty Text
k) Map PartitionLocation (Set PartitionData)
m) Lifted Partitions
f

  pure $ [Lifted Partitions] -> Lifted Partitions
forall a (f :: * -> *).
(BoundedMeetSemiLattice a, Foldable f) =>
f a -> a
meets ([Lifted Partitions] -> Lifted Partitions)
-> [Lifted Partitions] -> Lifted Partitions
forall a b. (a -> b) -> a -> b
$ [Lifted Partitions]
allClauses [Lifted Partitions] -> [Lifted Partitions] -> [Lifted Partitions]
forall a. Semigroup a => a -> a -> a
<> [Lifted Partitions
anyClause, Lifted Partitions
oneClause, Lifted Partitions
byEnumClause, Lifted Partitions
byPropertiesClause] [Lifted Partitions] -> [Lifted Partitions] -> [Lifted Partitions]
forall a. Semigroup a => a -> a -> a
<> [Lifted Partitions]
inPropertiesClauses

partitionRefSchema :: Traced (Referenced Schema) -> PartitionM (Lifted Partitions)
partitionRefSchema :: Traced (Referenced Schema) -> PartitionM (Lifted Partitions)
partitionRefSchema Traced (Referenced Schema)
x = do
  Traced (Definitions Schema)
defs <- ReaderT
  (Traced (Definitions Schema))
  (State (MemoState ()))
  (Traced (Definitions Schema))
forall r (m :: * -> *). MonadReader r m => m r
R.ask
  KnotTier (Lifted Partitions) () PartitionM
-> PartitionM (Lifted Partitions)
-> Paths Step TraceRoot (Referenced Schema)
-> PartitionM (Lifted Partitions)
forall k v d (m :: * -> *) s.
(Typeable k, Typeable v, Typeable d, Ord k, MonadMemo s m) =>
KnotTier v d m -> m v -> k -> m v
memoWithKnot KnotTier (Lifted Partitions) () PartitionM
ignoreKnot (Traced Schema -> PartitionM (Lifted Partitions)
partitionSchema (Traced Schema -> PartitionM (Lifted Partitions))
-> Traced Schema -> PartitionM (Lifted Partitions)
forall a b. (a -> b) -> a -> b
$ Traced (Definitions Schema)
-> Traced (Referenced Schema) -> Traced Schema
forall a.
Typeable a =>
Traced (Definitions a) -> Traced (Referenced a) -> Traced a
dereference Traced (Definitions Schema)
defs Traced (Referenced Schema)
x) (Traced (Referenced Schema)
-> Paths Step TraceRoot (Referenced Schema)
forall e (w :: * -> *) a. ComonadEnv e w => w a -> e
ask Traced (Referenced Schema)
x)

partitionCondition :: Condition t -> PartitionM (Lifted Partitions)
partitionCondition :: Condition t -> PartitionM (Lifted Partitions)
partitionCondition = \case
  Exactly TypedValue t
x ->
    Lifted Partitions -> PartitionM (Lifted Partitions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lifted Partitions -> PartitionM (Lifted Partitions))
-> (PartitionData -> Lifted Partitions)
-> PartitionData
-> PartitionM (Lifted Partitions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartitionData -> Lifted Partitions
singletonPart (PartitionData -> PartitionM (Lifted Partitions))
-> PartitionData -> PartitionM (Lifted Partitions)
forall a b. (a -> b) -> a -> b
$
      DNF (Set Value) -> PartitionData
DByEnumValue (DNF (Set Value) -> PartitionData)
-> DNF (Set Value) -> PartitionData
forall a b. (a -> b) -> a -> b
$ Set Value -> DNF (Set Value)
forall a. Ord a => a -> DNF a
LiteralDNF (Value -> Set Value
forall a. a -> Set a
S.singleton (Value -> Set Value) -> Value -> Set Value
forall a b. (a -> b) -> a -> b
$ TypedValue t -> Value
forall (t :: JsonType). TypedValue t -> Value
untypeValue TypedValue t
x)
  Properties Map Text Property
props ForeachType JsonFormula
_ Maybe (Traced (Referenced Schema))
madd -> do
    let byProps :: Lifted Partitions
byProps = case Maybe (Traced (Referenced Schema))
madd of
          Just Traced (Referenced Schema)
_ -> Lifted Partitions
forall a. BoundedMeetSemiLattice a => a
top
          Maybe (Traced (Referenced Schema))
Nothing ->
            PartitionData -> Lifted Partitions
singletonPart (PartitionData -> Lifted Partitions)
-> PartitionData -> Lifted Partitions
forall a b. (a -> b) -> a -> b
$
              DNF (Set Text, Set Text) -> PartitionData
DByProperties (DNF (Set Text, Set Text) -> PartitionData)
-> DNF (Set Text, Set Text) -> PartitionData
forall a b. (a -> b) -> a -> b
$
                (Set Text, Set Text) -> DNF (Set Text, Set Text)
forall a. Ord a => a -> DNF a
LiteralDNF
                  ( Map Text Property -> Set Text
forall k a. Map k a -> Set k
M.keysSet (Map Text Property -> Set Text) -> Map Text Property -> Set Text
forall a b. (a -> b) -> a -> b
$ (Property -> Bool) -> Map Text Property -> Map Text Property
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool) -> (Property -> Bool) -> Property -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Bool
propRequired) Map Text Property
props
                  , Map Text Property -> Set Text
forall k a. Map k a -> Set k
M.keysSet (Map Text Property -> Set Text) -> Map Text Property -> Set Text
forall a b. (a -> b) -> a -> b
$ (Property -> Bool) -> Map Text Property -> Map Text Property
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter Property -> Bool
propRequired Map Text Property
props
                  )
    [Lifted Partitions]
inProps <- [(Text, Property)]
-> ((Text, Property) -> PartitionM (Lifted Partitions))
-> ReaderT
     (Traced (Definitions Schema))
     (State (MemoState ()))
     [Lifted Partitions]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map Text Property -> [(Text, Property)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Text Property -> [(Text, Property)])
-> Map Text Property -> [(Text, Property)]
forall a b. (a -> b) -> a -> b
$ (Property -> Bool) -> Map Text Property -> Map Text Property
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter Property -> Bool
propRequired Map Text Property
props) (((Text, Property) -> PartitionM (Lifted Partitions))
 -> ReaderT
      (Traced (Definitions Schema))
      (State (MemoState ()))
      [Lifted Partitions])
-> ((Text, Property) -> PartitionM (Lifted Partitions))
-> ReaderT
     (Traced (Definitions Schema))
     (State (MemoState ()))
     [Lifted Partitions]
forall a b. (a -> b) -> a -> b
$ \(Text
k, Property
prop) -> do
      Lifted Partitions
f <- Traced (Referenced Schema) -> PartitionM (Lifted Partitions)
partitionRefSchema (Traced (Referenced Schema) -> PartitionM (Lifted Partitions))
-> Traced (Referenced Schema) -> PartitionM (Lifted Partitions)
forall a b. (a -> b) -> a -> b
$ Property -> Traced (Referenced Schema)
propRefSchema Property
prop
      pure $ (Partitions -> Partitions)
-> Lifted Partitions -> Lifted Partitions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Partitions Map PartitionLocation (Set PartitionData)
m) -> Map PartitionLocation (Set PartitionData) -> Partitions
Partitions (Map PartitionLocation (Set PartitionData) -> Partitions)
-> Map PartitionLocation (Set PartitionData) -> Partitions
forall a b. (a -> b) -> a -> b
$ (PartitionLocation -> PartitionLocation)
-> Map PartitionLocation (Set PartitionData)
-> Map PartitionLocation (Set PartitionData)
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeysMonotonic (Text -> PartitionLocation -> PartitionLocation
PInProperty Text
k) Map PartitionLocation (Set PartitionData)
m) Lifted Partitions
f
    pure $ Lifted Partitions
byProps Lifted Partitions -> Lifted Partitions -> Lifted Partitions
forall a. Lattice a => a -> a -> a
/\ [Lifted Partitions] -> Lifted Partitions
forall a (f :: * -> *).
(BoundedMeetSemiLattice a, Foldable f) =>
f a -> a
meets [Lifted Partitions]
inProps
  Condition t
_ -> Lifted Partitions -> PartitionM (Lifted Partitions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lifted Partitions
forall a. BoundedMeetSemiLattice a => a
top

runPartitionM :: Traced (Definitions Schema) -> PartitionM a -> a
runPartitionM :: Traced (Definitions Schema) -> PartitionM a -> a
runPartitionM Traced (Definitions Schema)
defs = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a)
-> (PartitionM a -> Identity a) -> PartitionM a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> StateT (MemoState ()) Identity a -> Identity a
forall (m :: * -> *) s a.
Monad m =>
s -> StateT (MemoState s) m a -> m a
runMemo () (StateT (MemoState ()) Identity a -> Identity a)
-> (PartitionM a -> StateT (MemoState ()) Identity a)
-> PartitionM a
-> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PartitionM a
-> Traced (Definitions Schema) -> StateT (MemoState ()) Identity a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Traced (Definitions Schema)
defs)

partitionJsonFormulas ::
  ProdCons (Traced (Definitions Schema)) ->
  ProdCons (JsonFormula t) ->
  Lifted Partitions
partitionJsonFormulas :: ProdCons (Traced (Definitions Schema))
-> ProdCons (JsonFormula t) -> Lifted Partitions
partitionJsonFormulas ProdCons (Traced (Definitions Schema))
defs ProdCons (JsonFormula t)
pc = ProdCons (Lifted Partitions) -> Lifted Partitions
forall a. ProdCons a -> a
producer ProdCons (Lifted Partitions)
pcPart Lifted Partitions -> Lifted Partitions -> Lifted Partitions
forall a. Lattice a => a -> a -> a
\/ ProdCons (Lifted Partitions) -> Lifted Partitions
forall a. ProdCons a -> a
consumer ProdCons (Lifted Partitions)
pcPart
  where
    pcPart :: ProdCons (Lifted Partitions)
pcPart = Traced (Definitions Schema) -> JsonFormula t -> Lifted Partitions
forall (t :: JsonType).
Traced (Definitions Schema) -> JsonFormula t -> Lifted Partitions
partitionFormula (Traced (Definitions Schema) -> JsonFormula t -> Lifted Partitions)
-> ProdCons (Traced (Definitions Schema))
-> ProdCons (JsonFormula t -> Lifted Partitions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced (Definitions Schema))
defs ProdCons (JsonFormula t -> Lifted Partitions)
-> ProdCons (JsonFormula t) -> ProdCons (Lifted Partitions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProdCons (JsonFormula t)
pc
    partitionFormula :: Traced (Definitions Schema) -> JsonFormula t -> Lifted Partitions
partitionFormula Traced (Definitions Schema)
def (JsonFormula DNF (Condition t)
xss) = Traced (Definitions Schema)
-> PartitionM (Lifted Partitions) -> Lifted Partitions
forall a. Traced (Definitions Schema) -> PartitionM a -> a
runPartitionM Traced (Definitions Schema)
def (PartitionM (Lifted Partitions) -> Lifted Partitions)
-> PartitionM (Lifted Partitions) -> Lifted Partitions
forall a b. (a -> b) -> a -> b
$ (Condition t -> PartitionM (Lifted Partitions))
-> DNF (Condition t) -> PartitionM (Lifted Partitions)
forall l (f :: * -> *) a.
(BoundedLattice l, Applicative f) =>
(a -> f l) -> DNF a -> f l
forDNF Condition t -> PartitionM (Lifted Partitions)
forall (t :: JsonType).
Condition t -> PartitionM (Lifted Partitions)
partitionCondition DNF (Condition t)
xss

selectPartition :: Lifted Partitions -> Maybe (PartitionLocation, S.Set PartitionChoice)
selectPartition :: Lifted Partitions -> Maybe (PartitionLocation, Set PartitionChoice)
selectPartition Lifted Partitions
Bottom = Maybe (PartitionLocation, Set PartitionChoice)
forall a. Maybe a
Nothing
selectPartition (Lift (Partitions Map PartitionLocation (Set PartitionData)
m)) =
  [(PartitionLocation, PartitionData)]
-> Maybe (PartitionLocation, Set PartitionChoice)
go [(PartitionLocation
loc, PartitionData
part) | (PartitionLocation
loc, Set PartitionData
parts) <- ((PartitionLocation, Set PartitionData)
 -> (PartitionLocation, Set PartitionData) -> Ordering)
-> [(PartitionLocation, Set PartitionData)]
-> [(PartitionLocation, Set PartitionData)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((PartitionLocation, Set PartitionData) -> Int)
-> (PartitionLocation, Set PartitionData)
-> (PartitionLocation, Set PartitionData)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (((PartitionLocation, Set PartitionData) -> Int)
 -> (PartitionLocation, Set PartitionData)
 -> (PartitionLocation, Set PartitionData)
 -> Ordering)
-> ((PartitionLocation, Set PartitionData) -> Int)
-> (PartitionLocation, Set PartitionData)
-> (PartitionLocation, Set PartitionData)
-> Ordering
forall a b. (a -> b) -> a -> b
$ PartitionLocation -> Int
locLength (PartitionLocation -> Int)
-> ((PartitionLocation, Set PartitionData) -> PartitionLocation)
-> (PartitionLocation, Set PartitionData)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PartitionLocation, Set PartitionData) -> PartitionLocation
forall a b. (a, b) -> a
fst) ([(PartitionLocation, Set PartitionData)]
 -> [(PartitionLocation, Set PartitionData)])
-> [(PartitionLocation, Set PartitionData)]
-> [(PartitionLocation, Set PartitionData)]
forall a b. (a -> b) -> a -> b
$ Map PartitionLocation (Set PartitionData)
-> [(PartitionLocation, Set PartitionData)]
forall k a. Map k a -> [(k, a)]
M.toList Map PartitionLocation (Set PartitionData)
m, PartitionData
part <- Set PartitionData -> [PartitionData]
forall a. Set a -> [a]
S.toList Set PartitionData
parts]
  where
    locLength :: PartitionLocation -> Int
    locLength :: PartitionLocation -> Int
locLength = Int -> PartitionLocation -> Int
forall t. Num t => t -> PartitionLocation -> t
walk Int
0
      where
        walk :: t -> PartitionLocation -> t
walk !t
n PartitionLocation
PHere = t
n
        walk !t
n (PInProperty Text
_ PartitionLocation
l) = t -> PartitionLocation -> t
walk (t
n t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) PartitionLocation
l
    go :: [(PartitionLocation, PartitionData)]
-> Maybe (PartitionLocation, Set PartitionChoice)
go [] = Maybe (PartitionLocation, Set PartitionChoice)
forall a. Maybe a
Nothing
    -- Skip partitioning by property for now
    go ((PartitionLocation
_, DByProperties DNF (Set Text, Set Text)
_) : [(PartitionLocation, PartitionData)]
ps) = [(PartitionLocation, PartitionData)]
-> Maybe (PartitionLocation, Set PartitionChoice)
go [(PartitionLocation, PartitionData)]
ps
    -- Don't partition by enum value at the root (this reports removed enum values as contradictions in their respective partitions)
    go ((PartitionLocation
PHere, DByEnumValue DNF (Set Value)
_) : [(PartitionLocation, PartitionData)]
ps) = [(PartitionLocation, PartitionData)]
-> Maybe (PartitionLocation, Set PartitionChoice)
go [(PartitionLocation, PartitionData)]
ps
    go ((PartitionLocation
loc, DByEnumValue (DNF Set (Disjunct (Set Value))
xss)) : [(PartitionLocation, PartitionData)]
ps)
      -- Check that no disjunction branches are unresticted
      | Just [Set Value]
enums <- (Disjunct (Set Value) -> Maybe (Set Value))
-> [Disjunct (Set Value)] -> Maybe [Set Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Disjunct Set (Set Value)
xs) -> (NonEmpty (Set Value) -> Set Value)
-> Maybe (NonEmpty (Set Value)) -> Maybe (Set Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Set Value -> Set Value -> Set Value)
-> NonEmpty (Set Value) -> Set Value
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Set Value -> Set Value -> Set Value
forall a. Ord a => Set a -> Set a -> Set a
S.intersection) (Maybe (NonEmpty (Set Value)) -> Maybe (Set Value))
-> (Set (Set Value) -> Maybe (NonEmpty (Set Value)))
-> Set (Set Value)
-> Maybe (Set Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Set Value] -> Maybe (NonEmpty (Set Value))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Set Value] -> Maybe (NonEmpty (Set Value)))
-> (Set (Set Value) -> [Set Value])
-> Set (Set Value)
-> Maybe (NonEmpty (Set Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Set Value) -> [Set Value]
forall a. Set a -> [a]
S.toList (Set (Set Value) -> Maybe (Set Value))
-> Set (Set Value) -> Maybe (Set Value)
forall a b. (a -> b) -> a -> b
$ Set (Set Value)
xs) ([Disjunct (Set Value)] -> Maybe [Set Value])
-> (Set (Disjunct (Set Value)) -> [Disjunct (Set Value)])
-> Set (Disjunct (Set Value))
-> Maybe [Set Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Disjunct (Set Value)) -> [Disjunct (Set Value)]
forall a. Set a -> [a]
S.toList (Set (Disjunct (Set Value)) -> Maybe [Set Value])
-> Set (Disjunct (Set Value)) -> Maybe [Set Value]
forall a b. (a -> b) -> a -> b
$ Set (Disjunct (Set Value))
xss =
        -- TODO: improve
        (PartitionLocation, Set PartitionChoice)
-> Maybe (PartitionLocation, Set PartitionChoice)
forall a. a -> Maybe a
Just (PartitionLocation
loc, (Value -> PartitionChoice) -> Set Value -> Set PartitionChoice
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (Set Value -> PartitionChoice
CByEnumValue (Set Value -> PartitionChoice)
-> (Value -> Set Value) -> Value -> PartitionChoice
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Set Value
forall a. a -> Set a
S.singleton) (Set Value -> Set PartitionChoice)
-> Set Value -> Set PartitionChoice
forall a b. (a -> b) -> a -> b
$ [Set Value] -> Set Value
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set Value]
enums)
      | Bool
otherwise = [(PartitionLocation, PartitionData)]
-> Maybe (PartitionLocation, Set PartitionChoice)
go [(PartitionLocation, PartitionData)]
ps

-- This essentially has 3 cases:
-- Nothing -- we have produced a bottom schema
-- Just (False, _) -- there's been no change to the schema
-- Just (True, x) -- x is a new schema
type IntersectionM = ReaderT (Traced (Definitions Schema)) (WriterT Any Maybe)

mBottom :: IntersectionM a
mBottom :: IntersectionM a
mBottom = WriterT Any Maybe a -> IntersectionM a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT Any Maybe a -> IntersectionM a)
-> (Maybe a -> WriterT Any Maybe a) -> Maybe a -> IntersectionM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> WriterT Any Maybe a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe a -> IntersectionM a) -> Maybe a -> IntersectionM a
forall a b. (a -> b) -> a -> b
$ Maybe a
forall a. Maybe a
Nothing

catchBottom :: IntersectionM a -> IntersectionM a -> IntersectionM a
catchBottom :: IntersectionM a -> IntersectionM a -> IntersectionM a
catchBottom IntersectionM a
act IntersectionM a
handler = Catch () (WriterT Any Maybe) a
-> Catch
     () (ReaderT (Traced (Definitions Schema)) (WriterT Any Maybe)) a
forall e (m :: * -> *) a r. Catch e m a -> Catch e (ReaderT r m) a
R.liftCatch (Catch () Maybe (a, Any) -> Catch () (WriterT Any Maybe) a
forall e (m :: * -> *) a w.
Catch e m (a, w) -> Catch e (WriterT w m) a
W.liftCatch (\Maybe (a, Any)
a () -> Maybe (a, Any)
h -> Maybe (a, Any)
a Maybe (a, Any) -> Maybe (a, Any) -> Maybe (a, Any)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Maybe (a, Any)
h ())) IntersectionM a
act (\()
_ -> IntersectionM a
handler)

mChange :: IntersectionM ()
mChange :: IntersectionM ()
mChange = Any -> IntersectionM ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> IntersectionM ()) -> Any -> IntersectionM ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True

data IntersectionResult a = Disjoint | Same a | New a
  deriving stock (IntersectionResult a -> IntersectionResult a -> Bool
(IntersectionResult a -> IntersectionResult a -> Bool)
-> (IntersectionResult a -> IntersectionResult a -> Bool)
-> Eq (IntersectionResult a)
forall a.
Eq a =>
IntersectionResult a -> IntersectionResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntersectionResult a -> IntersectionResult a -> Bool
$c/= :: forall a.
Eq a =>
IntersectionResult a -> IntersectionResult a -> Bool
== :: IntersectionResult a -> IntersectionResult a -> Bool
$c== :: forall a.
Eq a =>
IntersectionResult a -> IntersectionResult a -> Bool
Eq, Eq (IntersectionResult a)
Eq (IntersectionResult a)
-> (IntersectionResult a -> IntersectionResult a -> Ordering)
-> (IntersectionResult a -> IntersectionResult a -> Bool)
-> (IntersectionResult a -> IntersectionResult a -> Bool)
-> (IntersectionResult a -> IntersectionResult a -> Bool)
-> (IntersectionResult a -> IntersectionResult a -> Bool)
-> (IntersectionResult a
    -> IntersectionResult a -> IntersectionResult a)
-> (IntersectionResult a
    -> IntersectionResult a -> IntersectionResult a)
-> Ord (IntersectionResult a)
IntersectionResult a -> IntersectionResult a -> Bool
IntersectionResult a -> IntersectionResult a -> Ordering
IntersectionResult a
-> IntersectionResult a -> IntersectionResult a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (IntersectionResult a)
forall a.
Ord a =>
IntersectionResult a -> IntersectionResult a -> Bool
forall a.
Ord a =>
IntersectionResult a -> IntersectionResult a -> Ordering
forall a.
Ord a =>
IntersectionResult a
-> IntersectionResult a -> IntersectionResult a
min :: IntersectionResult a
-> IntersectionResult a -> IntersectionResult a
$cmin :: forall a.
Ord a =>
IntersectionResult a
-> IntersectionResult a -> IntersectionResult a
max :: IntersectionResult a
-> IntersectionResult a -> IntersectionResult a
$cmax :: forall a.
Ord a =>
IntersectionResult a
-> IntersectionResult a -> IntersectionResult a
>= :: IntersectionResult a -> IntersectionResult a -> Bool
$c>= :: forall a.
Ord a =>
IntersectionResult a -> IntersectionResult a -> Bool
> :: IntersectionResult a -> IntersectionResult a -> Bool
$c> :: forall a.
Ord a =>
IntersectionResult a -> IntersectionResult a -> Bool
<= :: IntersectionResult a -> IntersectionResult a -> Bool
$c<= :: forall a.
Ord a =>
IntersectionResult a -> IntersectionResult a -> Bool
< :: IntersectionResult a -> IntersectionResult a -> Bool
$c< :: forall a.
Ord a =>
IntersectionResult a -> IntersectionResult a -> Bool
compare :: IntersectionResult a -> IntersectionResult a -> Ordering
$ccompare :: forall a.
Ord a =>
IntersectionResult a -> IntersectionResult a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (IntersectionResult a)
Ord, Int -> IntersectionResult a -> ShowS
[IntersectionResult a] -> ShowS
IntersectionResult a -> String
(Int -> IntersectionResult a -> ShowS)
-> (IntersectionResult a -> String)
-> ([IntersectionResult a] -> ShowS)
-> Show (IntersectionResult a)
forall a. Show a => Int -> IntersectionResult a -> ShowS
forall a. Show a => [IntersectionResult a] -> ShowS
forall a. Show a => IntersectionResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntersectionResult a] -> ShowS
$cshowList :: forall a. Show a => [IntersectionResult a] -> ShowS
show :: IntersectionResult a -> String
$cshow :: forall a. Show a => IntersectionResult a -> String
showsPrec :: Int -> IntersectionResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> IntersectionResult a -> ShowS
Show)

runIntersectionM :: Traced (Definitions Schema) -> IntersectionM a -> IntersectionResult a
runIntersectionM :: Traced (Definitions Schema)
-> IntersectionM a -> IntersectionResult a
runIntersectionM Traced (Definitions Schema)
defs IntersectionM a
act = case WriterT Any Maybe a -> Maybe (a, Any)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT Any Maybe a -> Maybe (a, Any))
-> WriterT Any Maybe a -> Maybe (a, Any)
forall a b. (a -> b) -> a -> b
$ IntersectionM a
-> Traced (Definitions Schema) -> WriterT Any Maybe a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT IntersectionM a
act Traced (Definitions Schema)
defs of
  Maybe (a, Any)
Nothing -> IntersectionResult a
forall a. IntersectionResult a
Disjoint
  Just (a
x, Any Bool
False) -> a -> IntersectionResult a
forall a. a -> IntersectionResult a
Same a
x
  Just (a
x, Any Bool
True) -> a -> IntersectionResult a
forall a. a -> IntersectionResult a
New a
x

intersectSchema ::
  PartitionLocation ->
  PartitionChoice ->
  Traced Schema ->
  IntersectionM Schema
intersectSchema :: PartitionLocation
-> PartitionChoice -> Traced Schema -> IntersectionM Schema
intersectSchema PartitionLocation
loc PartitionChoice
part Traced Schema
sch = do
  Maybe [Referenced Schema]
allOf' <- Maybe [Traced (Referenced Schema)]
-> ([Traced (Referenced Schema)]
    -> ReaderT
         (Traced (Definitions Schema))
         (WriterT Any Maybe)
         [Referenced Schema])
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe [Referenced Schema])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Traced Schema -> Maybe [Traced (Referenced Schema)]
tracedAllOf Traced Schema
sch) (([Traced (Referenced Schema)]
  -> ReaderT
       (Traced (Definitions Schema))
       (WriterT Any Maybe)
       [Referenced Schema])
 -> ReaderT
      (Traced (Definitions Schema))
      (WriterT Any Maybe)
      (Maybe [Referenced Schema]))
-> ([Traced (Referenced Schema)]
    -> ReaderT
         (Traced (Definitions Schema))
         (WriterT Any Maybe)
         [Referenced Schema])
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe [Referenced Schema])
forall a b. (a -> b) -> a -> b
$ \[Traced (Referenced Schema)]
rss ->
    -- Assuming i ranges over a nonempty set (checked in processSchema)
    -- (⋂_i A[i]) ∩ X = ⋂_i (A[i] ∩ X)
    -- If any intersections are empty, the result is empty. If any intersections are a change, the result is a change.
    (Traced (Referenced Schema)
 -> ReaderT
      (Traced (Definitions Schema))
      (WriterT Any Maybe)
      (Referenced Schema))
-> [Traced (Referenced Schema)]
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     [Referenced Schema]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (PartitionLocation
-> PartitionChoice
-> Traced (Referenced Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Referenced Schema)
intersectRefSchema PartitionLocation
loc PartitionChoice
part) [Traced (Referenced Schema)]
rss
  Maybe [Referenced Schema]
anyOf' <- Maybe [Traced (Referenced Schema)]
-> ([Traced (Referenced Schema)]
    -> ReaderT
         (Traced (Definitions Schema))
         (WriterT Any Maybe)
         [Referenced Schema])
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe [Referenced Schema])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Traced Schema -> Maybe [Traced (Referenced Schema)]
tracedAnyOf Traced Schema
sch) (([Traced (Referenced Schema)]
  -> ReaderT
       (Traced (Definitions Schema))
       (WriterT Any Maybe)
       [Referenced Schema])
 -> ReaderT
      (Traced (Definitions Schema))
      (WriterT Any Maybe)
      (Maybe [Referenced Schema]))
-> ([Traced (Referenced Schema)]
    -> ReaderT
         (Traced (Definitions Schema))
         (WriterT Any Maybe)
         [Referenced Schema])
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe [Referenced Schema])
forall a b. (a -> b) -> a -> b
$ \[Traced (Referenced Schema)]
rss -> do
    -- (⋃_i A[i]) ∩ X = ⋃_i (A[i] ∩ X)
    -- Collect only the nonempty A[i] ∩ X, unless there are none, in which case the result is empty.
    -- If any schema is empty, we remove it from the list which constitutes a change.
    [Maybe (Referenced Schema)]
mSchemas <- [Traced (Referenced Schema)]
-> (Traced (Referenced Schema)
    -> ReaderT
         (Traced (Definitions Schema))
         (WriterT Any Maybe)
         (Maybe (Referenced Schema)))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     [Maybe (Referenced Schema)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Traced (Referenced Schema)]
rss ((Traced (Referenced Schema)
  -> ReaderT
       (Traced (Definitions Schema))
       (WriterT Any Maybe)
       (Maybe (Referenced Schema)))
 -> ReaderT
      (Traced (Definitions Schema))
      (WriterT Any Maybe)
      [Maybe (Referenced Schema)])
-> (Traced (Referenced Schema)
    -> ReaderT
         (Traced (Definitions Schema))
         (WriterT Any Maybe)
         (Maybe (Referenced Schema)))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     [Maybe (Referenced Schema)]
forall a b. (a -> b) -> a -> b
$ \Traced (Referenced Schema)
rs -> ReaderT
  (Traced (Definitions Schema))
  (WriterT Any Maybe)
  (Maybe (Referenced Schema))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe (Referenced Schema))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe (Referenced Schema))
forall a. IntersectionM a -> IntersectionM a -> IntersectionM a
catchBottom (Referenced Schema -> Maybe (Referenced Schema)
forall a. a -> Maybe a
Just (Referenced Schema -> Maybe (Referenced Schema))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Referenced Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe (Referenced Schema))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PartitionLocation
-> PartitionChoice
-> Traced (Referenced Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Referenced Schema)
intersectRefSchema PartitionLocation
loc PartitionChoice
part Traced (Referenced Schema)
rs) (IntersectionM ()
mChange IntersectionM ()
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe (Referenced Schema))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe (Referenced Schema))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Referenced Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe (Referenced Schema))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Referenced Schema)
forall a. Maybe a
Nothing)
    case [Maybe (Referenced Schema)] -> [Referenced Schema]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Referenced Schema)]
mSchemas of
      [] -> ReaderT
  (Traced (Definitions Schema))
  (WriterT Any Maybe)
  [Referenced Schema]
forall a. IntersectionM a
mBottom
      [Referenced Schema]
schs -> [Referenced Schema]
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     [Referenced Schema]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Referenced Schema]
schs
  Maybe [Referenced Schema]
oneOf' <- Maybe [Traced (Referenced Schema)]
-> ([Traced (Referenced Schema)]
    -> ReaderT
         (Traced (Definitions Schema))
         (WriterT Any Maybe)
         [Referenced Schema])
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe [Referenced Schema])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Traced Schema -> Maybe [Traced (Referenced Schema)]
tracedOneOf Traced Schema
sch) (([Traced (Referenced Schema)]
  -> ReaderT
       (Traced (Definitions Schema))
       (WriterT Any Maybe)
       [Referenced Schema])
 -> ReaderT
      (Traced (Definitions Schema))
      (WriterT Any Maybe)
      (Maybe [Referenced Schema]))
-> ([Traced (Referenced Schema)]
    -> ReaderT
         (Traced (Definitions Schema))
         (WriterT Any Maybe)
         [Referenced Schema])
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe [Referenced Schema])
forall a b. (a -> b) -> a -> b
$ \[Traced (Referenced Schema)]
rss -> do
    -- Same as anyOf'. By intersecting we're only making them more disjoint if anything.
    [Maybe (Referenced Schema)]
mSchemas <- [Traced (Referenced Schema)]
-> (Traced (Referenced Schema)
    -> ReaderT
         (Traced (Definitions Schema))
         (WriterT Any Maybe)
         (Maybe (Referenced Schema)))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     [Maybe (Referenced Schema)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Traced (Referenced Schema)]
rss ((Traced (Referenced Schema)
  -> ReaderT
       (Traced (Definitions Schema))
       (WriterT Any Maybe)
       (Maybe (Referenced Schema)))
 -> ReaderT
      (Traced (Definitions Schema))
      (WriterT Any Maybe)
      [Maybe (Referenced Schema)])
-> (Traced (Referenced Schema)
    -> ReaderT
         (Traced (Definitions Schema))
         (WriterT Any Maybe)
         (Maybe (Referenced Schema)))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     [Maybe (Referenced Schema)]
forall a b. (a -> b) -> a -> b
$ \Traced (Referenced Schema)
rs -> ReaderT
  (Traced (Definitions Schema))
  (WriterT Any Maybe)
  (Maybe (Referenced Schema))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe (Referenced Schema))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe (Referenced Schema))
forall a. IntersectionM a -> IntersectionM a -> IntersectionM a
catchBottom (Referenced Schema -> Maybe (Referenced Schema)
forall a. a -> Maybe a
Just (Referenced Schema -> Maybe (Referenced Schema))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Referenced Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe (Referenced Schema))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PartitionLocation
-> PartitionChoice
-> Traced (Referenced Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Referenced Schema)
intersectRefSchema PartitionLocation
loc PartitionChoice
part Traced (Referenced Schema)
rs) (IntersectionM ()
mChange IntersectionM ()
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe (Referenced Schema))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe (Referenced Schema))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Referenced Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Maybe (Referenced Schema))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Referenced Schema)
forall a. Maybe a
Nothing)
    case [Maybe (Referenced Schema)] -> [Referenced Schema]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Referenced Schema)]
mSchemas of
      [] -> ReaderT
  (Traced (Definitions Schema))
  (WriterT Any Maybe)
  [Referenced Schema]
forall a. IntersectionM a
mBottom
      [Referenced Schema]
schs -> [Referenced Schema]
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     [Referenced Schema]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Referenced Schema]
schs
  let sch' :: Schema
sch' = (Traced Schema -> Schema
forall (w :: * -> *) a. Comonad w => w a -> a
extract Traced Schema
sch) {_schemaAllOf :: Maybe [Referenced Schema]
_schemaAllOf = Maybe [Referenced Schema]
allOf', _schemaAnyOf :: Maybe [Referenced Schema]
_schemaAnyOf = Maybe [Referenced Schema]
anyOf', _schemaOneOf :: Maybe [Referenced Schema]
_schemaOneOf = Maybe [Referenced Schema]
oneOf'}
  -- Now the local changes:
  case PartitionLocation
loc of
    PInProperty Text
k PartitionLocation
loc' -> case Text
-> InsOrdHashMap Text (Traced (Referenced Schema))
-> Maybe (Traced (Referenced Schema))
forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
IOHM.lookup Text
k (InsOrdHashMap Text (Traced (Referenced Schema))
 -> Maybe (Traced (Referenced Schema)))
-> InsOrdHashMap Text (Traced (Referenced Schema))
-> Maybe (Traced (Referenced Schema))
forall a b. (a -> b) -> a -> b
$ Traced Schema -> InsOrdHashMap Text (Traced (Referenced Schema))
tracedProperties Traced Schema
sch of
      Maybe (Traced (Referenced Schema))
Nothing -> String -> IntersectionM Schema
forall a. HasCallStack => String -> a
error (String -> IntersectionM Schema) -> String -> IntersectionM Schema
forall a b. (a -> b) -> a -> b
$ String
"Partitioning via absent property: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
k
      Just Traced (Referenced Schema)
prop -> do
        Referenced Schema
prop' <- PartitionLocation
-> PartitionChoice
-> Traced (Referenced Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Referenced Schema)
intersectRefSchema PartitionLocation
loc' PartitionChoice
part Traced (Referenced Schema)
prop
        pure $ Schema
sch' {_schemaProperties :: InsOrdHashMap Text (Referenced Schema)
_schemaProperties = (Referenced Schema -> Referenced Schema)
-> Text
-> InsOrdHashMap Text (Referenced Schema)
-> InsOrdHashMap Text (Referenced Schema)
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> InsOrdHashMap k v -> InsOrdHashMap k v
IOHM.adjust (Referenced Schema -> Referenced Schema -> Referenced Schema
forall a b. a -> b -> a
const Referenced Schema
prop') Text
k (InsOrdHashMap Text (Referenced Schema)
 -> InsOrdHashMap Text (Referenced Schema))
-> InsOrdHashMap Text (Referenced Schema)
-> InsOrdHashMap Text (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema -> InsOrdHashMap Text (Referenced Schema)
_schemaProperties Schema
sch'}
    PartitionLocation
PHere -> case PartitionChoice
part of
      CByEnumValue Set Value
vals -> do
        [Value]
enum' <- case Schema -> Maybe [Value]
_schemaEnum Schema
sch' of
          Maybe [Value]
Nothing -> do
            IntersectionM ()
mChange
            pure $ Set Value -> [Value]
forall a. Set a -> [a]
S.toList Set Value
vals
          Just [Value]
xs -> do
            Bool -> IntersectionM () -> IntersectionM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Value -> Set Value -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Value
vals) [Value]
xs) IntersectionM ()
mChange
            case (Value -> Bool) -> [Value] -> [Value]
forall a. (a -> Bool) -> [a] -> [a]
filter (Value -> Set Value -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Value
vals) [Value]
xs of
              [] -> ReaderT (Traced (Definitions Schema)) (WriterT Any Maybe) [Value]
forall a. IntersectionM a
mBottom
              [Value]
xs' -> [Value]
-> ReaderT
     (Traced (Definitions Schema)) (WriterT Any Maybe) [Value]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
xs'
        pure $ Schema
sch' {_schemaEnum :: Maybe [Value]
_schemaEnum = [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
enum'}
      CByProperties {} -> String -> IntersectionM Schema
forall a. HasCallStack => String -> a
error String
"CByProperties not implemented"

intersectRefSchema ::
  PartitionLocation ->
  PartitionChoice ->
  Traced (Referenced Schema) ->
  IntersectionM (Referenced Schema)
intersectRefSchema :: PartitionLocation
-> PartitionChoice
-> Traced (Referenced Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Referenced Schema)
intersectRefSchema PartitionLocation
loc PartitionChoice
part Traced (Referenced Schema)
rs = do
  Traced (Definitions Schema)
defs <- ReaderT
  (Traced (Definitions Schema))
  (WriterT Any Maybe)
  (Traced (Definitions Schema))
forall r (m :: * -> *). MonadReader r m => m r
R.ask
  Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema)
-> IntersectionM Schema
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Referenced Schema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PartitionLocation
-> PartitionChoice -> Traced Schema -> IntersectionM Schema
intersectSchema PartitionLocation
loc PartitionChoice
part (Traced (Definitions Schema)
-> Traced (Referenced Schema) -> Traced Schema
forall a.
Typeable a =>
Traced (Definitions a) -> Traced (Referenced a) -> Traced a
dereference Traced (Definitions Schema)
defs Traced (Referenced Schema)
rs)

intersectCondition :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> Condition t -> DNF (Condition t)
intersectCondition :: Traced (Definitions Schema)
-> PartitionLocation
-> PartitionChoice
-> Condition t
-> DNF (Condition t)
intersectCondition Traced (Definitions Schema)
_defs PartitionLocation
PHere (CByEnumValue Set Value
values) cond :: Condition t
cond@(Exactly TypedValue t
x) =
  if TypedValue t -> Value
forall (t :: JsonType). TypedValue t -> Value
untypeValue TypedValue t
x Value -> Set Value -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Value
values then Condition t -> DNF (Condition t)
forall a. Ord a => a -> DNF a
LiteralDNF Condition t
cond else DNF (Condition t)
forall a. BoundedJoinSemiLattice a => a
bottom
intersectCondition Traced (Definitions Schema)
defs (PInProperty Text
k PartitionLocation
loc) PartitionChoice
part cond :: Condition t
cond@(Properties Map Text Property
props ForeachType JsonFormula
add Maybe (Traced (Referenced Schema))
madd) = case Text -> Map Text Property -> Maybe Property
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
k Map Text Property
props of
  Maybe Property
Nothing -> Condition t -> DNF (Condition t)
forall a. Ord a => a -> DNF a
LiteralDNF Condition t
cond -- shouldn't happen
  Just Property
prop -> case Traced (Definitions Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Referenced Schema)
-> IntersectionResult (Referenced Schema)
forall a.
Traced (Definitions Schema)
-> IntersectionM a -> IntersectionResult a
runIntersectionM Traced (Definitions Schema)
defs (ReaderT
   (Traced (Definitions Schema))
   (WriterT Any Maybe)
   (Referenced Schema)
 -> IntersectionResult (Referenced Schema))
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Referenced Schema)
-> IntersectionResult (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ PartitionLocation
-> PartitionChoice
-> Traced (Referenced Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Referenced Schema)
intersectRefSchema PartitionLocation
loc PartitionChoice
part (Traced (Referenced Schema)
 -> ReaderT
      (Traced (Definitions Schema))
      (WriterT Any Maybe)
      (Referenced Schema))
-> Traced (Referenced Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT Any Maybe)
     (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Property -> Traced (Referenced Schema)
propRefSchema Property
prop of
    New Referenced Schema
rs' ->
      let trs' :: Traced (Referenced Schema)
trs' = Paths Step TraceRoot (Referenced Schema)
-> Referenced Schema -> Traced (Referenced Schema)
forall a. Trace a -> a -> Traced a
traced (Traced (Referenced Schema)
-> Paths Step TraceRoot (Referenced Schema)
forall e (w :: * -> *) a. ComonadEnv e w => w a -> e
ask (Property -> Traced (Referenced Schema)
propRefSchema Property
prop) Paths Step TraceRoot (Referenced Schema)
-> Paths Step (Referenced Schema) (Referenced Schema)
-> Paths Step TraceRoot (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 (Referenced Schema) (Referenced Schema)
-> Paths Step (Referenced Schema) (Referenced Schema)
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step (Partition -> Step (Referenced Schema) (Referenced Schema)
Partitioned (PartitionLocation
loc, PartitionChoice
part))) Referenced Schema
rs'
       in Condition 'Object -> DNF (Condition 'Object)
forall a. Ord a => a -> DNF a
LiteralDNF (Condition 'Object -> DNF (Condition 'Object))
-> Condition 'Object -> DNF (Condition 'Object)
forall a b. (a -> b) -> a -> b
$ Map Text Property
-> ForeachType JsonFormula
-> Maybe (Traced (Referenced Schema))
-> Condition 'Object
Properties (Text -> Property -> Map Text Property -> Map Text Property
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
k Property
prop {$sel:propRefSchema:Property :: Traced (Referenced Schema)
propRefSchema = Traced (Referenced Schema)
trs'} Map Text Property
props) ForeachType JsonFormula
add Maybe (Traced (Referenced Schema))
madd
    Same Referenced Schema
_ -> Condition t -> DNF (Condition t)
forall a. Ord a => a -> DNF a
LiteralDNF Condition t
cond
    IntersectionResult (Referenced Schema)
Disjoint -> DNF (Condition t)
forall a. BoundedJoinSemiLattice a => a
bottom
intersectCondition Traced (Definitions Schema)
_defs PartitionLocation
_loc PartitionChoice
_part Condition t
cond = Condition t -> DNF (Condition t)
forall a. Ord a => a -> DNF a
LiteralDNF Condition t
cond

intersectFormula :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> JsonFormula t -> JsonFormula t
intersectFormula :: Traced (Definitions Schema)
-> PartitionLocation
-> PartitionChoice
-> JsonFormula t
-> JsonFormula t
intersectFormula Traced (Definitions Schema)
defs PartitionLocation
loc PartitionChoice
part = DNF (Condition t) -> JsonFormula t
forall (t :: JsonType). DNF (Condition t) -> JsonFormula t
JsonFormula (DNF (Condition t) -> JsonFormula t)
-> (JsonFormula t -> DNF (Condition t))
-> JsonFormula t
-> JsonFormula t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Condition t -> DNF (Condition t))
-> DNF (Condition t) -> DNF (Condition t)
forall l a. BoundedLattice l => (a -> l) -> DNF a -> l
foldDNF (Traced (Definitions Schema)
-> PartitionLocation
-> PartitionChoice
-> Condition t
-> DNF (Condition t)
forall (t :: JsonType).
Traced (Definitions Schema)
-> PartitionLocation
-> PartitionChoice
-> Condition t
-> DNF (Condition t)
intersectCondition Traced (Definitions Schema)
defs PartitionLocation
loc PartitionChoice
part) (DNF (Condition t) -> DNF (Condition t))
-> (JsonFormula t -> DNF (Condition t))
-> JsonFormula t
-> DNF (Condition t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonFormula t -> DNF (Condition t)
forall (t :: JsonType). JsonFormula t -> DNF (Condition t)
getJsonFormula

tryPartition :: ProdCons (Traced (Definitions Schema)) -> ProdCons (JsonFormula t) -> [(Maybe Partition, ProdCons (JsonFormula t))]
tryPartition :: ProdCons (Traced (Definitions Schema))
-> ProdCons (JsonFormula t)
-> [(Maybe Partition, ProdCons (JsonFormula t))]
tryPartition ProdCons (Traced (Definitions Schema))
defs ProdCons (JsonFormula t)
pc = case Lifted Partitions -> Maybe (PartitionLocation, Set PartitionChoice)
selectPartition (Lifted Partitions
 -> Maybe (PartitionLocation, Set PartitionChoice))
-> Lifted Partitions
-> Maybe (PartitionLocation, Set PartitionChoice)
forall a b. (a -> b) -> a -> b
$ ProdCons (Traced (Definitions Schema))
-> ProdCons (JsonFormula t) -> Lifted Partitions
forall (t :: JsonType).
ProdCons (Traced (Definitions Schema))
-> ProdCons (JsonFormula t) -> Lifted Partitions
partitionJsonFormulas ProdCons (Traced (Definitions Schema))
defs ProdCons (JsonFormula t)
pc of
  Maybe (PartitionLocation, Set PartitionChoice)
Nothing -> [(Maybe Partition
forall a. Maybe a
Nothing, ProdCons (JsonFormula t)
pc)]
  Just (PartitionLocation
loc, Set PartitionChoice
parts) -> [(Partition -> Maybe Partition
forall a. a -> Maybe a
Just (PartitionLocation
loc, PartitionChoice
part), Traced (Definitions Schema)
-> PartitionLocation
-> PartitionChoice
-> JsonFormula t
-> JsonFormula t
forall (t :: JsonType).
Traced (Definitions Schema)
-> PartitionLocation
-> PartitionChoice
-> JsonFormula t
-> JsonFormula t
intersectFormula (Traced (Definitions Schema)
 -> PartitionLocation
 -> PartitionChoice
 -> JsonFormula t
 -> JsonFormula t)
-> ProdCons (Traced (Definitions Schema))
-> ProdCons
     (PartitionLocation
      -> PartitionChoice -> JsonFormula t -> JsonFormula t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced (Definitions Schema))
defs ProdCons
  (PartitionLocation
   -> PartitionChoice -> JsonFormula t -> JsonFormula t)
-> ProdCons PartitionLocation
-> ProdCons (PartitionChoice -> JsonFormula t -> JsonFormula t)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PartitionLocation -> ProdCons PartitionLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure PartitionLocation
loc ProdCons (PartitionChoice -> JsonFormula t -> JsonFormula t)
-> ProdCons PartitionChoice
-> ProdCons (JsonFormula t -> JsonFormula t)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PartitionChoice -> ProdCons PartitionChoice
forall (f :: * -> *) a. Applicative f => a -> f a
pure PartitionChoice
part ProdCons (JsonFormula t -> JsonFormula t)
-> ProdCons (JsonFormula t) -> ProdCons (JsonFormula t)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProdCons (JsonFormula t)
pc) | PartitionChoice
part <- Set PartitionChoice -> [PartitionChoice]
forall a. Set a -> [a]
S.toList Set PartitionChoice
parts]

showPartition :: Partition -> Inlines
showPartition :: Partition -> Inlines
showPartition = \case
  (PartitionLocation
partition, CByEnumValue (Set Value -> [Value]
forall a. Set a -> [a]
S.toList -> [Value
v])) ->
    PartitionLocation -> Inlines
renderPartitionLocation PartitionLocation
partition Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
" is " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Value -> Inlines
showJSONValueInline Value
v
  (PartitionLocation
partition, CByEnumValue (Set Value -> [Value]
forall a. Set a -> [a]
S.toList -> [Value]
vs)) ->
    PartitionLocation -> Inlines
renderPartitionLocation PartitionLocation
partition Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
" has values: "
      Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> ([Inlines] -> Inlines
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Inlines] -> Inlines)
-> ([Value] -> [Inlines]) -> [Value] -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> [Inlines] -> [Inlines]
forall a. a -> [a] -> [a]
L.intersperse Inlines
", " ([Inlines] -> [Inlines])
-> ([Value] -> [Inlines]) -> [Value] -> [Inlines]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Inlines) -> [Value] -> [Inlines]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Inlines
showJSONValueInline ([Value] -> Inlines) -> [Value] -> Inlines
forall a b. (a -> b) -> a -> b
$ [Value]
vs)
  (PartitionLocation
partition, CByProperties (Set Text -> [Text]
forall a. Set a -> [a]
S.toList -> [Text]
incl) (Set Text -> [Text]
forall a. Set a -> [a]
S.toList -> [])) ->
    PartitionLocation -> Inlines
renderPartitionLocation PartitionLocation
partition Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
" contains the properties: " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> [Text] -> Inlines
listCodes [Text]
incl
  (PartitionLocation
partition, CByProperties (Set Text -> [Text]
forall a. Set a -> [a]
S.toList -> []) (Set Text -> [Text]
forall a. Set a -> [a]
S.toList -> [Text]
excl)) ->
    PartitionLocation -> Inlines
renderPartitionLocation PartitionLocation
partition Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
" does not contain the properties: " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> [Text] -> Inlines
listCodes [Text]
excl
  (PartitionLocation
partition, CByProperties (Set Text -> [Text]
forall a. Set a -> [a]
S.toList -> [Text]
incl) (Set Text -> [Text]
forall a. Set a -> [a]
S.toList -> [Text]
excl)) ->
    PartitionLocation -> Inlines
renderPartitionLocation PartitionLocation
partition
      Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
" contains the properties "
      Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> [Text] -> Inlines
listCodes [Text]
incl
      Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
" and does not contain the properties "
      Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> [Text] -> Inlines
listCodes [Text]
excl
  where
    listCodes :: [Text] -> Inlines
    listCodes :: [Text] -> Inlines
listCodes = [Inlines] -> Inlines
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Inlines] -> Inlines)
-> ([Text] -> [Inlines]) -> [Text] -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> [Inlines] -> [Inlines]
forall a. a -> [a] -> [a]
L.intersperse Inlines
", " ([Inlines] -> [Inlines])
-> ([Text] -> [Inlines]) -> [Text] -> [Inlines]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Inlines) -> [Text] -> [Inlines]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Inlines
code
    renderPartitionLocation :: PartitionLocation -> Inlines
    renderPartitionLocation :: PartitionLocation -> Inlines
renderPartitionLocation PartitionLocation
p = Text -> Inlines
code (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PartitionLocation -> Text
renderPartitionLocation' PartitionLocation
p
      where
        renderPartitionLocation' :: PartitionLocation -> Text
        renderPartitionLocation' :: PartitionLocation -> Text
renderPartitionLocation' PartitionLocation
PHere = Text
forall a. Monoid a => a
mempty
        renderPartitionLocation' (PInProperty Text
prop PartitionLocation
rest) = Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PartitionLocation -> Text
renderPartitionLocation' PartitionLocation
rest