{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

module DataTypeTest
    ( specsWith
    , dataTypeMigrate
    , roundTime
    , roundUTCTime
    ) where

import Control.Applicative (liftA2)
import qualified Data.ByteString as BS
import Data.Fixed (Pico)
import Data.Foldable (for_)
import Data.IntMap (IntMap)
import qualified Data.Text as T
import Data.Time
    ( Day
    , TimeOfDay
    , UTCTime (..)
    , timeOfDayToTime
    , timeToTimeOfDay
    )
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Database.Persist.Class.PersistEntity
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import Test.QuickCheck.Gen (Gen (..))
import Test.QuickCheck.Instances ()
import Test.QuickCheck.Random (newQCGen)

import Database.Persist.TH
import Init

type Tuple a b = (a, b)

-- Test lower case names
share
    [mkPersist persistSettings, mkMigrate "dataTypeMigrate"]
    [persistLowerCase|
DataTypeTable no-json
    text Text
    textMaxLen Text maxlen=100
    bytes ByteString
    bytesTextTuple (Tuple ByteString Text)
    bytesMaxLen ByteString maxlen=100
    int Int
    intList [Int]
    intMap (IntMap Int)
    double Double
    bool Bool
    day Day
    utc UTCTime
|]

cleanDB'
    :: (MonadIO m, PersistStoreWrite (BaseBackend backend), PersistQuery backend)
    => ReaderT backend m ()
cleanDB' :: forall (m :: * -> *) backend.
(MonadIO m, PersistStoreWrite (BaseBackend backend),
 PersistQuery backend) =>
ReaderT backend m ()
cleanDB' = [Filter (DataTypeTableGeneric (BaseBackend backend))]
-> ReaderT backend m ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter (DataTypeTableGeneric backend)])

roundFn :: (RealFrac a) => a -> Integer
roundFn :: forall a. RealFrac a => a -> Integer
roundFn = a -> Integer
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate

roundTime :: TimeOfDay -> TimeOfDay
roundTime :: TimeOfDay -> TimeOfDay
roundTime TimeOfDay
t = DiffTime -> TimeOfDay
timeToTimeOfDay (DiffTime -> TimeOfDay) -> DiffTime -> TimeOfDay
forall a b. (a -> b) -> a -> b
$ Integer -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> DiffTime) -> Integer -> DiffTime
forall a b. (a -> b) -> a -> b
$ DiffTime -> Integer
forall a. RealFrac a => a -> Integer
roundFn (DiffTime -> Integer) -> DiffTime -> Integer
forall a b. (a -> b) -> a -> b
$ TimeOfDay -> DiffTime
timeOfDayToTime TimeOfDay
t

roundUTCTime :: UTCTime -> UTCTime
roundUTCTime :: UTCTime -> UTCTime
roundUTCTime UTCTime
t =
    POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Integer -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> POSIXTime) -> Integer -> POSIXTime
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Integer
forall a. RealFrac a => a -> Integer
roundFn (POSIXTime -> Integer) -> POSIXTime -> Integer
forall a b. (a -> b) -> a -> b
$ UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
t

randomValues :: (Arbitrary a) => Int -> IO [a]
randomValues :: forall a. Arbitrary a => Int -> IO [a]
randomValues Int
i = do
    [QCGen]
gs <- Int -> IO QCGen -> IO [QCGen]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
i IO QCGen
newQCGen
    [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> IO [a]) -> [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ (QCGen -> Int -> a) -> [QCGen] -> [Int] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Gen a -> QCGen -> Int -> a
forall a. Gen a -> QCGen -> Int -> a
unGen Gen a
forall a. Arbitrary a => Gen a
arbitrary) [QCGen]
gs [Int
0 ..]

instance Arbitrary DataTypeTable where
    arbitrary :: Gen DataTypeTable
arbitrary =
        Text
-> Text
-> ByteString
-> Tuple ByteString Text
-> ByteString
-> Int
-> [Int]
-> IntMap Int
-> Double
-> Bool
-> Day
-> UTCTime
-> DataTypeTable
forall backend.
Text
-> Text
-> ByteString
-> Tuple ByteString Text
-> ByteString
-> Int
-> [Int]
-> IntMap Int
-> Double
-> Bool
-> Day
-> UTCTime
-> DataTypeTableGeneric backend
DataTypeTable
            (Text
 -> Text
 -> ByteString
 -> Tuple ByteString Text
 -> ByteString
 -> Int
 -> [Int]
 -> IntMap Int
 -> Double
 -> Bool
 -> Day
 -> UTCTime
 -> DataTypeTable)
-> Gen Text
-> Gen
     (Text
      -> ByteString
      -> Tuple ByteString Text
      -> ByteString
      -> Int
      -> [Int]
      -> IntMap Int
      -> Double
      -> Bool
      -> Day
      -> UTCTime
      -> DataTypeTable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
forall s. IsString s => Gen s
arbText -- text
            Gen
  (Text
   -> ByteString
   -> Tuple ByteString Text
   -> ByteString
   -> Int
   -> [Int]
   -> IntMap Int
   -> Double
   -> Bool
   -> Day
   -> UTCTime
   -> DataTypeTable)
-> Gen Text
-> Gen
     (ByteString
      -> Tuple ByteString Text
      -> ByteString
      -> Int
      -> [Int]
      -> IntMap Int
      -> Double
      -> Bool
      -> Day
      -> UTCTime
      -> DataTypeTable)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Text -> Text
T.take Int
100 (Text -> Text) -> Gen Text -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
forall s. IsString s => Gen s
arbText) -- textManLen
            Gen
  (ByteString
   -> Tuple ByteString Text
   -> ByteString
   -> Int
   -> [Int]
   -> IntMap Int
   -> Double
   -> Bool
   -> Day
   -> UTCTime
   -> DataTypeTable)
-> Gen ByteString
-> Gen
     (Tuple ByteString Text
      -> ByteString
      -> Int
      -> [Int]
      -> IntMap Int
      -> Double
      -> Bool
      -> Day
      -> UTCTime
      -> DataTypeTable)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary -- bytes
            Gen
  (Tuple ByteString Text
   -> ByteString
   -> Int
   -> [Int]
   -> IntMap Int
   -> Double
   -> Bool
   -> Day
   -> UTCTime
   -> DataTypeTable)
-> Gen (Tuple ByteString Text)
-> Gen
     (ByteString
      -> Int
      -> [Int]
      -> IntMap Int
      -> Double
      -> Bool
      -> Day
      -> UTCTime
      -> DataTypeTable)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> Text -> Tuple ByteString Text)
-> Gen ByteString -> Gen Text -> Gen (Tuple ByteString Text)
forall a b c. (a -> b -> c) -> Gen a -> Gen b -> Gen c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary Gen Text
forall s. IsString s => Gen s
arbText -- bytesTextTuple
            Gen
  (ByteString
   -> Int
   -> [Int]
   -> IntMap Int
   -> Double
   -> Bool
   -> Day
   -> UTCTime
   -> DataTypeTable)
-> Gen ByteString
-> Gen
     (Int
      -> [Int]
      -> IntMap Int
      -> Double
      -> Bool
      -> Day
      -> UTCTime
      -> DataTypeTable)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> ByteString -> ByteString
BS.take Int
100 (ByteString -> ByteString) -> Gen ByteString -> Gen ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary) -- bytesMaxLen
            Gen
  (Int
   -> [Int]
   -> IntMap Int
   -> Double
   -> Bool
   -> Day
   -> UTCTime
   -> DataTypeTable)
-> Gen Int
-> Gen
     ([Int]
      -> IntMap Int -> Double -> Bool -> Day -> UTCTime -> DataTypeTable)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Int
forall a. Arbitrary a => Gen a
arbitrary -- int
            Gen
  ([Int]
   -> IntMap Int -> Double -> Bool -> Day -> UTCTime -> DataTypeTable)
-> Gen [Int]
-> Gen
     (IntMap Int -> Double -> Bool -> Day -> UTCTime -> DataTypeTable)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen [Int]
forall a. Arbitrary a => Gen a
arbitrary -- intList
            Gen
  (IntMap Int -> Double -> Bool -> Day -> UTCTime -> DataTypeTable)
-> Gen (IntMap Int)
-> Gen (Double -> Bool -> Day -> UTCTime -> DataTypeTable)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (IntMap Int)
forall a. Arbitrary a => Gen a
arbitrary -- intMap
            Gen (Double -> Bool -> Day -> UTCTime -> DataTypeTable)
-> Gen Double -> Gen (Bool -> Day -> UTCTime -> DataTypeTable)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Double
forall a. Arbitrary a => Gen a
arbitrary -- double
            Gen (Bool -> Day -> UTCTime -> DataTypeTable)
-> Gen Bool -> Gen (Day -> UTCTime -> DataTypeTable)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary -- bool
            Gen (Day -> UTCTime -> DataTypeTable)
-> Gen Day -> Gen (UTCTime -> DataTypeTable)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Day
forall a. Arbitrary a => Gen a
arbitrary -- day
            Gen (UTCTime -> DataTypeTable) -> Gen UTCTime -> Gen DataTypeTable
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (UTCTime -> Gen UTCTime
truncateUTCTime (UTCTime -> Gen UTCTime) -> Gen UTCTime -> Gen UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary) -- utc

specsWith
    :: forall db backend m entity
     . ( db ~ ReaderT backend m
       , PersistStoreRead backend
       , PersistEntity entity
       , PersistEntityBackend entity ~ BaseBackend backend
       , Arbitrary entity
       , PersistStoreWrite backend
       , PersistStoreWrite (BaseBackend backend)
       , PersistQueryWrite (BaseBackend backend)
       , PersistQueryWrite backend
       , MonadFail m
       , MonadIO m
       , SafeToInsert entity
       )
    => (db () -> IO ())
    -- ^ DB Runner
    -> Maybe (db [Text])
    -- ^ Optional migrations to run
    -> [TestFn entity]
    -- ^ List of entity fields to test
    -> [(String, entity -> Pico)]
    -- ^ List of pico fields to test
    -> (entity -> Double)
    -> Spec
specsWith :: forall (db :: * -> *) backend (m :: * -> *) entity.
(db ~ ReaderT backend m, PersistStoreRead backend,
 PersistEntity entity,
 PersistEntityBackend entity ~ BaseBackend backend,
 Arbitrary entity, PersistStoreWrite backend,
 PersistStoreWrite (BaseBackend backend),
 PersistQueryWrite (BaseBackend backend), PersistQueryWrite backend,
 MonadFail m, MonadIO m, SafeToInsert entity) =>
(db () -> IO ())
-> Maybe (db [Text])
-> [TestFn entity]
-> [(String, entity -> Pico)]
-> (entity -> Double)
-> Spec
specsWith db () -> IO ()
runDb Maybe (db [Text])
mmigration [TestFn entity]
checks [(String, entity -> Pico)]
apprxChecks entity -> Double
doubleFn = String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"data type specs" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"handles all types" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
        IO () -> IO ()
forall a. IO a -> IO a
asIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            db () -> IO ()
runDb (db () -> IO ()) -> db () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ()
_ <- Maybe (db [Text]) -> db ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ Maybe (db [Text])
mmigration
                -- Ensure reading the data from the database works...
                ()
_ <- Maybe (db [Text]) -> db ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ Maybe (db [Text])
mmigration
                db ()
ReaderT backend m ()
forall (m :: * -> *) backend.
(MonadIO m, PersistStoreWrite (BaseBackend backend),
 PersistQuery backend) =>
ReaderT backend m ()
cleanDB'
                [entity]
rvals <- IO [entity] -> db [entity]
forall a. IO a -> db a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [entity] -> db [entity]) -> IO [entity] -> db [entity]
forall a b. (a -> b) -> a -> b
$ Int -> IO [entity]
forall a. Arbitrary a => Int -> IO [a]
randomValues Int
1000
                [entity] -> (entity -> db ()) -> db ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [entity]
rvals ((entity -> db ()) -> db ()) -> (entity -> db ()) -> db ()
forall a b. (a -> b) -> a -> b
$ \entity
x -> do
                    Key entity
key <- entity -> ReaderT backend m (Key entity)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record backend,
 SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert entity
x
                    Just entity
y <- Key entity -> ReaderT backend m (Maybe entity)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key entity
key
                    IO () -> db ()
forall a. IO a -> db a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> db ()) -> IO () -> db ()
forall a b. (a -> b) -> a -> b
$ do
                        let
                            check :: (Eq a, Show a, HasCallStack) => String -> (entity -> a) -> IO ()
                            check :: forall a.
(Eq a, Show a, HasCallStack) =>
String -> (entity -> a) -> IO ()
check String
s entity -> a
f = (String
s, entity -> a
f entity
x) (String, a) -> (String, a) -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@=? (String
s, entity -> a
f entity
y)
                        -- Check floating-point near equality
                        let
                            check'
                                :: (Fractional p, Show p, Real p, HasCallStack) => String -> (entity -> p) -> IO ()
                            check' :: forall p.
(Fractional p, Show p, Real p, HasCallStack) =>
String -> (entity -> p) -> IO ()
check' String
s entity -> p
f
                                | p -> p
forall a. Num a => a -> a
abs (entity -> p
f entity
x p -> p -> p
forall a. Num a => a -> a -> a
- entity -> p
f entity
y) p -> p -> Bool
forall a. Ord a => a -> a -> Bool
< p
0.000001 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                | Bool
otherwise = (String
s, entity -> p
f entity
x) (String, p) -> (String, p) -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@=? (String
s, entity -> p
f entity
y)
                        -- Check individual fields for better error messages
                        [TestFn entity] -> (TestFn entity -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TestFn entity]
checks ((TestFn entity -> IO ()) -> IO ())
-> (TestFn entity -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(TestFn String
msg entity -> a
f) -> String -> (entity -> a) -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
String -> (entity -> a) -> IO ()
check String
msg entity -> a
f
                        [(String, entity -> Pico)]
-> ((String, entity -> Pico) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(String, entity -> Pico)]
apprxChecks (((String, entity -> Pico) -> IO ()) -> IO ())
-> ((String, entity -> Pico) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
msg, entity -> Pico
f) -> String -> (entity -> Pico) -> IO ()
forall p.
(Fractional p, Show p, Real p, HasCallStack) =>
String -> (entity -> p) -> IO ()
check' String
msg entity -> Pico
f

                        -- Do a special check for Double since it may
                        -- lose precision when serialized.
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double -> Double -> Double
getDoubleDiff (entity -> Double
doubleFn entity
x) (entity -> Double
doubleFn entity
y) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1e-14) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                            String -> (entity -> Double) -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
String -> (entity -> a) -> IO ()
check String
"double" entity -> Double
doubleFn
  where
    normDouble :: Double -> Double
    normDouble :: Double -> Double
normDouble Double
x
        | Double -> Double
forall a. Num a => a -> a
abs Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1 = Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
10 Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
10 (Double -> Double
forall a. Num a => a -> a
abs Double
x)) :: Integer)
        | Bool
otherwise = Double
x
    getDoubleDiff :: Double -> Double -> Double
getDoubleDiff Double
x Double
y = Double -> Double
forall a. Num a => a -> a
abs (Double -> Double
normDouble Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
normDouble Double
y)