pinboard-0.9.6: tests/PropJSON.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}

module PropJSON where

import           Data.Aeson
import           Data.Aeson.Types (parseEither)
import           Data.Monoid ((<>))
import           Data.Typeable (Proxy(..), typeOf, Typeable)
import qualified Data.ByteString.Lazy.Char8 as BL8
import           Test.Hspec
import           Test.QuickCheck
import           Test.QuickCheck.Property
import           Test.Hspec.QuickCheck (prop)

import           ApproxEq

type ArbitraryJSON a = (Arbitrary a, ToJSON a, FromJSON a, Show a, Typeable a)

propJSON :: forall a b. (ArbitraryJSON a, Testable b) 
         => String
         -> (a -> a -> b) 
         -> Proxy a 
         -> Spec
propJSON eqDescr eq _ = prop (show (typeOf (undefined :: a)) <> " FromJSON/ToJSON roundtrip " <> eqDescr) $ \(x :: a) ->
  let actual = parseEither parseJSON (toJSON x)
      expected = Right x
      failMsg = "ACTUAL: " <> show actual <> "\nJSON: " <> BL8.unpack (encode x)
  in counterexample failMsg $ either reject property (eq <$> actual <*> expected)
  where reject = property . const rejected

propJSONEq :: (ArbitraryJSON a, Eq a) => Proxy a -> Spec
propJSONEq = propJSON "(Eq)" (==) 

propJSONApproxEq :: (ArbitraryJSON a, ApproxEq a) => Proxy a -> Spec
propJSONApproxEq = propJSON "(ApproxEq)" (==~)