pinboard-0.9.11: 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)" (==~)