{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS -fno-warn-type-defaults #-}
{-# OPTIONS -fno-warn-orphans #-}
module Main where
import Control.Arrow (arr)
import Data.Char (toLower)
import Data.Int (Int64)
import Data.Time.LocalTime (TimeZone(..), utc)
import Data.Time.Zones (TZ, loadTZFromDB)
import Numeric.IEEE (epsilon)
import System.Exit (ExitCode(..), exitWith)
import System.Locale (defaultTimeLocale)
import Test.HUnit (Counts(..), Test(..), assertBool, assertEqual, runTestTT)
import Test.QuickCheck (Arbitrary(..), choose, sample')
import Text.Printf (printf)
import qualified Data.Text as Text (pack)
import Data.Time.Exts.Base
import Data.Time.Exts.Format
import Data.Time.Exts.Parser
import Data.Time.Exts.Unix
import Data.Time.Exts.Util
import Foreign.C.Time
instance Arbitrary Year where
arbitrary = Year <$> choose (1970, 9999)
instance Arbitrary Day where
arbitrary = Day <$> choose (1, 31)
instance Arbitrary Hour where
arbitrary = Hour <$> choose (0, 23)
instance Arbitrary Minute where
arbitrary = Minute <$> choose (0, 59)
instance Arbitrary Second where
arbitrary = Second <$> choose (0, 59)
instance Arbitrary Millis where
arbitrary = Millis <$> choose (0, 999)
instance Arbitrary Micros where
arbitrary = Micros <$> choose (0, 999999)
instance Arbitrary Nanos where
arbitrary = Nanos <$> choose (0, 999999999)
instance Arbitrary (Month 'Gregorian) where
arbitrary = toEnum <$> choose (jan, dec)
where jan = fromEnum (minBound :: DayOfWeek 'Gregorian)
dec = fromEnum (maxBound :: DayOfWeek 'Gregorian)
instance Arbitrary (DayOfWeek 'Gregorian) where
arbitrary = toEnum <$> choose (sun, sat)
where sun = fromEnum (minBound :: DayOfWeek 'Gregorian)
sat = fromEnum (maxBound :: DayOfWeek 'Gregorian)
instance Arbitrary (UnixDate 'Gregorian) where
arbitrary = choose (minBound, maxBound)
instance Arbitrary (UnixDateTime 'Gregorian) where
arbitrary = choose (minBound, maxBound)
instance Arbitrary (UnixDateTimeNanos 'Gregorian) where
arbitrary = choose (minBound, maxBound)
withArbitraryInput
:: Arbitrary a
=> (a -> Test)
-> IO Test
withArbitraryInput f = TestList . map f <$> sample' arbitrary
test_properFracMillis :: Test
test_properFracMillis = TestList
[
TestCase . assertEqual "properFracMillis 0.33333333333333" (0, 000000000333) $ properFracMillis 0.33333333333333,
TestCase . assertEqual "properFracMillis 0.66666666666666" (0, 000000000667) $ properFracMillis 0.66666666666666,
TestCase . assertEqual "properFracMillis 0.99999999999999" (1, 000000000000) $ properFracMillis 0.99999999999999
]
test_properFracMicros :: Test
test_properFracMicros = TestList
[
TestCase . assertEqual "properFracMicros 0.33333333333333" (0, 000000333333) $ properFracMicros 0.33333333333333,
TestCase . assertEqual "properFracMicros 0.66666666666666" (0, 000000666667) $ properFracMicros 0.66666666666666,
TestCase . assertEqual "properFracMicros 0.99999999999999" (1, 000000000000) $ properFracMicros 0.99999999999999
]
test_properFracNanos :: Test
test_properFracNanos = TestList
[
TestCase . assertEqual "properFracNanos 0.33333333333333" (0, 000333333333) $ properFracNanos 0.33333333333333,
TestCase . assertEqual "properFracNanos 0.66666666666666" (0, 000666666667) $ properFracNanos 0.66666666666666,
TestCase . assertEqual "properFracNanos 0.99999999999999" (1, 000000000000) $ properFracNanos 0.99999999999999
]
test_properFracPicos :: Test
test_properFracPicos = TestList
[
TestCase . assertEqual "properFracPicos 0.33333333333333" (0, 333333333333) $ properFracPicos 0.33333333333333,
TestCase . assertEqual "properFracPicos 0.66666666666666" (0, 666666666667) $ properFracPicos 0.66666666666666,
TestCase . assertEqual "properFracPicos 0.99999999999999" (1, 000000000000) $ properFracPicos 0.99999999999999
]
parse
:: (ParserState 'Gregorian -> Test)
-> Maybe TZ
-> Format
-> String
-> Test
parse test mtz formet input =
either error test . runParser defaultTimeLocale mtz state formet $ Text.pack input
where state = ParserState 1970 January 1 Thursday 0 0 0.0 id id (const (return utc))
deltaZero :: Double -> (Double -> Bool)
deltaZero x = (>) epsilon . abs . (-) x
test_parseYear :: Year -> Test
test_parseYear year =
parse test Nothing "%Y" input
where input = printf "%d" year
err = printf "test_parseYear: \"%s\"" input
test = TestCase . assertEqual err year . _ps_year
test_parseYear' :: Year -> Test
test_parseYear' year =
parse test Nothing "%y" input
where year' = mod year 100
fix x = if x >= 2000 then x - 2000 else x - 1900
input = printf "%02d" year'
err = printf "test_parseYear': \"%s\"" input
test = TestCase . assertEqual err year' . fix . _ps_year
test_parseMonth :: Month 'Gregorian -> Test
test_parseMonth month =
parse test Nothing "%B" input
where input = show month
err = printf "test_parseMonth: \"%s\"" input
test = TestCase . assertEqual err month . _ps_mon
test_parseMonth' :: Month 'Gregorian -> Test
test_parseMonth' month =
parse test Nothing "%b" input
where input = take 3 $ show month
err = printf "test_parseMonth': \"%s\"" input
test = TestCase . assertEqual err month . _ps_mon
test_parseMonth'' :: Month 'Gregorian -> Test
test_parseMonth'' month =
parse test Nothing "%h" input
where input = take 3 $ show month
err = printf "test_parseMonth'': \"%s\"" input
test = TestCase . assertEqual err month . _ps_mon
test_parseMonth''' :: Month 'Gregorian -> Test
test_parseMonth''' month =
parse test Nothing "%m" input
where input = printf "%02d" $ fromEnum month
err = printf "test_parseMonth''': \"%s\"" input
test = TestCase . assertEqual err month . _ps_mon
test_parseDay :: Day -> Test
test_parseDay day =
parse test Nothing "%d" input
where input = printf "%02d" day
err = printf "test_parseDay: \"%s\"" input
test = TestCase . assertEqual err day . _ps_mday
test_parseDay' :: Day -> Test
test_parseDay' day =
parse test Nothing "%e" input
where input = printf "%2d" day
err = printf "test_parseDay': \"%s\"" input
test = TestCase . assertEqual err day . _ps_mday
test_parseDayOfWeek :: DayOfWeek 'Gregorian -> Test
test_parseDayOfWeek day =
parse test Nothing "%A" input
where input = show day
err = printf "test_parseDayOfWeek: \"%s\"" input
test = TestCase . assertEqual err day . _ps_wday
test_parseDayOfWeek' :: DayOfWeek 'Gregorian -> Test
test_parseDayOfWeek' day =
parse test Nothing "%a" input
where input = take 3 $ show day
err = printf "test_parseDayOfWeek': \"%s\"" input
test = TestCase . assertEqual err day . _ps_wday
test_parseHour :: Hour -> Test
test_parseHour hour =
parse test Nothing "%H" input
where input = printf "%02d" hour
err = printf "test_parseHour: \"%s\"" input
test = TestCase . assertEqual err hour . _ps_hour
test_parseHour' :: Hour -> Test
test_parseHour' hour =
parse test Nothing "%I%p" input
where (,) period hour' = getPeriod hour
input = printf "%02d%s" hour' period
err = printf "test_parseHour': \"%s\"" input
test = TestCase . assertEqual err hour . \ ps -> (_ps_ampm ps) (_ps_hour ps)
test_parseHour'' :: Hour -> Test
test_parseHour'' hour =
parse test Nothing "%l%P" input
where (,) period hour' = getPeriod hour
input = printf "%2d%s" hour' (map toLower period)
err = printf "test_parseHour'': \"%s\"" input
test = TestCase . assertEqual err hour . \ ps -> (_ps_ampm ps) (_ps_hour ps)
test_parseMinute :: Minute -> Test
test_parseMinute minute =
parse test Nothing "%M" input
where input = printf "%02d" minute
err = printf "test_parseMinute: \"%s\"" input
test = TestCase . assertEqual err minute . _ps_min
test_parseSecond :: Second -> Test
test_parseSecond second =
parse test Nothing "%S" input
where input = printf "%02d" second
err = printf "test_parseSecond: \"%s\"" input
test = TestCase . assertEqual err second . truncate . _ps_sec
test_parseMillis :: Millis -> Test
test_parseMillis millis =
parse test Nothing "%S%f" input
where frac = realToFrac millis / 1000 :: Double
input = printf "%06.3f" frac
err = printf "test_parseMillis: \"%s\"" input
test = TestCase . assertBool err . deltaZero frac . flip arr 0 . _ps_frac
test_parseMicros :: Micros -> Test
test_parseMicros micros =
parse test Nothing "%S%f" input
where frac = realToFrac micros / 1000000 :: Double
input = printf "%09.6f" frac
err = printf "test_parseMicros: \"%s\"" input
test = TestCase . assertBool err . deltaZero frac . flip arr 0 . _ps_frac
test_parseNanos :: Nanos -> Test
test_parseNanos nanos =
parse test Nothing "%S%f" input
where frac = realToFrac nanos / 1000000000 :: Double
input = printf "%012.9f" frac
err = printf "test_parseNanos: \"%s\"" input
test = TestCase . assertBool err . deltaZero frac . flip arr 0 . _ps_frac
test_parseZone :: String -> Int64 -> TimeZone -> IO Test
test_parseZone region base tz = do
tzdata <- Just <$> loadTZFromDB region
return $! parse test tzdata "%Z" input
where input = timeZoneName tz
err = printf "test_parseZone: \"%s\"" input
test = TestCase . assertEqual err (Right tz) . flip arr base . _ps_zone
test_EnumUnixDate :: UnixDate 'Gregorian -> Test
test_EnumUnixDate date =
TestCase . assertEqual err date . toEnum $ fromEnum date
where err = "test_EnumUnixDate: " ++ show date
test_EnumUnixDateTime :: UnixDateTime 'Gregorian -> Test
test_EnumUnixDateTime time =
TestCase . assertEqual err time . toEnum $ fromEnum time
where err = "test_EnumUnixDateTime: " ++ show time
test_HumanUnixDate :: UnixDate 'Gregorian -> Test
test_HumanUnixDate date =
TestCase . assertEqual err date . pack $ unpack date
where err = "test_HumanUnixDate: " ++ show date
test_HumanUnixDateTime :: UnixDateTime 'Gregorian -> Test
test_HumanUnixDateTime time =
TestCase . assertEqual err time . pack $ unpack time
where err = "test_HumanUnixDateTime: " ++ show time
test_HumanUnixDateTimeNanos :: UnixDateTimeNanos 'Gregorian -> Test
test_HumanUnixDateTimeNanos time =
TestCase . assertEqual err time . pack $ unpack time
where err = "test_HumanUnixDateTimeNanos: " ++ show time
test_HumanCTime :: UnixDateTime 'Gregorian -> Test
test_HumanCTime time =
TestCase . assertBool err $
toInteger (c'tm'tm_year + 1900) == toInteger _dt_year &&
toInteger (c'tm'tm_mon + 0001) == toInteger (fromEnum _dt_mon) &&
toInteger c'tm'tm_mday == toInteger _dt_mday &&
toInteger (c'tm'tm_wday + 0001) == toInteger (fromEnum _dt_wday) &&
toInteger c'tm'tm_hour == toInteger _dt_hour &&
toInteger c'tm'tm_min == toInteger _dt_min &&
toInteger c'tm'tm_sec == truncate _dt_sec
where ctime :: CTime
ctime = fromIntegral $ fromEnum time
C'tm {..} = unpack ctime
DateTimeStruct {..} = unpack time
err = "test_HumanCTime: " ++ show time
test_MathUnixDate :: UnixDate 'Gregorian -> Test
test_MathUnixDate date =
TestCase . assertEqual err minBound $
date `plus` negate day
where err = "test_MathUnixDate: " ++ show date
day = fromIntegral $ fromEnum date :: Day
test_MathUnixDateTime :: UnixDateTime 'Gregorian -> Test
test_MathUnixDateTime time =
TestCase . assertEqual err minBound $
time `plus` negate day `plus` negate _dt_hour `plus` negate _dt_min `plus` negate sec
where DateTimeStruct {..} = unpack time
date = createUnixDate _dt_year _dt_mon _dt_mday
err = "test_MathUnixDateTime: " ++ show time
day = fromIntegral $ fromEnum date :: Day
sec = round _dt_sec :: Second
test_MathUnixDateTimeNanos :: UnixDateTimeNanos 'Gregorian -> Test
test_MathUnixDateTimeNanos time =
TestCase . assertEqual err minBound $
time `plus` negate day `plus` negate _dt_hour `plus` negate _dt_min `plus` negate sec `plus` negate nsec
where DateTimeStruct {..} = unpack time
date = createUnixDate _dt_year _dt_mon _dt_mday
err = "test_MathUnixDateTime: " ++ show time
day = fromIntegral $ fromEnum date :: Day
(,) sec nsec = properFracNanos _dt_sec
test_ShowUnixDate :: UnixDate 'Gregorian -> Test
test_ShowUnixDate date =
TestCase . assertEqual err date . either error id .
parseUnixDate defaultTimeLocale fmt . Text.pack $ show date
where fmt = "%a %b %d %Y"
err = "test_ShowUnixDate: " ++ show date
test_ShowUnixDateTime :: UnixDateTime 'Gregorian -> Test
test_ShowUnixDateTime time =
TestCase . assertEqual err time . either error id .
parseUnixDateTime defaultTimeLocale fmt . Text.pack $ show time
where fmt = "%r %a %b %d %Y"
err = "test_ShowUnixDateTime: " ++ show time
test_ShowUnixDateTimeNanos :: UnixDateTimeNanos 'Gregorian -> Test
test_ShowUnixDateTimeNanos time =
TestCase . assertEqual err time . either error id .
parseUnixDateTimeNanos defaultTimeLocale fmt . Text.pack $ show time
where fmt = "%I:%M:%S%f %p %a %b %d %Y"
err = "test_ShowUnixDateTimeNanos: " ++ show time
tests :: IO Test
tests = TestList <$> sequence
[
return test_properFracMillis,
return test_properFracMicros,
return test_properFracNanos,
return test_properFracPicos,
withArbitraryInput test_parseYear,
withArbitraryInput test_parseYear',
withArbitraryInput test_parseMonth,
withArbitraryInput test_parseMonth',
withArbitraryInput test_parseMonth'',
withArbitraryInput test_parseMonth''',
withArbitraryInput test_parseDay,
withArbitraryInput test_parseDay',
withArbitraryInput test_parseDayOfWeek,
withArbitraryInput test_parseDayOfWeek',
withArbitraryInput test_parseHour,
withArbitraryInput test_parseHour',
withArbitraryInput test_parseHour'',
withArbitraryInput test_parseMinute,
withArbitraryInput test_parseSecond,
withArbitraryInput test_parseMillis,
withArbitraryInput test_parseMicros,
withArbitraryInput test_parseNanos,
test_parseZone "America/Los_Angeles" 1457834399 (TimeZone (-480) False "PST"),
test_parseZone "America/Los_Angeles" 1457838000 (TimeZone (-420) True "PDT"),
test_parseZone "America/Los_Angeles" 1478397599 (TimeZone (-420) True "PDT"),
test_parseZone "America/Los_Angeles" 1478394000 (TimeZone (-480) False "PST"),
withArbitraryInput test_EnumUnixDate,
withArbitraryInput test_EnumUnixDateTime,
withArbitraryInput test_HumanUnixDate,
withArbitraryInput test_HumanUnixDateTime,
withArbitraryInput test_HumanUnixDateTimeNanos,
withArbitraryInput test_HumanCTime,
withArbitraryInput test_MathUnixDate,
withArbitraryInput test_MathUnixDateTime,
withArbitraryInput test_MathUnixDateTimeNanos,
withArbitraryInput test_ShowUnixDate,
withArbitraryInput test_ShowUnixDateTime,
withArbitraryInput test_ShowUnixDateTimeNanos
]
main :: IO ()
main = do
Counts {..} <- tests >>= runTestTT
exitWith $ case failures + errors of
0 -> ExitSuccess
_ -> ExitFailure 1