{-# 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
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
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
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. 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 =
    forall a. Monoid a => [a] -> a
mconcat
      [ forall a. (Generic a, GValidity (Rep a)) => a -> Validation
genericValidate JSONSchema
js,
        String -> Bool -> Validation
declare String
"never has two nested comments" 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" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty JSONSchema
cs forall a. Ord a => a -> a -> Bool
>= Int
2
          OneOfSchema NonEmpty JSONSchema
cs -> String -> Bool -> Validation
declare String
"there are 2 of more choices" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty JSONSchema
cs forall a. Ord a => a -> a -> Bool
>= Int
2
          JSONSchema
_ -> Validation
valid
      ]

instance ToJSON JSONSchema where
  toJSON :: JSONSchema -> Value
toJSON = [Pair] -> Value
JSON.object 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"null" :: Text)]
        JSONSchema
BoolSchema -> [Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"boolean" :: Text)]
        JSONSchema
StringSchema -> [Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"string" :: Text)]
        NumberSchema Maybe NumberBounds
mBounds ->
          (Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"number" :: Text)) 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Scientific
numberBoundsLower, Key
"maximum" 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" 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" 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"object" :: Text), Key
"additionalProperties" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= [Pair] -> Value
JSON.object [Pair]
itemSchemaVal]
        ObjectSchema ObjectSchema
os ->
          case forall a. ToJSON a => a -> Value
toJSON ObjectSchema
os of
            JSON.Object Object
o -> 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 = forall a b. (a -> b) -> [a] -> [b]
map ([Pair] -> Value
JSON.object forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONSchema -> [Pair]
go) (forall a. NonEmpty a -> [a]
NE.toList NonEmpty JSONSchema
jcs)
              val :: JSON.Value
              val :: Value
val = (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 = forall a b. (a -> b) -> [a] -> [b]
map ([Pair] -> Value
JSON.object forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONSchema -> [Pair]
go) (forall a. NonEmpty a -> [a]
NE.toList NonEmpty JSONSchema
jcs)
              val :: JSON.Value
              val :: Value
val = (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 forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
innerComment) JSONSchema
s)
        CommentSchema Text
comment JSONSchema
s -> (Key
"$comment" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Text
comment) forall a. a -> [a] -> [a]
: JSONSchema -> [Pair]
go JSONSchema
s
        RefSchema Text
name -> [Key
"$ref" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
defsPrefix forall a. Semigroup a => a -> a -> a
<> Text
name :: Text)]
        WithDefSchema Map Text JSONSchema
defs JSONSchema
s -> (Key
"$defs" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Map Text JSONSchema
defs) forall a. a -> [a] -> [a]
: JSONSchema -> [Pair]
go JSONSchema
s

instance FromJSON JSONSchema where
  parseJSON :: Value -> Parser JSONSchema
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"JSONSchema" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Maybe Text
mt <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"type"
    Maybe Text
mc <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"$comment"
    let commentFunc :: JSONSchema -> JSONSchema
commentFunc = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mc
    Maybe (Map Text JSONSchema)
mdefs <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"$defs"
    let defsFunc :: JSONSchema -> JSONSchema
defsFunc = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Map Text JSONSchema -> JSONSchema -> JSONSchema
WithDefSchema Maybe (Map Text JSONSchema)
mdefs
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (JSONSchema -> JSONSchema
commentFunc forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONSchema -> JSONSchema
defsFunc) forall a b. (a -> b) -> a -> b
$ case Maybe Text
mt :: Maybe Text of
      Just Text
"null" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
NullSchema
      Just Text
"boolean" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
BoolSchema
      Just Text
"string" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
StringSchema
      Just Text
"number" -> do
        Maybe Scientific
mLower <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"minimum"
        Maybe Scientific
mUpper <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"maximum"
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          Maybe NumberBounds -> JSONSchema
NumberSchema forall a b. (a -> b) -> a -> b
$ case (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Scientific
mLower forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Scientific
mUpper of
            Maybe (Scientific, Scientific)
Nothing -> forall a. Maybe a
Nothing
            Just (Scientific
numberBoundsLower, Scientific
numberBoundsUpper) -> forall a. a -> Maybe a
Just NumberBounds {Scientific
numberBoundsUpper :: Scientific
numberBoundsLower :: Scientific
numberBoundsLower :: Scientific
numberBoundsUpper :: Scientific
..}
      Just Text
"array" -> do
        Maybe JSONSchema
mI <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"items"
        case Maybe JSONSchema
mI of
          Maybe JSONSchema
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ JSONSchema -> JSONSchema
ArraySchema JSONSchema
AnySchema
          Just JSONSchema
is -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ JSONSchema -> JSONSchema
ArraySchema JSONSchema
is
      Just Text
"object" -> do
        Maybe JSONSchema
mAdditional <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"additionalProperties"
        case Maybe JSONSchema
mAdditional of
          Maybe JSONSchema
Nothing -> ObjectSchema -> JSONSchema
ObjectSchema forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
JSON.Object Object
o)
          Just JSONSchema
additional -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ JSONSchema -> JSONSchema
MapSchema JSONSchema
additional
      Maybe Text
Nothing -> do
        Maybe (NonEmpty JSONSchema)
mAny <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"anyOf"
        case Maybe (NonEmpty JSONSchema)
mAny of
          Just NonEmpty JSONSchema
anies -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"oneOf"
            case Maybe (NonEmpty JSONSchema)
mOne of
              Just NonEmpty JSONSchema
ones -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NonEmpty JSONSchema -> JSONSchema
OneOfSchema NonEmpty JSONSchema
ones
              Maybe (NonEmpty JSONSchema)
Nothing -> do
                let mConst :: Maybe Value
mConst = forall v. Key -> KeyMap v -> Maybe v
Compat.lookupKey Key
"const" Object
o
                case Maybe Value
mConst of
                  Just Value
constant -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value -> JSONSchema
ValueSchema Value
constant
                  Maybe Value
Nothing -> do
                    Maybe Text
mRef <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"$ref"
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unknown schema type:" forall a. Semigroup a => a -> a -> a
<> 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
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
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. 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 = 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 forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"type"
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Text
t forall a. Eq a => a -> a -> Bool
== (Text
"object" :: Text)
        Maybe Value
mAllOf <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"allOf"
        case Maybe Value
mAllOf of
          Just Value
ao -> do
            NonEmpty Object
ne <- forall a. FromJSON a => Value -> Parser a
parseJSON Value
ao
            NonEmpty ObjectSchema -> ObjectSchema
ObjectAllOfSchema forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"anyOf"
            case Maybe Value
mAnyOf of
              Just Value
anies -> do
                NonEmpty Object
ne <- forall a. FromJSON a => Value -> Parser a
parseJSON Value
anies
                NonEmpty ObjectSchema -> ObjectSchema
ObjectAnyOfSchema forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"oneOf"
                case Maybe Value
mOneOf of
                  Just Value
ones -> do
                    NonEmpty Object
ne <- forall a. FromJSON a => Value -> Parser a
parseJSON Value
ones
                    NonEmpty ObjectSchema -> ObjectSchema
ObjectOneOfSchema forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"properties" forall a. Parser (Maybe a) -> a -> Parser a
JSON..!= forall k v. HashMap k v
HM.empty
                    [Text]
reqs <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"required" forall a. Parser (Maybe a) -> a -> Parser a
JSON..!= []
                    let keySchemaFor :: Text -> Value -> Parser ObjectSchema
keySchemaFor Text
k Value
v = do
                          JSONSchema
ks <- 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'' -> (forall a. a -> Maybe a
Just Text
doc, JSONSchema
ks'')
                                JSONSchema
_ -> (forall a. Maybe a
Nothing, JSONSchema
ks)
                          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                            if Text
k 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 forall a. Maybe a
Nothing) JSONSchema
ks' Maybe Text
mDoc
                    [ObjectSchema]
keySchemas <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Value -> Parser ObjectSchema
keySchemaFor) (forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Text Value
props)
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= (Text
"object" :: Text)) forall a. a -> [a] -> [a]
:) 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.
              forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Key
"properties" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= [Pair] -> Value
JSON.object [Text -> Key
Compat.toKey Text
k forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Value
propVal]], [Key
"required" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= [Text
k] | Bool
req]]
        ObjectAnyOfSchema NonEmpty ObjectSchema
ne -> [Key
"anyOf" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map forall a. ToJSON a => a -> Value
toJSON NonEmpty ObjectSchema
ne]
        ObjectOneOfSchema NonEmpty ObjectSchema
ne -> [Key
"oneOf" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map forall a. ToJSON a => a -> Value
toJSON NonEmpty ObjectSchema
ne]
        ObjectAllOfSchema NonEmpty ObjectSchema
ne ->
          case 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 (forall a. NonEmpty a -> [a]
NE.toList NonEmpty ObjectSchema
ne) of
            Maybe [[(Text, KeyRequirement, JSONSchema, Maybe Text)]]
Nothing -> [Key
"allOf" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map 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 (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 forall a. a -> [a] -> [a]
: [Text]
l else [Text]
l)
                  (HashMap Text Value
propValMap, [Text]
reqs) = 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 (forall k v. HashMap k v
HM.empty, []) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Text, KeyRequirement, JSONSchema, Maybe Text)]]
ne')
               in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Key
"properties" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= HashMap Text Value
propValMap], [Key
"required" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= [Text]
reqs | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ 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 = forall a. ToJSON a => a -> Value
toJSON (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mDoc JSONSchema
ks)
         in (Value
propVal, KeyRequirement
kr 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 -> forall a. a -> Maybe a
Just [(Text
k, KeyRequirement
kr, JSONSchema
ks, Maybe Text
mDoc)]
        ObjectAllOfSchema NonEmpty ObjectSchema
os -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
_ -> 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 = (forall s a. State s a -> s -> a
`evalState` forall k a. Map k a
M.empty) 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      ObjectKeySchema Text
key KeyRequirement
kr JSONSchema
ks Maybe Text
_ -> case 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          Optional Maybe Value
_ -> 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 -> forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> (forall a. Eq a => a -> a -> Bool
== Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      JSONSchema
NullSchema -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value
value forall a. Eq a => a -> a -> Bool
== Value
JSON.Null
      JSONSchema
BoolSchema -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Value
value of
        JSON.Bool Bool
_ -> Bool
True
        Value
_ -> Bool
False
      JSONSchema
StringSchema -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Value
value of
        JSON.String Text
_ -> Bool
True
        Value
_ -> Bool
False
      NumberSchema Maybe NumberBounds
mBounds -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Value
value of
        JSON.Number Scientific
s -> case forall b a. b -> (a -> b) -> Maybe a -> b
maybe 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 -> forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      MapSchema JSONSchema
vs -> case Value
value of
        JSON.Object Object
hm -> forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
_ -> 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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      ValueSchema Value
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value
v forall a. Eq a => a -> a -> Bool
== Value
value
      AnyOfSchema NonEmpty JSONSchema
ss -> forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> (forall a. Eq a => a -> a -> Bool
== Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name)
        case Maybe JSONSchema
mSchema of
          Maybe JSONSchema
Nothing -> 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
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (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
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
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. 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 :: forall a. HasCodec a => JSONSchema
jsonSchemaViaCodec = 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 = (forall s a. State s a -> s -> a
`evalState` forall a. Set a
S.empty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
go
  where
    go :: ValueCodec input output -> State (Set Text) JSONSchema
    go :: forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
go = \case
      ValueCodec input output
NullCodec -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
NullSchema
      BoolCodec Maybe Text
mname -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mname JSONSchema
BoolSchema
      StringCodec Maybe Text
mname -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mname JSONSchema
StringSchema
      NumberCodec Maybe Text
mname Maybe NumberBounds
mBounds -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mname 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 <- forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
go ValueCodec input1 output1
c
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mname forall a b. (a -> b) -> a -> b
$ JSONSchema -> JSONSchema
ArraySchema JSONSchema
s
      ObjectOfCodec Maybe Text
mname ObjectCodec input output
oc -> do
        ObjectSchema
s <- forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject ObjectCodec input output
oc
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Text -> JSONSchema -> JSONSchema
CommentSchema Maybe Text
mname forall a b. (a -> b) -> a -> b
$ ObjectSchema -> JSONSchema
ObjectSchema ObjectSchema
s
      HashMapCodec JSONCodec v
c -> JSONSchema -> JSONSchema
MapSchema forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
go JSONCodec v
c
      MapCodec JSONCodec v
c -> JSONSchema -> JSONSchema
MapSchema forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
go JSONCodec v
c
      ValueCodec input output
ValueCodec -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONSchema
AnySchema
      EqCodec input
value JSONCodec input
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value -> JSONSchema
ValueSchema (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 <- forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
go Codec Value input1 output1
c1
        JSONSchema
s2 <- forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
go Codec Value input2 output2
c2
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Union
u of
          Union
DisjointUnion -> NonEmpty JSONSchema -> JSONSchema
OneOfSchema (NonEmpty JSONSchema -> NonEmpty JSONSchema
goOneOf (JSONSchema
s1 forall a. a -> [a] -> NonEmpty a
:| [JSONSchema
s2]))
          Union
PossiblyJointUnion -> NonEmpty JSONSchema -> JSONSchema
AnyOfSchema (NonEmpty JSONSchema -> NonEmpty JSONSchema
goAnyOf (JSONSchema
s1 forall a. a -> [a] -> NonEmpty a
:| [JSONSchema
s2]))
      BimapCodec oldOutput -> Either String output
_ input -> oldInput
_ Codec Value oldInput oldOutput
c -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. Ord a => a -> Set a -> Bool
S.member Text
name)
        if Bool
alreadySeen
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> JSONSchema
RefSchema Text
name
          else do
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Ord a => a -> Set a -> Set a
S.insert Text
name)
            JSONSchema
s <- forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
go ValueCodec input output
c
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map Text JSONSchema -> JSONSchema -> JSONSchema
WithDefSchema (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 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 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' forall a. a -> [a] -> NonEmpty a
:| []
    goOneOf :: NonEmpty JSONSchema -> NonEmpty JSONSchema
    goOneOf :: NonEmpty JSONSchema -> NonEmpty JSONSchema
goOneOf (JSONSchema
s :| [JSONSchema]
rest) = case 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 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' 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 <- forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
go ValueCodec input output
c
        forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
go ValueCodec input1 output1
c
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> KeyRequirement -> JSONSchema -> Maybe Text -> ObjectSchema
ObjectKeySchema Text
k (Maybe Value -> KeyRequirement
Optional 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 <- forall input output.
ValueCodec input output -> State (Set Text) JSONSchema
go ValueCodec input input
c
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> KeyRequirement -> JSONSchema -> Maybe Text -> ObjectSchema
ObjectKeySchema Text
k (Maybe Value -> KeyRequirement
Optional (forall a. a -> Maybe a
Just (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 -> forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject (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 -> 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 <- forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject Codec Object input1 output1
oc1
        ObjectSchema
os2 <- forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject Codec Object input2 output2
oc2
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Union
u of
          Union
DisjointUnion -> NonEmpty ObjectSchema -> ObjectSchema
ObjectOneOfSchema (NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectOneOf (ObjectSchema
os1 forall a. a -> [a] -> NonEmpty a
:| [ObjectSchema
os2]))
          Union
PossiblyJointUnion -> NonEmpty ObjectSchema -> ObjectSchema
ObjectAnyOfSchema (NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectAnyOf (ObjectSchema
os1 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) =
              forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject forall a b. (a -> b) -> a -> b
$ ObjectCodec Void output
oc forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall input output.
Text -> ValueCodec input output -> ObjectCodec input output
requiredFieldWith' Text
pn (Text -> JSONCodec Text
literalTextCodec Text
dName) forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
.= forall a b. a -> b -> a
const Text
dName)
        HashMap Text ObjectSchema
ss <- 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
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectOneOf NonEmpty ObjectSchema
ss'
      PureCodec output
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ObjectSchema
ObjectAnySchema
      ApCodec ObjectCodec input (output1 -> output)
oc1 ObjectCodec input output1
oc2 -> do
        ObjectSchema
os1 <- forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject ObjectCodec input (output1 -> output)
oc1
        ObjectSchema
os2 <- forall input output.
ObjectCodec input output -> State (Set Text) ObjectSchema
goObject ObjectCodec input output1
oc2
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NonEmpty ObjectSchema -> ObjectSchema
ObjectAllOfSchema (NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectAllOf (ObjectSchema
os1 forall a. a -> [a] -> NonEmpty a
:| [ObjectSchema
os2]))

    goObjectAnyOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
    goObjectAnyOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectAnyOf (ObjectSchema
s :| [ObjectSchema]
rest) = case 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 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' forall a. a -> [a] -> NonEmpty a
:| []

    goObjectOneOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
    goObjectOneOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectOneOf (ObjectSchema
s :| [ObjectSchema]
rest) = case 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 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' forall a. a -> [a] -> NonEmpty a
:| []

    goObjectAllOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
    goObjectAllOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
goObjectAllOf (ObjectSchema
s :| [ObjectSchema]
rest) = case 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 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' forall a. a -> [a] -> NonEmpty a
:| []

uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)
uncurry3 :: forall a b c d. (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