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

-- | Standard test `Spec`s and raw `Property`s for `PersistField` instances.
--
-- You will need @TypeApplications@ to use these.
module Test.Validity.Persist
  ( persistSpec,
    persistSpecOnArbitrary,
    persistSpecOnGen,
    fromPersistValueAndToPersistValueAreInversesOnGen,
  )
where

import Control.Monad
import Data.GenValidity
import qualified Data.Text as T
import Data.Typeable
import Database.Persist (PersistField (..))
import Test.Hspec
import Test.QuickCheck
import Test.Validity.Utils

-- | Standard test spec for properties of persistent-related functions for valid values
--
-- Example usage:
--
-- > persistSpec @Int
persistSpec ::
  forall a.
  (Show a, Eq a, Typeable a, GenValid a, PersistField a) =>
  Spec
persistSpec :: Spec
persistSpec = Gen a -> String -> (a -> [a]) -> Spec
forall a.
(Show a, Eq a, Typeable a, PersistField a) =>
Gen a -> String -> (a -> [a]) -> Spec
persistSpecOnGen (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 persistent-related functions for arbitrary values
--
-- Example usage:
--
-- > persistSpecOnArbitrary @Int
persistSpecOnArbitrary ::
  forall a.
  (Show a, Eq a, Typeable a, Arbitrary a, PersistField a) =>
  Spec
persistSpecOnArbitrary :: Spec
persistSpecOnArbitrary = Gen a -> String -> (a -> [a]) -> Spec
forall a.
(Show a, Eq a, Typeable a, PersistField a) =>
Gen a -> String -> (a -> [a]) -> Spec
persistSpecOnGen (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 persistent-related functions for a given generator (and a name for that generator).
--
-- Example usage:
--
-- > persistSpecOnGen (genListOf $ pure 'a') "sequence of 'a's"
persistSpecOnGen ::
  forall a.
  (Show a, Eq a, Typeable a, PersistField a) =>
  Gen a ->
  String ->
  (a -> [a]) ->
  Spec
persistSpecOnGen :: Gen a -> String -> (a -> [a]) -> Spec
persistSpecOnGen 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
"PersistField " 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
"fromPersistValue :: PersistValue -> Either Text " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) (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 toPersistValue and fromPersistValue 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, PersistField a) =>
Gen a -> (a -> [a]) -> Property
fromPersistValueAndToPersistValueAreInversesOnGen Gen a
gen a -> [a]
s

-- |
--
-- prop> fromPersistValueAndToPersistValueAreInversesOnGen @Bool arbitrary shrink
--
-- prop> fromPersistValueAndToPersistValueAreInversesOnGen @Bool genValid shrinkValid
--
-- prop> fromPersistValueAndToPersistValueAreInversesOnGen @Bool genValid shrinkValid
--
-- prop> fromPersistValueAndToPersistValueAreInversesOnGen @Int arbitrary shrink
--
-- prop> fromPersistValueAndToPersistValueAreInversesOnGen @Int genValid shrinkValid
--
-- prop> fromPersistValueAndToPersistValueAreInversesOnGen @Int genValid shrinkValid
fromPersistValueAndToPersistValueAreInversesOnGen ::
  (Show a, Eq a, PersistField a) => Gen a -> (a -> [a]) -> Property
fromPersistValueAndToPersistValueAreInversesOnGen :: Gen a -> (a -> [a]) -> Property
fromPersistValueAndToPersistValueAreInversesOnGen 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) ->
    let encoded :: PersistValue
encoded = a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
a
        errOrDecoded :: Either Text a
errOrDecoded = PersistValue -> Either Text a
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
encoded
     in case Either Text a
errOrDecoded of
          Left Text
err ->
            HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$
              [String] -> String
unlines
                [ String
"Decoding failed with error",
                  Text -> String
T.unpack Text
err,
                  String
"instead of decoding to",
                  a -> String
forall a. Show a => a -> String
show a
a,
                  String
"'encode' encoded it to the persist",
                  PersistValue -> String
forall a. Show a => a -> String
show PersistValue
encoded
                ]
          Right a
decoded ->
            Bool -> Expectation -> Expectation
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a
decoded a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a) (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$
              HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$
                [String] -> String
unlines
                  [ String
"Decoding succeeded, but the decoded value",
                    a -> String
forall a. Show a => a -> String
show a
decoded,
                    String
"differs from expected decoded value",
                    a -> String
forall a. Show a => a -> String
show a
a,
                    String
"'encode' encoded it to the persist",
                    PersistValue -> String
forall a. Show a => a -> String
show PersistValue
encoded
                  ]