{-# 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.Class.PersistEntity
import Database.Persist.TH
import Init
type Tuple a b = (a, b)
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
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 :: 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
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)
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
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
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)
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
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
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
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
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
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
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)
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 ())
-> 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
()
_ <- 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, 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)
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)
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)
[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
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)