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