{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Autodocodec.Schema
  ( jsonSchemaViaCodec,
    jsonSchemaVia,
    jsonObjectSchemaViaCodec,
    jsonObjectSchemaVia,
    JSONSchema (..),
    ObjectSchema (..),
    KeyRequirement (..),
    validateAccordingTo,
    validateObjectAccordingTo,
  )
where

import Autodocodec
import qualified Autodocodec.Aeson.Compat as Compat
import Control.Monad
import Control.Monad.State
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import Data.Foldable
import qualified Data.HashMap.Strict as HM
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Scientific
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Validity
import Data.Validity.Aeson ()
import Data.Validity.Containers ()
import Data.Validity.Text ()
import GHC.Generics (Generic)

-- | A JSON Schema
--
-- http://json-schema.org/understanding-json-schema/reference/index.html
--
-- Contrary to a 'Codec', values of this type should be finite.
--
-- NOTE: This schema roundtrips to JSON, but it cannot expres everything that a fully-featured json-schema may be able to express.
data JSONSchema
  = AnySchema
  | NullSchema
  | BoolSchema
  | StringSchema
  | IntegerSchema !(Bounds Integer)
  | NumberSchema !(Bounds Scientific)
  | ArraySchema !JSONSchema
  | MapSchema !JSONSchema
  | -- | This needs to be a list because keys should stay in their original ordering.
    ObjectSchema !ObjectSchema
  | ValueSchema !JSON.Value
  | AnyOfSchema !(NonEmpty JSONSchema)
  | OneOfSchema !(NonEmpty JSONSchema)
  | CommentSchema !Text !JSONSchema
  | RefSchema !Text
  | WithDefSchema !(Map Text JSONSchema) !JSONSchema
  deriving (Int -> JSONSchema -> ShowS
[JSONSchema] -> ShowS
JSONSchema -> String
(Int -> JSONSchema -> ShowS)
-> (JSONSchema -> String)
-> ([JSONSchema] -> ShowS)
-> Show JSONSchema
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JSONSchema -> ShowS
showsPrec :: Int -> JSONSchema -> ShowS
$cshow :: JSONSchema -> String
show :: JSONSchema -> String
$cshowList :: [JSONSchema] -> ShowS
showList :: [JSONSchema] -> ShowS
Show, JSONSchema -> JSONSchema -> Bool
(JSONSchema -> JSONSchema -> Bool)
-> (JSONSchema -> JSONSchema -> Bool) -> Eq JSONSchema
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JSONSchema -> JSONSchema -> Bool
== :: JSONSchema -> JSONSchema -> Bool
$c/= :: JSONSchema -> JSONSchema -> Bool
/= :: JSONSchema -> JSONSchema -> Bool
Eq, Eq JSONSchema
Eq JSONSchema =>
(JSONSchema -> JSONSchema -> Ordering)
-> (JSONSchema -> JSONSchema -> Bool)
-> (JSONSchema -> JSONSchema -> Bool)
-> (JSONSchema -> JSONSchema -> Bool)
-> (JSONSchema -> JSONSchema -> Bool)
-> (JSONSchema -> JSONSchema -> JSONSchema)
-> (JSONSchema -> JSONSchema -> JSONSchema)
-> Ord JSONSchema
JSONSchema -> JSONSchema -> Bool
JSONSchema -> JSONSchema -> Ordering
JSONSchema -> JSONSchema -> JSONSchema
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
$ccompare :: JSONSchema -> JSONSchema -> Ordering
compare :: JSONSchema -> JSONSchema -> Ordering
$c< :: JSONSchema -> JSONSchema -> Bool
< :: JSONSchema -> JSONSchema -> Bool
$c<= :: JSONSchema -> JSONSchema -> Bool
<= :: JSONSchema -> JSONSchema -> Bool
$c> :: JSONSchema -> JSONSchema -> Bool
> :: JSONSchema -> JSONSchema -> Bool
$c>= :: JSONSchema -> JSONSchema -> Bool
>= :: JSONSchema -> JSONSchema -> Bool
$cmax :: JSONSchema -> JSONSchema -> JSONSchema
max :: JSONSchema -> JSONSchema -> JSONSchema
$cmin :: JSONSchema -> JSONSchema -> JSONSchema
min :: JSONSchema -> JSONSchema -> JSONSchema
Ord, (forall x. JSONSchema -> Rep JSONSchema x)
-> (forall x. Rep JSONSchema x -> JSONSchema) -> Generic JSONSchema
forall x. Rep JSONSchema x -> JSONSchema
forall x. JSONSchema -> Rep JSONSchema x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JSONSchema -> Rep JSONSchema x
from :: forall x. JSONSchema -> Rep JSONSchema x
$cto :: forall x. Rep JSONSchema x -> JSONSchema
to :: forall x. Rep JSONSchema x -> JSONSchema
Generic)

instance Validity JSONSchema where
  validate :: JSONSchema -> Validation
validate JSONSchema
js =
    [Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
      [ JSONSchema -> Validation
forall a. (Generic a, GValidity (Rep a)) => a -> Validation
genericValidate JSONSchema
js,
        String -> Bool -> Validation
declare String
"never has two nested comments" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ case JSONSchema
js of
          CommentSchema Text
_ (CommentSchema Text
_ JSONSchema
_) -> Bool
False
          JSONSchema
_ -> Bool
True,
        case JSONSchema
js of
          AnyOfSchema NonEmpty JSONSchema
cs -> String -> Bool -> Validation
declare String
"there are 2 of more choices" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ NonEmpty JSONSchema -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty JSONSchema
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
          OneOfSchema NonEmpty JSONSchema
cs -> String -> Bool -> Validation
declare String
"there are 2 of more choices" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ NonEmpty JSONSchema -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty JSONSchema
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
          JSONSchema
_ -> Validation
valid
      ]

instance ToJSON JSONSchema where
  toJSON :: JSONSchema -> Value
toJSON = [Pair] -> Value
JSON.object ([Pair] -> Value) -> (JSONSchema -> [Pair]) -> JSONSchema -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONSchema -> [Pair]
go
    where
      go :: JSONSchema -> [JSON.Pair]
      go :: JSONSchema -> [Pair]
go = \case
        JSONSchema
AnySchema -> []
        JSONSchema
NullSchema -> [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"null" :: Text)]
        JSONSchema
BoolSchema -> [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"boolean" :: Text)]
        JSONSchema
StringSchema -> [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"string" :: Text)]
        IntegerSchema Bounds {Maybe Integer
boundsLower :: Maybe Integer
boundsUpper :: Maybe Integer
boundsLower :: forall a. Bounds a -> Maybe a
boundsUpper :: forall a. Bounds a -> Maybe a
..} ->
          [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
            [ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"integer" :: Text)),
              (Key
"minimum" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..=) (Integer -> Pair) -> Maybe Integer -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
boundsLower,
              (Key
"maximum" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..=) (Integer -> Pair) -> Maybe Integer -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
boundsUpper
            ]
        NumberSchema Bounds {Maybe Scientific
boundsLower :: forall a. Bounds a -> Maybe a
boundsUpper :: forall a. Bounds a -> Maybe a
boundsLower :: Maybe Scientific
boundsUpper :: Maybe Scientific
..} ->
          [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
            [ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"number" :: Text)),
              (Key
"minimum" Key -> Scientific -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..=) (Scientific -> Pair) -> Maybe Scientific -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Scientific
boundsLower,
              (Key
"maximum" Key -> Scientific -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..=) (Scientific -> Pair) -> Maybe Scientific -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Scientific
boundsUpper
            ]
        ArraySchema JSONSchema
s ->
          let itemSchemaVal :: [Pair]
itemSchemaVal = JSONSchema -> [Pair]
go JSONSchema
s
           in [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"array" :: Text), (Key
"items", [Pair] -> Value
JSON.object [Pair]
itemSchemaVal)]
        ValueSchema Value
v -> [Key
"const" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= Value
v]
        MapSchema JSONSchema
s ->
          let itemSchemaVal :: [Pair]
itemSchemaVal = JSONSchema -> [Pair]
go JSONSchema
s
           in [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"object" :: Text), Key
"additionalProperties" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= [Pair] -> Value
JSON.object [Pair]
itemSchemaVal]
        ObjectSchema ObjectSchema
os ->
          case ObjectSchema -> Value
forall a. ToJSON a => a -> Value
toJSON ObjectSchema
os of
            JSON.Object Object
o -> Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
Compat.toList Object
o
            Value
_ -> [] -- Should not happen.
        AnyOfSchema NonEmpty JSONSchema
jcs ->
          let svals :: [JSON.Value]
              svals :: [Value]
svals = (JSONSchema -> Value) -> [JSONSchema] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ([Pair] -> Value
JSON.object ([Pair] -> Value) -> (JSONSchema -> [Pair]) -> JSONSchema -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONSchema -> [Pair]
go) (NonEmpty JSONSchema -> [JSONSchema]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty JSONSchema
jcs)
              val :: JSON.Value
              val :: Value
val = ([Value] -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON :: [JSON.Value] -> JSON.Value) [Value]
svals
           in [(Key
"anyOf", Value
val)]
        OneOfSchema NonEmpty JSONSchema
jcs ->
          let svals :: [JSON.Value]
              svals :: [Value]
svals = (JSONSchema -> Value) -> [JSONSchema] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ([Pair] -> Value
JSON.object ([Pair] -> Value) -> (JSONSchema -> [Pair]) -> JSONSchema -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONSchema -> [Pair]
go) (NonEmpty JSONSchema -> [JSONSchema]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty JSONSchema
jcs)
              val :: JSON.Value
              val :: Value
val = ([Value] -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON :: [JSON.Value] -> JSON.Value) [Value]
svals
           in [(Key
"oneOf", Value
val)]
        (CommentSchema Text
outerComment (CommentSchema Text
innerComment JSONSchema
s)) ->
          JSONSchema -> [Pair]
go (Text -> JSONSchema -> JSONSchema
CommentSchema (Text
outerComment Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
innerComment) JSONSchema
s)
        CommentSchema Text
comment JSONSchema
s -> (Key
"$comment" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= Text
comment) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: JSONSchema -> [Pair]
go JSONSchema
s
        RefSchema Text
name -> [Key
"$ref" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
defsPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name :: Text)]
        WithDefSchema Map Text JSONSchema
defs JSONSchema
s -> (Key
"$defs" Key -> Map Text JSONSchema -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= Map Text JSONSchema
defs) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: JSONSchema -> [Pair]
go JSONSchema
s

instance FromJSON JSONSchema where
  parseJSON :: Value -> Parser JSONSchema
parseJSON = String
-> (Object -> Parser JSONSchema) -> Value -> Parser JSONSchema
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"JSONSchema" ((Object -> Parser JSONSchema) -> Value -> Parser JSONSchema)
-> (Object -> Parser JSONSchema) -> Value -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Maybe Text
mt <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"type"
    Maybe Text
mc <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"$comment"
    let commentFunc :: JSONSchema -> JSONSchema
commentFunc = (JSONSchema -> JSONSchema)
-> (Text -> JSONSchema -> JSONSchema)
-> Maybe Text
-> JSONSchema
-> JSONSchema
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JSONSchema -> JSONSchema
forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mc
    Maybe (Map Text JSONSchema)
mdefs <- Object
o Object -> Key -> Parser (Maybe (Map Text JSONSchema))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"$defs"
    let defsFunc :: JSONSchema -> JSONSchema
defsFunc = (JSONSchema -> JSONSchema)
-> (Map Text JSONSchema -> JSONSchema -> JSONSchema)
-> Maybe (Map Text JSONSchema)
-> JSONSchema
-> JSONSchema
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JSONSchema -> JSONSchema
forall a. a -> a
id Map Text JSONSchema -> JSONSchema -> JSONSchema
WithDefSchema Maybe (Map Text JSONSchema)
mdefs
    (JSONSchema -> JSONSchema)
-> Parser JSONSchema -> Parser JSONSchema
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (JSONSchema -> JSONSchema
commentFunc (JSONSchema -> JSONSchema)
-> (JSONSchema -> JSONSchema) -> JSONSchema -> JSONSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONSchema -> JSONSchema
defsFunc) (Parser JSONSchema -> Parser JSONSchema)
-> Parser JSONSchema -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$ case Maybe Text
mt :: Maybe Text of
      Just Text
"null" -> JSONSchema -> Parser JSONSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
NullSchema
      Just Text
"boolean" -> JSONSchema -> Parser JSONSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
BoolSchema
      Just Text
"string" -> JSONSchema -> Parser JSONSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
StringSchema
      Just Text
"integer" -> do
        Maybe Integer
boundsLower <- Object
o Object -> Key -> Parser (Maybe Integer)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"minimum"
        Maybe Integer
boundsUpper <- Object
o Object -> Key -> Parser (Maybe Integer)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"maximum"
        JSONSchema -> Parser JSONSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> Parser JSONSchema)
-> JSONSchema -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$ Bounds Integer -> JSONSchema
IntegerSchema Bounds {Maybe Integer
boundsLower :: Maybe Integer
boundsUpper :: Maybe Integer
boundsLower :: Maybe Integer
boundsUpper :: Maybe Integer
..}
      Just Text
"number" -> do
        Maybe Scientific
boundsLower <- Object
o Object -> Key -> Parser (Maybe Scientific)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"minimum"
        Maybe Scientific
boundsUpper <- Object
o Object -> Key -> Parser (Maybe Scientific)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"maximum"
        JSONSchema -> Parser JSONSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> Parser JSONSchema)
-> JSONSchema -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$ Bounds Scientific -> JSONSchema
NumberSchema Bounds {Maybe Scientific
boundsLower :: Maybe Scientific
boundsUpper :: Maybe Scientific
boundsLower :: Maybe Scientific
boundsUpper :: Maybe Scientific
..}
      Just Text
"array" -> do
        Maybe JSONSchema
mI <- Object
o Object -> Key -> Parser (Maybe JSONSchema)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"items"
        case Maybe JSONSchema
mI of
          Maybe JSONSchema
Nothing -> JSONSchema -> Parser JSONSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> Parser JSONSchema)
-> JSONSchema -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$ JSONSchema -> JSONSchema
ArraySchema JSONSchema
AnySchema
          Just JSONSchema
is -> JSONSchema -> Parser JSONSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> Parser JSONSchema)
-> JSONSchema -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$ JSONSchema -> JSONSchema
ArraySchema JSONSchema
is
      Just Text
"object" -> do
        Maybe JSONSchema
mAdditional <- Object
o Object -> Key -> Parser (Maybe JSONSchema)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"additionalProperties"
        case Maybe JSONSchema
mAdditional of
          Maybe JSONSchema
Nothing -> ObjectSchema -> JSONSchema
ObjectSchema (ObjectSchema -> JSONSchema)
-> Parser ObjectSchema -> Parser JSONSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser ObjectSchema
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
JSON.Object Object
o)
          Just JSONSchema
additional -> JSONSchema -> Parser JSONSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> Parser JSONSchema)
-> JSONSchema -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$ JSONSchema -> JSONSchema
MapSchema JSONSchema
additional
      Maybe Text
Nothing -> do
        Maybe (NonEmpty JSONSchema)
mAny <- Object
o Object -> Key -> Parser (Maybe (NonEmpty JSONSchema))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"anyOf"
        case Maybe (NonEmpty JSONSchema)
mAny of
          Just NonEmpty JSONSchema
anies -> JSONSchema -> Parser JSONSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> Parser JSONSchema)
-> JSONSchema -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$ NonEmpty JSONSchema -> JSONSchema
AnyOfSchema NonEmpty JSONSchema
anies
          Maybe (NonEmpty JSONSchema)
Nothing -> do
            Maybe (NonEmpty JSONSchema)
mOne <- Object
o Object -> Key -> Parser (Maybe (NonEmpty JSONSchema))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"oneOf"
            case Maybe (NonEmpty JSONSchema)
mOne of
              Just NonEmpty JSONSchema
ones -> JSONSchema -> Parser JSONSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> Parser JSONSchema)
-> JSONSchema -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$ NonEmpty JSONSchema -> JSONSchema
OneOfSchema NonEmpty JSONSchema
ones
              Maybe (NonEmpty JSONSchema)
Nothing -> do
                let mConst :: Maybe Value
mConst = Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
Compat.lookupKey Key
"const" Object
o
                case Maybe Value
mConst of
                  Just Value
constant -> JSONSchema -> Parser JSONSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> Parser JSONSchema)
-> JSONSchema -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$ Value -> JSONSchema
ValueSchema Value
constant
                  Maybe Value
Nothing -> do
                    Maybe Text
mRef <- Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"$ref"
                    JSONSchema -> Parser JSONSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> Parser JSONSchema)
-> JSONSchema -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$ case Maybe Text
mRef of
                      Just Text
ref -> case Text -> Text -> Maybe Text
T.stripPrefix Text
defsPrefix Text
ref of
                        Just Text
name -> Text -> JSONSchema
RefSchema Text
name
                        Maybe Text
Nothing -> JSONSchema
AnySchema
                      Maybe Text
Nothing -> JSONSchema
AnySchema
      Maybe Text
t -> String -> Parser JSONSchema
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser JSONSchema) -> String -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$ String
"unknown schema type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> String
forall a. Show a => a -> String
show Maybe Text
t

data ObjectSchema
  = ObjectKeySchema !Text !KeyRequirement !JSONSchema !(Maybe Text)
  | ObjectAnySchema -- For 'pure'
  | ObjectAnyOfSchema !(NonEmpty ObjectSchema)
  | ObjectOneOfSchema !(NonEmpty ObjectSchema)
  | ObjectAllOfSchema !(NonEmpty ObjectSchema)
  deriving (Int -> ObjectSchema -> ShowS
[ObjectSchema] -> ShowS
ObjectSchema -> String
(Int -> ObjectSchema -> ShowS)
-> (ObjectSchema -> String)
-> ([ObjectSchema] -> ShowS)
-> Show ObjectSchema
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ObjectSchema -> ShowS
showsPrec :: Int -> ObjectSchema -> ShowS
$cshow :: ObjectSchema -> String
show :: ObjectSchema -> String
$cshowList :: [ObjectSchema] -> ShowS
showList :: [ObjectSchema] -> ShowS
Show, ObjectSchema -> ObjectSchema -> Bool
(ObjectSchema -> ObjectSchema -> Bool)
-> (ObjectSchema -> ObjectSchema -> Bool) -> Eq ObjectSchema
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ObjectSchema -> ObjectSchema -> Bool
== :: ObjectSchema -> ObjectSchema -> Bool
$c/= :: ObjectSchema -> ObjectSchema -> Bool
/= :: ObjectSchema -> ObjectSchema -> Bool
Eq, Eq ObjectSchema
Eq ObjectSchema =>
(ObjectSchema -> ObjectSchema -> Ordering)
-> (ObjectSchema -> ObjectSchema -> Bool)
-> (ObjectSchema -> ObjectSchema -> Bool)
-> (ObjectSchema -> ObjectSchema -> Bool)
-> (ObjectSchema -> ObjectSchema -> Bool)
-> (ObjectSchema -> ObjectSchema -> ObjectSchema)
-> (ObjectSchema -> ObjectSchema -> ObjectSchema)
-> Ord ObjectSchema
ObjectSchema -> ObjectSchema -> Bool
ObjectSchema -> ObjectSchema -> Ordering
ObjectSchema -> ObjectSchema -> ObjectSchema
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
$ccompare :: ObjectSchema -> ObjectSchema -> Ordering
compare :: ObjectSchema -> ObjectSchema -> Ordering
$c< :: ObjectSchema -> ObjectSchema -> Bool
< :: ObjectSchema -> ObjectSchema -> Bool
$c<= :: ObjectSchema -> ObjectSchema -> Bool
<= :: ObjectSchema -> ObjectSchema -> Bool
$c> :: ObjectSchema -> ObjectSchema -> Bool
> :: ObjectSchema -> ObjectSchema -> Bool
$c>= :: ObjectSchema -> ObjectSchema -> Bool
>= :: ObjectSchema -> ObjectSchema -> Bool
$cmax :: ObjectSchema -> ObjectSchema -> ObjectSchema
max :: ObjectSchema -> ObjectSchema -> ObjectSchema
$cmin :: ObjectSchema -> ObjectSchema -> ObjectSchema
min :: ObjectSchema -> ObjectSchema -> ObjectSchema
Ord, (forall x. ObjectSchema -> Rep ObjectSchema x)
-> (forall x. Rep ObjectSchema x -> ObjectSchema)
-> Generic ObjectSchema
forall x. Rep ObjectSchema x -> ObjectSchema
forall x. ObjectSchema -> Rep ObjectSchema x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ObjectSchema -> Rep ObjectSchema x
from :: forall x. ObjectSchema -> Rep ObjectSchema x
$cto :: forall x. Rep ObjectSchema x -> ObjectSchema
to :: forall x. Rep ObjectSchema x -> ObjectSchema
Generic)

instance Validity ObjectSchema

instance FromJSON ObjectSchema where
  parseJSON :: Value -> Parser ObjectSchema
parseJSON = String
-> (Object -> Parser ObjectSchema) -> Value -> Parser ObjectSchema
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"ObjectSchema" Object -> Parser ObjectSchema
go
    where
      go :: JSON.Object -> JSON.Parser ObjectSchema
      go :: Object -> Parser ObjectSchema
go Object
o = do
        Text
t <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"type"
        Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== (Text
"object" :: Text)
        Maybe Value
mAllOf <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"allOf"
        case Maybe Value
mAllOf of
          Just Value
ao -> do
            NonEmpty Object
ne <- Value -> Parser (NonEmpty Object)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
ao
            NonEmpty ObjectSchema -> ObjectSchema
ObjectAllOfSchema (NonEmpty ObjectSchema -> ObjectSchema)
-> Parser (NonEmpty ObjectSchema) -> Parser ObjectSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object -> Parser ObjectSchema)
-> NonEmpty Object -> Parser (NonEmpty ObjectSchema)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM Object -> Parser ObjectSchema
go NonEmpty Object
ne
          Maybe Value
Nothing -> do
            Maybe Value
mAnyOf <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"anyOf"
            case Maybe Value
mAnyOf of
              Just Value
anies -> do
                NonEmpty Object
ne <- Value -> Parser (NonEmpty Object)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
anies
                NonEmpty ObjectSchema -> ObjectSchema
ObjectAnyOfSchema (NonEmpty ObjectSchema -> ObjectSchema)
-> Parser (NonEmpty ObjectSchema) -> Parser ObjectSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object -> Parser ObjectSchema)
-> NonEmpty Object -> Parser (NonEmpty ObjectSchema)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM Object -> Parser ObjectSchema
go NonEmpty Object
ne
              Maybe Value
Nothing -> do
                Maybe Value
mOneOf <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"oneOf"
                case Maybe Value
mOneOf of
                  Just Value
ones -> do
                    NonEmpty Object
ne <- Value -> Parser (NonEmpty Object)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
ones
                    NonEmpty ObjectSchema -> ObjectSchema
ObjectOneOfSchema (NonEmpty ObjectSchema -> ObjectSchema)
-> Parser (NonEmpty ObjectSchema) -> Parser ObjectSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object -> Parser ObjectSchema)
-> NonEmpty Object -> Parser (NonEmpty ObjectSchema)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM Object -> Parser ObjectSchema
go NonEmpty Object
ne
                  Maybe Value
Nothing -> do
                    HashMap Text Value
props <- Object
o Object -> Key -> Parser (Maybe (HashMap Text Value))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"properties" Parser (Maybe (HashMap Text Value))
-> HashMap Text Value -> Parser (HashMap Text Value)
forall a. Parser (Maybe a) -> a -> Parser a
JSON..!= HashMap Text Value
forall k v. HashMap k v
HM.empty
                    [Text]
reqs <- Object
o Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"required" Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
JSON..!= []
                    let keySchemaFor :: Text -> Value -> Parser ObjectSchema
keySchemaFor Text
k Value
v = do
                          JSONSchema
ks <- Value -> Parser JSONSchema
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
                          let (Maybe Text
mDoc, JSONSchema
ks') = case JSONSchema
ks of
                                CommentSchema Text
doc JSONSchema
ks'' -> (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
doc, JSONSchema
ks'')
                                JSONSchema
_ -> (Maybe Text
forall a. Maybe a
Nothing, JSONSchema
ks)
                          ObjectSchema -> Parser ObjectSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectSchema -> Parser ObjectSchema)
-> ObjectSchema -> Parser ObjectSchema
forall a b. (a -> b) -> a -> b
$
                            if Text
k Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
reqs
                              then Text -> KeyRequirement -> JSONSchema -> Maybe Text -> ObjectSchema
ObjectKeySchema Text
k KeyRequirement
Required JSONSchema
ks' Maybe Text
mDoc
                              else Text -> KeyRequirement -> JSONSchema -> Maybe Text -> ObjectSchema
ObjectKeySchema Text
k (Maybe Value -> KeyRequirement
Optional Maybe Value
forall a. Maybe a
Nothing) JSONSchema
ks' Maybe Text
mDoc
                    [ObjectSchema]
keySchemas <- ((Text, Value) -> Parser ObjectSchema)
-> [(Text, Value)] -> Parser [ObjectSchema]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Text -> Value -> Parser ObjectSchema)
-> (Text, Value) -> Parser ObjectSchema
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Value -> Parser ObjectSchema
keySchemaFor) (HashMap Text Value -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Text Value
props)
                    ObjectSchema -> Parser ObjectSchema
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectSchema -> Parser ObjectSchema)
-> ObjectSchema -> Parser ObjectSchema
forall a b. (a -> b) -> a -> b
$ case [ObjectSchema] -> Maybe (NonEmpty ObjectSchema)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [ObjectSchema]
keySchemas of
                      Maybe (NonEmpty ObjectSchema)
Nothing -> ObjectSchema
ObjectAnySchema
                      Just (ObjectSchema
el :| []) -> ObjectSchema
el
                      Just NonEmpty ObjectSchema
ne -> NonEmpty ObjectSchema -> ObjectSchema
ObjectAllOfSchema NonEmpty ObjectSchema
ne

instance ToJSON ObjectSchema where
  toJSON :: ObjectSchema -> Value
toJSON = [Pair] -> Value
JSON.object ([Pair] -> Value)
-> (ObjectSchema -> [Pair]) -> ObjectSchema -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"object" :: Text)) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
:) ([Pair] -> [Pair])
-> (ObjectSchema -> [Pair]) -> ObjectSchema -> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectSchema -> [Pair]
go
    where
      go :: ObjectSchema -> [JSON.Pair]
      go :: ObjectSchema -> [Pair]
go = \case
        ObjectSchema
ObjectAnySchema -> []
        ObjectKeySchema Text
k KeyRequirement
kr JSONSchema
ks Maybe Text
mDoc ->
          let (Value
propVal, Bool
req) = (Text, KeyRequirement, JSONSchema, Maybe Text) -> (Value, Bool)
keySchemaToPieces (Text
k, KeyRequirement
kr, JSONSchema
ks, Maybe Text
mDoc)
           in -- TODO deal with the default value somehow.
              [[Pair]] -> [Pair]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Key
"properties" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= [Pair] -> Value
JSON.object [Text -> Key
Compat.toKey Text
k Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= Value
propVal]], [Key
"required" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= [Text
k] | Bool
req]]
        ObjectAnyOfSchema NonEmpty ObjectSchema
ne -> [Key
"anyOf" Key -> NonEmpty Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (ObjectSchema -> Value) -> NonEmpty ObjectSchema -> NonEmpty Value
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ObjectSchema -> Value
forall a. ToJSON a => a -> Value
toJSON NonEmpty ObjectSchema
ne]
        ObjectOneOfSchema NonEmpty ObjectSchema
ne -> [Key
"oneOf" Key -> NonEmpty Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (ObjectSchema -> Value) -> NonEmpty ObjectSchema -> NonEmpty Value
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ObjectSchema -> Value
forall a. ToJSON a => a -> Value
toJSON NonEmpty ObjectSchema
ne]
        ObjectAllOfSchema NonEmpty ObjectSchema
ne ->
          case (ObjectSchema
 -> Maybe [(Text, KeyRequirement, JSONSchema, Maybe Text)])
-> [ObjectSchema]
-> Maybe [[(Text, KeyRequirement, JSONSchema, Maybe Text)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ObjectSchema
-> Maybe [(Text, KeyRequirement, JSONSchema, Maybe Text)]
parseAndObjectKeySchema (NonEmpty ObjectSchema -> [ObjectSchema]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty ObjectSchema
ne) of
            Maybe [[(Text, KeyRequirement, JSONSchema, Maybe Text)]]
Nothing -> [Key
"allOf" Key -> NonEmpty Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (ObjectSchema -> Value) -> NonEmpty ObjectSchema -> NonEmpty Value
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ObjectSchema -> Value
forall a. ToJSON a => a -> Value
toJSON NonEmpty ObjectSchema
ne]
            Just [[(Text, KeyRequirement, JSONSchema, Maybe Text)]]
ne' ->
              let f :: (HashMap Text Value, [Text])
-> (Text, KeyRequirement, JSONSchema, Maybe Text)
-> (HashMap Text Value, [Text])
f (HashMap Text Value
hm, [Text]
l) tup :: (Text, KeyRequirement, JSONSchema, Maybe Text)
tup@(Text
k, KeyRequirement
_, JSONSchema
_, Maybe Text
_) =
                    let (Value
propVal, Bool
req) = (Text, KeyRequirement, JSONSchema, Maybe Text) -> (Value, Bool)
keySchemaToPieces (Text, KeyRequirement, JSONSchema, Maybe Text)
tup
                     in (Text -> Value -> HashMap Text Value -> HashMap Text Value
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
k Value
propVal HashMap Text Value
hm, if Bool
req then Text
k Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
l else [Text]
l)
                  (HashMap Text Value
propValMap, [Text]
reqs) = ((HashMap Text Value, [Text])
 -> (Text, KeyRequirement, JSONSchema, Maybe Text)
 -> (HashMap Text Value, [Text]))
-> (HashMap Text Value, [Text])
-> [(Text, KeyRequirement, JSONSchema, Maybe Text)]
-> (HashMap Text Value, [Text])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (HashMap Text Value, [Text])
-> (Text, KeyRequirement, JSONSchema, Maybe Text)
-> (HashMap Text Value, [Text])
f (HashMap Text Value
forall k v. HashMap k v
HM.empty, []) ([[(Text, KeyRequirement, JSONSchema, Maybe Text)]]
-> [(Text, KeyRequirement, JSONSchema, Maybe Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Text, KeyRequirement, JSONSchema, Maybe Text)]]
ne')
               in [[Pair]] -> [Pair]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Key
"properties" Key -> HashMap Text Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= HashMap Text Value
propValMap], [Key
"required" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= [Text]
reqs | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
reqs]]

      keySchemaToPieces :: (Text, KeyRequirement, JSONSchema, Maybe Text) -> (JSON.Value, Bool)
      keySchemaToPieces :: (Text, KeyRequirement, JSONSchema, Maybe Text) -> (Value, Bool)
keySchemaToPieces (Text
_, KeyRequirement
kr, JSONSchema
ks, Maybe Text
mDoc) =
        let propVal :: Value
propVal = JSONSchema -> Value
forall a. ToJSON a => a -> Value
toJSON ((JSONSchema -> JSONSchema)
-> (Text -> JSONSchema -> JSONSchema)
-> Maybe Text
-> JSONSchema
-> JSONSchema
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JSONSchema -> JSONSchema
forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mDoc JSONSchema
ks)
         in (Value
propVal, KeyRequirement
kr KeyRequirement -> KeyRequirement -> Bool
forall a. Eq a => a -> a -> Bool
== KeyRequirement
Required)

      parseAndObjectKeySchema :: ObjectSchema -> Maybe [(Text, KeyRequirement, JSONSchema, Maybe Text)]
      parseAndObjectKeySchema :: ObjectSchema
-> Maybe [(Text, KeyRequirement, JSONSchema, Maybe Text)]
parseAndObjectKeySchema = \case
        ObjectKeySchema Text
k KeyRequirement
kr JSONSchema
ks Maybe Text
mDoc -> [(Text, KeyRequirement, JSONSchema, Maybe Text)]
-> Maybe [(Text, KeyRequirement, JSONSchema, Maybe Text)]
forall a. a -> Maybe a
Just [(Text
k, KeyRequirement
kr, JSONSchema
ks, Maybe Text
mDoc)]
        ObjectAllOfSchema NonEmpty ObjectSchema
os -> NonEmpty [(Text, KeyRequirement, JSONSchema, Maybe Text)]
-> [(Text, KeyRequirement, JSONSchema, Maybe Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (NonEmpty [(Text, KeyRequirement, JSONSchema, Maybe Text)]
 -> [(Text, KeyRequirement, JSONSchema, Maybe Text)])
-> Maybe
     (NonEmpty [(Text, KeyRequirement, JSONSchema, Maybe Text)])
-> Maybe [(Text, KeyRequirement, JSONSchema, Maybe Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ObjectSchema
 -> Maybe [(Text, KeyRequirement, JSONSchema, Maybe Text)])
-> NonEmpty ObjectSchema
-> Maybe
     (NonEmpty [(Text, KeyRequirement, JSONSchema, Maybe Text)])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM ObjectSchema
-> Maybe [(Text, KeyRequirement, JSONSchema, Maybe Text)]
parseAndObjectKeySchema NonEmpty ObjectSchema
os
        ObjectSchema
_ -> Maybe [(Text, KeyRequirement, JSONSchema, Maybe Text)]
forall a. Maybe a
Nothing

defsPrefix :: Text
defsPrefix :: Text
defsPrefix = Text
"#/$defs/"

data KeyRequirement
  = Required
  | Optional !(Maybe JSON.Value) -- Default value
  deriving (Int -> KeyRequirement -> ShowS
[KeyRequirement] -> ShowS
KeyRequirement -> String
(Int -> KeyRequirement -> ShowS)
-> (KeyRequirement -> String)
-> ([KeyRequirement] -> ShowS)
-> Show KeyRequirement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyRequirement -> ShowS
showsPrec :: Int -> KeyRequirement -> ShowS
$cshow :: KeyRequirement -> String
show :: KeyRequirement -> String
$cshowList :: [KeyRequirement] -> ShowS
showList :: [KeyRequirement] -> ShowS
Show, KeyRequirement -> KeyRequirement -> Bool
(KeyRequirement -> KeyRequirement -> Bool)
-> (KeyRequirement -> KeyRequirement -> Bool) -> Eq KeyRequirement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyRequirement -> KeyRequirement -> Bool
== :: KeyRequirement -> KeyRequirement -> Bool
$c/= :: KeyRequirement -> KeyRequirement -> Bool
/= :: KeyRequirement -> KeyRequirement -> Bool
Eq, Eq KeyRequirement
Eq KeyRequirement =>
(KeyRequirement -> KeyRequirement -> Ordering)
-> (KeyRequirement -> KeyRequirement -> Bool)
-> (KeyRequirement -> KeyRequirement -> Bool)
-> (KeyRequirement -> KeyRequirement -> Bool)
-> (KeyRequirement -> KeyRequirement -> Bool)
-> (KeyRequirement -> KeyRequirement -> KeyRequirement)
-> (KeyRequirement -> KeyRequirement -> KeyRequirement)
-> Ord KeyRequirement
KeyRequirement -> KeyRequirement -> Bool
KeyRequirement -> KeyRequirement -> Ordering
KeyRequirement -> KeyRequirement -> KeyRequirement
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
$ccompare :: KeyRequirement -> KeyRequirement -> Ordering
compare :: KeyRequirement -> KeyRequirement -> Ordering
$c< :: KeyRequirement -> KeyRequirement -> Bool
< :: KeyRequirement -> KeyRequirement -> Bool
$c<= :: KeyRequirement -> KeyRequirement -> Bool
<= :: KeyRequirement -> KeyRequirement -> Bool
$c> :: KeyRequirement -> KeyRequirement -> Bool
> :: KeyRequirement -> KeyRequirement -> Bool
$c>= :: KeyRequirement -> KeyRequirement -> Bool
>= :: KeyRequirement -> KeyRequirement -> Bool
$cmax :: KeyRequirement -> KeyRequirement -> KeyRequirement
max :: KeyRequirement -> KeyRequirement -> KeyRequirement
$cmin :: KeyRequirement -> KeyRequirement -> KeyRequirement
min :: KeyRequirement -> KeyRequirement -> KeyRequirement
Ord, (forall x. KeyRequirement -> Rep KeyRequirement x)
-> (forall x. Rep KeyRequirement x -> KeyRequirement)
-> Generic KeyRequirement
forall x. Rep KeyRequirement x -> KeyRequirement
forall x. KeyRequirement -> Rep KeyRequirement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. KeyRequirement -> Rep KeyRequirement x
from :: forall x. KeyRequirement -> Rep KeyRequirement x
$cto :: forall x. Rep KeyRequirement x -> KeyRequirement
to :: forall x. Rep KeyRequirement x -> KeyRequirement
Generic)

instance Validity KeyRequirement

jsonSchemaViaCodec :: forall a. (HasCodec a) => JSONSchema
jsonSchemaViaCodec :: forall a. HasCodec a => JSONSchema
jsonSchemaViaCodec = ValueCodec a a -> JSONSchema
forall input output. ValueCodec input output -> JSONSchema
jsonSchemaVia (forall value. HasCodec value => JSONCodec value
codec @a)

jsonSchemaVia :: ValueCodec input output -> JSONSchema
jsonSchemaVia :: forall input output. ValueCodec input output -> JSONSchema
jsonSchemaVia = (State (Set Text) JSONSchema -> Set Text -> JSONSchema
forall s a. State s a -> s -> a
`evalState` Set Text
forall a. Set a
S.empty) (State (Set Text) JSONSchema -> JSONSchema)
-> (ValueCodec input output -> State (Set Text) JSONSchema)
-> ValueCodec input output
-> JSONSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueCodec input output -> State (Set Text) JSONSchema
forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue

jsonObjectSchemaViaCodec :: forall a. (HasObjectCodec a) => ObjectSchema
jsonObjectSchemaViaCodec :: forall a. HasObjectCodec a => ObjectSchema
jsonObjectSchemaViaCodec = ObjectCodec a a -> ObjectSchema
forall input output. ObjectCodec input output -> ObjectSchema
jsonObjectSchemaVia (forall object. HasObjectCodec object => JSONObjectCodec object
objectCodec @a)

jsonObjectSchemaVia :: ObjectCodec input output -> ObjectSchema
jsonObjectSchemaVia :: forall input output. ObjectCodec input output -> ObjectSchema
jsonObjectSchemaVia = (State (Set Text) ObjectSchema -> Set Text -> ObjectSchema
forall s a. State s a -> s -> a
`evalState` Set Text
forall a. Set a
S.empty) (State (Set Text) ObjectSchema -> ObjectSchema)
-> (ObjectCodec input output -> State (Set Text) ObjectSchema)
-> ObjectCodec input output
-> ObjectSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectCodec input output -> State (Set Text) ObjectSchema
forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject

goValue :: ValueCodec input output -> State (Set Text) JSONSchema
goValue :: forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue = \case
  ValueCodec input output
NullCodec -> JSONSchema -> State (Set Text) JSONSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
NullSchema
  BoolCodec Maybe Text
mname -> JSONSchema -> State (Set Text) JSONSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> State (Set Text) JSONSchema)
-> JSONSchema -> State (Set Text) JSONSchema
forall a b. (a -> b) -> a -> b
$ (JSONSchema -> JSONSchema)
-> (Text -> JSONSchema -> JSONSchema)
-> Maybe Text
-> JSONSchema
-> JSONSchema
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JSONSchema -> JSONSchema
forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mname JSONSchema
BoolSchema
  StringCodec Maybe Text
mname -> JSONSchema -> State (Set Text) JSONSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> State (Set Text) JSONSchema)
-> JSONSchema -> State (Set Text) JSONSchema
forall a b. (a -> b) -> a -> b
$ (JSONSchema -> JSONSchema)
-> (Text -> JSONSchema -> JSONSchema)
-> Maybe Text
-> JSONSchema
-> JSONSchema
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JSONSchema -> JSONSchema
forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mname JSONSchema
StringSchema
  IntegerCodec Maybe Text
mname Bounds Integer
mBounds -> JSONSchema -> State (Set Text) JSONSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> State (Set Text) JSONSchema)
-> JSONSchema -> State (Set Text) JSONSchema
forall a b. (a -> b) -> a -> b
$ (JSONSchema -> JSONSchema)
-> (Text -> JSONSchema -> JSONSchema)
-> Maybe Text
-> JSONSchema
-> JSONSchema
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JSONSchema -> JSONSchema
forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mname (JSONSchema -> JSONSchema) -> JSONSchema -> JSONSchema
forall a b. (a -> b) -> a -> b
$ Bounds Integer -> JSONSchema
IntegerSchema Bounds Integer
mBounds
  NumberCodec Maybe Text
mname Bounds Scientific
mBounds -> JSONSchema -> State (Set Text) JSONSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> State (Set Text) JSONSchema)
-> JSONSchema -> State (Set Text) JSONSchema
forall a b. (a -> b) -> a -> b
$ (JSONSchema -> JSONSchema)
-> (Text -> JSONSchema -> JSONSchema)
-> Maybe Text
-> JSONSchema
-> JSONSchema
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JSONSchema -> JSONSchema
forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mname (JSONSchema -> JSONSchema) -> JSONSchema -> JSONSchema
forall a b. (a -> b) -> a -> b
$ Bounds Scientific -> JSONSchema
NumberSchema Bounds Scientific
mBounds
  ArrayOfCodec Maybe Text
mname ValueCodec input1 output1
c -> do
    JSONSchema
s <- ValueCodec input1 output1 -> State (Set Text) JSONSchema
forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue ValueCodec input1 output1
c
    JSONSchema -> State (Set Text) JSONSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> State (Set Text) JSONSchema)
-> JSONSchema -> State (Set Text) JSONSchema
forall a b. (a -> b) -> a -> b
$ (JSONSchema -> JSONSchema)
-> (Text -> JSONSchema -> JSONSchema)
-> Maybe Text
-> JSONSchema
-> JSONSchema
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JSONSchema -> JSONSchema
forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mname (JSONSchema -> JSONSchema) -> JSONSchema -> JSONSchema
forall a b. (a -> b) -> a -> b
$ JSONSchema -> JSONSchema
ArraySchema JSONSchema
s
  ObjectOfCodec Maybe Text
mname ObjectCodec input output
oc -> do
    ObjectSchema
s <- ObjectCodec input output -> State (Set Text) ObjectSchema
forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject ObjectCodec input output
oc
    JSONSchema -> State (Set Text) JSONSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> State (Set Text) JSONSchema)
-> JSONSchema -> State (Set Text) JSONSchema
forall a b. (a -> b) -> a -> b
$ (JSONSchema -> JSONSchema)
-> (Text -> JSONSchema -> JSONSchema)
-> Maybe Text
-> JSONSchema
-> JSONSchema
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JSONSchema -> JSONSchema
forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mname (JSONSchema -> JSONSchema) -> JSONSchema -> JSONSchema
forall a b. (a -> b) -> a -> b
$ ObjectSchema -> JSONSchema
ObjectSchema ObjectSchema
s
  HashMapCodec JSONCodec v
c -> JSONSchema -> JSONSchema
MapSchema (JSONSchema -> JSONSchema)
-> State (Set Text) JSONSchema -> State (Set Text) JSONSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSONCodec v -> State (Set Text) JSONSchema
forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue JSONCodec v
c
  MapCodec JSONCodec v
c -> JSONSchema -> JSONSchema
MapSchema (JSONSchema -> JSONSchema)
-> State (Set Text) JSONSchema -> State (Set Text) JSONSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSONCodec v -> State (Set Text) JSONSchema
forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue JSONCodec v
c
  ValueCodec input output
ValueCodec -> JSONSchema -> State (Set Text) JSONSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
AnySchema
  EqCodec value
value JSONCodec value
c -> JSONSchema -> State (Set Text) JSONSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> State (Set Text) JSONSchema)
-> JSONSchema -> State (Set Text) JSONSchema
forall a b. (a -> b) -> a -> b
$ Value -> JSONSchema
ValueSchema (JSONCodec value -> value -> Value
forall a void. ValueCodec a void -> a -> Value
toJSONVia JSONCodec value
c value
value)
  EitherCodec Union
u Codec Value input1 output1
c1 Codec Value input2 output2
c2 -> do
    JSONSchema
s1 <- Codec Value input1 output1 -> State (Set Text) JSONSchema
forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue Codec Value input1 output1
c1
    JSONSchema
s2 <- Codec Value input2 output2 -> State (Set Text) JSONSchema
forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue Codec Value input2 output2
c2
    JSONSchema -> State (Set Text) JSONSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> State (Set Text) JSONSchema)
-> JSONSchema -> State (Set Text) JSONSchema
forall a b. (a -> b) -> a -> b
$ case Union
u of
      Union
DisjointUnion -> NonEmpty JSONSchema -> JSONSchema
OneOfSchema (NonEmpty JSONSchema -> NonEmpty JSONSchema
goOneOf (JSONSchema
s1 JSONSchema -> [JSONSchema] -> NonEmpty JSONSchema
forall a. a -> [a] -> NonEmpty a
:| [JSONSchema
s2]))
      Union
PossiblyJointUnion -> NonEmpty JSONSchema -> JSONSchema
AnyOfSchema (NonEmpty JSONSchema -> NonEmpty JSONSchema
goAnyOf (JSONSchema
s1 JSONSchema -> [JSONSchema] -> NonEmpty JSONSchema
forall a. a -> [a] -> NonEmpty a
:| [JSONSchema
s2]))
  BimapCodec oldOutput -> Either String output
_ input -> oldInput
_ Codec Value oldInput oldOutput
c -> Codec Value oldInput oldOutput -> State (Set Text) JSONSchema
forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue Codec Value oldInput oldOutput
c
  CommentCodec Text
t ValueCodec input output
c -> Text -> JSONSchema -> JSONSchema
CommentSchema Text
t (JSONSchema -> JSONSchema)
-> State (Set Text) JSONSchema -> State (Set Text) JSONSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueCodec input output -> State (Set Text) JSONSchema
forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue ValueCodec input output
c
  ReferenceCodec Text
name ValueCodec input output
c -> do
    Bool
alreadySeen <- (Set Text -> Bool) -> StateT (Set Text) Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Text
name)
    if Bool
alreadySeen
      then JSONSchema -> State (Set Text) JSONSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> State (Set Text) JSONSchema)
-> JSONSchema -> State (Set Text) JSONSchema
forall a b. (a -> b) -> a -> b
$ Text -> JSONSchema
RefSchema Text
name
      else do
        (Set Text -> Set Text) -> StateT (Set Text) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
S.insert Text
name)
        JSONSchema
s <- ValueCodec input output -> State (Set Text) JSONSchema
forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue ValueCodec input output
c
        JSONSchema -> State (Set Text) JSONSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> State (Set Text) JSONSchema)
-> JSONSchema -> State (Set Text) JSONSchema
forall a b. (a -> b) -> a -> b
$ Map Text JSONSchema -> JSONSchema -> JSONSchema
WithDefSchema (Text -> JSONSchema -> Map Text JSONSchema
forall k a. k -> a -> Map k a
M.singleton Text
name JSONSchema
s) (Text -> JSONSchema
RefSchema Text
name)
  where
    goAnyOf :: NonEmpty JSONSchema -> NonEmpty JSONSchema
    goAnyOf :: NonEmpty JSONSchema -> NonEmpty JSONSchema
goAnyOf (JSONSchema
s :| [JSONSchema]
rest) = case [JSONSchema] -> Maybe (NonEmpty JSONSchema)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [JSONSchema]
rest of
      Maybe (NonEmpty JSONSchema)
Nothing -> JSONSchema -> NonEmpty JSONSchema
goSingle JSONSchema
s
      Just NonEmpty JSONSchema
ne -> JSONSchema -> NonEmpty JSONSchema
goSingle JSONSchema
s NonEmpty JSONSchema -> NonEmpty JSONSchema -> NonEmpty JSONSchema
forall a. Semigroup a => a -> a -> a
<> NonEmpty JSONSchema -> NonEmpty JSONSchema
goAnyOf NonEmpty JSONSchema
ne
      where
        goSingle :: JSONSchema -> NonEmpty JSONSchema
        goSingle :: JSONSchema -> NonEmpty JSONSchema
goSingle = \case
          AnyOfSchema NonEmpty JSONSchema
ss -> NonEmpty JSONSchema -> NonEmpty JSONSchema
goAnyOf NonEmpty JSONSchema
ss
          JSONSchema
s' -> JSONSchema
s' JSONSchema -> [JSONSchema] -> NonEmpty JSONSchema
forall a. a -> [a] -> NonEmpty a
:| []
    goOneOf :: NonEmpty JSONSchema -> NonEmpty JSONSchema
    goOneOf :: NonEmpty JSONSchema -> NonEmpty JSONSchema
goOneOf (JSONSchema
s :| [JSONSchema]
rest) = case [JSONSchema] -> Maybe (NonEmpty JSONSchema)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [JSONSchema]
rest of
      Maybe (NonEmpty JSONSchema)
Nothing -> JSONSchema -> NonEmpty JSONSchema
goSingle JSONSchema
s
      Just NonEmpty JSONSchema
ne -> JSONSchema -> NonEmpty JSONSchema
goSingle JSONSchema
s NonEmpty JSONSchema -> NonEmpty JSONSchema -> NonEmpty JSONSchema
forall a. Semigroup a => a -> a -> a
<> NonEmpty JSONSchema -> NonEmpty JSONSchema
goOneOf NonEmpty JSONSchema
ne
      where
        goSingle :: JSONSchema -> NonEmpty JSONSchema
        goSingle :: JSONSchema -> NonEmpty JSONSchema
goSingle = \case
          OneOfSchema NonEmpty JSONSchema
ss -> NonEmpty JSONSchema -> NonEmpty JSONSchema
goOneOf NonEmpty JSONSchema
ss
          JSONSchema
s' -> JSONSchema
s' JSONSchema -> [JSONSchema] -> NonEmpty JSONSchema
forall a. a -> [a] -> NonEmpty a
:| []

goObject :: ObjectCodec input output -> State (Set Text) ObjectSchema
goObject :: forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject = \case
  RequiredKeyCodec Text
k ValueCodec input output
c Maybe Text
mdoc -> do
    JSONSchema
s <- ValueCodec input output -> State (Set Text) JSONSchema
forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue ValueCodec input output
c
    ObjectSchema -> State (Set Text) ObjectSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectSchema -> State (Set Text) ObjectSchema)
-> ObjectSchema -> State (Set Text) ObjectSchema
forall a b. (a -> b) -> a -> b
$ Text -> KeyRequirement -> JSONSchema -> Maybe Text -> ObjectSchema
ObjectKeySchema Text
k KeyRequirement
Required JSONSchema
s Maybe Text
mdoc
  OptionalKeyCodec Text
k ValueCodec input1 output1
c Maybe Text
mdoc -> do
    JSONSchema
s <- ValueCodec input1 output1 -> State (Set Text) JSONSchema
forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue ValueCodec input1 output1
c
    ObjectSchema -> State (Set Text) ObjectSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectSchema -> State (Set Text) ObjectSchema)
-> ObjectSchema -> State (Set Text) ObjectSchema
forall a b. (a -> b) -> a -> b
$ Text -> KeyRequirement -> JSONSchema -> Maybe Text -> ObjectSchema
ObjectKeySchema Text
k (Maybe Value -> KeyRequirement
Optional Maybe Value
forall a. Maybe a
Nothing) JSONSchema
s Maybe Text
mdoc
  OptionalKeyWithDefaultCodec Text
k ValueCodec input input
c input
mr Maybe Text
mdoc -> do
    JSONSchema
s <- ValueCodec input input -> State (Set Text) JSONSchema
forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
goValue ValueCodec input input
c
    ObjectSchema -> State (Set Text) ObjectSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectSchema -> State (Set Text) ObjectSchema)
-> ObjectSchema -> State (Set Text) ObjectSchema
forall a b. (a -> b) -> a -> b
$ Text -> KeyRequirement -> JSONSchema -> Maybe Text -> ObjectSchema
ObjectKeySchema Text
k (Maybe Value -> KeyRequirement
Optional (Value -> Maybe Value
forall a. a -> Maybe a
Just (ValueCodec input input -> input -> Value
forall a void. ValueCodec a void -> a -> Value
toJSONVia ValueCodec input input
c input
mr))) JSONSchema
s Maybe Text
mdoc
  OptionalKeyWithOmittedDefaultCodec Text
k ValueCodec value value
c value
defaultValue Maybe Text
mDoc -> ObjectCodec value value -> State (Set Text) ObjectSchema
forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject (Text
-> ValueCodec value value
-> value
-> Maybe Text
-> ObjectCodec value value
forall value.
Text
-> ValueCodec value value
-> value
-> Maybe Text
-> ObjectCodec value value
optionalKeyWithDefaultCodec Text
k ValueCodec value value
c value
defaultValue Maybe Text
mDoc)
  BimapCodec oldOutput -> Either String output
_ input -> oldInput
_ Codec Object oldInput oldOutput
c -> Codec Object oldInput oldOutput -> State (Set Text) ObjectSchema
forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject Codec Object oldInput oldOutput
c
  EitherCodec Union
u Codec Object input1 output1
oc1 Codec Object input2 output2
oc2 -> do
    ObjectSchema
os1 <- Codec Object input1 output1 -> State (Set Text) ObjectSchema
forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject Codec Object input1 output1
oc1
    ObjectSchema
os2 <- Codec Object input2 output2 -> State (Set Text) ObjectSchema
forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject Codec Object input2 output2
oc2
    ObjectSchema -> State (Set Text) ObjectSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectSchema -> State (Set Text) ObjectSchema)
-> ObjectSchema -> State (Set Text) ObjectSchema
forall a b. (a -> b) -> a -> b
$ case Union
u of
      Union
DisjointUnion -> NonEmpty ObjectSchema -> ObjectSchema
ObjectOneOfSchema (NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectOneOf (ObjectSchema
os1 ObjectSchema -> [ObjectSchema] -> NonEmpty ObjectSchema
forall a. a -> [a] -> NonEmpty a
:| [ObjectSchema
os2]))
      Union
PossiblyJointUnion -> NonEmpty ObjectSchema -> ObjectSchema
ObjectAnyOfSchema (NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectAnyOf (ObjectSchema
os1 ObjectSchema -> [ObjectSchema] -> NonEmpty ObjectSchema
forall a. a -> [a] -> NonEmpty a
:| [ObjectSchema
os2]))
  DiscriminatedUnionCodec Text
pn input -> (Text, ObjectCodec input ())
_ HashMap Text (Text, ObjectCodec Void output)
m -> do
    let mkSchema :: Text
-> (Text, ObjectCodec Void output) -> State (Set Text) ObjectSchema
mkSchema Text
dName (Text
_, ObjectCodec Void output
oc) =
          ObjectCodec Void Text -> State (Set Text) ObjectSchema
forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject (ObjectCodec Void Text -> State (Set Text) ObjectSchema)
-> ObjectCodec Void Text -> State (Set Text) ObjectSchema
forall a b. (a -> b) -> a -> b
$ ObjectCodec Void output
oc ObjectCodec Void output
-> ObjectCodec Void Text -> ObjectCodec Void Text
forall a b.
Codec Object Void a -> Codec Object Void b -> Codec Object Void b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> ValueCodec Text Text -> ObjectCodec Text Text
forall input output.
Text -> ValueCodec input output -> ObjectCodec input output
requiredFieldWith' Text
pn (Text -> ValueCodec Text Text
literalTextCodec Text
dName) ObjectCodec Text Text -> (Void -> Text) -> ObjectCodec Void Text
forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
.= Text -> Void -> Text
forall a b. a -> b -> a
const Text
dName)
    HashMap Text ObjectSchema
ss <- (Text
 -> (Text, ObjectCodec Void output)
 -> State (Set Text) ObjectSchema)
-> HashMap Text (Text, ObjectCodec Void output)
-> StateT (Set Text) Identity (HashMap Text ObjectSchema)
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HM.traverseWithKey Text
-> (Text, ObjectCodec Void output) -> State (Set Text) ObjectSchema
mkSchema HashMap Text (Text, ObjectCodec Void output)
m
    ObjectSchema -> State (Set Text) ObjectSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectSchema -> State (Set Text) ObjectSchema)
-> ObjectSchema -> State (Set Text) ObjectSchema
forall a b. (a -> b) -> a -> b
$ case [ObjectSchema] -> Maybe (NonEmpty ObjectSchema)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([ObjectSchema] -> Maybe (NonEmpty ObjectSchema))
-> [ObjectSchema] -> Maybe (NonEmpty ObjectSchema)
forall a b. (a -> b) -> a -> b
$ HashMap Text ObjectSchema -> [ObjectSchema]
forall a. HashMap Text a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashMap Text ObjectSchema
ss of
      Maybe (NonEmpty ObjectSchema)
Nothing -> ObjectSchema
ObjectAnySchema
      Just NonEmpty ObjectSchema
ss' -> NonEmpty ObjectSchema -> ObjectSchema
ObjectOneOfSchema (NonEmpty ObjectSchema -> ObjectSchema)
-> NonEmpty ObjectSchema -> ObjectSchema
forall a b. (a -> b) -> a -> b
$ NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectOneOf NonEmpty ObjectSchema
ss'
  PureCodec output
_ -> ObjectSchema -> State (Set Text) ObjectSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ObjectSchema
ObjectAnySchema
  ApCodec ObjectCodec input (output1 -> output)
oc1 ObjectCodec input output1
oc2 -> do
    ObjectSchema
os1 <- ObjectCodec input (output1 -> output)
-> State (Set Text) ObjectSchema
forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject ObjectCodec input (output1 -> output)
oc1
    ObjectSchema
os2 <- ObjectCodec input output1 -> State (Set Text) ObjectSchema
forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject ObjectCodec input output1
oc2
    ObjectSchema -> State (Set Text) ObjectSchema
forall a. a -> StateT (Set Text) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectSchema -> State (Set Text) ObjectSchema)
-> ObjectSchema -> State (Set Text) ObjectSchema
forall a b. (a -> b) -> a -> b
$ NonEmpty ObjectSchema -> ObjectSchema
ObjectAllOfSchema (NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectAllOf (ObjectSchema
os1 ObjectSchema -> [ObjectSchema] -> NonEmpty ObjectSchema
forall a. a -> [a] -> NonEmpty a
:| [ObjectSchema
os2]))
  where
    goObjectAnyOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
    goObjectAnyOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectAnyOf (ObjectSchema
s :| [ObjectSchema]
rest) = case [ObjectSchema] -> Maybe (NonEmpty ObjectSchema)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [ObjectSchema]
rest of
      Maybe (NonEmpty ObjectSchema)
Nothing -> ObjectSchema -> NonEmpty ObjectSchema
goSingle ObjectSchema
s
      Just NonEmpty ObjectSchema
ne -> ObjectSchema -> NonEmpty ObjectSchema
goSingle ObjectSchema
s NonEmpty ObjectSchema
-> NonEmpty ObjectSchema -> NonEmpty ObjectSchema
forall a. Semigroup a => a -> a -> a
<> NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectAnyOf NonEmpty ObjectSchema
ne
      where
        goSingle :: ObjectSchema -> NonEmpty ObjectSchema
        goSingle :: ObjectSchema -> NonEmpty ObjectSchema
goSingle = \case
          ObjectAnyOfSchema NonEmpty ObjectSchema
ss -> NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectAnyOf NonEmpty ObjectSchema
ss
          ObjectSchema
s' -> ObjectSchema
s' ObjectSchema -> [ObjectSchema] -> NonEmpty ObjectSchema
forall a. a -> [a] -> NonEmpty a
:| []

    goObjectOneOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
    goObjectOneOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectOneOf (ObjectSchema
s :| [ObjectSchema]
rest) = case [ObjectSchema] -> Maybe (NonEmpty ObjectSchema)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [ObjectSchema]
rest of
      Maybe (NonEmpty ObjectSchema)
Nothing -> ObjectSchema -> NonEmpty ObjectSchema
goSingle ObjectSchema
s
      Just NonEmpty ObjectSchema
ne -> ObjectSchema -> NonEmpty ObjectSchema
goSingle ObjectSchema
s NonEmpty ObjectSchema
-> NonEmpty ObjectSchema -> NonEmpty ObjectSchema
forall a. Semigroup a => a -> a -> a
<> NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectOneOf NonEmpty ObjectSchema
ne
      where
        goSingle :: ObjectSchema -> NonEmpty ObjectSchema
        goSingle :: ObjectSchema -> NonEmpty ObjectSchema
goSingle = \case
          ObjectOneOfSchema NonEmpty ObjectSchema
ss -> NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectOneOf NonEmpty ObjectSchema
ss
          ObjectSchema
s' -> ObjectSchema
s' ObjectSchema -> [ObjectSchema] -> NonEmpty ObjectSchema
forall a. a -> [a] -> NonEmpty a
:| []

    goObjectAllOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
    goObjectAllOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectAllOf (ObjectSchema
s :| [ObjectSchema]
rest) = case [ObjectSchema] -> Maybe (NonEmpty ObjectSchema)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [ObjectSchema]
rest of
      Maybe (NonEmpty ObjectSchema)
Nothing -> ObjectSchema -> NonEmpty ObjectSchema
goSingle ObjectSchema
s
      Just NonEmpty ObjectSchema
ne -> ObjectSchema -> NonEmpty ObjectSchema
goSingle ObjectSchema
s NonEmpty ObjectSchema
-> NonEmpty ObjectSchema -> NonEmpty ObjectSchema
forall a. Semigroup a => a -> a -> a
<> NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectAllOf NonEmpty ObjectSchema
ne
      where
        goSingle :: ObjectSchema -> NonEmpty ObjectSchema
        goSingle :: ObjectSchema -> NonEmpty ObjectSchema
goSingle = \case
          ObjectAllOfSchema NonEmpty ObjectSchema
ss -> NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectAllOf NonEmpty ObjectSchema
ss
          ObjectSchema
s' -> ObjectSchema
s' ObjectSchema -> [ObjectSchema] -> NonEmpty ObjectSchema
forall a. a -> [a] -> NonEmpty a
:| []

validateAccordingTo :: JSON.Value -> JSONSchema -> Bool
validateAccordingTo :: Value -> JSONSchema -> Bool
validateAccordingTo Value
val JSONSchema
schema = (State (Map Text JSONSchema) Bool -> Map Text JSONSchema -> Bool
forall s a. State s a -> s -> a
`evalState` Map Text JSONSchema
forall k a. Map k a
M.empty) (State (Map Text JSONSchema) Bool -> Bool)
-> State (Map Text JSONSchema) Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Value -> JSONSchema -> State (Map Text JSONSchema) Bool
validateValue Value
val JSONSchema
schema

validateObjectAccordingTo :: JSON.Value -> JSONSchema -> Bool
validateObjectAccordingTo :: Value -> JSONSchema -> Bool
validateObjectAccordingTo Value
val JSONSchema
schema = (State (Map Text JSONSchema) Bool -> Map Text JSONSchema -> Bool
forall s a. State s a -> s -> a
`evalState` Map Text JSONSchema
forall k a. Map k a
M.empty) (State (Map Text JSONSchema) Bool -> Bool)
-> State (Map Text JSONSchema) Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Value -> JSONSchema -> State (Map Text JSONSchema) Bool
validateValue Value
val JSONSchema
schema

validateValue :: JSON.Value -> JSONSchema -> State (Map Text JSONSchema) Bool
validateValue :: Value -> JSONSchema -> State (Map Text JSONSchema) Bool
validateValue Value
value = \case
  JSONSchema
AnySchema -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  JSONSchema
NullSchema -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> State (Map Text JSONSchema) Bool)
-> Bool -> State (Map Text JSONSchema) Bool
forall a b. (a -> b) -> a -> b
$ Value
value Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
JSON.Null
  JSONSchema
BoolSchema -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> State (Map Text JSONSchema) Bool)
-> Bool -> State (Map Text JSONSchema) Bool
forall a b. (a -> b) -> a -> b
$ case Value
value of
    JSON.Bool Bool
_ -> Bool
True
    Value
_ -> Bool
False
  JSONSchema
StringSchema -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> State (Map Text JSONSchema) Bool)
-> Bool -> State (Map Text JSONSchema) Bool
forall a b. (a -> b) -> a -> b
$ case Value
value of
    JSON.String Text
_ -> Bool
True
    Value
_ -> Bool
False
  IntegerSchema Bounds Integer
bounds -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> State (Map Text JSONSchema) Bool)
-> Bool -> State (Map Text JSONSchema) Bool
forall a b. (a -> b) -> a -> b
$ case Value
value of
    JSON.Number Scientific
s -> case Bounds Scientific -> Scientific -> Either String Scientific
forall a. (Show a, Ord a) => Bounds a -> a -> Either String a
checkBounds (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Scientific) -> Bounds Integer -> Bounds Scientific
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bounds Integer
bounds) Scientific
s of
      Left String
_ -> Bool
False
      Right Scientific
_ -> Bool
True
    Value
_ -> Bool
False
  NumberSchema Bounds Scientific
bounds -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> State (Map Text JSONSchema) Bool)
-> Bool -> State (Map Text JSONSchema) Bool
forall a b. (a -> b) -> a -> b
$ case Value
value of
    JSON.Number Scientific
s -> case Bounds Scientific -> Scientific -> Either String Scientific
forall a. (Show a, Ord a) => Bounds a -> a -> Either String a
checkBounds Bounds Scientific
bounds Scientific
s of
      Left String
_ -> Bool
False
      Right Scientific
_ -> Bool
True
    Value
_ -> Bool
False
  ArraySchema JSONSchema
as -> case Value
value of
    JSON.Array Array
v -> Vector Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (Vector Bool -> Bool)
-> StateT (Map Text JSONSchema) Identity (Vector Bool)
-> State (Map Text JSONSchema) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> State (Map Text JSONSchema) Bool)
-> Array -> StateT (Map Text JSONSchema) Identity (Vector Bool)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
mapM (Value -> JSONSchema -> State (Map Text JSONSchema) Bool
`validateValue` JSONSchema
as) Array
v
    Value
_ -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  MapSchema JSONSchema
vs -> case Value
value of
    JSON.Object Object
hm -> KeyMap Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (KeyMap Bool -> Bool)
-> StateT (Map Text JSONSchema) Identity (KeyMap Bool)
-> State (Map Text JSONSchema) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> State (Map Text JSONSchema) Bool)
-> Object -> StateT (Map Text JSONSchema) Identity (KeyMap Bool)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> KeyMap a -> m (KeyMap b)
mapM (Value -> JSONSchema -> State (Map Text JSONSchema) Bool
`validateValue` JSONSchema
vs) Object
hm
    Value
_ -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  ObjectSchema ObjectSchema
os -> case Value
value of
    JSON.Object Object
obj -> Object -> ObjectSchema -> State (Map Text JSONSchema) Bool
validateObject Object
obj ObjectSchema
os
    Value
_ -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  ValueSchema Value
v -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> State (Map Text JSONSchema) Bool)
-> Bool -> State (Map Text JSONSchema) Bool
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
value
  AnyOfSchema NonEmpty JSONSchema
ss -> NonEmpty Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (NonEmpty Bool -> Bool)
-> StateT (Map Text JSONSchema) Identity (NonEmpty Bool)
-> State (Map Text JSONSchema) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JSONSchema -> State (Map Text JSONSchema) Bool)
-> NonEmpty JSONSchema
-> StateT (Map Text JSONSchema) Identity (NonEmpty Bool)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Value -> JSONSchema -> State (Map Text JSONSchema) Bool
validateValue Value
value) NonEmpty JSONSchema
ss
  OneOfSchema NonEmpty JSONSchema
ss -> (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> (NonEmpty Bool -> Int) -> NonEmpty Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Bool] -> Int)
-> (NonEmpty Bool -> [Bool]) -> NonEmpty Bool -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool) -> NonEmpty Bool -> [Bool]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter Bool -> Bool
forall a. a -> a
id (NonEmpty Bool -> Bool)
-> StateT (Map Text JSONSchema) Identity (NonEmpty Bool)
-> State (Map Text JSONSchema) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JSONSchema -> State (Map Text JSONSchema) Bool)
-> NonEmpty JSONSchema
-> StateT (Map Text JSONSchema) Identity (NonEmpty Bool)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Value -> JSONSchema -> State (Map Text JSONSchema) Bool
validateValue Value
value) NonEmpty JSONSchema
ss
  CommentSchema Text
_ JSONSchema
s -> Value -> JSONSchema -> State (Map Text JSONSchema) Bool
validateValue Value
value JSONSchema
s
  RefSchema Text
name -> do
    Maybe JSONSchema
mSchema <- (Map Text JSONSchema -> Maybe JSONSchema)
-> StateT (Map Text JSONSchema) Identity (Maybe JSONSchema)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Text -> Map Text JSONSchema -> Maybe JSONSchema
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name)
    case Maybe JSONSchema
mSchema of
      Maybe JSONSchema
Nothing -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False -- Referred to a schema that's not defined, we have no choice but to reject the value.
      Just JSONSchema
s -> Value -> JSONSchema -> State (Map Text JSONSchema) Bool
validateValue Value
value JSONSchema
s
  WithDefSchema Map Text JSONSchema
defs JSONSchema
s -> do
    (Map Text JSONSchema -> Map Text JSONSchema)
-> StateT (Map Text JSONSchema) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Map Text JSONSchema -> Map Text JSONSchema -> Map Text JSONSchema
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map Text JSONSchema
defs)
    Value -> JSONSchema -> State (Map Text JSONSchema) Bool
validateValue Value
value JSONSchema
s

validateObject :: JSON.Object -> ObjectSchema -> State (Map Text JSONSchema) Bool
validateObject :: Object -> ObjectSchema -> State (Map Text JSONSchema) Bool
validateObject Object
obj = \case
  ObjectSchema
ObjectAnySchema -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  ObjectKeySchema Text
key KeyRequirement
kr JSONSchema
ks Maybe Text
_ -> case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
Compat.lookupKey (Text -> Key
Compat.toKey Text
key) Object
obj of
    Maybe Value
Nothing -> case KeyRequirement
kr of
      KeyRequirement
Required -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Optional Maybe Value
_ -> Bool -> State (Map Text JSONSchema) Bool
forall a. a -> StateT (Map Text JSONSchema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Just Value
value' -> Value -> JSONSchema -> State (Map Text JSONSchema) Bool
validateValue Value
value' JSONSchema
ks
  ObjectAllOfSchema NonEmpty ObjectSchema
ne -> NonEmpty Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (NonEmpty Bool -> Bool)
-> StateT (Map Text JSONSchema) Identity (NonEmpty Bool)
-> State (Map Text JSONSchema) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ObjectSchema -> State (Map Text JSONSchema) Bool)
-> NonEmpty ObjectSchema
-> StateT (Map Text JSONSchema) Identity (NonEmpty Bool)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Object -> ObjectSchema -> State (Map Text JSONSchema) Bool
validateObject Object
obj) NonEmpty ObjectSchema
ne
  ObjectAnyOfSchema NonEmpty ObjectSchema
ne -> NonEmpty Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (NonEmpty Bool -> Bool)
-> StateT (Map Text JSONSchema) Identity (NonEmpty Bool)
-> State (Map Text JSONSchema) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ObjectSchema -> State (Map Text JSONSchema) Bool)
-> NonEmpty ObjectSchema
-> StateT (Map Text JSONSchema) Identity (NonEmpty Bool)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Object -> ObjectSchema -> State (Map Text JSONSchema) Bool
validateObject Object
obj) NonEmpty ObjectSchema
ne
  ObjectOneOfSchema NonEmpty ObjectSchema
ne -> (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> (NonEmpty Bool -> Int) -> NonEmpty Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Bool] -> Int)
-> (NonEmpty Bool -> [Bool]) -> NonEmpty Bool -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool) -> NonEmpty Bool -> [Bool]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter Bool -> Bool
forall a. a -> a
id (NonEmpty Bool -> Bool)
-> StateT (Map Text JSONSchema) Identity (NonEmpty Bool)
-> State (Map Text JSONSchema) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ObjectSchema -> State (Map Text JSONSchema) Bool)
-> NonEmpty ObjectSchema
-> StateT (Map Text JSONSchema) Identity (NonEmpty Bool)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Object -> ObjectSchema -> State (Map Text JSONSchema) Bool
validateObject Object
obj) NonEmpty ObjectSchema
ne