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

module Autodocodec.Schema where

import Autodocodec
import qualified Autodocodec.Aeson.Compat as Compat
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.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
  | NumberSchema !(Maybe NumberBounds)
  | 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
showList :: [JSONSchema] -> ShowS
$cshowList :: [JSONSchema] -> ShowS
show :: JSONSchema -> String
$cshow :: JSONSchema -> String
showsPrec :: Int -> JSONSchema -> ShowS
$cshowsPrec :: Int -> JSONSchema -> ShowS
Show, JSONSchema -> JSONSchema -> Bool
(JSONSchema -> JSONSchema -> Bool)
-> (JSONSchema -> JSONSchema -> Bool) -> Eq JSONSchema
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JSONSchema -> JSONSchema -> Bool
$c/= :: JSONSchema -> JSONSchema -> Bool
== :: JSONSchema -> JSONSchema -> Bool
$c== :: JSONSchema -> JSONSchema -> Bool
Eq, (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
$cto :: forall x. Rep JSONSchema x -> JSONSchema
$cfrom :: forall x. JSONSchema -> Rep JSONSchema x
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 (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 (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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"null" :: Text)]
        JSONSchema
BoolSchema -> [Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"boolean" :: Text)]
        JSONSchema
StringSchema -> [Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"string" :: Text)]
        NumberSchema Maybe NumberBounds
mBounds ->
          (Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"number" :: Text)) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: case Maybe NumberBounds
mBounds of
            Maybe NumberBounds
Nothing -> []
            Just NumberBounds {Scientific
numberBoundsLower :: NumberBounds -> Scientific
numberBoundsUpper :: NumberBounds -> Scientific
numberBoundsUpper :: Scientific
numberBoundsLower :: Scientific
..} -> [Key
"minimum" Key -> Scientific -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Scientific
numberBoundsLower, Key
"maximum" Key -> Scientific -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Scientific
numberBoundsUpper]
        ArraySchema JSONSchema
s ->
          let itemSchemaVal :: [Pair]
itemSchemaVal = JSONSchema -> [Pair]
go JSONSchema
s
           in [Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"object" :: Text), Key
"additionalProperties" Key -> Value -> Pair
forall kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue 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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
NullSchema
      Just Text
"boolean" -> JSONSchema -> Parser JSONSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
BoolSchema
      Just Text
"string" -> JSONSchema -> Parser JSONSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
StringSchema
      Just Text
"number" -> do
        Maybe Scientific
mLower <- Object
o Object -> Key -> Parser (Maybe Scientific)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"minimum"
        Maybe Scientific
mUpper <- Object
o Object -> Key -> Parser (Maybe Scientific)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"maximum"
        JSONSchema -> Parser JSONSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONSchema -> Parser JSONSchema)
-> JSONSchema -> Parser JSONSchema
forall a b. (a -> b) -> a -> b
$
          Maybe NumberBounds -> JSONSchema
NumberSchema (Maybe NumberBounds -> JSONSchema)
-> Maybe NumberBounds -> JSONSchema
forall a b. (a -> b) -> a -> b
$ case (,) (Scientific -> Scientific -> (Scientific, Scientific))
-> Maybe Scientific
-> Maybe (Scientific -> (Scientific, Scientific))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Scientific
mLower Maybe (Scientific -> (Scientific, Scientific))
-> Maybe Scientific -> Maybe (Scientific, Scientific)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Scientific
mUpper of
            Maybe (Scientific, Scientific)
Nothing -> Maybe NumberBounds
forall a. Maybe a
Nothing
            Just (Scientific
numberBoundsLower, Scientific
numberBoundsUpper) -> NumberBounds -> Maybe NumberBounds
forall a. a -> Maybe a
Just NumberBounds :: Scientific -> Scientific -> NumberBounds
NumberBounds {Scientific
numberBoundsUpper :: Scientific
numberBoundsLower :: Scientific
numberBoundsLower :: Scientific
numberBoundsUpper :: 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 (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 (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 (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 (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 (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 (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 (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 (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
showList :: [ObjectSchema] -> ShowS
$cshowList :: [ObjectSchema] -> ShowS
show :: ObjectSchema -> String
$cshow :: ObjectSchema -> String
showsPrec :: Int -> ObjectSchema -> ShowS
$cshowsPrec :: Int -> ObjectSchema -> ShowS
Show, ObjectSchema -> ObjectSchema -> Bool
(ObjectSchema -> ObjectSchema -> Bool)
-> (ObjectSchema -> ObjectSchema -> Bool) -> Eq ObjectSchema
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ObjectSchema -> ObjectSchema -> Bool
$c/= :: ObjectSchema -> ObjectSchema -> Bool
== :: ObjectSchema -> ObjectSchema -> Bool
$c== :: ObjectSchema -> ObjectSchema -> Bool
Eq, (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
$cto :: forall x. Rep ObjectSchema x -> ObjectSchema
$cfrom :: forall x. ObjectSchema -> Rep ObjectSchema x
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)
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)
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)
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 (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 (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)
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 (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 kv v. (KeyValue 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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= [Pair] -> Value
JSON.object [Text -> Key
Compat.toKey Text
k Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Value
propVal]], [Key
"required" Key -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= [Text
k] | Bool
req]]
        ObjectAnyOfSchema NonEmpty ObjectSchema
ne -> [Key
"anyOf" Key -> NonEmpty Value -> Pair
forall kv v. (KeyValue 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 kv v. (KeyValue 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)
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 kv v. (KeyValue 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 (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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= HashMap Text Value
propValMap], [Key
"required" Key -> [Text] -> Pair
forall kv v. (KeyValue 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 (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)
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/"

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
go Value
val JSONSchema
schema
  where
    goObject :: JSON.Object -> ObjectSchema -> State (Map Text JSONSchema) Bool
    goObject :: Object -> ObjectSchema -> State (Map Text JSONSchema) Bool
goObject Object
obj = \case
      ObjectSchema
ObjectAnySchema -> Bool -> State (Map Text JSONSchema) Bool
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 (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          Optional Maybe Value
_ -> Bool -> State (Map Text JSONSchema) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        Just Value
value' -> Value -> JSONSchema -> State (Map Text JSONSchema) Bool
go 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)
mapM (Object -> ObjectSchema -> State (Map Text JSONSchema) Bool
goObject 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)
mapM (Object -> ObjectSchema -> State (Map Text JSONSchema) Bool
goObject 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 (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)
mapM (Object -> ObjectSchema -> State (Map Text JSONSchema) Bool
goObject Object
obj) NonEmpty ObjectSchema
ne

    go :: JSON.Value -> JSONSchema -> State (Map Text JSONSchema) Bool
    go :: Value -> JSONSchema -> State (Map Text JSONSchema) Bool
go Value
value = \case
      JSONSchema
AnySchema -> Bool -> State (Map Text JSONSchema) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      JSONSchema
NullSchema -> Bool -> State (Map Text JSONSchema) Bool
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 (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 (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
      NumberSchema Maybe NumberBounds
mBounds -> Bool -> State (Map Text JSONSchema) Bool
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 (Scientific -> Either String Scientific)
-> (NumberBounds -> Scientific -> Either String Scientific)
-> Maybe NumberBounds
-> Scientific
-> Either String Scientific
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Scientific -> Either String Scientific
forall a b. b -> Either a b
Right NumberBounds -> Scientific -> Either String Scientific
checkNumberBounds Maybe NumberBounds
mBounds 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)
mapM (Value -> JSONSchema -> State (Map Text JSONSchema) Bool
`go` JSONSchema
as) Array
v
        Value
_ -> Bool -> State (Map Text JSONSchema) Bool
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)
mapM (Value -> JSONSchema -> State (Map Text JSONSchema) Bool
`go` JSONSchema
vs) Object
hm
        Value
_ -> Bool -> State (Map Text JSONSchema) Bool
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
goObject Object
obj ObjectSchema
os
        Value
_ -> Bool -> State (Map Text JSONSchema) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      ValueSchema Value
v -> Bool -> State (Map Text JSONSchema) Bool
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)
mapM (Value -> JSONSchema -> State (Map Text JSONSchema) Bool
go 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 (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)
mapM (Value -> JSONSchema -> State (Map Text JSONSchema) Bool
go Value
value) NonEmpty JSONSchema
ss
      CommentSchema Text
_ JSONSchema
s -> Value -> JSONSchema -> State (Map Text JSONSchema) Bool
go 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 (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
go 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
go Value
value JSONSchema
s

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
showList :: [KeyRequirement] -> ShowS
$cshowList :: [KeyRequirement] -> ShowS
show :: KeyRequirement -> String
$cshow :: KeyRequirement -> String
showsPrec :: Int -> KeyRequirement -> ShowS
$cshowsPrec :: Int -> KeyRequirement -> ShowS
Show, KeyRequirement -> KeyRequirement -> Bool
(KeyRequirement -> KeyRequirement -> Bool)
-> (KeyRequirement -> KeyRequirement -> Bool) -> Eq KeyRequirement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyRequirement -> KeyRequirement -> Bool
$c/= :: KeyRequirement -> KeyRequirement -> Bool
== :: KeyRequirement -> KeyRequirement -> Bool
$c== :: KeyRequirement -> KeyRequirement -> Bool
Eq, (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
$cto :: forall x. Rep KeyRequirement x -> KeyRequirement
$cfrom :: forall x. KeyRequirement -> Rep KeyRequirement x
Generic)

instance Validity KeyRequirement

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

jsonSchemaVia :: ValueCodec input output -> JSONSchema
jsonSchemaVia :: 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
go
  where
    go :: ValueCodec input output -> State (Set Text) JSONSchema
    go :: ValueCodec input output -> State (Set Text) JSONSchema
go = \case
      ValueCodec input output
NullCodec -> JSONSchema -> State (Set Text) JSONSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
NullSchema
      BoolCodec Maybe Text
mname -> JSONSchema -> State (Set Text) JSONSchema
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 (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
      NumberCodec Maybe Text
mname Maybe NumberBounds
mBounds -> JSONSchema -> State (Set Text) JSONSchema
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
$ Maybe NumberBounds -> JSONSchema
NumberSchema Maybe NumberBounds
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
go ValueCodec input1 output1
c
        JSONSchema -> State (Set Text) JSONSchema
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 (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
go 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
go JSONCodec v
c
      ValueCodec input output
ValueCodec -> JSONSchema -> State (Set Text) JSONSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
AnySchema
      EqCodec input
value JSONCodec input
c -> JSONSchema -> State (Set Text) JSONSchema
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 input -> input -> Value
forall a void. ValueCodec a void -> a -> Value
toJSONVia JSONCodec input
c input
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
go 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
go Codec Value input2 output2
c2
        JSONSchema -> State (Set Text) JSONSchema
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
go 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
go 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 (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
go ValueCodec input output
c
            JSONSchema -> State (Set Text) JSONSchema
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)

    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 :: 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
go ValueCodec input output
c
        ObjectSchema -> State (Set Text) ObjectSchema
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
go ValueCodec input1 output1
c
        ObjectSchema -> State (Set Text) ObjectSchema
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
go ValueCodec input input
c
        ObjectSchema -> State (Set Text) ObjectSchema
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 input input
c input
defaultValue Maybe Text
mDoc -> ObjectCodec input input -> State (Set Text) ObjectSchema
forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject (Text
-> ValueCodec input input
-> input
-> Maybe Text
-> ObjectCodec input input
forall input.
Text
-> ValueCodec input input
-> input
-> Maybe Text
-> Codec Object input input
OptionalKeyWithDefaultCodec Text
k ValueCodec input input
c input
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 (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]))
      PureCodec output
_ -> ObjectSchema -> State (Set Text) ObjectSchema
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 (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]))

    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
:| []

uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 a -> b -> c -> d
f (a
a, b
b, c
c) = a -> b -> c -> d
f a
a b
b c
c