{-# 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' = deleteWhere ([] :: [Filter (DataTypeTableGeneric backend)])
roundFn :: (RealFrac a) => a -> Integer
roundFn = truncate
roundTime :: TimeOfDay -> TimeOfDay
roundTime t = timeToTimeOfDay $ fromIntegral $ roundFn $ timeOfDayToTime t
roundUTCTime :: UTCTime -> UTCTime
roundUTCTime t =
posixSecondsToUTCTime $ fromIntegral $ roundFn $ utcTimeToPOSIXSeconds t
randomValues :: (Arbitrary a) => Int -> IO [a]
randomValues i = do
gs <- replicateM i newQCGen
return $ zipWith (unGen arbitrary) gs [0 ..]
instance Arbitrary DataTypeTable where
arbitrary =
DataTypeTable
<$> arbText -- text
<*> (T.take 100 <$> arbText) -- textManLen
<*> arbitrary -- bytes
<*> liftA2 (,) arbitrary arbText -- bytesTextTuple
<*> (BS.take 100 <$> arbitrary) -- bytesMaxLen
<*> arbitrary -- int
<*> arbitrary -- intList
<*> arbitrary -- intMap
<*> arbitrary -- double
<*> arbitrary -- bool
<*> arbitrary -- day
<*> (truncateUTCTime =<< 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 runDb mmigration checks apprxChecks doubleFn = describe "data type specs" $
it "handles all types" $
asIO $
runDb $ do
_ <- sequence_ mmigration
-- Ensure reading the data from the database works...
_ <- sequence_ mmigration
cleanDB'
rvals <- liftIO $ randomValues 1000
for_ rvals $ \x -> do
key <- insert x
Just y <- get key
liftIO $ do
let
check :: (Eq a, Show a, HasCallStack) => String -> (entity -> a) -> IO ()
check s f = (s, f x) @=? (s, f y)
-- Check floating-point near equality
let
check'
:: (Fractional p, Show p, Real p, HasCallStack) => String -> (entity -> p) -> IO ()
check' s f
| abs (f x - f y) < 0.000001 = return ()
| otherwise = (s, f x) @=? (s, f y)
-- Check individual fields for better error messages
for_ checks $ \(TestFn msg f) -> check msg f
for_ apprxChecks $ \(msg, f) -> check' msg f
-- Do a special check for Double since it may
-- lose precision when serialized.
when (getDoubleDiff (doubleFn x) (doubleFn y) > 1e-14) $
check "double" doubleFn
where
normDouble :: Double -> Double
normDouble x
| abs x > 1 = x / 10 ^ (truncate (logBase 10 (abs x)) :: Integer)
| otherwise = x
getDoubleDiff x y = abs (normDouble x - normDouble y)