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

module Hedgehog.Classes.Binary (binaryLaws) where

import Hedgehog
import Hedgehog.Classes.Common
import Data.Binary (Binary)
import qualified Data.Binary as Binary

-- | Tests the following 'Binary' laws:
--
-- [__Encoding Partial Isomorphism__]: @'Binary.decode' '.' 'Binary.encode'@ ≡ @'id'@
binaryLaws :: (Binary a, Eq a, Show a) => Gen a -> Laws
binaryLaws :: Gen a -> Laws
binaryLaws Gen a
gen = String -> [(String, Property)] -> Laws
Laws String
"Binary"
  [ (String
"Partial Isomorphism", Gen a -> Property
forall a. (Binary a, Show a, Eq a) => Gen a -> Property
binaryPartialIsomorphism Gen a
gen)
  ]

binaryPartialIsomorphism :: forall a. (Binary a, Show a, Eq a) => Gen a -> Property
binaryPartialIsomorphism :: Gen a -> Property
binaryPartialIsomorphism Gen a
gen = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  a
x <- Gen a -> PropertyT IO a
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  let encoded :: ByteString
encoded = a -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode a
x
  let lhs :: a
lhs = ByteString -> a
forall a. Binary a => ByteString -> a
Binary.decode @a ByteString
encoded
  let rhs :: a
rhs = a
x
  let ctx :: Context
ctx = LawContext -> Context
contextualise (LawContext -> Context) -> LawContext -> Context
forall a b. (a -> b) -> a -> b
$ LawContext :: String -> String -> String -> String -> String -> LawContext
LawContext
        { lawContextLawName :: String
lawContextLawName = String
"Partial Isomorphism", lawContextTcName :: String
lawContextTcName = String
"Binary"
        , lawContextLawBody :: String
lawContextLawBody = String
"decode . encode" String -> String -> String
`congruency` String
"id"
        , lawContextTcProp :: String
lawContextTcProp =
            let showX :: String
showX = a -> String
forall a. Show a => a -> String
show a
x
                showEncoded :: String
showEncoded = ByteString -> String
forall a. Show a => a -> String
show ByteString
encoded
            in [String] -> String
lawWhere
              [ String
"decode . encode $ x" String -> String -> String
`congruency` String
"x, where"
              , String
"x = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showX
              , String
"encode x = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showEncoded
              ]
        , lawContextReduced :: String
lawContextReduced = a -> a -> String
forall a. Show a => a -> a -> String
reduced a
lhs a
rhs
        }
  a -> a -> Context -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
lhs a
rhs Context
ctx