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

import           Control.Applicative                 ((<$>), (<*>))
import           Data.Aeson
import           Data.Aeson.Key                      (fromText)
import qualified Data.Aeson.KeyMap           as KM
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 (Char
'a', Char
'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 :: forall a b. (Ord a, Hashable a) => [(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 a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Int
forall a. Arbitrary a => Gen a
arbitrary

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

-- | Generator for compound @Value@s
complexGens ::  Int -> [Gen Value]
complexGens :: Int -> [Gen Value]
complexGens Int
i = [Object -> Value
Object (Object -> Value)
-> ([(Key, Value)] -> Object) -> [(Key, Value)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KM.fromList ([(Key, Value)] -> Value) -> Gen [(Key, Value)] -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [(Key, Value)] -> Gen [(Key, Value)]
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
i Gen [(Key, 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. HasCallStack => 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. HasCallStack => [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 (Monad m) => Serial m Key where
  series :: Series m Key
series = (Text -> Key) -> Series m Text -> Series m Key
forall a b. (a -> b) -> Series m a -> Series m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Key
fromText Series m Text
forall (m :: * -> *) a. Serial m a => Series m a
series

instance Serial m v => Serial m (KM.KeyMap v) where
  series :: Series m (KeyMap v)
series = ([(Key, v)] -> KeyMap v) -> Series m (KeyMap v)
forall (m :: * -> *) a b. Serial m a => (a -> b) -> Series m b
newtypeCons (([(Key, v)] -> KeyMap v) -> Series m (KeyMap v))
-> ([(Key, v)] -> KeyMap v) -> Series m (KeyMap v)
forall a b. (a -> b) -> a -> b
$ [(Key, v)] -> KeyMap v
forall v. [(Key, v)] -> KeyMap v
KM.fromList
                       ([(Key, v)] -> KeyMap v)
-> ([(Key, v)] -> [(Key, v)]) -> [(Key, v)] -> KeyMap v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, v) -> (Key, v) -> Bool) -> [(Key, v)] -> [(Key, v)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy  (Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Key -> Key -> Bool)
-> ((Key, v) -> Key) -> (Key, v) -> (Key, v) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Key, v) -> Key
forall a b. (a, b) -> a
fst)
                       ([(Key, v)] -> [(Key, v)])
-> ([(Key, v)] -> [(Key, v)]) -> [(Key, v)] -> [(Key, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, v) -> (Key, v) -> Ordering) -> [(Key, v)] -> [(Key, v)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Key -> Key -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Key -> Key -> Ordering)
-> ((Key, v) -> Key) -> (Key, v) -> (Key, v) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Key, v) -> Key
forall a b. (a, b) -> a
fst)

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