pinboard-0.10.2.0: tests/PropJSON.hs

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

module PropJSON where

import Data.Aeson
import Data.Aeson.Types (parseEither)
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)" (==~)