module DataTypeTest (specs) where
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 Data.Char (generalCategory, GeneralCategory(..))
import qualified Data.Text as T
import qualified Data.ByteString as BS
import Data.Time (Day, UTCTime (..), fromGregorian, picosecondsToDiffTime,
TimeOfDay (TimeOfDay), timeToTimeOfDay, timeOfDayToTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
import Data.IntMap (IntMap)
import Data.Fixed (Pico,Micro)
import Init
type Tuple a b = (a, b)
#ifdef WITH_NOSQL
mkPersist persistSettings [persistUpperCase|
#else
share [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase|
#endif
DataTypeTable nojson
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
#ifndef WITH_NOSQL
pico Pico
time TimeOfDay
#endif
utc UTCTime
#if defined(WITH_MYSQL) && !(defined(OLD_MYSQL))
timeFrac TimeOfDay sqltype=TIME(6)
utcFrac UTCTime sqltype=DATETIME(6)
#endif
|]
cleanDB :: (MonadIO m, PersistQuery backend, backend ~ PersistEntityBackend DataTypeTable) => ReaderT backend m ()
cleanDB = deleteWhere ([] :: [Filter DataTypeTable])
specs :: Spec
specs = describe "data type specs" $
it "handles all types" $ asIO $ runConn $ do
#ifndef WITH_NOSQL
_ <- runMigrationSilent dataTypeMigrate
_ <- runMigrationSilent dataTypeMigrate
#endif
rvals <- liftIO randomValues
forM_ (take 1000 rvals) $ \x -> do
key <- insert x
Just y <- get key
liftIO $ do
let check :: (Eq a, Show a) => String -> (DataTypeTable -> a) -> IO ()
check s f = (s, f x) @=? (s, f y)
let check' :: String -> (DataTypeTable -> Pico) -> IO ()
check' s f
| abs (f x f y) < 0.000001 = return ()
| otherwise = (s, f x) @=? (s, f y)
check "text" dataTypeTableText
check "textMaxLen" dataTypeTableTextMaxLen
check "bytes" dataTypeTableBytes
check "bytesTextTuple" dataTypeTableBytesTextTuple
check "bytesMaxLen" dataTypeTableBytesMaxLen
check "int" dataTypeTableInt
check "intList" dataTypeTableIntList
check "intMap" dataTypeTableIntMap
check "bool" dataTypeTableBool
check "day" dataTypeTableDay
#ifndef WITH_NOSQL
check' "pico" dataTypeTablePico
check "time" (roundTime . dataTypeTableTime)
#endif
#if !(defined(WITH_NOSQL)) || (defined(WITH_NOSQL) && defined(HIGH_PRECISION_DATE))
check "utc" (roundUTCTime . dataTypeTableUtc)
#endif
#if defined(WITH_MYSQL) && !(defined(OLD_MYSQL))
check "timeFrac" (dataTypeTableTimeFrac)
check "utcFrac" (dataTypeTableUtcFrac)
#endif
when (getDoubleDiff (dataTypeTableDouble x)(dataTypeTableDouble y) > 1e-14) $
check "double" dataTypeTableDouble
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)
roundFn :: RealFrac a => a -> Integer
#ifdef OLD_MYSQL
roundFn = truncate
#else
roundFn = round
#endif
roundTime :: TimeOfDay -> TimeOfDay
#ifdef WITH_MYSQL
roundTime t = timeToTimeOfDay $ fromIntegral $ roundFn $ timeOfDayToTime t
#else
roundTime = id
#endif
roundUTCTime :: UTCTime -> UTCTime
#ifdef WITH_MYSQL
roundUTCTime t =
posixSecondsToUTCTime $ fromIntegral $ roundFn $ utcTimeToPOSIXSeconds t
#else
roundUTCTime = id
#endif
randomValues :: IO [DataTypeTable]
randomValues = do
g <- newQCGen
return $ map (unGen arbitrary g) [0..]
instance Arbitrary DataTypeTable where
arbitrary = DataTypeTable
<$> arbText
<*> (T.take 100 <$> arbText)
<*> arbitrary
<*> arbTuple arbitrary arbText
<*> (BS.take 100 <$> arbitrary)
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
#ifndef WITH_NOSQL
<*> arbitrary
<*> (truncateTimeOfDay =<< arbitrary)
#endif
<*> (truncateUTCTime =<< arbitrary)
#if defined(WITH_MYSQL) && !(defined(OLD_MYSQL))
<*> (truncateTimeOfDay =<< arbitrary)
<*> (truncateUTCTime =<< arbitrary)
#endif
arbText :: Gen Text
arbText =
T.pack
. filter ((`notElem` forbidden) . generalCategory)
. filter (<= '\xFFFF')
. filter (/= '\0')
<$> arbitrary
where forbidden = [NotAssigned, PrivateUse]
arbTuple :: Gen a -> Gen b -> Gen (a, b)
arbTuple x y = (,) <$> x <*> y
truncateToMicro :: Pico -> Pico
truncateToMicro p = let
p' = fromRational . toRational $ p :: Micro
in fromRational . toRational $ p' :: Pico
truncateTimeOfDay :: TimeOfDay -> Gen TimeOfDay
truncateTimeOfDay (TimeOfDay h m s) =
return $ TimeOfDay h m $ truncateToMicro s
truncateUTCTime :: UTCTime -> Gen UTCTime
truncateUTCTime (UTCTime d dift) = do
let pico = fromRational . toRational $ dift :: Pico
picoi= truncate . (*1000000000000) . toRational $ truncateToMicro pico :: Integer
d' = max d $ fromGregorian 1950 1 1
return $ UTCTime d' $ picosecondsToDiffTime picoi
asIO :: IO a -> IO a
asIO = id