{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedLists     #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.OpenApi.Schema.Generator where

import           Prelude                                 ()
import           Prelude.Compat

import           Control.Lens.Operators
import           Control.Monad                           (filterM)
import           Data.Aeson
import           Data.Aeson.Types
import qualified Data.HashMap.Strict.InsOrd              as M
import           Data.Maybe
import           Data.Proxy
import           Data.Scientific
import qualified Data.Set                                as S
import           Data.OpenApi
import           Data.OpenApi.Declare
import           Data.OpenApi.Internal.Schema.Validation (inferSchemaTypes)
import qualified Data.Text                               as T
import qualified Data.Vector                             as V
import           Test.QuickCheck                         (arbitrary)
import           Test.QuickCheck.Gen
import           Test.QuickCheck.Property

-- | Note: 'schemaGen' may 'error', if schema type is not specified,
-- and cannot be inferred.
schemaGen :: Definitions Schema -> Schema -> Gen Value
schemaGen :: Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
_ Schema
schema
    | Just [Value]
cases <- Schema
schema  Schema
-> Getting (Maybe [Value]) Schema (Maybe [Value]) -> Maybe [Value]
forall s a. s -> Getting a s a -> a
^. Getting (Maybe [Value]) Schema (Maybe [Value])
forall s a. HasEnum s a => Lens' s a
enum_  = [Value] -> Gen Value
forall a. [a] -> Gen a
elements [Value]
cases
schemaGen Definitions Schema
defns Schema
schema
    | Just [Referenced Schema]
variants <- Schema
schema Schema
-> Getting
     (Maybe [Referenced Schema]) Schema (Maybe [Referenced Schema])
-> Maybe [Referenced Schema]
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe [Referenced Schema]) Schema (Maybe [Referenced Schema])
forall s a. HasOneOf s a => Lens' s a
oneOf = Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defns (Schema -> Gen Value) -> Gen Schema -> Gen Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Schema] -> Gen Schema
forall a. [a] -> Gen a
elements (Definitions Schema -> Referenced Schema -> Schema
forall a. Definitions a -> Referenced a -> a
dereference Definitions Schema
defns (Referenced Schema -> Schema) -> [Referenced Schema] -> [Schema]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Referenced Schema]
variants)
schemaGen Definitions Schema
defns Schema
schema =
    case Schema
schema Schema
-> Getting (Maybe OpenApiType) Schema (Maybe OpenApiType)
-> Maybe OpenApiType
forall s a. s -> Getting a s a -> a
^. Getting (Maybe OpenApiType) Schema (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
type_ of
      Maybe OpenApiType
Nothing ->
        case Schema -> [OpenApiType]
inferSchemaTypes Schema
schema of
          [ Item [OpenApiType]
inferredType ] -> Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defns (Schema
schema Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Item [OpenApiType]
OpenApiType
inferredType)
          -- Gen is not MonadFail
          [OpenApiType]
_ -> [Char] -> Gen Value
forall a. HasCallStack => [Char] -> a
error [Char]
"unable to infer schema type"
      Just OpenApiType
OpenApiBoolean -> Bool -> Value
Bool (Bool -> Value) -> Gen Bool -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Bool] -> Gen Bool
forall a. [a] -> Gen a
elements [Bool
Item [Bool]
True, Bool
Item [Bool]
False]
      Just OpenApiType
OpenApiNull    -> Value -> Gen Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null
      Just OpenApiType
OpenApiNumber
        | Just Scientific
min <- Schema
schema Schema
-> Getting (Maybe Scientific) Schema (Maybe Scientific)
-> Maybe Scientific
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Scientific) Schema (Maybe Scientific)
forall s a. HasMinimum s a => Lens' s a
minimum_
        , Just Scientific
max <- Schema
schema Schema
-> Getting (Maybe Scientific) Schema (Maybe Scientific)
-> Maybe Scientific
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Scientific) Schema (Maybe Scientific)
forall s a. HasMaximum s a => Lens' s a
maximum_ ->
            Scientific -> Value
Number (Scientific -> Value) -> (Double -> Scientific) -> Double -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Scientific
forall a. RealFloat a => a -> Scientific
fromFloatDigits (Double -> Value) -> Gen Double -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                   (Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
min, Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
max :: Double)
        | Bool
otherwise -> Scientific -> Value
Number (Scientific -> Value) -> (Double -> Scientific) -> Double -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Double -> Scientific
forall a. RealFloat a => a -> Scientific
fromFloatDigits (Double -> Value) -> Gen Double -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen Double
forall a. Arbitrary a => Gen a
arbitrary :: Gen Double)
      Just OpenApiType
OpenApiInteger
        | Just Scientific
min <- Schema
schema Schema
-> Getting (Maybe Scientific) Schema (Maybe Scientific)
-> Maybe Scientific
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Scientific) Schema (Maybe Scientific)
forall s a. HasMinimum s a => Lens' s a
minimum_
        , Just Scientific
max <- Schema
schema Schema
-> Getting (Maybe Scientific) Schema (Maybe Scientific)
-> Maybe Scientific
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Scientific) Schema (Maybe Scientific)
forall s a. HasMaximum s a => Lens' s a
maximum_ ->
            Scientific -> Value
Number (Scientific -> Value)
-> (Integer -> Scientific) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Value) -> Gen Integer -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                   (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Scientific -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate Scientific
min, Scientific -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate Scientific
max)
        | Bool
otherwise -> Scientific -> Value
Number (Scientific -> Value)
-> (Integer -> Scientific) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Value) -> Gen Integer -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. Arbitrary a => Gen a
arbitrary
      Just OpenApiType
OpenApiArray
        | Just Integer
0 <- Schema
schema Schema
-> Getting (Maybe Integer) Schema (Maybe Integer) -> Maybe Integer
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Integer) Schema (Maybe Integer)
forall s a. HasMaxLength s a => Lens' s a
maxLength -> Value -> Gen Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Gen Value) -> Value -> Gen Value
forall a b. (a -> b) -> a -> b
$ Array -> Value
Array Array
forall a. Vector a
V.empty
        | Just OpenApiItems
items <- Schema
schema Schema
-> Getting (Maybe OpenApiItems) Schema (Maybe OpenApiItems)
-> Maybe OpenApiItems
forall s a. s -> Getting a s a -> a
^. Getting (Maybe OpenApiItems) Schema (Maybe OpenApiItems)
forall s a. HasItems s a => Lens' s a
items ->
            case OpenApiItems
items of
              OpenApiItemsObject Referenced Schema
ref -> do
                  Int
size <- Gen Int
getSize
                  let itemSchema :: Schema
itemSchema = Definitions Schema -> Referenced Schema -> Schema
forall a. Definitions a -> Referenced a -> a
dereference Definitions Schema
defns Referenced Schema
ref
                      minLength' :: Int
minLength' = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Maybe Integer -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema Schema
-> Getting (Maybe Integer) Schema (Maybe Integer) -> Maybe Integer
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Integer) Schema (Maybe Integer)
forall s a. HasMinItems s a => Lens' s a
minItems
                      maxLength' :: Int
maxLength' = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
size (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Maybe Integer -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema Schema
-> Getting (Maybe Integer) Schema (Maybe Integer) -> Maybe Integer
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Integer) Schema (Maybe Integer)
forall s a. HasMaxItems s a => Lens' s a
maxItems
                  Int
arrayLength <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
minLength', Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
minLength' Int
maxLength')
                  [Value]
generatedArray <- Int -> Gen Value -> Gen [Value]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
arrayLength (Gen Value -> Gen [Value]) -> Gen Value -> Gen [Value]
forall a b. (a -> b) -> a -> b
$ Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defns Schema
itemSchema
                  Value -> Gen Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Gen Value) -> (Array -> Value) -> Array -> Gen Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Value
Array (Array -> Gen Value) -> Array -> Gen Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
V.fromList [Value]
generatedArray
              OpenApiItemsArray [Referenced Schema]
refs ->
                  let itemGens :: [Gen Value]
itemGens = Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defns (Schema -> Gen Value)
-> (Referenced Schema -> Schema) -> Referenced Schema -> Gen Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definitions Schema -> Referenced Schema -> Schema
forall a. Definitions a -> Referenced a -> a
dereference Definitions Schema
defns (Referenced Schema -> Gen Value)
-> [Referenced Schema] -> [Gen Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Referenced Schema]
refs
                  in ([Value] -> Value) -> Gen [Value] -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Array -> Value
Array (Array -> Value) -> ([Value] -> Array) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
V.fromList) (Gen [Value] -> Gen Value) -> Gen [Value] -> Gen Value
forall a b. (a -> b) -> a -> b
$ [Gen Value] -> Gen [Value]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Gen Value]
itemGens
      Just OpenApiType
OpenApiString -> do
        Int
size <- Gen Int
getSize
        let minLength' :: Int
minLength' = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Maybe Integer -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema Schema
-> Getting (Maybe Integer) Schema (Maybe Integer) -> Maybe Integer
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Integer) Schema (Maybe Integer)
forall s a. HasMinLength s a => Lens' s a
minLength
        let maxLength' :: Int
maxLength' = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
size (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Maybe Integer -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema Schema
-> Getting (Maybe Integer) Schema (Maybe Integer) -> Maybe Integer
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Integer) Schema (Maybe Integer)
forall s a. HasMaxLength s a => Lens' s a
maxLength
        Int
length <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
minLength', Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
minLength' Int
maxLength')
        [Char]
str <- Int -> Gen Char -> Gen [Char]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
length Gen Char
forall a. Arbitrary a => Gen a
arbitrary
        Value -> Gen Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Gen Value) -> (Text -> Value) -> Text -> Gen Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String (Text -> Gen Value) -> Text -> Gen Value
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
str
      Just OpenApiType
OpenApiObject -> do
          Int
size <- Gen Int
getSize
          let props :: Definitions Schema
props = Definitions Schema -> Referenced Schema -> Schema
forall a. Definitions a -> Referenced a -> a
dereference Definitions Schema
defns (Referenced Schema -> Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Definitions Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema Schema
-> Getting
     (InsOrdHashMap Text (Referenced Schema))
     Schema
     (InsOrdHashMap Text (Referenced Schema))
-> InsOrdHashMap Text (Referenced Schema)
forall s a. s -> Getting a s a -> a
^. Getting
  (InsOrdHashMap Text (Referenced Schema))
  Schema
  (InsOrdHashMap Text (Referenced Schema))
forall s a. HasProperties s a => Lens' s a
properties
              reqKeys :: Set Text
reqKeys = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ Schema
schema Schema -> Getting [Text] Schema [Text] -> [Text]
forall s a. s -> Getting a s a -> a
^. Getting [Text] Schema [Text]
forall s a. HasRequired s a => Lens' s a
required
              allKeys :: Set Text
allKeys = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text)
-> (InsOrdHashMap Text (Referenced Schema) -> [Text])
-> InsOrdHashMap Text (Referenced Schema)
-> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InsOrdHashMap Text (Referenced Schema) -> [Text]
forall k v. InsOrdHashMap k v -> [k]
M.keys (InsOrdHashMap Text (Referenced Schema) -> Set Text)
-> InsOrdHashMap Text (Referenced Schema) -> Set Text
forall a b. (a -> b) -> a -> b
$ Schema
schema Schema
-> Getting
     (InsOrdHashMap Text (Referenced Schema))
     Schema
     (InsOrdHashMap Text (Referenced Schema))
-> InsOrdHashMap Text (Referenced Schema)
forall s a. s -> Getting a s a -> a
^. Getting
  (InsOrdHashMap Text (Referenced Schema))
  Schema
  (InsOrdHashMap Text (Referenced Schema))
forall s a. HasProperties s a => Lens' s a
properties
              optionalKeys :: Set Text
optionalKeys = Set Text
allKeys Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set Text
reqKeys
              minProps' :: Int
minProps' = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Set Text -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set Text
reqKeys) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$
                            Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Maybe Integer -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema Schema
-> Getting (Maybe Integer) Schema (Maybe Integer) -> Maybe Integer
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Integer) Schema (Maybe Integer)
forall s a. HasMinProperties s a => Lens' s a
minProperties
              maxProps' :: Int
maxProps' = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
size (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Maybe Integer -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema
schema Schema
-> Getting (Maybe Integer) Schema (Maybe Integer) -> Maybe Integer
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Integer) Schema (Maybe Integer)
forall s a. HasMaxProperties s a => Lens' s a
maxProperties
          [Text]
shuffledOptional <- [Text] -> Gen [Text]
forall a. [a] -> Gen [a]
shuffle ([Text] -> Gen [Text]) -> [Text] -> Gen [Text]
forall a b. (a -> b) -> a -> b
$ Set Text -> [Text]
forall a. Set a -> [a]
S.toList Set Text
optionalKeys
          Int
numProps <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
minProps', Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
minProps' Int
maxProps')
          let presentKeys :: [Text]
presentKeys = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
numProps ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Set Text -> [Text]
forall a. Set a -> [a]
S.toList Set Text
reqKeys [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
shuffledOptional
          let presentProps :: Definitions Schema
presentProps = (Text -> Schema -> Bool)
-> Definitions Schema -> Definitions Schema
forall k v.
(k -> v -> Bool) -> InsOrdHashMap k v -> InsOrdHashMap k v
M.filterWithKey (\Text
k Schema
_ -> Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
presentKeys) Definitions Schema
props
          let gens :: InsOrdHashMap Text (Gen Value)
gens = Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defns (Schema -> Gen Value)
-> Definitions Schema -> InsOrdHashMap Text (Gen Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Definitions Schema
presentProps
          InsOrdHashMap Text (Gen Value)
additionalGens <- case Schema
schema Schema
-> Getting
     (Maybe AdditionalProperties) Schema (Maybe AdditionalProperties)
-> Maybe AdditionalProperties
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe AdditionalProperties) Schema (Maybe AdditionalProperties)
forall s a. HasAdditionalProperties s a => Lens' s a
additionalProperties of
            Just (AdditionalPropertiesSchema Referenced Schema
addlSchema) -> do
              [Text]
additionalKeys <- [Gen Text] -> Gen [Text]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Gen Text] -> Gen [Text])
-> (Gen Text -> [Gen Text]) -> Gen Text -> Gen [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Gen Text] -> [Gen Text]
forall a. Int -> [a] -> [a]
take (Int
numProps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Definitions Schema -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Definitions Schema
presentProps) ([Gen Text] -> [Gen Text])
-> (Gen Text -> [Gen Text]) -> Gen Text -> [Gen Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen Text -> [Gen Text]
forall a. a -> [a]
repeat (Gen Text -> Gen [Text]) -> Gen Text -> Gen [Text]
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> Gen [Char] -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [Char]
forall a. Arbitrary a => Gen a
arbitrary
              InsOrdHashMap Text (Gen Value)
-> Gen (InsOrdHashMap Text (Gen Value))
forall (m :: * -> *) a. Monad m => a -> m a
return (InsOrdHashMap Text (Gen Value)
 -> Gen (InsOrdHashMap Text (Gen Value)))
-> ([(Text, Gen Value)] -> InsOrdHashMap Text (Gen Value))
-> [(Text, Gen Value)]
-> Gen (InsOrdHashMap Text (Gen Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Gen Value)] -> InsOrdHashMap Text (Gen Value)
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
M.fromList ([(Text, Gen Value)] -> Gen (InsOrdHashMap Text (Gen Value)))
-> [(Text, Gen Value)] -> Gen (InsOrdHashMap Text (Gen Value))
forall a b. (a -> b) -> a -> b
$ [Text] -> [Gen Value] -> [(Text, Gen Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
additionalKeys (Gen Value -> [Gen Value]
forall a. a -> [a]
repeat (Gen Value -> [Gen Value])
-> (Schema -> Gen Value) -> Schema -> [Gen Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defns (Schema -> [Gen Value]) -> Schema -> [Gen Value]
forall a b. (a -> b) -> a -> b
$ Definitions Schema -> Referenced Schema -> Schema
forall a. Definitions a -> Referenced a -> a
dereference Definitions Schema
defns Referenced Schema
addlSchema)
            Maybe AdditionalProperties
_                                      -> InsOrdHashMap Text (Gen Value)
-> Gen (InsOrdHashMap Text (Gen Value))
forall (m :: * -> *) a. Monad m => a -> m a
return []
          InsOrdHashMap Text Value
x <- InsOrdHashMap Text (Gen Value) -> Gen (InsOrdHashMap Text Value)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (InsOrdHashMap Text (Gen Value) -> Gen (InsOrdHashMap Text Value))
-> InsOrdHashMap Text (Gen Value) -> Gen (InsOrdHashMap Text Value)
forall a b. (a -> b) -> a -> b
$ InsOrdHashMap Text (Gen Value)
gens InsOrdHashMap Text (Gen Value)
-> InsOrdHashMap Text (Gen Value) -> InsOrdHashMap Text (Gen Value)
forall a. Semigroup a => a -> a -> a
<> InsOrdHashMap Text (Gen Value)
additionalGens
          Value -> Gen Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Gen Value) -> (Object -> Value) -> Object -> Gen Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
Object (Object -> Gen Value) -> Object -> Gen Value
forall a b. (a -> b) -> a -> b
$ InsOrdHashMap Text Value -> Object
forall k v. InsOrdHashMap k v -> HashMap k v
M.toHashMap InsOrdHashMap Text Value
x

dereference :: Definitions a -> Referenced a -> a
dereference :: Definitions a -> Referenced a -> a
dereference Definitions a
_ (Inline a
a)               = a
a
dereference Definitions a
defs (Ref (Reference Text
ref)) = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ Text -> Definitions a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
M.lookup Text
ref Definitions a
defs

genValue :: (ToSchema a) => Proxy a -> Gen Value
genValue :: Proxy a -> Gen Value
genValue Proxy a
p =
 let (Definitions Schema
defs, NamedSchema Maybe Text
_ Schema
schema) = Declare (Definitions Schema) NamedSchema
-> Definitions Schema -> (Definitions Schema, NamedSchema)
forall d a. Declare d a -> d -> (d, a)
runDeclare (Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy a
p) Definitions Schema
forall k v. InsOrdHashMap k v
M.empty
 in Definitions Schema -> Schema -> Gen Value
schemaGen Definitions Schema
defs Schema
schema

validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property
validateFromJSON :: Proxy a -> Property
validateFromJSON Proxy a
p = Gen Value -> (Value -> Result) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Proxy a -> Gen Value
forall a. ToSchema a => Proxy a -> Gen Value
genValue Proxy a
p) ((Value -> Result) -> Property) -> (Value -> Result) -> Property
forall a b. (a -> b) -> a -> b
$
                       \Value
val -> case (Value -> Parser a) -> Value -> Either [Char] a
forall a b. (a -> Parser b) -> a -> Either [Char] b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val of
                                 Right (a
_ :: a) -> Result
succeeded
                                 Left [Char]
err -> Result
failed
                                               { reason :: [Char]
reason = [Char]
err
                                               }