Test.hs

{-# 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 = Text.pack  <$> sized (`vectorOf` alphabetic)
    where
      alphabetic = choose ('a', 'z')

instance (Arbitrary a) => Arbitrary (V.Vector a) where
  arbitrary = V.fromList <$> arbitrary

instance (Arbitrary v) => Arbitrary (Map.HashMap Text v) where
  arbitrary = makeMap <$> 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  = Map.fromList
         . nubBy  ((==)    `on` fst)
         . sortBy (compare `on` fst)

instance Arbitrary Scientific where
  arbitrary = scientific <$> arbitrary <*> 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 = sized arb
    where
      arb n | n < 0 = error "Negative size!"
      arb 0         = return Null
      arb 1         = oneof                          simpleGens
      arb i         = oneof $ complexGens (i - 1) ++ simpleGens
      simpleGens    = [Number <$> arbitrary
                      ,Bool   <$> arbitrary
                      ,String <$> arbitrary]
  shrink = concatMap simpleShrink
         . universe

-- | Transformation to shrink top level of @Value@, doesn't consider nested sub-@Value@s.
simpleShrink           :: Value -> [Value]
simpleShrink (Array  a) = map (Array  .   V.fromList) $ shrink $ V.toList   a
simpleShrink (Object o) = map (Object . Map.fromList) $ shrink $ Map.toList o
simpleShrink _          = [] -- Nothing for simple objects

-- | Generator for compound @Value@s
complexGens ::  Int -> [Gen Value]
complexGens i = [Object . Map.fromList <$> resize i arbitrary,
                 Array                 <$> resize i arbitrary]

-- | Arbitrary JSON (must start with Object or Array.)
arbitraryTopValue :: Gen Value
arbitraryTopValue  = sized $ oneof . complexGens

-- * SmallCheck Serial instances
instance Monad m => Serial m Text where
  series = newtypeCons Text.pack

instance Monad m => Serial m Scientific where
  series = cons2 scientific

instance Serial m a => Serial m (V.Vector a) where
  series = newtypeCons V.fromList

instance Serial m v => Serial m (Map.HashMap Text v) where
  series = newtypeCons makeMap

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