{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Test.Validity.Binary
( binarySpecOnValid
, binarySpec
, binarySpecOnArbitrary
, binarySpecOnGen
, neverFailsToEncodeOnGen
, encodeAndDecodeAreInversesOnGen
) where
import Data.GenValidity
import Control.DeepSeq (deepseq)
import Control.Exception (evaluate)
import qualified Data.Binary as Binary
import Data.Binary (Binary)
import Data.Typeable
import Test.Hspec
import Test.QuickCheck
import Test.Validity.Utils
binarySpecOnValid ::
forall a. (Show a, Eq a, Typeable a, GenValid a, Binary a)
=> Spec
binarySpecOnValid = binarySpecOnGen (genValid @a) "valid" shrinkValid
binarySpec ::
forall a. (Show a, Eq a, Typeable a, GenUnchecked a, Binary a)
=> Spec
binarySpec = binarySpecOnGen (genUnchecked @a) "unchecked" shrinkUnchecked
binarySpecOnArbitrary ::
forall a. (Show a, Eq a, Typeable a, Arbitrary a, Binary a)
=> Spec
binarySpecOnArbitrary = binarySpecOnGen (arbitrary @a) "arbitrary" shrink
binarySpecOnGen ::
forall a. (Show a, Eq a, Typeable a, Binary a)
=> Gen a
-> String
-> (a -> [a])
-> Spec
binarySpecOnGen gen genname s =
parallel $ do
let name = nameOf @a
describe ("Binary " ++ name ++ " (" ++ genname ++ ")") $ do
describe
("encode :: " ++ name ++ " -> Data.ByteString.Lazy.ByteString") $
it
(unwords
[ "never fails to encode a"
, "\"" ++ genname
, name ++ "\""
]) $
neverFailsToEncodeOnGen gen s
describe
("decode :: " ++ name ++ " -> Data.ByteString.Lazy.ByteString") $
it
(unwords
[ "ensures that encode and decode are inverses for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
encodeAndDecodeAreInversesOnGen gen s
neverFailsToEncodeOnGen :: (Show a, Binary a) => Gen a -> (a -> [a]) -> Property
neverFailsToEncodeOnGen gen s =
forAllShrink gen s $ \(a :: a) ->
evaluate (deepseq (Binary.encode a) ()) `shouldReturn` ()
encodeAndDecodeAreInversesOnGen ::
(Show a, Eq a, Binary a) => Gen a -> (a -> [a]) -> Property
encodeAndDecodeAreInversesOnGen gen s =
forAllShrink gen s $ \(a :: a) ->
case Binary.decodeOrFail (Binary.encode a) of
Right (_, _, b) -> b `shouldBe` a
Left (_, _, s_) ->
expectationFailure $
unwords ["decode of encode is not identity:", s_]