{-# LANGUAGE ScopedTypeVariables #-}
{-# 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, UTCTime (..), TimeOfDay, timeToTimeOfDay, timeOfDayToTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
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' :: 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 ()
deleteWhere ([] :: [Filter (DataTypeTableGeneric backend)])

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

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 :: 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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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
    )
    => (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 :: (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 ()
forall (m :: * -> *) backend.
(MonadIO m, PersistStoreWrite (BaseBackend backend),
 PersistQuery backend) =>
ReaderT backend m ()
cleanDB'
        [entity]
rvals <- IO [entity] -> db [entity]
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 -> ReaderT backend m ()) -> ReaderT backend m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [entity]
rvals ((entity -> ReaderT backend m ()) -> ReaderT backend m ())
-> (entity -> ReaderT backend m ()) -> ReaderT backend m ()
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) =>
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)
get Key entity
key
            IO () -> ReaderT backend m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT backend m ()) -> IO () -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ do
                let check :: (Eq a, Show a) => String -> (entity -> a) -> IO ()
                    check :: 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) => String -> (entity -> p) -> IO ()
                    check' :: 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 (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) => 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) =>
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) => 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 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)