{-# 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)
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 = round
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
<*> (T.take 100 <$> arbText)
<*> arbitrary
<*> liftA2 (,) arbitrary arbText
<*> (BS.take 100 <$> arbitrary)
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> (truncateUTCTime =<< 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
)
=> (db () -> IO ())
-> Maybe (db [Text])
-> [TestFn entity]
-> [(String, entity -> Pico)]
-> (entity -> Double)
-> Spec
specsWith runDb mmigration checks apprxChecks doubleFn = describe "data type specs" $
it "handles all types" $ asIO $ runDb $ do
_ <- sequence_ mmigration
_ <- 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) => String -> (entity -> a) -> IO ()
check s f = (s, f x) @=? (s, f y)
let check' :: (Fractional p, Show p, Real p) => String -> (entity -> p) -> IO ()
check' s f
| abs (f x - f y) < 0.000001 = return ()
| otherwise = (s, f x) @=? (s, f y)
for_ checks $ \(TestFn msg f) -> check msg f
for_ apprxChecks $ \(msg, f) -> check' msg f
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)