1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE BangPatterns #-}
4{-# LANGUAGE CPP #-}
5module Main where
6
7import Control.Applicative
8
9import Test.Tasty
10import Test.Tasty.QuickCheck
11import Test.Tasty.HUnit
12
13import Data.Ratio
14import Data.Word
15import Data.Int
16import Data.Hourglass
17import Data.Hourglass.Epoch
18
19import Foreign.Storable
20import Foreign.C.Types (CTime)
21
22import qualified Data.Time.Calendar as T
23import qualified Data.Time.Clock as T
24import qualified Data.Time.Clock.POSIX as T
25import qualified Data.Time.Format as T
26#if MIN_VERSION_time(1,5,0)
27import qualified System.Locale as T hiding (defaultTimeLocale)
28#else
29import qualified System.Locale as T
30#endif
31
32import qualified Control.Exception as E
33
34import TimeDB
35
36tmPosix0 :: Elapsed
37tmPosix0 = fromIntegral (0 :: Word64)
38
39timePosix0 :: T.POSIXTime
40timePosix0 = fromIntegral (0 :: Word64)
41
42elapsedToPosixTime :: Elapsed -> T.POSIXTime
43elapsedToPosixTime (Elapsed (Seconds s)) = fromIntegral s
44
45dateEqual :: LocalTime DateTime -> T.UTCTime -> Bool
46dateEqual localtime utcTime =
47    and [ fromIntegral y == y', m' == (fromEnum m + 1), d' == d
48        , fromIntegral h' == h, fromIntegral mi' == mi, sec' == sec ]
49 where (y',m',d') = T.toGregorian (T.utctDay utcTime)
50       daytime    = floor $ T.utctDayTime utcTime
51       (dt', sec')= daytime `divMod` 60
52       (h' , mi') = dt' `divMod` 60
53       (DateTime (Date y m d) (TimeOfDay h mi sec _)) = localTimeToGlobal localtime
54
55-- | The @Date@ type is able to represent some values that aren't actually legal,
56-- specifically dates with a day field outside of the range of dates in the
57-- month. This function validates a @Date@.
58isValidDate :: Date -> Bool
59isValidDate (Date y m d) = d > 0 && d <= (daysInMonth y m)
60
61-- windows native functions to convert time cannot handle time before year 1601
62#ifdef WINDOWS
63loElapsed = -11644473600 -- ~ year 1601
64hiElapsed =  32503680000
65dateRange = (1800, 2202)
66#else
67isCTime64 = sizeOf (undefined :: CTime) == 8
68loElapsed =
69  if isCTime64
70     then -62135596800 -- ~ year 0
71     else -(2^(28 :: Int))
72hiElapsed =
73  if isCTime64
74     then 2^(55 :: Int) -- in a future far far away
75     else 2^(29 :: Int) -- before the 2038 bug.
76dateRange =
77  if isCTime64
78     then (1800, 2202)
79     else (1960, 2036)
80#endif
81instance Arbitrary Seconds where
82    arbitrary = Seconds . toHiLo <$> arbitrary
83      where toHiLo v | v > loElapsed && v < hiElapsed = v
84                     | v > hiElapsed = v `mod` hiElapsed
85                     | v < loElapsed = v `mod` loElapsed
86                     | otherwise = error "internal error"
87instance Arbitrary Minutes where
88    arbitrary = Minutes <$> choose (-1125899906842624, 1125899906842624)
89instance Arbitrary Hours where
90    arbitrary = Hours <$> choose (-1125899906842, 1125899906842)
91instance Arbitrary NanoSeconds where
92    arbitrary = NanoSeconds <$> choose (0, 100000000)
93instance Arbitrary Elapsed where
94    arbitrary = Elapsed <$> arbitrary
95instance Arbitrary TimezoneOffset where
96    arbitrary = TimezoneOffset <$> choose (-11*60,11*60)
97instance Arbitrary Duration where
98    arbitrary = Duration <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
99instance Arbitrary Period where
100    arbitrary = Period <$> choose (-29,29) <*> choose (-27,27) <*> choose (-400,400)
101instance Arbitrary Month where
102    arbitrary = elements [January ..]
103instance Arbitrary DateTime where
104    arbitrary = DateTime <$> arbitrary <*> arbitrary
105instance Arbitrary Date where
106    arbitrary = do
107        year <- choose dateRange
108        month <- arbitrary
109        Date year month <$> choose (1, daysInMonth year month)
110instance Arbitrary TimeOfDay where
111    arbitrary = TimeOfDay <$> (Hours <$> choose (0,23))
112                          <*> (Minutes <$> choose (0,59))
113                          <*> (Seconds <$> choose (0,59))
114                          <*> arbitrary
115instance (Time t, Arbitrary t) => Arbitrary (LocalTime t) where
116    arbitrary = localTime <$> arbitrary <*> arbitrary
117
118eq expected got
119    | expected == got = True
120    | otherwise       = error ("expected: " ++ show expected ++ " got: " ++ show got)
121
122testCaseWith :: (Num a, Eq a, Show a) => String -> (a -> a -> a) -> (a, a, a) -> TestTree
123testCaseWith what fun (x, y, ref) =
124    testCase ((show x) ++ " " ++ what ++ " " ++ (show y) ++ " ?= " ++ (show ref)) checkAdd
125  where
126    checkAdd :: Assertion
127    checkAdd =
128        if fun x y /= ref
129            then assertFailure $ (show $ fun x y) ++ " /= " ++ (show ref)
130            else return ()
131
132arithmeticTestAddRef :: [(ElapsedP, ElapsedP, ElapsedP)]
133arithmeticTestAddRef = map testRefToElapsedP
134    [ ((1, 090000000), (2, 090000000), (3, 180000000))
135    , ((1, 900000000), (1, 200000000), (3, 100000000))
136    , ((1, 000000001), (0, 999999999), (2, 000000000))
137    ]
138
139arithmeticTestSubRef :: [(ElapsedP, ElapsedP, ElapsedP)]
140arithmeticTestSubRef = map testRefToElapsedP
141    [ ((1, ms 100), (1, ms 100), (0, ms 000))
142    , ((1, ms 900), (1, ms 100), (0, ms 800))
143    , ((1, ms 100), (0, ms 200), (0, ms 900))
144    , ((1, ms 100), (2, ms 400), (-2, ms 700))
145    ]
146  where ms v = v * 1000000
147
148testRefToElapsedP :: ((Int64, Int64), (Int64, Int64), (Int64, Int64)) -> (ElapsedP, ElapsedP, ElapsedP)
149testRefToElapsedP (a, b, c) = (tupleToElapsedP a, tupleToElapsedP b, tupleToElapsedP c)
150  where
151    tupleToElapsedP :: (Int64, Int64) -> ElapsedP
152    tupleToElapsedP (s, n) = ElapsedP (Elapsed $ Seconds s) (NanoSeconds n)
153
154tests knowns = testGroup "hourglass"
155    [ testGroup "known"
156        [ testGroup "calendar conv" (map toCalendarTest $ zip eint (map tuple12 knowns))
157        , testGroup "seconds conv" (map toSecondTest $ zip eint (map tuple12 knowns))
158        , testGroup "weekday" (map toWeekDayTest $ zip eint (map tuple13 knowns))
159        ]
160    , testGroup "conversion"
161        [ testProperty "calendar" $ \(e :: Elapsed) ->
162             e `eq` timeGetElapsed (timeGetDateTimeOfDay e)
163        , testProperty "win epoch" $ \(e :: Elapsed) ->
164            let e2 = timeConvert e :: ElapsedSince WindowsEpoch
165             in timePrint ISO8601_DateAndTime e `eq` timePrint ISO8601_DateAndTime e2
166        ]
167    , testGroup "localtime"
168        [ testProperty "eq" $ \(l :: LocalTime Elapsed) ->
169            let g = localTimeToGlobal l
170             in l `eq` localTimeSetTimezone (localTimeGetTimezone l) (localTimeFromGlobal g)
171        , testProperty "set" $ \(l :: LocalTime Elapsed, newTz) ->
172            let l2 = localTimeSetTimezone newTz l
173             in localTimeToGlobal l `eq` localTimeToGlobal l2
174        ]
175    , testGroup "arithmetic"
176        [ testGroup "ElapseP add" $ map (testCaseWith "+" (+)) arithmeticTestAddRef
177        , testGroup "ElapseP sub" $ map (testCaseWith "-" (-)) arithmeticTestSubRef
178          {-testProperty "add-diff" $ \(e :: Elapsed, tdiff) ->
179            let d@(TimeDiff _ _ day h mi s _) = tdiff { timeDiffYears  = 0
180                                                      , timeDiffMonths = 0
181                                                      , timeDiffNs     = 0
182                                                      }
183                i64     = fromIntegral
184                accSecs = (((i64 day * 24) + i64 h) * 60 + i64 mi) * 60 + i64 s :: Int64
185                e'      = timeAdd e d
186             in Seconds accSecs `eq` timeDiff e' e
187        , testProperty "calendar-add-month" $ \date@(DateTime (Date y m d) _) ->
188            let date'@(DateTime (Date y' m' d') _) = timeAdd date (mempty { timeDiffMonths = 1 })
189             in timeGetTimeOfDay date `eq` timeGetTimeOfDay date' &&
190                (d `eq` d')                                       &&
191                (toEnum ((fromEnum m+1) `mod` 12) `eq` m')        &&
192                (if m == December then (y+1) `eq` y' else y `eq` y')
193                -}
194
195        -- Make sure our Arbitrary instance only generates valid dates:
196        , testProperty "Arbitrary-isValidDate" isValidDate
197
198        , testProperty "dateAddPeriod" $ (\date period ->
199            isValidDate (date `dateAddPeriod` period))
200        ]
201    , testGroup "formating"
202        [ testProperty "iso8601 date" $ \(e :: Elapsed) ->
203            (calTimeFormatTimeISO8601 (elapsedToPosixTime e) `eq` timePrint ISO8601_Date e)
204        , testProperty "unix seconds" $ \(e :: Elapsed) ->
205            let sTime = T.formatTime T.defaultTimeLocale "%s" (T.posixSecondsToUTCTime $ elapsedToPosixTime e)
206                sHg = timePrint "EPOCH" e
207             in sTime `eq` sHg
208        ]
209    , testGroup "parsing"
210        [ testProperty "iso8601 date" $ \(e :: Elapsed) ->
211            let fmt = calTimeFormatTimeISO8601 (elapsedToPosixTime e)
212                ed1  = localTimeParseE ISO8601_Date fmt
213                md2  = T.parseTime T.defaultTimeLocale fmt "%F"
214             in case (ed1,md2) of
215                    (Left err, Nothing)       -> error ("both cannot parse: " ++ show fmt ++ " hourglass-err=" ++ show err)
216                    (Left err, Just _)        -> error ("error parsing string: " ++ show err)
217                    (Right (d1, ""), Just d2) -> dateEqual d1 d2
218                    (Right (_,_), Nothing)    -> True -- let (LocalTime tparsed _) = r in error ("time cannot parse: " ++ show tparsed ++ " " ++ fmt)
219                    (Right (_, rm), _)        -> error ("remaining string after parse: " ++ rm)
220        , testProperty "timezone" $ \tz ->
221            let r = localTimeParseE "TZHM" (show tz) in
222            case r of
223                Right (localtime, "") -> tz `eq` localTimeGetTimezone localtime
224                _                     -> error "Cannot parse timezone"
225        , testProperty "custom-1" $ test_property_format ("YYYY-MM-DDTH:MI:S.msusns" :: String)
226        , testProperty "custom-2" $ test_property_format ("Mon DD\\t\\h YYYY at HH\\hMI\\mS\\s.p9\\n\\s" :: String)
227        ]
228    , testGroup "Regression Tests"
229        [ testCase  "Real instance of ElapsedP (#33)" $
230            let res = toRational (ElapsedP (Elapsed $ Seconds 0) (NanoSeconds 0))
231                ref = toRational 0 :: Rational
232             in assertEqual "failed equality" ref res
233        , testCase  "Real instance of ElapsedP (#33) (2)" $
234            let res = toRational (ElapsedP (Elapsed $ Seconds 100) (NanoSeconds 1000000))
235                ref = toRational 100 + (1 % 1000) :: Rational
236             in assertEqual "failed equality" ref res
237        ]
238    ]
239  where toCalendarTest (i, (us, dt)) =
240            testCase (show i) (dt @=? timeGetDateTimeOfDay us)
241        toSecondTest (i, (us@(Elapsed (Seconds s)), dt)) =
242            testCase (show i ++ "-" ++ show s ++ "s") (us @=? timeGetElapsed dt)
243        toWeekDayTest (i, (us, wd)) =
244            testCase (show i ++ "-" ++ show wd) (wd @=? getWeekDay (dtDate $ timeGetDateTimeOfDay us))
245
246        eint :: [Int]
247        eint = [1..]
248
249        tuple12 (a,b,_,_) = (a,b)
250        tuple13 (a,_,b,_) = (a,b)
251
252        calTimeFormatTimeISO8601 timePosix =
253            T.formatTime T.defaultTimeLocale "%F" (T.posixSecondsToUTCTime timePosix)
254
255        test_property_format :: (TimeFormat format, Show format) => format -> DateTime -> Bool
256        test_property_format fmt dt =
257            let p1  = timePrint fmt dt in
258            case timeParseE fmt p1 of
259                Left (fmtEl, err) -> error ("cannot decode printed DateTime: " ++ show p1 ++ " with format " ++ show fmt ++ " error with(" ++ show fmtEl ++ "): " ++ err)
260                Right (dt2, _) -> dt `eq` dt2
261
262main = do
263    knowns <- E.catch (map parseTimeConv . lines <$> readFile "test-time-db")
264                      (\(_ :: E.SomeException) -> return [])
265    defaultMain (tests knowns)
266