{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Standard test `Spec`s and raw `Property`s for `Binary` instances.
--
-- You will need @TypeApplications@ to use these.
module Test.Validity.Binary
  ( binarySpec,
    binarySpecOnArbitrary,
    binarySpecOnGen,
    neverFailsToEncodeOnGen,
    encodeAndDecodeAreInversesOnGen,
  )
where

import Control.DeepSeq (deepseq)
import Control.Exception (evaluate)
import Data.Binary (Binary)
import qualified Data.Binary as Binary
import Data.GenValidity
import Data.Typeable
import Test.Hspec
import Test.QuickCheck
import Test.Validity.Utils

-- | Standard test spec for properties of 'Binary'-related functions for valid values
--
-- Example usage:
--
-- > binarySpec @Int
binarySpec ::
  forall a.
  (Show a, Eq a, Typeable a, GenValid a, Binary a) =>
  Spec
binarySpec :: Spec
binarySpec = Gen a -> String -> (a -> [a]) -> Spec
forall a.
(Show a, Eq a, Typeable a, Binary a) =>
Gen a -> String -> (a -> [a]) -> Spec
binarySpecOnGen (GenValid a => Gen a
forall a. GenValid a => Gen a
genValid @a) String
"valid" a -> [a]
forall a. GenValid a => a -> [a]
shrinkValid

-- | Standard test spec for properties of 'Binary'-related functions for arbitrary values
--
-- Example usage:
--
-- > binarySpecOnArbitrary @Int
binarySpecOnArbitrary ::
  forall a.
  (Show a, Eq a, Typeable a, Arbitrary a, Binary a) =>
  Spec
binarySpecOnArbitrary :: Spec
binarySpecOnArbitrary = Gen a -> String -> (a -> [a]) -> Spec
forall a.
(Show a, Eq a, Typeable a, Binary a) =>
Gen a -> String -> (a -> [a]) -> Spec
binarySpecOnGen (Arbitrary a => Gen a
forall a. Arbitrary a => Gen a
arbitrary @a) String
"arbitrary" a -> [a]
forall a. Arbitrary a => a -> [a]
shrink

-- | Standard test spec for properties of 'Binary'-related functions for a given generator (and a name for that generator).
--
-- Example usage:
--
-- > binarySpecOnGen (genListOf $ pure 'a') "sequence of 'a's" (const [])
binarySpecOnGen ::
  forall a.
  (Show a, Eq a, Typeable a, Binary a) =>
  Gen a ->
  String ->
  (a -> [a]) ->
  Spec
binarySpecOnGen :: Gen a -> String -> (a -> [a]) -> Spec
binarySpecOnGen Gen a
gen String
genname a -> [a]
s =
  Spec -> Spec
forall a. SpecWith a -> SpecWith a
parallel (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    let name :: String
name = Typeable a => String
forall k (a :: k). Typeable a => String
nameOf @a
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (String
"Binary " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
genname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe
        (String
"encode :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> Data.ByteString.Lazy.ByteString")
        (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
          ( [String] -> String
unwords
              [ String
"never fails to encode a",
                String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
genname,
                String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
              ]
          )
          (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ Gen a -> (a -> [a]) -> Property
forall a. (Show a, Binary a) => Gen a -> (a -> [a]) -> Property
neverFailsToEncodeOnGen Gen a
gen a -> [a]
s
      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe
        (String
"decode :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> Data.ByteString.Lazy.ByteString")
        (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
          ( [String] -> String
unwords
              [ String
"ensures that encode and decode are inverses for",
                String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
genname,
                String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'s"
              ]
          )
          (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ Gen a -> (a -> [a]) -> Property
forall a.
(Show a, Eq a, Binary a) =>
Gen a -> (a -> [a]) -> Property
encodeAndDecodeAreInversesOnGen Gen a
gen a -> [a]
s

-- |
--
-- prop> neverFailsToEncodeOnGen @Bool arbitrary shrink
-- prop> neverFailsToEncodeOnGen @Bool genValid shrinkValid
-- prop> neverFailsToEncodeOnGen @Bool genValid shrinkValid
-- prop> neverFailsToEncodeOnGen @Int arbitrary shrink
-- prop> neverFailsToEncodeOnGen @Int genValid shrinkValid
-- prop> neverFailsToEncodeOnGen @Int genValid shrinkValid
neverFailsToEncodeOnGen :: (Show a, Binary a) => Gen a -> (a -> [a]) -> Property
neverFailsToEncodeOnGen :: Gen a -> (a -> [a]) -> Property
neverFailsToEncodeOnGen Gen a
gen a -> [a]
s =
  Gen a -> (a -> [a]) -> (a -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen a
gen a -> [a]
s ((a -> Expectation) -> Property) -> (a -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$ \(a
a :: a) ->
    () -> Expectation
forall a. a -> IO a
evaluate (ByteString -> () -> ()
forall a b. NFData a => a -> b -> b
deepseq (a -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode a
a) ()) Expectation -> () -> Expectation
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` ()

-- |
--
-- prop> encodeAndDecodeAreInversesOnGen @Bool arbitrary shrinkValid
-- prop> encodeAndDecodeAreInversesOnGen @Bool genValid shrinkValid
-- prop> encodeAndDecodeAreInversesOnGen @Bool genValid shrinkValid
-- prop> encodeAndDecodeAreInversesOnGen @Int arbitrary shrink
-- prop> encodeAndDecodeAreInversesOnGen @Int genValid shrinkValid
-- prop> encodeAndDecodeAreInversesOnGen @Int genValid shrinkValid
encodeAndDecodeAreInversesOnGen ::
  (Show a, Eq a, Binary a) => Gen a -> (a -> [a]) -> Property
encodeAndDecodeAreInversesOnGen :: Gen a -> (a -> [a]) -> Property
encodeAndDecodeAreInversesOnGen Gen a
gen a -> [a]
s =
  Gen a -> (a -> [a]) -> (a -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen a
gen a -> [a]
s ((a -> Expectation) -> Property) -> (a -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$ \(a
a :: a) ->
    case ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
Binary.decodeOrFail (a -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode a
a) of
      Right (ByteString
_, ByteOffset
_, a
b) -> a
b a -> a -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` a
a
      Left (ByteString
_, ByteOffset
_, String
s_) ->
        HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$
          [String] -> String
unwords [String
"decode of encode is not identity:", String
s_]