{-# 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.Syd.Validity.Persist
  ( persistSpecOnValid,
    persistSpec,
    persistSpecOnArbitrary,
    persistSpecOnGen,
    fromPersistValueAndToPersistValueAreInversesOnGen,
  )
where

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

-- | Standard test spec for properties of persistent-related functions for valid values
--
-- Example usage:
--
-- > persistSpecOnValid @Rational
persistSpecOnValid ::
  forall a.
  (Show a, Eq a, Typeable a, GenValid a, PersistField a) =>
  Spec
persistSpecOnValid :: Spec
persistSpecOnValid = 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 unchecked values
--
-- Example usage:
--
-- > persistSpec @Int
persistSpec ::
  forall a.
  (Show a, Eq a, Typeable a, GenUnchecked 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 (GenUnchecked a => Gen a
forall a. GenUnchecked a => Gen a
genUnchecked @a) String
"unchecked" a -> [a]
forall a. GenUnchecked a => a -> [a]
shrinkUnchecked

-- | 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 :: [*]) b c. TestDefM a b c -> TestDefM a b c
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 (outers :: [*]) inner.
String -> TestDefM outers inner () -> TestDefM outers inner ()
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 (outers :: [*]) inner.
String -> TestDefM outers inner () -> TestDefM outers inner ()
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 -> Spec
forall (outers :: [*]) inner test.
(HasCallStack, IsTest test, Arg1 test ~ (), Arg2 test ~ inner) =>
String -> test -> TestDefM outers inner ()
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 -> Spec) -> Property -> Spec
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 genUnchecked shrinkUnchecked
--
-- prop> fromPersistValueAndToPersistValueAreInversesOnGen @Bool genValid shrinkValid
--
-- prop> fromPersistValueAndToPersistValueAreInversesOnGen @Int arbitrary shrink
--
-- prop> fromPersistValueAndToPersistValueAreInversesOnGen @Int genUnchecked shrinkUnchecked
--
-- 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 -> IO ()) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen a
gen a -> [a]
s ((a -> IO ()) -> Property) -> (a -> IO ()) -> 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 ->
            String -> IO ()
forall a. HasCallStack => String -> IO a
expectationFailure (String -> IO ()) -> String -> IO ()
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 ->
            let ctx :: String
ctx =
                  [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
                    ]
             in String -> IO () -> IO ()
forall a. String -> IO a -> IO a
context String
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ a
decoded a -> a -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` a
a