module Data.OpenApi.Compare.Validate.Schema.Process
  ( schemaToFormula,
  )
where

import Algebra.Lattice
import Control.Monad.Reader hiding (ask)
import qualified Control.Monad.Reader as R
import Control.Monad.State
import Control.Monad.Writer
import qualified Data.Aeson as A
import Data.Functor.Identity
import qualified Data.HashMap.Strict.InsOrd as IOHM
import qualified Data.Map as M
import Data.Maybe
import Data.OpenApi hiding (get)
import Data.OpenApi.Compare.Behavior
import Data.OpenApi.Compare.Memo
import Data.OpenApi.Compare.Paths
import qualified Data.OpenApi.Compare.PathsPrefixTree as P
import Data.OpenApi.Compare.References
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.Traced
import Data.OpenApi.Compare.Validate.Schema.TypedJson
import Data.Ord
import qualified Data.Set as S

-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.
newtype Silent w a = Silent {Silent w a -> a
runSilent :: a}
  deriving stock (a -> Silent w b -> Silent w a
(a -> b) -> Silent w a -> Silent w b
(forall a b. (a -> b) -> Silent w a -> Silent w b)
-> (forall a b. a -> Silent w b -> Silent w a)
-> Functor (Silent w)
forall k (w :: k) a b. a -> Silent w b -> Silent w a
forall k (w :: k) a b. (a -> b) -> Silent w a -> Silent w b
forall a b. a -> Silent w b -> Silent w a
forall a b. (a -> b) -> Silent w a -> Silent w b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Silent w b -> Silent w a
$c<$ :: forall k (w :: k) a b. a -> Silent w b -> Silent w a
fmap :: (a -> b) -> Silent w a -> Silent w b
$cfmap :: forall k (w :: k) a b. (a -> b) -> Silent w a -> Silent w b
Functor)
  deriving (Functor (Silent w)
a -> Silent w a
Functor (Silent w)
-> (forall a. a -> Silent w a)
-> (forall a b. Silent w (a -> b) -> Silent w a -> Silent w b)
-> (forall a b c.
    (a -> b -> c) -> Silent w a -> Silent w b -> Silent w c)
-> (forall a b. Silent w a -> Silent w b -> Silent w b)
-> (forall a b. Silent w a -> Silent w b -> Silent w a)
-> Applicative (Silent w)
Silent w a -> Silent w b -> Silent w b
Silent w a -> Silent w b -> Silent w a
Silent w (a -> b) -> Silent w a -> Silent w b
(a -> b -> c) -> Silent w a -> Silent w b -> Silent w c
forall a. a -> Silent w a
forall k (w :: k). Functor (Silent w)
forall k (w :: k) a. a -> Silent w a
forall k (w :: k) a b. Silent w a -> Silent w b -> Silent w a
forall k (w :: k) a b. Silent w a -> Silent w b -> Silent w b
forall k (w :: k) a b.
Silent w (a -> b) -> Silent w a -> Silent w b
forall k (w :: k) a b c.
(a -> b -> c) -> Silent w a -> Silent w b -> Silent w c
forall a b. Silent w a -> Silent w b -> Silent w a
forall a b. Silent w a -> Silent w b -> Silent w b
forall a b. Silent w (a -> b) -> Silent w a -> Silent w b
forall a b c.
(a -> b -> c) -> Silent w a -> Silent w b -> Silent w c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Silent w a -> Silent w b -> Silent w a
$c<* :: forall k (w :: k) a b. Silent w a -> Silent w b -> Silent w a
*> :: Silent w a -> Silent w b -> Silent w b
$c*> :: forall k (w :: k) a b. Silent w a -> Silent w b -> Silent w b
liftA2 :: (a -> b -> c) -> Silent w a -> Silent w b -> Silent w c
$cliftA2 :: forall k (w :: k) a b c.
(a -> b -> c) -> Silent w a -> Silent w b -> Silent w c
<*> :: Silent w (a -> b) -> Silent w a -> Silent w b
$c<*> :: forall k (w :: k) a b.
Silent w (a -> b) -> Silent w a -> Silent w b
pure :: a -> Silent w a
$cpure :: forall k (w :: k) a. a -> Silent w a
$cp1Applicative :: forall k (w :: k). Functor (Silent w)
Applicative, Applicative (Silent w)
a -> Silent w a
Applicative (Silent w)
-> (forall a b. Silent w a -> (a -> Silent w b) -> Silent w b)
-> (forall a b. Silent w a -> Silent w b -> Silent w b)
-> (forall a. a -> Silent w a)
-> Monad (Silent w)
Silent w a -> (a -> Silent w b) -> Silent w b
Silent w a -> Silent w b -> Silent w b
forall a. a -> Silent w a
forall k (w :: k). Applicative (Silent w)
forall k (w :: k) a. a -> Silent w a
forall k (w :: k) a b. Silent w a -> Silent w b -> Silent w b
forall k (w :: k) a b.
Silent w a -> (a -> Silent w b) -> Silent w b
forall a b. Silent w a -> Silent w b -> Silent w b
forall a b. Silent w a -> (a -> Silent w b) -> Silent w b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Silent w a
$creturn :: forall k (w :: k) a. a -> Silent w a
>> :: Silent w a -> Silent w b -> Silent w b
$c>> :: forall k (w :: k) a b. Silent w a -> Silent w b -> Silent w b
>>= :: Silent w a -> (a -> Silent w b) -> Silent w b
$c>>= :: forall k (w :: k) a b.
Silent w a -> (a -> Silent w b) -> Silent w b
$cp1Monad :: forall k (w :: k). Applicative (Silent w)
Monad) via Identity

instance Monoid w => MonadWriter w (Silent w) where
  tell :: w -> Silent w ()
tell w
_ = () -> Silent w ()
forall k (w :: k) a. a -> Silent w a
Silent ()
  listen :: Silent w a -> Silent w (a, w)
listen (Silent a
x) = (a, w) -> Silent w (a, w)
forall k (w :: k) a. a -> Silent w a
Silent (a
x, w
forall a. Monoid a => a
mempty)
  pass :: Silent w (a, w -> w) -> Silent w a
pass (Silent (a
x, w -> w
_)) = a -> Silent w a
forall k (w :: k) a. a -> Silent w a
Silent a
x

type ProcessM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))

type SilentM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Silent (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))

-- Either ProcessM or SilentM
type MonadProcess m =
  ( MonadReader (Traced (Definitions Schema)) m
  , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m
  , MonadState (MemoState ()) m
  )

warn :: MonadProcess m => Issue 'SchemaLevel -> m ()
warn :: Issue 'SchemaLevel -> m ()
warn Issue 'SchemaLevel
issue = PathsPrefixTree Behave AnIssue 'SchemaLevel -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (PathsPrefixTree Behave AnIssue 'SchemaLevel -> m ())
-> PathsPrefixTree Behave AnIssue 'SchemaLevel -> m ()
forall a b. (a -> b) -> a -> b
$ AnItem Behave AnIssue 'SchemaLevel
-> PathsPrefixTree Behave AnIssue 'SchemaLevel
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
AnItem q f r -> PathsPrefixTree q f r
P.singleton (AnItem Behave AnIssue 'SchemaLevel
 -> PathsPrefixTree Behave AnIssue 'SchemaLevel)
-> AnItem Behave AnIssue 'SchemaLevel
-> PathsPrefixTree Behave AnIssue 'SchemaLevel
forall a b. (a -> b) -> a -> b
$ Paths Behave 'SchemaLevel 'SchemaLevel
-> AnIssue 'SchemaLevel -> AnItem Behave AnIssue 'SchemaLevel
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 'SchemaLevel 'SchemaLevel
forall k (q :: k -> k -> *) (a :: k). Paths q a a
Root (AnIssue 'SchemaLevel -> AnItem Behave AnIssue 'SchemaLevel)
-> AnIssue 'SchemaLevel -> AnItem Behave AnIssue 'SchemaLevel
forall a b. (a -> b) -> a -> b
$ Issue 'SchemaLevel -> AnIssue 'SchemaLevel
forall (l :: BehaviorLevel). Issuable l => Issue l -> AnIssue l
anIssue Issue 'SchemaLevel
issue

-- Perform a computation lazily, ignoring the warnings and discarding memoization/loop detection information.
lazily :: MonadProcess m => SilentM a -> m a
lazily :: SilentM a -> m a
lazily SilentM a
m = do
  Traced (Definitions Schema)
defs <- m (Traced (Definitions Schema))
forall r (m :: * -> *). MonadReader r m => m r
R.ask
  pure $ Silent (PathsPrefixTree Behave AnIssue 'SchemaLevel) a -> a
forall k (w :: k) a. Silent w a -> a
runSilent (Silent (PathsPrefixTree Behave AnIssue 'SchemaLevel) a -> a)
-> Silent (PathsPrefixTree Behave AnIssue 'SchemaLevel) a -> a
forall a b. (a -> b) -> a -> b
$ ReaderT
  (Traced (Definitions Schema))
  (Silent (PathsPrefixTree Behave AnIssue 'SchemaLevel))
  a
-> Traced (Definitions Schema)
-> Silent (PathsPrefixTree Behave AnIssue 'SchemaLevel) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (()
-> SilentM a
-> ReaderT
     (Traced (Definitions Schema))
     (Silent (PathsPrefixTree Behave AnIssue 'SchemaLevel))
     a
forall (m :: * -> *) s a.
Monad m =>
s -> StateT (MemoState s) m a -> m a
runMemo () SilentM a
m) Traced (Definitions Schema)
defs

warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m
warnKnot :: KnotTier (ForeachType JsonFormula) () m
warnKnot =
  KnotTier :: forall v d (m :: * -> *).
m d -> (d -> m v) -> (d -> v -> m v) -> KnotTier v d m
KnotTier
    { $sel:onKnotFound:KnotTier :: m ()
onKnotFound = Issue 'SchemaLevel -> m ()
forall (m :: * -> *). MonadProcess m => Issue 'SchemaLevel -> m ()
warn Issue 'SchemaLevel
UnguardedRecursion
    , $sel:onKnotUsed:KnotTier :: () -> m (ForeachType JsonFormula)
onKnotUsed = \()
_ -> ForeachType JsonFormula -> m (ForeachType JsonFormula)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
    , $sel:tieKnot:KnotTier :: () -> ForeachType JsonFormula -> m (ForeachType JsonFormula)
tieKnot = \()
_ -> ForeachType JsonFormula -> m (ForeachType JsonFormula)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    }

processRefSchema ::
  MonadProcess m =>
  Traced (Referenced Schema) ->
  m (ForeachType JsonFormula)
processRefSchema :: Traced (Referenced Schema) -> m (ForeachType JsonFormula)
processRefSchema Traced (Referenced Schema)
x = do
  Traced (Definitions Schema)
defs <- m (Traced (Definitions Schema))
forall r (m :: * -> *). MonadReader r m => m r
R.ask
  KnotTier (ForeachType JsonFormula) () m
-> m (ForeachType JsonFormula)
-> Paths Step TraceRoot (Referenced Schema)
-> m (ForeachType JsonFormula)
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 (ForeachType JsonFormula) () m
forall (m :: * -> *).
MonadProcess m =>
KnotTier (ForeachType JsonFormula) () m
warnKnot (Traced Schema -> m (ForeachType JsonFormula)
forall (m :: * -> *).
MonadProcess m =>
Traced Schema -> m (ForeachType JsonFormula)
processSchema (Traced Schema -> m (ForeachType JsonFormula))
-> Traced Schema -> m (ForeachType JsonFormula)
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)

-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition
-- for every possible type of a JSON value. The conditions are independent, and
-- are thus checked independently.
processSchema ::
  MonadProcess m =>
  Traced Schema ->
  m (ForeachType JsonFormula)
processSchema :: Traced Schema -> m (ForeachType JsonFormula)
processSchema sch :: Traced Schema
sch@(Traced Schema -> Schema
forall (w :: * -> *) a. Comonad w => w a -> a
extract -> Schema {[ParamName]
Maybe Bool
Maybe Integer
Maybe [Value]
Maybe [Referenced Schema]
Maybe ParamName
Maybe Scientific
Maybe Value
Maybe OpenApiItems
Maybe OpenApiType
Maybe Discriminator
Maybe Xml
Maybe ExternalDocs
Maybe (Referenced Schema)
Maybe AdditionalProperties
InsOrdHashMap ParamName (Referenced Schema)
_schemaTitle :: Schema -> Maybe ParamName
_schemaDescription :: Schema -> Maybe ParamName
_schemaRequired :: Schema -> [ParamName]
_schemaNullable :: Schema -> Maybe Bool
_schemaAllOf :: Schema -> Maybe [Referenced Schema]
_schemaOneOf :: Schema -> Maybe [Referenced Schema]
_schemaNot :: Schema -> Maybe (Referenced Schema)
_schemaAnyOf :: Schema -> Maybe [Referenced Schema]
_schemaProperties :: Schema -> InsOrdHashMap ParamName (Referenced Schema)
_schemaAdditionalProperties :: Schema -> Maybe AdditionalProperties
_schemaDiscriminator :: Schema -> Maybe Discriminator
_schemaReadOnly :: Schema -> Maybe Bool
_schemaWriteOnly :: Schema -> Maybe Bool
_schemaXml :: Schema -> Maybe Xml
_schemaExternalDocs :: Schema -> Maybe ExternalDocs
_schemaExample :: Schema -> Maybe Value
_schemaDeprecated :: Schema -> Maybe Bool
_schemaMaxProperties :: Schema -> Maybe Integer
_schemaMinProperties :: Schema -> Maybe Integer
_schemaDefault :: Schema -> Maybe Value
_schemaType :: Schema -> Maybe OpenApiType
_schemaFormat :: Schema -> Maybe ParamName
_schemaItems :: Schema -> Maybe OpenApiItems
_schemaMaximum :: Schema -> Maybe Scientific
_schemaExclusiveMaximum :: Schema -> Maybe Bool
_schemaMinimum :: Schema -> Maybe Scientific
_schemaExclusiveMinimum :: Schema -> Maybe Bool
_schemaMaxLength :: Schema -> Maybe Integer
_schemaMinLength :: Schema -> Maybe Integer
_schemaPattern :: Schema -> Maybe ParamName
_schemaMaxItems :: Schema -> Maybe Integer
_schemaMinItems :: Schema -> Maybe Integer
_schemaUniqueItems :: Schema -> Maybe Bool
_schemaEnum :: Schema -> Maybe [Value]
_schemaMultipleOf :: Schema -> Maybe Scientific
_schemaMultipleOf :: Maybe Scientific
_schemaEnum :: Maybe [Value]
_schemaUniqueItems :: Maybe Bool
_schemaMinItems :: Maybe Integer
_schemaMaxItems :: Maybe Integer
_schemaPattern :: Maybe ParamName
_schemaMinLength :: Maybe Integer
_schemaMaxLength :: Maybe Integer
_schemaExclusiveMinimum :: Maybe Bool
_schemaMinimum :: Maybe Scientific
_schemaExclusiveMaximum :: Maybe Bool
_schemaMaximum :: Maybe Scientific
_schemaItems :: Maybe OpenApiItems
_schemaFormat :: Maybe ParamName
_schemaType :: Maybe OpenApiType
_schemaDefault :: Maybe Value
_schemaMinProperties :: Maybe Integer
_schemaMaxProperties :: Maybe Integer
_schemaDeprecated :: Maybe Bool
_schemaExample :: Maybe Value
_schemaExternalDocs :: Maybe ExternalDocs
_schemaXml :: Maybe Xml
_schemaWriteOnly :: Maybe Bool
_schemaReadOnly :: Maybe Bool
_schemaDiscriminator :: Maybe Discriminator
_schemaAdditionalProperties :: Maybe AdditionalProperties
_schemaProperties :: InsOrdHashMap ParamName (Referenced Schema)
_schemaAnyOf :: Maybe [Referenced Schema]
_schemaNot :: Maybe (Referenced Schema)
_schemaOneOf :: Maybe [Referenced Schema]
_schemaAllOf :: Maybe [Referenced Schema]
_schemaNullable :: Maybe Bool
_schemaRequired :: [ParamName]
_schemaDescription :: Maybe ParamName
_schemaTitle :: Maybe ParamName
..}) = do
  let singletonFormula :: Condition t -> JsonFormula t
      singletonFormula :: Condition t -> JsonFormula t
singletonFormula = DNF (Condition t) -> JsonFormula t
forall (t :: JsonType). DNF (Condition t) -> JsonFormula t
JsonFormula (DNF (Condition t) -> JsonFormula t)
-> (Condition t -> DNF (Condition t))
-> Condition t
-> JsonFormula t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Condition t -> DNF (Condition t)
forall a. Ord a => a -> DNF a
LiteralDNF

  [ForeachType JsonFormula]
allClauses <- case Traced Schema -> Maybe [Traced (Referenced Schema)]
tracedAllOf Traced Schema
sch of
    Maybe [Traced (Referenced Schema)]
Nothing -> [ForeachType JsonFormula] -> m [ForeachType JsonFormula]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just [] -> [] [ForeachType JsonFormula] -> m () -> m [ForeachType JsonFormula]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Issue 'SchemaLevel -> m ()
forall (m :: * -> *). MonadProcess m => Issue 'SchemaLevel -> m ()
warn (ParamName -> Issue 'SchemaLevel
InvalidSchema ParamName
"no items in allOf")
    Just [Traced (Referenced Schema)]
xs -> (Traced (Referenced Schema) -> m (ForeachType JsonFormula))
-> [Traced (Referenced Schema)] -> m [ForeachType JsonFormula]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Traced (Referenced Schema) -> m (ForeachType JsonFormula)
forall (m :: * -> *).
MonadProcess m =>
Traced (Referenced Schema) -> m (ForeachType JsonFormula)
processRefSchema [Traced (Referenced Schema)]
xs

  ForeachType JsonFormula
anyClause <- case Traced Schema -> Maybe [Traced (Referenced Schema)]
tracedAnyOf Traced Schema
sch of
    Maybe [Traced (Referenced Schema)]
Nothing -> ForeachType JsonFormula -> m (ForeachType JsonFormula)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
    Just [] -> ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom ForeachType JsonFormula -> m () -> m (ForeachType JsonFormula)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Issue 'SchemaLevel -> m ()
forall (m :: * -> *). MonadProcess m => Issue 'SchemaLevel -> m ()
warn (ParamName -> Issue 'SchemaLevel
InvalidSchema ParamName
"no items in anyOf")
    Just [Traced (Referenced Schema)]
xs -> [ForeachType JsonFormula] -> ForeachType JsonFormula
forall a (f :: * -> *).
(BoundedJoinSemiLattice a, Foldable f) =>
f a -> a
joins ([ForeachType JsonFormula] -> ForeachType JsonFormula)
-> m [ForeachType JsonFormula] -> m (ForeachType JsonFormula)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Traced (Referenced Schema) -> m (ForeachType JsonFormula))
-> [Traced (Referenced Schema)] -> m [ForeachType JsonFormula]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Traced (Referenced Schema) -> m (ForeachType JsonFormula)
forall (m :: * -> *).
MonadProcess m =>
Traced (Referenced Schema) -> m (ForeachType JsonFormula)
processRefSchema [Traced (Referenced Schema)]
xs

  ForeachType JsonFormula
oneClause <- case Traced Schema -> Maybe [Traced (Referenced Schema)]
tracedOneOf Traced Schema
sch of
    Maybe [Traced (Referenced Schema)]
Nothing -> ForeachType JsonFormula -> m (ForeachType JsonFormula)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
    Just [] -> ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom ForeachType JsonFormula -> m () -> m (ForeachType JsonFormula)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Issue 'SchemaLevel -> m ()
forall (m :: * -> *). MonadProcess m => Issue 'SchemaLevel -> m ()
warn (ParamName -> Issue 'SchemaLevel
InvalidSchema ParamName
"no items in oneOf")
    Just [Traced (Referenced Schema)]
xs -> do
      [Traced (Referenced Schema)] -> m Bool
forall (m :: * -> *).
MonadProcess m =>
[Traced (Referenced Schema)] -> m Bool
checkOneOfDisjoint [Traced (Referenced Schema)]
xs m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Bool
False -> Issue 'SchemaLevel -> m ()
forall (m :: * -> *). MonadProcess m => Issue 'SchemaLevel -> m ()
warn Issue 'SchemaLevel
OneOfNotDisjoint
      [ForeachType JsonFormula] -> ForeachType JsonFormula
forall a (f :: * -> *).
(BoundedJoinSemiLattice a, Foldable f) =>
f a -> a
joins ([ForeachType JsonFormula] -> ForeachType JsonFormula)
-> m [ForeachType JsonFormula] -> m (ForeachType JsonFormula)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Traced (Referenced Schema) -> m (ForeachType JsonFormula))
-> [Traced (Referenced Schema)] -> m [ForeachType JsonFormula]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Traced (Referenced Schema) -> m (ForeachType JsonFormula)
forall (m :: * -> *).
MonadProcess m =>
Traced (Referenced Schema) -> m (ForeachType JsonFormula)
processRefSchema [Traced (Referenced Schema)]
xs

  case Maybe (Referenced Schema)
_schemaNot of
    Maybe (Referenced Schema)
Nothing -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Referenced Schema
_ -> Issue 'SchemaLevel -> m ()
forall (m :: * -> *). MonadProcess m => Issue 'SchemaLevel -> m ()
warn (ParamName -> Issue 'SchemaLevel
NotSupported ParamName
"not clause is unsupported")

  let typeClause :: ForeachType JsonFormula
typeClause = case Maybe OpenApiType
_schemaType of
        Maybe OpenApiType
Nothing -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
        Just OpenApiType
OpenApiNull ->
          ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
            { $sel:forNull:ForeachType :: JsonFormula 'Null
forNull = JsonFormula 'Null
forall a. BoundedMeetSemiLattice a => a
top
            }
        Just OpenApiType
OpenApiBoolean ->
          ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
            { $sel:forBoolean:ForeachType :: JsonFormula 'Boolean
forBoolean = JsonFormula 'Boolean
forall a. BoundedMeetSemiLattice a => a
top
            }
        Just OpenApiType
OpenApiNumber ->
          ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
            { $sel:forNumber:ForeachType :: JsonFormula 'Number
forNumber = JsonFormula 'Number
forall a. BoundedMeetSemiLattice a => a
top
            }
        Just OpenApiType
OpenApiInteger ->
          ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
            { $sel:forNumber:ForeachType :: JsonFormula 'Number
forNumber = Condition 'Number -> JsonFormula 'Number
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Number -> JsonFormula 'Number)
-> Condition 'Number -> JsonFormula 'Number
forall a b. (a -> b) -> a -> b
$ Scientific -> Condition 'Number
MultipleOf Scientific
1
            }
        Just OpenApiType
OpenApiString ->
          ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
            { $sel:forString:ForeachType :: JsonFormula 'String
forString = JsonFormula 'String
forall a. BoundedMeetSemiLattice a => a
top
            }
        Just OpenApiType
OpenApiArray ->
          ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
            { $sel:forArray:ForeachType :: JsonFormula 'Array
forArray = JsonFormula 'Array
forall a. BoundedMeetSemiLattice a => a
top
            }
        Just OpenApiType
OpenApiObject ->
          ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
            { $sel:forObject:ForeachType :: JsonFormula 'Object
forObject = JsonFormula 'Object
forall a. BoundedMeetSemiLattice a => a
top
            }

  let valueEnum :: Value -> ForeachType JsonFormula
valueEnum Value
A.Null =
        ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
          { $sel:forNull:ForeachType :: JsonFormula 'Null
forNull = Condition 'Null -> JsonFormula 'Null
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Null -> JsonFormula 'Null)
-> Condition 'Null -> JsonFormula 'Null
forall a b. (a -> b) -> a -> b
$ TypedValue 'Null -> Condition 'Null
forall (t :: JsonType). TypedValue t -> Condition t
Exactly TypedValue 'Null
TNull
          }
      valueEnum (A.Bool Bool
b) =
        ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
          { $sel:forBoolean:ForeachType :: JsonFormula 'Boolean
forBoolean = Condition 'Boolean -> JsonFormula 'Boolean
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Boolean -> JsonFormula 'Boolean)
-> Condition 'Boolean -> JsonFormula 'Boolean
forall a b. (a -> b) -> a -> b
$ TypedValue 'Boolean -> Condition 'Boolean
forall (t :: JsonType). TypedValue t -> Condition t
Exactly (TypedValue 'Boolean -> Condition 'Boolean)
-> TypedValue 'Boolean -> Condition 'Boolean
forall a b. (a -> b) -> a -> b
$ Bool -> TypedValue 'Boolean
TBool Bool
b
          }
      valueEnum (A.Number Scientific
n) =
        ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
          { $sel:forNumber:ForeachType :: JsonFormula 'Number
forNumber = Condition 'Number -> JsonFormula 'Number
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Number -> JsonFormula 'Number)
-> Condition 'Number -> JsonFormula 'Number
forall a b. (a -> b) -> a -> b
$ TypedValue 'Number -> Condition 'Number
forall (t :: JsonType). TypedValue t -> Condition t
Exactly (TypedValue 'Number -> Condition 'Number)
-> TypedValue 'Number -> Condition 'Number
forall a b. (a -> b) -> a -> b
$ Scientific -> TypedValue 'Number
TNumber Scientific
n
          }
      valueEnum (A.String ParamName
s) =
        ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
          { $sel:forString:ForeachType :: JsonFormula 'String
forString = Condition 'String -> JsonFormula 'String
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'String -> JsonFormula 'String)
-> Condition 'String -> JsonFormula 'String
forall a b. (a -> b) -> a -> b
$ TypedValue 'String -> Condition 'String
forall (t :: JsonType). TypedValue t -> Condition t
Exactly (TypedValue 'String -> Condition 'String)
-> TypedValue 'String -> Condition 'String
forall a b. (a -> b) -> a -> b
$ ParamName -> TypedValue 'String
TString ParamName
s
          }
      valueEnum (A.Array Array
a) =
        ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
          { $sel:forArray:ForeachType :: JsonFormula 'Array
forArray = Condition 'Array -> JsonFormula 'Array
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Array -> JsonFormula 'Array)
-> Condition 'Array -> JsonFormula 'Array
forall a b. (a -> b) -> a -> b
$ TypedValue 'Array -> Condition 'Array
forall (t :: JsonType). TypedValue t -> Condition t
Exactly (TypedValue 'Array -> Condition 'Array)
-> TypedValue 'Array -> Condition 'Array
forall a b. (a -> b) -> a -> b
$ Array -> TypedValue 'Array
TArray Array
a
          }
      valueEnum (A.Object Object
o) =
        ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
          { $sel:forObject:ForeachType :: JsonFormula 'Object
forObject = Condition 'Object -> JsonFormula 'Object
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Object -> JsonFormula 'Object)
-> Condition 'Object -> JsonFormula 'Object
forall a b. (a -> b) -> a -> b
$ TypedValue 'Object -> Condition 'Object
forall (t :: JsonType). TypedValue t -> Condition t
Exactly (TypedValue 'Object -> Condition 'Object)
-> TypedValue 'Object -> Condition 'Object
forall a b. (a -> b) -> a -> b
$ Object -> TypedValue 'Object
TObject Object
o
          }
  ForeachType JsonFormula
enumClause <- case Maybe [Value]
_schemaEnum of
    Maybe [Value]
Nothing -> ForeachType JsonFormula -> m (ForeachType JsonFormula)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
    Just [] -> ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom ForeachType JsonFormula -> m () -> m (ForeachType JsonFormula)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Issue 'SchemaLevel -> m ()
forall (m :: * -> *). MonadProcess m => Issue 'SchemaLevel -> m ()
warn (ParamName -> Issue 'SchemaLevel
InvalidSchema ParamName
"no items in enum")
    Just [Value]
xs -> ForeachType JsonFormula -> m (ForeachType JsonFormula)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeachType JsonFormula -> m (ForeachType JsonFormula))
-> ForeachType JsonFormula -> m (ForeachType JsonFormula)
forall a b. (a -> b) -> a -> b
$ [ForeachType JsonFormula] -> ForeachType JsonFormula
forall a (f :: * -> *).
(BoundedJoinSemiLattice a, Foldable f) =>
f a -> a
joins (Value -> ForeachType JsonFormula
valueEnum (Value -> ForeachType JsonFormula)
-> [Value] -> [ForeachType JsonFormula]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
xs)

  let maximumClause :: ForeachType JsonFormula
maximumClause = case Maybe Scientific
_schemaMaximum of
        Maybe Scientific
Nothing -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
        Just Scientific
n ->
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forNumber:ForeachType :: JsonFormula 'Number
forNumber = Condition 'Number -> JsonFormula 'Number
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Number -> JsonFormula 'Number)
-> Condition 'Number -> JsonFormula 'Number
forall a b. (a -> b) -> a -> b
$
                Bound Scientific -> Condition 'Number
Maximum (Bound Scientific -> Condition 'Number)
-> Bound Scientific -> Condition 'Number
forall a b. (a -> b) -> a -> b
$
                  case Maybe Bool
_schemaExclusiveMaximum of
                    Just Bool
True -> Scientific -> Bound Scientific
forall a. a -> Bound a
Exclusive Scientific
n
                    Maybe Bool
_ -> Scientific -> Bound Scientific
forall a. a -> Bound a
Inclusive Scientific
n
            }

      minimumClause :: ForeachType JsonFormula
minimumClause = case Maybe Scientific
_schemaMinimum of
        Maybe Scientific
Nothing -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
        Just Scientific
n ->
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forNumber:ForeachType :: JsonFormula 'Number
forNumber = Condition 'Number -> JsonFormula 'Number
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Number -> JsonFormula 'Number)
-> Condition 'Number -> JsonFormula 'Number
forall a b. (a -> b) -> a -> b
$
                Down (Bound (Down Scientific)) -> Condition 'Number
Minimum (Down (Bound (Down Scientific)) -> Condition 'Number)
-> Down (Bound (Down Scientific)) -> Condition 'Number
forall a b. (a -> b) -> a -> b
$
                  Bound (Down Scientific) -> Down (Bound (Down Scientific))
forall a. a -> Down a
Down (Bound (Down Scientific) -> Down (Bound (Down Scientific)))
-> Bound (Down Scientific) -> Down (Bound (Down Scientific))
forall a b. (a -> b) -> a -> b
$
                    case Maybe Bool
_schemaExclusiveMinimum of
                      Just Bool
True -> Down Scientific -> Bound (Down Scientific)
forall a. a -> Bound a
Exclusive (Down Scientific -> Bound (Down Scientific))
-> Down Scientific -> Bound (Down Scientific)
forall a b. (a -> b) -> a -> b
$ Scientific -> Down Scientific
forall a. a -> Down a
Down Scientific
n
                      Maybe Bool
_ -> Down Scientific -> Bound (Down Scientific)
forall a. a -> Bound a
Inclusive (Down Scientific -> Bound (Down Scientific))
-> Down Scientific -> Bound (Down Scientific)
forall a b. (a -> b) -> a -> b
$ Scientific -> Down Scientific
forall a. a -> Down a
Down Scientific
n
            }

      multipleOfClause :: ForeachType JsonFormula
multipleOfClause = case Maybe Scientific
_schemaMultipleOf of
        Maybe Scientific
Nothing -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
        Just Scientific
n ->
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forNumber:ForeachType :: JsonFormula 'Number
forNumber = Condition 'Number -> JsonFormula 'Number
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Number -> JsonFormula 'Number)
-> Condition 'Number -> JsonFormula 'Number
forall a b. (a -> b) -> a -> b
$ Scientific -> Condition 'Number
MultipleOf Scientific
n
            }

  ForeachType JsonFormula
formatClause <- case Maybe ParamName
_schemaFormat of
    Maybe ParamName
Nothing -> ForeachType JsonFormula -> m (ForeachType JsonFormula)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
    Just ParamName
f
      | ParamName
f ParamName -> [ParamName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ParamName
"int32", ParamName
"int64", ParamName
"float", ParamName
"double"] ->
        ForeachType JsonFormula -> m (ForeachType JsonFormula)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forNumber:ForeachType :: JsonFormula 'Number
forNumber = Condition 'Number -> JsonFormula 'Number
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Number -> JsonFormula 'Number)
-> Condition 'Number -> JsonFormula 'Number
forall a b. (a -> b) -> a -> b
$ ParamName -> Condition 'Number
NumberFormat ParamName
f
            }
    Just ParamName
f
      | ParamName
f ParamName -> [ParamName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ParamName
"byte", ParamName
"binary", ParamName
"date", ParamName
"date-time", ParamName
"password", ParamName
"uuid"] ->
        ForeachType JsonFormula -> m (ForeachType JsonFormula)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forString:ForeachType :: JsonFormula 'String
forString = Condition 'String -> JsonFormula 'String
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'String -> JsonFormula 'String)
-> Condition 'String -> JsonFormula 'String
forall a b. (a -> b) -> a -> b
$ ParamName -> Condition 'String
StringFormat ParamName
f
            }
    Just ParamName
f -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top ForeachType JsonFormula -> m () -> m (ForeachType JsonFormula)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Issue 'SchemaLevel -> m ()
forall (m :: * -> *). MonadProcess m => Issue 'SchemaLevel -> m ()
warn (ParamName -> Issue 'SchemaLevel
NotSupported (ParamName -> Issue 'SchemaLevel)
-> ParamName -> Issue 'SchemaLevel
forall a b. (a -> b) -> a -> b
$ ParamName
"Unknown format: " ParamName -> ParamName -> ParamName
forall a. Semigroup a => a -> a -> a
<> ParamName
f)

  let maxLengthClause :: ForeachType JsonFormula
maxLengthClause = case Maybe Integer
_schemaMaxLength of
        Maybe Integer
Nothing -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
        Just Integer
n ->
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forString:ForeachType :: JsonFormula 'String
forString = Condition 'String -> JsonFormula 'String
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'String -> JsonFormula 'String)
-> Condition 'String -> JsonFormula 'String
forall a b. (a -> b) -> a -> b
$ Integer -> Condition 'String
MaxLength Integer
n
            }

      minLengthClause :: ForeachType JsonFormula
minLengthClause = case Maybe Integer
_schemaMinLength of
        Maybe Integer
Nothing -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
        Just Integer
n ->
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forString:ForeachType :: JsonFormula 'String
forString = Condition 'String -> JsonFormula 'String
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'String -> JsonFormula 'String)
-> Condition 'String -> JsonFormula 'String
forall a b. (a -> b) -> a -> b
$ Integer -> Condition 'String
MinLength Integer
n
            }

      patternClause :: ForeachType JsonFormula
patternClause = case Maybe ParamName
_schemaPattern of
        Maybe ParamName
Nothing -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
        Just ParamName
p ->
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forString:ForeachType :: JsonFormula 'String
forString = Condition 'String -> JsonFormula 'String
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'String -> JsonFormula 'String)
-> Condition 'String -> JsonFormula 'String
forall a b. (a -> b) -> a -> b
$ ParamName -> Condition 'String
Pattern ParamName
p
            }

  ForeachType JsonFormula
itemsClause <- case Traced Schema
-> Maybe
     (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
tracedItems Traced Schema
sch of
    Maybe
  (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
Nothing -> ForeachType JsonFormula -> m (ForeachType JsonFormula)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
    Just (Left Traced (Referenced Schema)
rs) -> do
      ForeachType JsonFormula
f <- SilentM (ForeachType JsonFormula) -> m (ForeachType JsonFormula)
forall (m :: * -> *) a. MonadProcess m => SilentM a -> m a
lazily (SilentM (ForeachType JsonFormula) -> m (ForeachType JsonFormula))
-> SilentM (ForeachType JsonFormula) -> m (ForeachType JsonFormula)
forall a b. (a -> b) -> a -> b
$ Traced (Referenced Schema) -> SilentM (ForeachType JsonFormula)
forall (m :: * -> *).
MonadProcess m =>
Traced (Referenced Schema) -> m (ForeachType JsonFormula)
processRefSchema Traced (Referenced Schema)
rs
      pure ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top {$sel:forArray:ForeachType :: JsonFormula 'Array
forArray = Condition 'Array -> JsonFormula 'Array
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Array -> JsonFormula 'Array)
-> Condition 'Array -> JsonFormula 'Array
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula
-> Traced (Referenced Schema) -> Condition 'Array
Items ForeachType JsonFormula
f Traced (Referenced Schema)
rs}
    Just (Right [Traced (Referenced Schema)]
rss) -> do
      [(ForeachType JsonFormula, Traced (Referenced Schema))]
fsrs <- [Traced (Referenced Schema)]
-> (Traced (Referenced Schema)
    -> m (ForeachType JsonFormula, Traced (Referenced Schema)))
-> m [(ForeachType JsonFormula, Traced (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)
  -> m (ForeachType JsonFormula, Traced (Referenced Schema)))
 -> m [(ForeachType JsonFormula, Traced (Referenced Schema))])
-> (Traced (Referenced Schema)
    -> m (ForeachType JsonFormula, Traced (Referenced Schema)))
-> m [(ForeachType JsonFormula, Traced (Referenced Schema))]
forall a b. (a -> b) -> a -> b
$ \Traced (Referenced Schema)
rs -> do
        ForeachType JsonFormula
f <- SilentM (ForeachType JsonFormula) -> m (ForeachType JsonFormula)
forall (m :: * -> *) a. MonadProcess m => SilentM a -> m a
lazily (SilentM (ForeachType JsonFormula) -> m (ForeachType JsonFormula))
-> SilentM (ForeachType JsonFormula) -> m (ForeachType JsonFormula)
forall a b. (a -> b) -> a -> b
$ Traced (Referenced Schema) -> SilentM (ForeachType JsonFormula)
forall (m :: * -> *).
MonadProcess m =>
Traced (Referenced Schema) -> m (ForeachType JsonFormula)
processRefSchema Traced (Referenced Schema)
rs
        pure (ForeachType JsonFormula
f, Traced (Referenced Schema)
rs)
      pure ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top {$sel:forArray:ForeachType :: JsonFormula 'Array
forArray = Condition 'Array -> JsonFormula 'Array
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Array -> JsonFormula 'Array)
-> Condition 'Array -> JsonFormula 'Array
forall a b. (a -> b) -> a -> b
$ [(ForeachType JsonFormula, Traced (Referenced Schema))]
-> Condition 'Array
TupleItems [(ForeachType JsonFormula, Traced (Referenced Schema))]
fsrs}

  let maxItemsClause :: ForeachType JsonFormula
maxItemsClause = case Maybe Integer
_schemaMaxItems of
        Maybe Integer
Nothing -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
        Just Integer
n ->
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forArray:ForeachType :: JsonFormula 'Array
forArray = Condition 'Array -> JsonFormula 'Array
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Array -> JsonFormula 'Array)
-> Condition 'Array -> JsonFormula 'Array
forall a b. (a -> b) -> a -> b
$ Integer -> Condition 'Array
MaxItems Integer
n
            }

      minItemsClause :: ForeachType JsonFormula
minItemsClause = case Maybe Integer
_schemaMinItems of
        Maybe Integer
Nothing -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
        Just Integer
n ->
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forArray:ForeachType :: JsonFormula 'Array
forArray = Condition 'Array -> JsonFormula 'Array
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Array -> JsonFormula 'Array)
-> Condition 'Array -> JsonFormula 'Array
forall a b. (a -> b) -> a -> b
$ Integer -> Condition 'Array
MinItems Integer
n
            }

      uniqueItemsClause :: ForeachType JsonFormula
uniqueItemsClause = case Maybe Bool
_schemaUniqueItems of
        Just Bool
True ->
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forArray:ForeachType :: JsonFormula 'Array
forArray = Condition 'Array -> JsonFormula 'Array
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula Condition 'Array
UniqueItems
            }
        Maybe Bool
_ -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top

  (ForeachType JsonFormula
addProps, Maybe (Traced (Referenced Schema))
addPropSchema) <- case Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))
tracedAdditionalProperties Traced Schema
sch of
    Just (Right Traced (Referenced Schema)
rs) -> (,Traced (Referenced Schema) -> Maybe (Traced (Referenced Schema))
forall a. a -> Maybe a
Just Traced (Referenced Schema)
rs) (ForeachType JsonFormula
 -> (ForeachType JsonFormula, Maybe (Traced (Referenced Schema))))
-> m (ForeachType JsonFormula)
-> m (ForeachType JsonFormula, Maybe (Traced (Referenced Schema)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SilentM (ForeachType JsonFormula) -> m (ForeachType JsonFormula)
forall (m :: * -> *) a. MonadProcess m => SilentM a -> m a
lazily (Traced (Referenced Schema) -> SilentM (ForeachType JsonFormula)
forall (m :: * -> *).
MonadProcess m =>
Traced (Referenced Schema) -> m (ForeachType JsonFormula)
processRefSchema Traced (Referenced Schema)
rs)
    Just (Left Bool
False) -> (ForeachType JsonFormula, Maybe (Traced (Referenced Schema)))
-> m (ForeachType JsonFormula, Maybe (Traced (Referenced Schema)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom, Maybe (Traced (Referenced Schema))
forall a. Maybe a
Nothing)
    Maybe (Either Bool (Traced (Referenced Schema)))
_ -> (ForeachType JsonFormula, Maybe (Traced (Referenced Schema)))
-> m (ForeachType JsonFormula, Maybe (Traced (Referenced Schema)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top, Traced (Referenced Schema) -> Maybe (Traced (Referenced Schema))
forall a. a -> Maybe a
Just (Traced (Referenced Schema) -> Maybe (Traced (Referenced Schema)))
-> Traced (Referenced Schema) -> Maybe (Traced (Referenced Schema))
forall a b. (a -> b) -> a -> b
$ Paths Step TraceRoot (Referenced Schema)
-> Referenced Schema -> Traced (Referenced Schema)
forall a. Trace a -> a -> Traced a
traced (Traced Schema -> Paths Step TraceRoot Schema
forall e (w :: * -> *) a. ComonadEnv e w => w a -> e
ask Traced Schema
sch Paths Step TraceRoot Schema
-> Step Schema (Referenced Schema)
-> Paths Step TraceRoot (Referenced Schema)
forall k (q :: k -> k -> *) (b :: k) (c :: k) (a :: k).
NiceQuiver q b c =>
Paths q a b -> q b c -> Paths q a c
`Snoc` Step Schema (Referenced Schema)
AdditionalPropertiesStep) (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)
  [(ParamName, Property)]
propList <- [ParamName]
-> (ParamName -> m (ParamName, Property))
-> m [(ParamName, Property)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set ParamName -> [ParamName]
forall a. Set a -> [a]
S.toList (Set ParamName -> [ParamName])
-> ([ParamName] -> Set ParamName) -> [ParamName] -> [ParamName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParamName] -> Set ParamName
forall a. Ord a => [a] -> Set a
S.fromList ([ParamName] -> [ParamName]) -> [ParamName] -> [ParamName]
forall a b. (a -> b) -> a -> b
$ InsOrdHashMap ParamName (Referenced Schema) -> [ParamName]
forall k v. InsOrdHashMap k v -> [k]
IOHM.keys InsOrdHashMap ParamName (Referenced Schema)
_schemaProperties [ParamName] -> [ParamName] -> [ParamName]
forall a. Semigroup a => a -> a -> a
<> [ParamName]
_schemaRequired) ((ParamName -> m (ParamName, Property))
 -> m [(ParamName, Property)])
-> (ParamName -> m (ParamName, Property))
-> m [(ParamName, Property)]
forall a b. (a -> b) -> a -> b
$ \ParamName
k -> do
    (ForeachType JsonFormula
f, Traced (Referenced Schema)
psch) <- case ParamName
-> InsOrdHashMap ParamName (Traced (Referenced Schema))
-> Maybe (Traced (Referenced Schema))
forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
IOHM.lookup ParamName
k (InsOrdHashMap ParamName (Traced (Referenced Schema))
 -> Maybe (Traced (Referenced Schema)))
-> InsOrdHashMap ParamName (Traced (Referenced Schema))
-> Maybe (Traced (Referenced Schema))
forall a b. (a -> b) -> a -> b
$ Traced Schema
-> InsOrdHashMap ParamName (Traced (Referenced Schema))
tracedProperties Traced Schema
sch of
      Just Traced (Referenced Schema)
rs -> (,Traced (Referenced Schema)
rs) (ForeachType JsonFormula
 -> (ForeachType JsonFormula, Traced (Referenced Schema)))
-> m (ForeachType JsonFormula)
-> m (ForeachType JsonFormula, Traced (Referenced Schema))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SilentM (ForeachType JsonFormula) -> m (ForeachType JsonFormula)
forall (m :: * -> *) a. MonadProcess m => SilentM a -> m a
lazily (Traced (Referenced Schema) -> SilentM (ForeachType JsonFormula)
forall (m :: * -> *).
MonadProcess m =>
Traced (Referenced Schema) -> m (ForeachType JsonFormula)
processRefSchema Traced (Referenced Schema)
rs)
      Maybe (Traced (Referenced Schema))
Nothing ->
        let fakeSchema :: Traced (Referenced Schema)
fakeSchema = Paths Step TraceRoot (Referenced Schema)
-> Referenced Schema -> Traced (Referenced Schema)
forall a. Trace a -> a -> Traced a
traced (Traced Schema -> Paths Step TraceRoot Schema
forall e (w :: * -> *) a. ComonadEnv e w => w a -> e
ask Traced Schema
sch Paths Step TraceRoot Schema
-> Step Schema (Referenced Schema)
-> Paths Step TraceRoot (Referenced Schema)
forall k (q :: k -> k -> *) (b :: k) (c :: k) (a :: k).
NiceQuiver q b c =>
Paths q a b -> q b c -> Paths q a c
`Snoc` Step Schema (Referenced Schema)
AdditionalPropertiesStep) (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
         in -- The mempty here is incorrect, but if addPropSchema was Nothing, then
            -- addProps is bottom, and k is in _schemaRequired. We handle this situation
            -- below and short-circuit the entire Properties condition to bottom
            (ForeachType JsonFormula, Traced (Referenced Schema))
-> m (ForeachType JsonFormula, Traced (Referenced Schema))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeachType JsonFormula
addProps, Traced (Referenced Schema)
-> Maybe (Traced (Referenced Schema)) -> Traced (Referenced Schema)
forall a. a -> Maybe a -> a
fromMaybe Traced (Referenced Schema)
fakeSchema Maybe (Traced (Referenced Schema))
addPropSchema)
    (ParamName, Property) -> m (ParamName, Property)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParamName
k, Bool
-> ForeachType JsonFormula
-> Traced (Referenced Schema)
-> Property
Property (ParamName
k ParamName -> [ParamName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ParamName]
_schemaRequired) ForeachType JsonFormula
f Traced (Referenced Schema)
psch)
  let allBottom :: ForeachType JsonFormula -> Bool
allBottom ForeachType JsonFormula
f = All -> Bool
getAll (All -> Bool) -> All -> Bool
forall a b. (a -> b) -> a -> b
$
        (forall (x :: JsonType).
 Typeable x =>
 JsonType -> (ForeachType JsonFormula -> JsonFormula x) -> All)
-> All
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) -> All)
 -> All)
-> (forall (x :: JsonType).
    Typeable x =>
    JsonType -> (ForeachType JsonFormula -> JsonFormula x) -> All)
-> All
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 -> All
All Bool
True
          DNF (Condition x)
_ -> Bool -> All
All Bool
False
      allTop :: ForeachType JsonFormula -> Bool
allTop ForeachType JsonFormula
f = All -> Bool
getAll (All -> Bool) -> All -> Bool
forall a b. (a -> b) -> a -> b
$
        (forall (x :: JsonType).
 Typeable x =>
 JsonType -> (ForeachType JsonFormula -> JsonFormula x) -> All)
-> All
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) -> All)
 -> All)
-> (forall (x :: JsonType).
    Typeable x =>
    JsonType -> (ForeachType JsonFormula -> JsonFormula x) -> All)
-> All
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)
TopDNF -> Bool -> All
All Bool
True
          DNF (Condition x)
_ -> Bool -> All
All Bool
False
      -- remove optional fields whose schemata match that of additional props
      propMap :: Map ParamName Property
propMap = (Property -> Bool)
-> Map ParamName Property -> Map ParamName Property
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (\Property
p -> Property -> Bool
propRequired Property
p Bool -> Bool -> Bool
|| Property -> ForeachType JsonFormula
propFormula Property
p ForeachType JsonFormula -> ForeachType JsonFormula -> Bool
forall a. Eq a => a -> a -> Bool
/= ForeachType JsonFormula
addProps) (Map ParamName Property -> Map ParamName Property)
-> Map ParamName Property -> Map ParamName Property
forall a b. (a -> b) -> a -> b
$ [(ParamName, Property)] -> Map ParamName Property
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(ParamName, Property)]
propList
      propertiesClause :: ForeachType JsonFormula
propertiesClause
        | (Property -> Bool) -> Map ParamName Property -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Property
p -> Property -> Bool
propRequired Property
p Bool -> Bool -> Bool
&& ForeachType JsonFormula -> Bool
allBottom (Property -> ForeachType JsonFormula
propFormula Property
p)) Map ParamName Property
propMap =
          ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom -- if any required field has unsatisfiable schema
        | Map ParamName Property -> Bool
forall k a. Map k a -> Bool
M.null Map ParamName Property
propMap
          , ForeachType JsonFormula -> Bool
allTop ForeachType JsonFormula
addProps =
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top -- if all fields are optional and have trivial schemata
        | Bool
otherwise =
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forObject:ForeachType :: JsonFormula 'Object
forObject = Condition 'Object -> JsonFormula 'Object
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Object -> JsonFormula 'Object)
-> Condition 'Object -> JsonFormula 'Object
forall a b. (a -> b) -> a -> b
$ Map ParamName Property
-> ForeachType JsonFormula
-> Maybe (Traced (Referenced Schema))
-> Condition 'Object
Properties Map ParamName Property
propMap ForeachType JsonFormula
addProps Maybe (Traced (Referenced Schema))
addPropSchema
            }

      maxPropertiesClause :: ForeachType JsonFormula
maxPropertiesClause = case Maybe Integer
_schemaMaxProperties of
        Maybe Integer
Nothing -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
        Just Integer
n ->
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forObject:ForeachType :: JsonFormula 'Object
forObject = Condition 'Object -> JsonFormula 'Object
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Object -> JsonFormula 'Object)
-> Condition 'Object -> JsonFormula 'Object
forall a b. (a -> b) -> a -> b
$ Integer -> Condition 'Object
MaxProperties Integer
n
            }

      minPropertiesClause :: ForeachType JsonFormula
minPropertiesClause = case Maybe Integer
_schemaMinProperties of
        Maybe Integer
Nothing -> ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
        Just Integer
n ->
          ForeachType JsonFormula
forall a. BoundedMeetSemiLattice a => a
top
            { $sel:forObject:ForeachType :: JsonFormula 'Object
forObject = Condition 'Object -> JsonFormula 'Object
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Object -> JsonFormula 'Object)
-> Condition 'Object -> JsonFormula 'Object
forall a b. (a -> b) -> a -> b
$ Integer -> Condition 'Object
MinProperties Integer
n
            }

      nullableClause :: ForeachType JsonFormula
nullableClause
        | Just Bool
True <- Maybe Bool
_schemaNullable =
          ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom
            { $sel:forNull:ForeachType :: JsonFormula 'Null
forNull = Condition 'Null -> JsonFormula 'Null
forall (t :: JsonType). Condition t -> JsonFormula t
singletonFormula (Condition 'Null -> JsonFormula 'Null)
-> Condition 'Null -> JsonFormula 'Null
forall a b. (a -> b) -> a -> b
$ TypedValue 'Null -> Condition 'Null
forall (t :: JsonType). TypedValue t -> Condition t
Exactly TypedValue 'Null
TNull
            }
        | Bool
otherwise = ForeachType JsonFormula
forall a. BoundedJoinSemiLattice a => a
bottom

  pure $
    ForeachType JsonFormula
nullableClause
      ForeachType JsonFormula
-> ForeachType JsonFormula -> ForeachType JsonFormula
forall a. Lattice a => a -> a -> a
\/ [ForeachType JsonFormula] -> ForeachType JsonFormula
forall a (f :: * -> *).
(BoundedMeetSemiLattice a, Foldable f) =>
f a -> a
meets
        ( [ForeachType JsonFormula]
allClauses
            [ForeachType JsonFormula]
-> [ForeachType JsonFormula] -> [ForeachType JsonFormula]
forall a. Semigroup a => a -> a -> a
<> [ ForeachType JsonFormula
anyClause
               , ForeachType JsonFormula
oneClause
               , ForeachType JsonFormula
typeClause
               , ForeachType JsonFormula
enumClause
               , ForeachType JsonFormula
maximumClause
               , ForeachType JsonFormula
minimumClause
               , ForeachType JsonFormula
multipleOfClause
               , ForeachType JsonFormula
formatClause
               , ForeachType JsonFormula
maxLengthClause
               , ForeachType JsonFormula
minLengthClause
               , ForeachType JsonFormula
patternClause
               , ForeachType JsonFormula
itemsClause
               , ForeachType JsonFormula
maxItemsClause
               , ForeachType JsonFormula
minItemsClause
               , ForeachType JsonFormula
uniqueItemsClause
               , ForeachType JsonFormula
propertiesClause
               , ForeachType JsonFormula
maxPropertiesClause
               , ForeachType JsonFormula
minPropertiesClause
               ]
        )

{- TODO: ReadOnly/WriteOnly #68 -}

checkOneOfDisjoint :: MonadProcess m => [Traced (Referenced Schema)] -> m Bool
checkOneOfDisjoint :: [Traced (Referenced Schema)] -> m Bool
checkOneOfDisjoint [Traced (Referenced Schema)]
schs = do
  Traced (Definitions Schema)
defs <- m (Traced (Definitions Schema))
forall r (m :: * -> *). MonadReader r m => m r
R.ask
  pure $ 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
$ [Lifted Partitions] -> Lifted Partitions
forall a (f :: * -> *).
(BoundedJoinSemiLattice a, Foldable f) =>
f a -> a
joins ([Lifted Partitions] -> Lifted Partitions)
-> [Lifted Partitions] -> Lifted Partitions
forall a b. (a -> b) -> a -> b
$ Traced (Definitions Schema)
-> PartitionM [Lifted Partitions] -> [Lifted Partitions]
forall a. Traced (Definitions Schema) -> PartitionM a -> a
runPartitionM Traced (Definitions Schema)
defs (PartitionM [Lifted Partitions] -> [Lifted Partitions])
-> PartitionM [Lifted Partitions] -> [Lifted Partitions]
forall a b. (a -> b) -> a -> b
$ (Traced (Referenced Schema)
 -> ReaderT
      (Traced (Definitions Schema))
      (State (MemoState ()))
      (Lifted Partitions))
-> [Traced (Referenced Schema)] -> PartitionM [Lifted Partitions]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Traced (Referenced Schema)
-> ReaderT
     (Traced (Definitions Schema))
     (State (MemoState ()))
     (Lifted Partitions)
partitionRefSchema [Traced (Referenced Schema)]
schs of
    Maybe (PartitionLocation, Set PartitionChoice)
Nothing -> Bool
False
    Just (PartitionLocation
loc, Set PartitionChoice
parts) ->
      let intersects :: PartitionChoice -> Traced (Referenced Schema) -> Bool
intersects PartitionChoice
part Traced (Referenced Schema)
sch = case Traced (Definitions Schema)
-> IntersectionM (Referenced Schema)
-> IntersectionResult (Referenced Schema)
forall a.
Traced (Definitions Schema)
-> IntersectionM a -> IntersectionResult a
runIntersectionM Traced (Definitions Schema)
defs (IntersectionM (Referenced Schema)
 -> IntersectionResult (Referenced Schema))
-> IntersectionM (Referenced Schema)
-> IntersectionResult (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ PartitionLocation
-> PartitionChoice
-> Traced (Referenced Schema)
-> IntersectionM (Referenced Schema)
intersectRefSchema PartitionLocation
loc PartitionChoice
part Traced (Referenced Schema)
sch of
            IntersectionResult (Referenced Schema)
Disjoint -> Bool
False
            IntersectionResult (Referenced Schema)
_ -> Bool
True
       in (PartitionChoice -> Bool) -> Set PartitionChoice -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\PartitionChoice
part -> Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [Traced (Referenced Schema)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Traced (Referenced Schema) -> Bool)
-> [Traced (Referenced Schema)] -> [Traced (Referenced Schema)]
forall a. (a -> Bool) -> [a] -> [a]
filter (PartitionChoice -> Traced (Referenced Schema) -> Bool
intersects PartitionChoice
part) [Traced (Referenced Schema)]
schs)) Set PartitionChoice
parts
  where

runProcessM :: Traced (Definitions Schema) -> ProcessM a -> (a, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
runProcessM :: Traced (Definitions Schema)
-> ProcessM a -> (a, PathsPrefixTree Behave AnIssue 'SchemaLevel)
runProcessM Traced (Definitions Schema)
defs = Writer (PathsPrefixTree Behave AnIssue 'SchemaLevel) a
-> (a, PathsPrefixTree Behave AnIssue 'SchemaLevel)
forall w a. Writer w a -> (a, w)
runWriter (Writer (PathsPrefixTree Behave AnIssue 'SchemaLevel) a
 -> (a, PathsPrefixTree Behave AnIssue 'SchemaLevel))
-> (ProcessM a
    -> Writer (PathsPrefixTree Behave AnIssue 'SchemaLevel) a)
-> ProcessM a
-> (a, PathsPrefixTree Behave AnIssue 'SchemaLevel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT
  (Traced (Definitions Schema))
  (WriterT (PathsPrefixTree Behave AnIssue 'SchemaLevel) Identity)
  a
-> Traced (Definitions Schema)
-> Writer (PathsPrefixTree Behave AnIssue 'SchemaLevel) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Traced (Definitions Schema)
defs) (ReaderT
   (Traced (Definitions Schema))
   (WriterT (PathsPrefixTree Behave AnIssue 'SchemaLevel) Identity)
   a
 -> Writer (PathsPrefixTree Behave AnIssue 'SchemaLevel) a)
-> (ProcessM a
    -> ReaderT
         (Traced (Definitions Schema))
         (WriterT (PathsPrefixTree Behave AnIssue 'SchemaLevel) Identity)
         a)
-> ProcessM a
-> Writer (PathsPrefixTree Behave AnIssue 'SchemaLevel) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ()
-> ProcessM a
-> ReaderT
     (Traced (Definitions Schema))
     (WriterT (PathsPrefixTree Behave AnIssue 'SchemaLevel) Identity)
     a
forall (m :: * -> *) s a.
Monad m =>
s -> StateT (MemoState s) m a -> m a
runMemo ()

schemaToFormula ::
  Traced (Definitions Schema) ->
  Traced Schema ->
  (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
schemaToFormula :: Traced (Definitions Schema)
-> Traced Schema
-> (ForeachType JsonFormula,
    PathsPrefixTree Behave AnIssue 'SchemaLevel)
schemaToFormula Traced (Definitions Schema)
defs Traced Schema
rs = Traced (Definitions Schema)
-> ProcessM (ForeachType JsonFormula)
-> (ForeachType JsonFormula,
    PathsPrefixTree Behave AnIssue 'SchemaLevel)
forall a.
Traced (Definitions Schema)
-> ProcessM a -> (a, PathsPrefixTree Behave AnIssue 'SchemaLevel)
runProcessM Traced (Definitions Schema)
defs (ProcessM (ForeachType JsonFormula)
 -> (ForeachType JsonFormula,
     PathsPrefixTree Behave AnIssue 'SchemaLevel))
-> ProcessM (ForeachType JsonFormula)
-> (ForeachType JsonFormula,
    PathsPrefixTree Behave AnIssue 'SchemaLevel)
forall a b. (a -> b) -> a -> b
$ Traced Schema -> ProcessM (ForeachType JsonFormula)
forall (m :: * -> *).
MonadProcess m =>
Traced Schema -> m (ForeachType JsonFormula)
processSchema Traced Schema
rs