Test.hs

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

import           Data.Functor                        ((<$>))
import           Data.Aeson
import           Data.Function                       (on)
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           Test.QuickCheck.Arbitrary
import           Test.QuickCheck

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
    where
      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
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

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

-- | Generators of compound structures: object and array.
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