{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}

-- | This module provides generators for JSON values
--
--   Since the Value data type is an ADT with different alternatives and a recursive data type
--   we need to control how many of each variant (Number, String, Array, etc...) we generate
--   and how deeply we recurse when generating arrays and objects which themselves contain Values.
--
--   A registry is used to store all the generators and the current generation configuration
--
--   In order to control the recursivity we tag the type of Values we generate:
--
--     - @Tag "Simple" Value@ is for generating Null, Number, String, Boolean
--     - @Tag "Recurse" Value@ is for generating Array and Object
--
--   And we put a 'Depth` parameter in the registry. That parameter is decremented every time we generate values
--   for an Array or an Object
module Data.Registry.Hedgehog.AesonGenerators where

import Data.Aeson
import Data.Registry
import Data.Scientific as Scientific hiding (normalize)
import Data.String (fromString)
import Data.Vector as Vector (fromList)
import Hedgehog as H
import Hedgehog.Gen as Gen hiding (either)
import Hedgehog.Range as Range
import Protolude

-- | Generator for a default JSON value
genValue :: Gen Value
genValue :: Gen Value
genValue = forall {insr :: [*]}.
Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
-> Gen Value
genValueFor Registry
  (GenT Identity (Tag "Simple" Value)
     : GenT Identity (Tag "Null" Value)
     : GenT Identity (Tag "Bool" Value) : Gen (Tag "Number" Value)
     : GenT Identity (Tag "String" Value)
     : GenT Identity (Range Integer) : GenT Identity Text
     : (Inputs (GenT Identity Text -> GenT Identity FieldName)
        :++ '[GenT Identity (Range Int)]))
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
simpleGens

-- | Generator for a JSON value with an adjusted set of generators
--
--   For example:
--    - change the recursive depth of the generation: genValueWith (setDepth 5)
--    - change the number of elements in an array or an object: genValueWith (setFieldsNb 5)
--    - change the generator used to generate field names in an object: genValueWith (setFieldNames (elements ["a", "b", "c"]))
--    - use a custom text generator: genValueWith (setGen myTextGenerator)
--    - change the range used for generating numbers: genValueWith (setRange (linear @Int 0 20))
genValueWith :: (Registry _ _ -> Registry _ _) -> Gen Value
genValueWith :: (Registry
   (GenT Identity (Tag "Simple" Value)
      : GenT Identity (Tag "Null" Value)
      : GenT Identity (Tag "Bool" Value) : Gen (Tag "Number" Value)
      : GenT Identity (Tag "String" Value)
      : GenT Identity (Range Integer) : GenT Identity Text
      : (Inputs (GenT Identity Text -> GenT Identity FieldName)
         :++ '[GenT Identity (Range Int)]))
   '[Gen Value, GenT Identity (Tag "Simple" Value),
     Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
     Output (GenT Identity Text -> GenT Identity FieldName),
     GenT Identity Text, GenT Identity (Tag "Bool" Value),
     GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
     GenT Identity (Range Integer), Depth]
 -> Registry
      insr
      '[Gen Value, GenT Identity (Tag "Simple" Value),
        Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
        Output (GenT Identity Text -> GenT Identity FieldName),
        GenT Identity Text, GenT Identity (Tag "Bool" Value),
        GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
        GenT Identity (Range Integer), Depth])
-> Gen Value
genValueWith Registry
  (GenT Identity (Tag "Simple" Value)
     : GenT Identity (Tag "Null" Value)
     : GenT Identity (Tag "Bool" Value) : Gen (Tag "Number" Value)
     : GenT Identity (Tag "String" Value)
     : GenT Identity (Range Integer) : GenT Identity Text
     : (Inputs (GenT Identity Text -> GenT Identity FieldName)
        :++ '[GenT Identity (Range Int)]))
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
-> Registry
     insr
     '[Gen Value, GenT Identity (Tag "Simple" Value),
       Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
       Output (GenT Identity Text -> GenT Identity FieldName),
       GenT Identity Text, GenT Identity (Tag "Bool" Value),
       GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
       GenT Identity (Range Integer), Depth]
f = forall {insr :: [*]}.
Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
-> Gen Value
genValueFor (Registry
  (GenT Identity (Tag "Simple" Value)
     : GenT Identity (Tag "Null" Value)
     : GenT Identity (Tag "Bool" Value) : Gen (Tag "Number" Value)
     : GenT Identity (Tag "String" Value)
     : GenT Identity (Range Integer) : GenT Identity Text
     : (Inputs (GenT Identity Text -> GenT Identity FieldName)
        :++ '[GenT Identity (Range Int)]))
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
-> Registry
     insr
     '[Gen Value, GenT Identity (Tag "Simple" Value),
       Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
       Output (GenT Identity Text -> GenT Identity FieldName),
       GenT Identity Text, GenT Identity (Tag "Bool" Value),
       GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
       GenT Identity (Range Integer), Depth]
f Registry
  (GenT Identity (Tag "Simple" Value)
     : GenT Identity (Tag "Null" Value)
     : GenT Identity (Tag "Bool" Value) : Gen (Tag "Number" Value)
     : GenT Identity (Tag "String" Value)
     : GenT Identity (Range Integer) : GenT Identity Text
     : (Inputs (GenT Identity Text -> GenT Identity FieldName)
        :++ '[GenT Identity (Range Int)]))
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
simpleGens)

-- | Specialized generator for a number value
genNumberValue :: Gen Value
genNumberValue :: Gen Value
genNumberValue = forall (s :: Symbol) a. Tag s a -> a
unTag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> a
make @(Gen (Tag "Number" Value)) Registry
  (GenT Identity (Tag "Simple" Value)
     : GenT Identity (Tag "Null" Value)
     : GenT Identity (Tag "Bool" Value) : Gen (Tag "Number" Value)
     : GenT Identity (Tag "String" Value)
     : GenT Identity (Range Integer) : GenT Identity Text
     : (Inputs (GenT Identity Text -> GenT Identity FieldName)
        :++ '[GenT Identity (Range Int)]))
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
simpleGens

-- | Generate a JSON value with a given set of generators to be used when recursing
genValueFor :: Registry _ _ -> Gen Value
genValueFor :: Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
-> Gen Value
genValueFor Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
gens =
  case forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> a
make @Depth Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
gens of
    -- if the depth is 0 generate a Value from the "Simple" Value generation
    Depth
0 -> forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> a
make @(Gen Value) Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
gens
    -- if the depth is > 0 generate possibly recursive values like arrays and objects
    Depth
_ -> forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> a
make @(Gen Value) forall a b. (a -> b) -> a -> b
$ Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
-> Registry
     (Normalized
        (GenT Identity (Tag "Array" Value)
           : GenT Identity (Tag "Object" Value)
           : GenT Identity (Tag "Simple" Value) : GenT Identity [FieldName]
           : GenT Identity [Tag "Recurse" Value]
           : GenT Identity [Tag "Recurse" Value] : GenT Identity FieldName
           : GenT Identity (Tag "Recurse" Value) : insr))
     (Normalized
        '[Gen Value, GenT Identity (Tag "Object" Value),
          GenT Identity (Tag "Array" Value), GenT Identity [FieldName],
          GenT Identity [Tag "Recurse" Value],
          GenT Identity (Tag "Recurse" Value), Gen Value,
          GenT Identity (Tag "Simple" Value), Gen (Tag "Number" Value),
          GenT Identity (Tag "String" Value),
          Output (GenT Identity Text -> GenT Identity FieldName),
          GenT Identity Text, GenT Identity (Tag "Bool" Value),
          GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
          GenT Identity (Range Integer), Depth])
recursiveGens (forall {w :: [*]} {w :: [*]}. Registry w w -> Registry w w
decrementDepth Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
gens)

-- | Set of generators for JSON values including recursive values like arrays and objects
--   In order to control the recursivity of the 'Value' data type we produce several types
--   for JSON values using tags:
--     @Recurse Value@ is a generated value to be used when generating an array or an object
--     @Simple Value@ is a generated value that is either: a string, a number, a bool, a null value
recursiveGens :: Registry _ _ -> Registry _ _
recursiveGens :: Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
-> Registry
     (Normalized
        (GenT Identity (Tag "Array" Value)
           : GenT Identity (Tag "Object" Value)
           : GenT Identity (Tag "Simple" Value) : GenT Identity [FieldName]
           : GenT Identity [Tag "Recurse" Value]
           : GenT Identity [Tag "Recurse" Value] : GenT Identity FieldName
           : GenT Identity (Tag "Recurse" Value) : insr))
     (Normalized
        '[Gen Value, GenT Identity (Tag "Object" Value),
          GenT Identity (Tag "Array" Value), GenT Identity [FieldName],
          GenT Identity [Tag "Recurse" Value],
          GenT Identity (Tag "Recurse" Value), Gen Value,
          GenT Identity (Tag "Simple" Value), Gen (Tag "Number" Value),
          GenT Identity (Tag "String" Value),
          Output (GenT Identity Text -> GenT Identity FieldName),
          GenT Identity Text, GenT Identity (Tag "Bool" Value),
          GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
          GenT Identity (Range Integer), Depth])
recursiveGens Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
overrides =
  forall (ins :: [*]) (out :: [*]).
Registry ins out -> Registry (Normalized ins) (Normalized out)
normalize forall a b. (a -> b) -> a -> b
$
    -- generator choosing between generated arrays, objects or simple values
    forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen Tag "Array" Value
-> Tag "Object" Value -> Tag "Simple" Value -> Gen Value
genRecursiveValue
      -- generator for objects
      forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen [FieldName] -> [Tag "Recurse" Value] -> Tag "Object" Value
genObject
      -- generator for arrays
      forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen [Tag "Recurse" Value] -> Tag "Array" Value
genArray
      -- generator for field names (up to 3 by default)
      forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a. Typeable a => a -> Typed a
fun (forall a. Int -> Int -> Gen a -> Gen [a]
listOf @FieldName Int
1 Int
3)
      -- generator for the elements of arrays or objects (up to 3 by default)
      forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a. Typeable a => a -> Typed a
fun (forall a. Int -> Int -> Gen a -> Gen [a]
listOf @(Tag "Recurse" Value) Int
1 Int
3)
      -- generator for a JSON value to be used in an object or an array
      forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a. Typeable a => a -> Typed a
fun (forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
-> Gen Value
genValueFor Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
overrides :: Gen (Tag "Recurse" Value))
      -- simple, non-recursive, generators
      forall a b c. AddRegistryLike a b c => a -> b -> c
<: Registry
  insr
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    GenT Identity (Range Integer), Depth]
overrides

-- | Set of generators for non-recursive JSON values
--   Those value are tagged as @Simple@ but we can also extract a @Gen Value@ from this list
simpleGens :: Registry _ _
simpleGens :: Registry
  (GenT Identity (Tag "Simple" Value)
     : GenT Identity (Tag "Null" Value)
     : GenT Identity (Tag "Bool" Value) : Gen (Tag "Number" Value)
     : GenT Identity (Tag "String" Value)
     : GenT Identity (Range Integer) : GenT Identity Text
     : (Inputs (GenT Identity Text -> GenT Identity FieldName)
        :++ (GenT Identity (Range Int)
               : (Inputs (GenT Identity (Range Integer)) :++ '[]))))
  '[Gen Value, GenT Identity (Tag "Simple" Value),
    Gen (Tag "Number" Value), GenT Identity (Tag "String" Value),
    Output (GenT Identity Text -> GenT Identity FieldName),
    GenT Identity Text, GenT Identity (Tag "Bool" Value),
    GenT Identity (Tag "Null" Value), GenT Identity (Range Int),
    Output (GenT Identity (Range Integer)), Depth]
simpleGens =
  forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen Tag "Simple" Value -> Value
untagSimpleValue
    forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen Tag "Null" Value
-> Tag "Bool" Value
-> Tag "Number" Value
-> Tag "String" Value
-> GenT Identity (Tag "Simple" Value)
genSimpleValue
    forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen Range Integer -> Gen (Tag "Number" Value)
genNumber
    forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen Text -> Tag "String" Value
genString
    forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen Text -> FieldName
FieldName
    forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen Range Int -> GenT Identity Text
genText
    forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen GenT Identity (Tag "Bool" Value)
genBool
    forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen GenT Identity (Tag "Null" Value)
genNull
    forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen (forall a. Integral a => a -> a -> Range a
linear Int
0 Int
5 :: Range Int)
    forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen (forall a. Integral a => a -> a -> Range a
linear (-Integer
1000) Integer
1000 :: Range Integer)
    forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a. (Typeable a, Show a) => a -> Typed a
val (Int -> Depth
Depth Int
3)

-- * Individual generators

-- | Create a generator for a Value which can possibly be recursive if it is an array or an object
genRecursiveValue :: Tag "Array" Value -> Tag "Object" Value -> Tag "Simple" Value -> Gen Value
genRecursiveValue :: Tag "Array" Value
-> Tag "Object" Value -> Tag "Simple" Value -> Gen Value
genRecursiveValue Tag "Array" Value
arrayValue Tag "Object" Value
objectValue Tag "Simple" Value
simpleValue = forall (m :: * -> *) a. MonadGen m => [a] -> m a
Gen.element [forall (s :: Symbol) a. Tag s a -> a
unTag Tag "Array" Value
arrayValue, forall (s :: Symbol) a. Tag s a -> a
unTag Tag "Object" Value
objectValue, forall (s :: Symbol) a. Tag s a -> a
unTag Tag "Simple" Value
simpleValue]

-- | Drop the tag on a Value
untagSimpleValue :: Tag "Simple" Value -> Value
untagSimpleValue :: Tag "Simple" Value -> Value
untagSimpleValue = forall (s :: Symbol) a. Tag s a -> a
unTag

-- | Create a generator for a non-recursive Value (i.e. not an array or an object)
genSimpleValue :: Tag "Null" Value -> Tag "Bool" Value -> Tag "Number" Value -> Tag "String" Value -> Gen (Tag "Simple" Value)
genSimpleValue :: Tag "Null" Value
-> Tag "Bool" Value
-> Tag "Number" Value
-> Tag "String" Value
-> GenT Identity (Tag "Simple" Value)
genSimpleValue Tag "Null" Value
nullValue Tag "Bool" Value
boolValue Tag "Number" Value
numberValue Tag "String" Value
stringValue =
  forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadGen m => [a] -> m a
Gen.element [forall (s :: Symbol) a. Tag s a -> a
unTag Tag "Null" Value
nullValue, forall (s :: Symbol) a. Tag s a -> a
unTag Tag "Bool" Value
boolValue, forall (s :: Symbol) a. Tag s a -> a
unTag Tag "Number" Value
numberValue, forall (s :: Symbol) a. Tag s a -> a
unTag Tag "String" Value
stringValue]

-- | Generator for the Null value
genNull :: Gen (Tag "Null" Value)
genNull :: GenT Identity (Tag "Null" Value)
genNull = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag Value
Null)

-- | Generator for a boolean value
genBool :: Gen (Tag "Bool" Value)
genBool :: GenT Identity (Tag "Bool" Value)
genBool = forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadGen m => m Bool
Gen.bool

-- | Generator for some Text
genText :: Range Int -> Gen Text
genText :: Range Int -> GenT Identity Text
genText Range Int
range = forall (m :: * -> *). MonadGen m => Range Int -> m Char -> m Text
Gen.text Range Int
range forall (m :: * -> *). MonadGen m => m Char
Gen.alphaNum

-- | Generator for a string value
genString :: Text -> Tag "String" Value
genString :: Text -> Tag "String" Value
genString = forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String

-- | Generator for a number value
genNumber :: Range Integer -> Gen (Tag "Number" Value)
genNumber :: Range Integer -> Gen (Tag "Number" Value)
genNumber Range Integer
range = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag forall a b. (a -> b) -> a -> b
$ Scientific -> Value
Number forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer -> Int -> Scientific
scientific forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. (MonadGen m, Integral a) => Range a -> m a
Gen.integral Range Integer
range forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0)

-- | Generator for an array value
genArray :: [Tag "Recurse" Value] -> Tag "Array" Value
genArray :: [Tag "Recurse" Value] -> Tag "Array" Value
genArray = forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Value
Array forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
Vector.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (s :: Symbol) a. Tag s a -> a
unTag

-- | Generator for an object value
genObject :: [FieldName] -> [Tag "Recurse" Value] -> Tag "Object" Value
genObject :: [FieldName] -> [Tag "Recurse" Value] -> Tag "Object" Value
genObject [FieldName]
fields [Tag "Recurse" Value]
values = forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Text
unFieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldName]
fields) (forall (s :: Symbol) a. Tag s a -> a
unTag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tag "Recurse" Value]
values)

-- * Support functions

-- | Simplification for funTo @Gen when adding a new function to the registry
gen :: forall a b. (ApplyVariadic Gen a b, Typeable a, Typeable b) => a -> Typed b
gen :: forall a b.
(ApplyVariadic (GenT Identity) a b, Typeable a, Typeable b) =>
a -> Typed b
gen = forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo @Gen

-- | set a specific generator on top of the list of generators
setGen :: (Typeable a) => Gen a -> Registry _ _ -> Registry _ _
setGen :: Gen a -> Registry w out -> Registry w (Gen a : out)
setGen Gen a
g Registry w out
r = forall a. Typeable a => a -> Typed a
fun Gen a
g forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
+: Registry w out
r

-- | set a specific range on top of the list of generators
setRange :: (Typeable a) => Range a -> Registry _ _ -> Registry _ _
setRange :: Range a -> Registry w out -> Registry w (Range a : out)
setRange Range a
range Registry w out
r = forall a. Typeable a => a -> Typed a
fun Range a
range forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
+: Registry w out
r

-- | Generate a list of min' to max' elements
listOf :: forall a. Int -> Int -> Gen a -> Gen [a]
listOf :: forall a. Int -> Int -> Gen a -> Gen [a]
listOf Int
min' Int
max' = forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (forall a. Integral a => a -> a -> Range a
linear Int
min' Int
max')

-- | Simplification for setting a new recursion depth on the registry
setDepth :: Depth -> Registry _ _ -> Registry _ _
setDepth :: Depth
-> Registry ins out
-> Registry (Normalized ins) (Normalized (Depth : out))
setDepth Depth
d Registry ins out
r = forall (ins :: [*]) (out :: [*]).
Registry ins out -> Registry (Normalized ins) (Normalized out)
normalize forall a b. (a -> b) -> a -> b
$ forall a. (Typeable a, Show a) => a -> Typed a
val Depth
d forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
+: Registry ins out
r

-- | Decrement the depth of generation during recursion
decrementDepth :: Registry _ _ -> Registry _ _
decrementDepth :: Registry w w -> Registry w w
decrementDepth = forall a (ins :: [*]) (out :: [*]).
Typeable a =>
(a -> a) -> Registry ins out -> Registry ins out
tweak (\(Depth
d :: Depth) -> Depth
d forall a. Num a => a -> a -> a
- Depth
1)

-- | Set the number of fields in an object
setFieldsNb :: Int -> Registry _ _ -> Registry _ _
setFieldsNb :: Int
-> Registry ins out
-> Registry
     (GenT Identity FieldName : ins) (GenT Identity [FieldName] : out)
setFieldsNb Int
n Registry ins out
r = forall a. Typeable a => a -> Typed a
fun (forall a. Int -> Int -> Gen a -> Gen [a]
listOf @FieldName Int
1 Int
n) forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
+: Registry ins out
r

-- | Set a generator for field names
setFieldNames :: Gen FieldName -> Registry _ _ -> Registry _ _
setFieldNames :: GenT Identity FieldName
-> Registry w out -> Registry w (GenT Identity FieldName : out)
setFieldNames GenT Identity FieldName
n Registry w out
r = forall a. Typeable a => a -> Typed a
fun GenT Identity FieldName
n forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
+: Registry w out
r

-- | Depth of generated Values
newtype Depth = Depth {Depth -> Int
unDepth :: Int}
  deriving newtype (Depth -> Depth -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Depth -> Depth -> Bool
$c/= :: Depth -> Depth -> Bool
== :: Depth -> Depth -> Bool
$c== :: Depth -> Depth -> Bool
Eq, Int -> Depth -> ShowS
[Depth] -> ShowS
Depth -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Depth] -> ShowS
$cshowList :: [Depth] -> ShowS
show :: Depth -> String
$cshow :: Depth -> String
showsPrec :: Int -> Depth -> ShowS
$cshowsPrec :: Int -> Depth -> ShowS
Show, Integer -> Depth
Depth -> Depth
Depth -> Depth -> Depth
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Depth
$cfromInteger :: Integer -> Depth
signum :: Depth -> Depth
$csignum :: Depth -> Depth
abs :: Depth -> Depth
$cabs :: Depth -> Depth
negate :: Depth -> Depth
$cnegate :: Depth -> Depth
* :: Depth -> Depth -> Depth
$c* :: Depth -> Depth -> Depth
- :: Depth -> Depth -> Depth
$c- :: Depth -> Depth -> Depth
+ :: Depth -> Depth -> Depth
$c+ :: Depth -> Depth -> Depth
Num)

-- | Newtype for the name of fields in an object
newtype FieldName = FieldName {FieldName -> Text
unFieldName :: Text}
  deriving newtype (FieldName -> FieldName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldName -> FieldName -> Bool
$c/= :: FieldName -> FieldName -> Bool
== :: FieldName -> FieldName -> Bool
$c== :: FieldName -> FieldName -> Bool
Eq, Int -> FieldName -> ShowS
[FieldName] -> ShowS
FieldName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldName] -> ShowS
$cshowList :: [FieldName] -> ShowS
show :: FieldName -> String
$cshow :: FieldName -> String
showsPrec :: Int -> FieldName -> ShowS
$cshowsPrec :: Int -> FieldName -> ShowS
Show, ReadPrec [FieldName]
ReadPrec FieldName
Int -> ReadS FieldName
ReadS [FieldName]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FieldName]
$creadListPrec :: ReadPrec [FieldName]
readPrec :: ReadPrec FieldName
$creadPrec :: ReadPrec FieldName
readList :: ReadS [FieldName]
$creadList :: ReadS [FieldName]
readsPrec :: Int -> ReadS FieldName
$creadsPrec :: Int -> ReadS FieldName
Read)