{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- | Arbitrary instances for the JSON @Value@.
module Data.Aeson.AutoType.Test (
    arbitraryTopValue
  ) where

import           Data.Aeson.AutoType.Pretty          () -- Generic instance for Value

import           Control.Applicative                 ((<$>), (<*>))
import           Data.Aeson
import           Data.Function                       (on)
import           Data.Hashable                       (Hashable)
import           Data.Generics.Uniplate.Data
import           Data.List
import           Data.Scientific
import qualified Data.Text                   as Text
import           Data.Text                           (Text)
import qualified Data.Vector                 as V
import qualified Data.HashMap.Strict         as Map
import           GHC.Generics

import           Test.QuickCheck.Arbitrary
import           Test.QuickCheck
import           Test.SmallCheck.Series

instance Arbitrary Text where
  arbitrary :: Gen Text
arbitrary = String -> Text
Text.pack  (String -> Text) -> Gen String -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Gen String) -> Gen String
forall a. (Int -> Gen a) -> Gen a
sized (Int -> Gen Char -> Gen String
forall a. Int -> Gen a -> Gen [a]
`vectorOf` Gen Char
alphabetic)
    where
      alphabetic :: Gen Char
alphabetic = (Char, Char) -> Gen Char
forall a. Random a => (a, a) -> Gen a
choose ('a', 'z')

instance (Arbitrary a) => Arbitrary (V.Vector a) where
  arbitrary :: Gen (Vector a)
arbitrary = [a] -> Vector a
forall a. [a] -> Vector a
V.fromList ([a] -> Vector a) -> Gen [a] -> Gen (Vector a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [a]
forall a. Arbitrary a => Gen a
arbitrary

instance (Arbitrary v) => Arbitrary (Map.HashMap Text v) where
  arbitrary :: Gen (HashMap Text v)
arbitrary = [(Text, v)] -> HashMap Text v
forall a b. (Ord a, Hashable a) => [(a, b)] -> HashMap a b
makeMap ([(Text, v)] -> HashMap Text v)
-> Gen [(Text, v)] -> Gen (HashMap Text v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [(Text, v)]
forall a. Arbitrary a => Gen a
arbitrary

-- | Helper function for generating Arbitrary and Series instances
-- for @Data.HashMap.Strict.Map@ from lists of pairs.
makeMap :: (Ord a, Hashable a) =>[(a, b)] -> Map.HashMap a b
makeMap :: [(a, b)] -> HashMap a b
makeMap  = [(a, b)] -> HashMap a b
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList
         ([(a, b)] -> HashMap a b)
-> ([(a, b)] -> [(a, b)]) -> [(a, b)] -> HashMap a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> (a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy  (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)    (a -> a -> Bool) -> ((a, b) -> a) -> (a, b) -> (a, b) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, b) -> a
forall a b. (a, b) -> a
fst)
         ([(a, b)] -> [(a, b)])
-> ([(a, b)] -> [(a, b)]) -> [(a, b)] -> [(a, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> (a, b) -> Ordering) -> [(a, b)] -> [(a, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> a -> Ordering)
-> ((a, b) -> a) -> (a, b) -> (a, b) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, b) -> a
forall a b. (a, b) -> a
fst)

instance Arbitrary Scientific where
  arbitrary :: Gen Scientific
arbitrary = Integer -> Int -> Scientific
scientific (Integer -> Int -> Scientific)
-> Gen Integer -> Gen (Int -> Scientific)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. Arbitrary a => Gen a
arbitrary Gen (Int -> Scientific) -> Gen Int -> Gen Scientific
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Int
forall a. Arbitrary a => Gen a
arbitrary

-- TODO: top value has to be complex: Object or Array
-- TODO: how to accumulate cost when generating the series?
instance Arbitrary Value where
  arbitrary :: Gen Value
arbitrary = (Int -> Gen Value) -> Gen Value
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen Value
arb
    where
      arb :: Int -> Gen Value
arb n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = String -> Gen Value
forall a. HasCallStack => String -> a
error "Negative size!"
      arb 0         = Value -> Gen Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
Null
      arb 1         = [Gen Value] -> Gen Value
forall a. [Gen a] -> Gen a
oneof                          [Gen Value]
simpleGens
      arb i :: Int
i         = [Gen Value] -> Gen Value
forall a. [Gen a] -> Gen a
oneof ([Gen Value] -> Gen Value) -> [Gen Value] -> Gen Value
forall a b. (a -> b) -> a -> b
$ Int -> [Gen Value]
complexGens (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) [Gen Value] -> [Gen Value] -> [Gen Value]
forall a. [a] -> [a] -> [a]
++ [Gen Value]
simpleGens
      simpleGens :: [Gen Value]
simpleGens    = [Scientific -> Value
Number (Scientific -> Value) -> Gen Scientific -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Scientific
forall a. Arbitrary a => Gen a
arbitrary
                      ,Bool -> Value
Bool   (Bool -> Value) -> Gen Bool -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
                      ,Text -> Value
String (Text -> Value) -> Gen Text -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
forall a. Arbitrary a => Gen a
arbitrary]
  shrink :: Value -> [Value]
shrink = (Value -> [Value]) -> [Value] -> [Value]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Value -> [Value]
simpleShrink
         ([Value] -> [Value]) -> (Value -> [Value]) -> Value -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [Value]
forall on. Uniplate on => on -> [on]
universe

-- | Transformation to shrink top level of @Value@, doesn't consider nested sub-@Value@s.
simpleShrink           :: Value -> [Value]
simpleShrink :: Value -> [Value]
simpleShrink (Array  a :: Array
a) = ([Value] -> Value) -> [[Value]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (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) ([[Value]] -> [Value]) -> [[Value]] -> [Value]
forall a b. (a -> b) -> a -> b
$ [Value] -> [[Value]]
forall a. Arbitrary a => a -> [a]
shrink ([Value] -> [[Value]]) -> [Value] -> [[Value]]
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
V.toList   Array
a
simpleShrink (Object o :: Object
o) = ([(Text, Value)] -> Value) -> [[(Text, Value)]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Object -> Value
Object (Object -> Value)
-> ([(Text, Value)] -> Object) -> [(Text, Value)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList) ([[(Text, Value)]] -> [Value]) -> [[(Text, Value)]] -> [Value]
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> [[(Text, Value)]]
forall a. Arbitrary a => a -> [a]
shrink ([(Text, Value)] -> [[(Text, Value)]])
-> [(Text, Value)] -> [[(Text, Value)]]
forall a b. (a -> b) -> a -> b
$ Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
Map.toList Object
o
simpleShrink _          = [] -- Nothing for simple objects

-- | Generator for compound @Value@s
complexGens ::  Int -> [Gen Value]
complexGens :: Int -> [Gen Value]
complexGens i :: Int
i = [Object -> Value
Object (Object -> Value)
-> ([(Text, Value)] -> Object) -> [(Text, Value)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Value)] -> Value) -> Gen [(Text, Value)] -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [(Text, Value)] -> Gen [(Text, Value)]
forall a. Int -> Gen a -> Gen a
resize Int
i Gen [(Text, Value)]
forall a. Arbitrary a => Gen a
arbitrary,
                 Array -> Value
Array                 (Array -> Value) -> Gen Array -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Array -> Gen Array
forall a. Int -> Gen a -> Gen a
resize Int
i Gen Array
forall a. Arbitrary a => Gen a
arbitrary]

-- | Arbitrary JSON (must start with Object or Array.)
arbitraryTopValue :: Gen Value
arbitraryTopValue :: Gen Value
arbitraryTopValue  = (Int -> Gen Value) -> Gen Value
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen Value) -> Gen Value)
-> (Int -> Gen Value) -> Gen Value
forall a b. (a -> b) -> a -> b
$ [Gen Value] -> Gen Value
forall a. [Gen a] -> Gen a
oneof ([Gen Value] -> Gen Value)
-> (Int -> [Gen Value]) -> Int -> Gen Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Gen Value]
complexGens

-- * SmallCheck Serial instances
instance Monad m => Serial m Text where
  series :: Series m Text
series = (String -> Text) -> Series m Text
forall (m :: * -> *) a b. Serial m a => (a -> b) -> Series m b
newtypeCons String -> Text
Text.pack

instance Monad m => Serial m Scientific where
  series :: Series m Scientific
series = (Integer -> Int -> Scientific) -> Series m Scientific
forall (m :: * -> *) a b c.
(Serial m a, Serial m b) =>
(a -> b -> c) -> Series m c
cons2 Integer -> Int -> Scientific
scientific

instance Serial m a => Serial m (V.Vector a) where
  series :: Series m (Vector a)
series = ([a] -> Vector a) -> Series m (Vector a)
forall (m :: * -> *) a b. Serial m a => (a -> b) -> Series m b
newtypeCons [a] -> Vector a
forall a. [a] -> Vector a
V.fromList

instance Serial m v => Serial m (Map.HashMap Text v) where
  series :: Series m (HashMap Text v)
series = ([(Text, v)] -> HashMap Text v) -> Series m (HashMap Text v)
forall (m :: * -> *) a b. Serial m a => (a -> b) -> Series m b
newtypeCons [(Text, v)] -> HashMap Text v
forall a b. (Ord a, Hashable a) => [(a, b)] -> HashMap a b
makeMap

-- This one is generated with Generics and instances above
instance Monad m => Serial m Value