1{-# OPTIONS -fno-warn-orphans #-} 2 3module Test.Format.ParseTime 4 ( testParseTime 5 , test_parse_format 6 ) where 7 8#if MIN_VERSION_base(4,11,0) 9#else 10import Data.Semigroup hiding (option) 11#endif 12import Control.Monad 13import Data.Char 14import Data.Maybe 15import Data.Proxy 16import Data.Time.Compat 17import Data.Time.Calendar.OrdinalDate.Compat 18import Data.Time.Calendar.WeekDate.Compat 19import Data.Time.Calendar.Month.Compat 20import Data.Time.Calendar.Quarter.Compat 21import Test.Arbitrary () 22import Test.QuickCheck.Property 23import Test.Tasty 24import Test.Tasty.HUnit 25import Test.Tasty.QuickCheck hiding (reason) 26import Test.TestUtil 27import Text.Read.Compat 28 29format :: FormatTime t => String -> t -> String 30format f t = formatTime defaultTimeLocale f t 31 32parse :: ParseTime t => Bool -> String -> String -> Maybe t 33parse sp f t = parseTimeM sp defaultTimeLocale f t 34 35data FormatOnly 36 37data ParseAndFormat 38 39data FormatCode pf t = MkFormatCode 40 { fcModifier :: String 41 , fcWidth :: Maybe Int 42 , fcAlt :: Bool 43 , fcSpecifier :: Char 44 } 45 46instance Show (FormatCode pf t) where 47 show (MkFormatCode m w a s) = let 48 ms = m 49 ws = fromMaybe "" $ fmap show w 50 as = 51 if a 52 then "E" 53 else "" 54 ss = [s] 55 in '%' : (ms <> ws <> as <> ss) 56 57formatCode :: FormatTime t => FormatCode pf t -> t -> String 58formatCode fc = format $ show fc 59 60parseCode :: ParseTime t => FormatCode ParseAndFormat t -> String -> Maybe t 61parseCode fc = parse False $ show fc 62 63class HasFormatCodes t where 64 allFormatCodes :: Proxy t -> [(Bool, Char)] 65 incompleteS :: Maybe t 66 incompleteS = Nothing 67 68minCodeWidth :: Char -> Int 69minCodeWidth _ = 0 70 71fcShrink :: FormatCode pf t -> [FormatCode pf t] 72fcShrink fc = let 73 fc1 = 74 case fcWidth fc of 75 Nothing -> [] 76 Just w 77 | w > (minCodeWidth $ fcSpecifier fc) -> [fc {fcWidth = Nothing}, fc {fcWidth = Just $ w - 1}] 78 Just _ -> [fc {fcWidth = Nothing}] 79 fc2 = 80 case fcAlt fc of 81 False -> [] 82 True -> [fc {fcAlt = False}] 83 fc3 = 84 case fcModifier fc of 85 "" -> [] 86 _ -> [fc {fcModifier = ""}] 87 in fc1 ++ fc2 ++ fc3 88 89instance HasFormatCodes t => Arbitrary (FormatCode FormatOnly t) where 90 arbitrary = do 91 m <- oneof [return "", oneof $ fmap return ["", "-", "_", "0", "^", "#"]] 92 (a, s) <- oneof $ fmap return $ allFormatCodes (Proxy :: Proxy t) 93 w <- 94 case minCodeWidth s of 95 0 -> return Nothing 96 mw -> oneof [return Nothing, fmap Just $ choose (mw, 15)] 97 return $ MkFormatCode m w a s 98 shrink = fcShrink 99 100instance HasFormatCodes t => Arbitrary (FormatCode ParseAndFormat t) where 101 arbitrary = do 102 (a, s) <- oneof $ fmap return $ allFormatCodes (Proxy :: Proxy t) 103 m <- 104 case s of 105 'Z' -> return "" 106 'z' -> return "" 107 _ -> oneof [return "", oneof $ fmap return ["", "-", "_", "0"]] 108 return $ MkFormatCode m Nothing a s 109 shrink = fcShrink 110 111testParseTime :: TestTree 112testParseTime = 113 testGroup 114 "testParseTime" 115 [ readOtherTypesTest 116 , readTests 117 , simpleFormatTests 118 , extests 119 , particularParseTests 120 , badParseTests 121 , defaultTimeZoneTests 122 , militaryTimeZoneTests 123 , propertyTests 124 ] 125 126yearDays :: Integer -> [Day] 127yearDays y = [(fromGregorian y 1 1) .. (fromGregorian y 12 31)] 128 129makeExhaustiveTest :: String -> [t] -> (t -> TestTree) -> TestTree 130makeExhaustiveTest name cases f = testGroup name (fmap f cases) 131 132extests :: TestTree 133extests = 134 testGroup 135 "exhaustive" 136 ([ makeExhaustiveTest "parse %y" [0 .. 99] parseYY 137 , makeExhaustiveTest "parse %-C %y 1900s" [0, 1, 50, 99] (parseCYY 19) 138 , makeExhaustiveTest "parse %-C %y 2000s" [0, 1, 50, 99] (parseCYY 20) 139 , makeExhaustiveTest "parse %-C %y 1400s" [0, 1, 50, 99] (parseCYY 14) 140 , makeExhaustiveTest "parse %C %y 0700s" [0, 1, 50, 99] (parseCYY2 7) 141 , makeExhaustiveTest "parse %-C %y 700s" [0, 1, 50, 99] (parseCYY 7) 142 , makeExhaustiveTest "parse %-C %y -700s" [0, 1, 50, 99] (parseCYY (-7)) 143 , makeExhaustiveTest "parse %-C %y -70000s" [0, 1, 50, 99] (parseCYY (-70000)) 144 , makeExhaustiveTest "parse %-C %y 10000s" [0, 1, 50, 99] (parseCYY 100) 145 , makeExhaustiveTest "parse %-C centuries" [20 .. 100] (parseCentury " ") 146 , makeExhaustiveTest "parse %-C century X" [1, 10, 20, 100] (parseCentury "X") 147 , makeExhaustiveTest "parse %-C century 2sp" [1, 10, 20, 100] (parseCentury " ") 148 , makeExhaustiveTest "parse %-C century 5sp" [1, 10, 20, 100] (parseCentury " ") 149 ] ++ 150 (concat $ 151 fmap 152 (\y -> 153 [ (makeExhaustiveTest "parse %Y%m%d" (yearDays y) parseYMD) 154 , (makeExhaustiveTest "parse %Y %m %d" (yearDays y) parseYearDayD) 155 , (makeExhaustiveTest "parse %Y %-m %e" (yearDays y) parseYearDayE) 156 ]) 157 [1, 4, 20, 753, 2000, 2011, 10001 ])) -- , (-1166)])) 158 159readTest :: (Eq a, Show a, Read a) => [(a, String)] -> String -> TestTree 160readTest expected target = let 161 found = reads target 162 result = assertEqual "" expected found 163 name = show target 164 in Test.Tasty.HUnit.testCase name result 165 166readTestsParensSpaces :: 167 forall a. (Eq a, Show a, Read a) 168 => a 169 -> String 170 -> TestTree 171readTestsParensSpaces expected target = 172 testGroup 173 target 174 [ readTest [(expected, "")] $ target 175 , readTest [(expected, "")] $ "(" ++ target ++ ")" 176 , readTest [(expected, "")] $ " (" ++ target ++ ")" 177 , readTest [(expected, " ")] $ " ( " ++ target ++ " ) " 178 , readTest [(expected, " ")] $ " (( " ++ target ++ " )) " 179 , readTest ([] :: [(a, String)]) $ "(" ++ target 180 , readTest [(expected, ")")] $ "" ++ target ++ ")" 181 , readTest [(expected, "")] $ "((" ++ target ++ "))" 182 , readTest [(expected, " ")] $ " ( ( " ++ target ++ " ) ) " 183 ] 184 where 185 186 187readOtherTypesTest :: TestTree 188readOtherTypesTest = 189 testGroup "read other types" [readTestsParensSpaces (3 :: Integer) "3", readTestsParensSpaces "a" "\"a\""] 190 191readTests :: TestTree 192readTests = 193 testGroup 194 "read times" 195 [ readTestsParensSpaces testDay "1912-07-08" 196 --readTestsParensSpaces testDay "1912-7-8", 197 , readTestsParensSpaces testTimeOfDay "08:04:02" 198 --,readTestsParensSpaces testTimeOfDay "8:4:2" 199 ] 200 where 201 testDay = fromGregorian 1912 7 8 202 testTimeOfDay = TimeOfDay 8 4 2 203 204epoch :: LocalTime 205epoch = LocalTime (fromGregorian 1970 0 0) midnight 206 207simpleFormatTests :: TestTree 208simpleFormatTests = 209 testGroup 210 "simple" 211 [ readsTest [(epoch, "")] "" "" 212 , readsTest [(epoch, " ")] "" " " 213 , readsTest [(epoch, "")] " " " " 214 , readsTest [(epoch, "")] " " " " 215 , readsTest [(epoch, "")] "%k" "0" 216 , readsTest [(epoch, "")] "%k" " 0" 217 , readsTest [(epoch, "")] "%m" "01" 218 , readsTest [(epoch, " ")] "%m" "01 " 219 , readsTest [(epoch, " ")] " %m" " 01 " 220 , readsTest [(epoch, "")] " %m" " 01" 221 -- https://ghc.haskell.org/trac/ghc/ticket/9150 222 , readsTest [(epoch, "")] " %M" " 00" 223 , readsTest [(epoch, "")] "%M " "00 " 224 , readsTest [(epoch, "")] "%Q" "" 225 , readsTest [(epoch, " ")] "%Q" " " 226 , readsTest [(epoch, "X")] "%Q" "X" 227 , readsTest [(epoch, " X")] "%Q" " X" 228 , readsTest [(epoch, "")] "%Q " " " 229 , readsTest [(epoch, "")] "%Q X" " X" 230 , readsTest [(epoch, "")] "%QX" "X" 231 ] 232 where 233 readsTest :: (Show a, Eq a, ParseTime a) => [(a, String)] -> String -> String -> TestTree 234 readsTest expected formatStr target = let 235 found = readSTime False defaultTimeLocale formatStr target 236 result = assertEqual "" expected found 237 name = (show formatStr) ++ " of " ++ (show target) 238 in Test.Tasty.HUnit.testCase name result 239 240spacingTests :: (Show t, Eq t, ParseTime t) => t -> String -> String -> TestTree 241spacingTests expected formatStr target = 242 testGroup 243 "particular" 244 [ parseTest False (Just expected) formatStr target 245 , parseTest True (Just expected) formatStr target 246 , parseTest False (Just expected) (formatStr ++ " ") (target ++ " ") 247 , parseTest True (Just expected) (formatStr ++ " ") (target ++ " ") 248 , parseTest False (Just expected) (" " ++ formatStr) (" " ++ target) 249 , parseTest True (Just expected) (" " ++ formatStr) (" " ++ target) 250 , parseTest True (Just expected) ("" ++ formatStr) (" " ++ target) 251 , parseTest True (Just expected) (" " ++ formatStr) (" " ++ target) 252 ] 253 254particularParseTests :: TestTree 255particularParseTests = 256 testGroup 257 "particular" 258 [ spacingTests epoch "%Q" "" 259 , spacingTests epoch "%Q" ".0" 260 , spacingTests epoch "%k" " 0" 261 , spacingTests epoch "%M" "00" 262 , spacingTests epoch "%m" "01" 263 , spacingTests (TimeZone 120 False "") "%z" "+0200" 264 , spacingTests (TimeZone 120 False "") "%Z" "+0200" 265 , spacingTests (TimeZone (-480) False "PST") "%Z" "PST" 266 ] 267 268badParseTests :: TestTree 269badParseTests = testGroup "bad" [parseTest False (Nothing :: Maybe Day) "%Y" ""] 270 271parseYMD :: Day -> TestTree 272parseYMD day = 273 case toGregorian day of 274 (y, m, d) -> parseTest False (Just day) "%Y%m%d" ((show y) ++ (show2 m) ++ (show2 d)) 275 276parseYearDayD :: Day -> TestTree 277parseYearDayD day = 278 case toGregorian day of 279 (y, m, d) -> parseTest False (Just day) "%Y %m %d" ((show y) ++ " " ++ (show2 m) ++ " " ++ (show2 d)) 280 281parseYearDayE :: Day -> TestTree 282parseYearDayE day = 283 case toGregorian day of 284 (y, m, d) -> parseTest False (Just day) "%Y %-m %e" ((show y) ++ " " ++ (show m) ++ " " ++ (show d)) 285 286-- | 1969 - 2068 287expectedYear :: Integer -> Integer 288expectedYear i 289 | i >= 69 = 1900 + i 290expectedYear i = 2000 + i 291 292show2 :: (Show n, Integral n) => n -> String 293show2 i = (show (div i 10)) ++ (show (mod i 10)) 294 295parseYY :: Integer -> TestTree 296parseYY i = parseTest False (Just (fromGregorian (expectedYear i) 1 1)) "%y" (show2 i) 297 298parseCYY :: Integer -> Integer -> TestTree 299parseCYY c i = parseTest False (Just (fromGregorian ((c * 100) + i) 1 1)) "%-C %y" ((show c) ++ " " ++ (show2 i)) 300 301parseCYY2 :: Integer -> Integer -> TestTree 302parseCYY2 c i = parseTest False (Just (fromGregorian ((c * 100) + i) 1 1)) "%C %y" ((show2 c) ++ " " ++ (show2 i)) 303 304parseCentury :: String -> Integer -> TestTree 305parseCentury int c = 306 parseTest False (Just (fromGregorian (c * 100) 1 1)) ("%-C" ++ int ++ "%y") ((show c) ++ int ++ "00") 307 308parseTest :: (Show t, Eq t, ParseTime t) => Bool -> Maybe t -> String -> String -> TestTree 309parseTest sp expected formatStr target = let 310 found = parse sp formatStr target 311 result = assertEqual "" expected found 312 name = 313 (show formatStr) ++ 314 " of " ++ 315 (show target) ++ 316 (if sp 317 then " allowing spaces" 318 else "") 319 in Test.Tasty.HUnit.testCase name result 320 321{- 322readsTest :: forall t. (Show t, Eq t, ParseTime t) => Maybe t -> String -> String -> TestTree 323readsTest (Just e) = readsTest' [(e,"")] 324readsTest Nothing = readsTest' ([] :: [(t,String)]) 325-} 326enumAdd :: (Enum a) => Int -> a -> a 327enumAdd i a = toEnum (i + fromEnum a) 328 329getMilZoneLetter :: Int -> Char 330getMilZoneLetter 0 = 'Z' 331getMilZoneLetter h 332 | h < 0 = enumAdd (negate h) 'M' 333getMilZoneLetter h 334 | h < 10 = enumAdd (h - 1) 'A' 335getMilZoneLetter h = enumAdd (h - 10) 'K' 336 337getMilZone :: Int -> TimeZone 338getMilZone hour = TimeZone (hour * 60) False [getMilZoneLetter hour] 339 340testParseTimeZone :: TimeZone -> TestTree 341testParseTimeZone tz = parseTest False (Just tz) "%Z" (timeZoneName tz) 342 343defaultTimeZoneTests :: TestTree 344defaultTimeZoneTests = testGroup "default time zones" [] -- (fmap testParseTimeZone (knownTimeZones defaultTimeLocale)) 345 346militaryTimeZoneTests :: TestTree 347militaryTimeZoneTests = testGroup "military time zones" (fmap (testParseTimeZone . getMilZone) [-12 .. 12]) 348 349-- missing from the time package 350instance Eq ZonedTime where 351 ZonedTime t1 tz1 == ZonedTime t2 tz2 = t1 == t2 && tz1 == tz2 352 353compareResult' :: (Eq a, Show a) => String -> a -> a -> Result 354compareResult' extra expected found 355 | expected == found = succeeded 356 | otherwise = failed {reason = "expected " ++ (show expected) ++ ", found " ++ (show found) ++ extra} 357 358compareResult :: (Eq a, Show a) => a -> a -> Result 359compareResult = compareResult' "" 360 361compareParse :: 362 forall a. (Eq a, Show a, ParseTime a) 363 => a 364 -> String 365 -> String 366 -> Result 367compareParse expected fmt text = compareResult' (", parsing " ++ (show text)) (Just expected) (parse False fmt text) 368 369-- 370-- * tests for debugging failing cases 371-- 372test_parse_format :: (FormatTime t, ParseTime t, Show t) => String -> t -> (String, String, Maybe t) 373test_parse_format f t = let 374 s = format f t 375 in (show t, s, parse False f s `asTypeOf` Just t) 376 377-- 378-- * show and read 379-- 380prop_read_show :: (Read a, Show a, Eq a) => a -> Result 381prop_read_show t = compareResult (Just t) (readMaybe (show t)) 382 383prop_read_show_ZonedUTC :: ZonedTime -> Result 384prop_read_show_ZonedUTC t = compareResult (Just $ zonedTimeToUTC t) (readMaybe (show t)) 385 386prop_read_show_LocalUTC :: LocalTime -> Result 387prop_read_show_LocalUTC t = compareResult (Just $ localTimeToUTC utc t) (readMaybe (show t)) 388 389-- 390-- * special show functions 391-- 392prop_parse_showWeekDate :: Day -> Result 393prop_parse_showWeekDate d = compareParse d "%G-W%V-%u" (showWeekDate d) 394 395prop_parse_showGregorian :: Day -> Result 396prop_parse_showGregorian d = compareParse d "%Y-%m-%d" (showGregorian d) 397 398prop_parse_showOrdinalDate :: Day -> Result 399prop_parse_showOrdinalDate d = compareParse d "%Y-%j" (showOrdinalDate d) 400 401-- 402-- * fromMondayStartWeek and fromSundayStartWeek 403-- 404prop_fromMondayStartWeek :: Day -> Result 405prop_fromMondayStartWeek d = let 406 (w, wd) = mondayStartWeek d 407 (y, _, _) = toGregorian d 408 in compareResult d (fromMondayStartWeek y w wd) 409 410prop_fromSundayStartWeek :: Day -> Result 411prop_fromSundayStartWeek d = let 412 (w, wd) = sundayStartWeek d 413 (y, _, _) = toGregorian d 414 in compareResult d (fromSundayStartWeek y w wd) 415 416-- t == parse (format t) 417prop_parse_format :: (Eq t, FormatTime t, ParseTime t, Show t) => FormatString t -> t -> Result 418prop_parse_format (FormatString f) t = compareParse t f (format f t) 419 420-- t == parse (upper (format t)) 421prop_parse_format_upper :: (Eq t, FormatTime t, ParseTime t, Show t) => FormatString t -> t -> Result 422prop_parse_format_upper (FormatString f) t = compareParse t f (map toUpper $ format f t) 423 424-- t == parse (lower (format t)) 425prop_parse_format_lower :: (Eq t, FormatTime t, ParseTime t, Show t) => FormatString t -> t -> Result 426prop_parse_format_lower (FormatString f) t = compareParse t f (map toLower $ format f t) 427 428-- Default time is 1970-01-01 00:00:00 +0000 (which was a Thursday) 429in1970 :: Maybe String -> Char -> String -> Maybe String 430in1970 _ 'j' "366" = Nothing -- 1970 was not a leap year 431in1970 _ 'U' "53" = Nothing -- last day of 1970 was Sunday-start-week 52 432in1970 _ 'W' "53" = Nothing -- last day of 1970 was Monday-start-week 52 433in1970 (Just s) 'S' "60" = Just s -- no leap second without other data 434in1970 _ _ s = Just s 435 436-- format t == format (parse (format t)) 437prop_format_parse_format :: 438 forall t. (HasFormatCodes t, FormatTime t, ParseTime t) 439 => Proxy t 440 -> FormatCode ParseAndFormat t 441 -> t 442 -> Result 443prop_format_parse_format _ fc v = let 444 s1 = formatCode fc v 445 ms1 = in1970 (fmap (formatCode fc) (incompleteS :: Maybe t)) (fcSpecifier fc) s1 446 mv2 :: Maybe t 447 mv2 = parseCode fc s1 448 ms2 = fmap (formatCode fc) mv2 449 in compareResult ms1 ms2 450 451instance HasFormatCodes Day where 452 allFormatCodes _ = [(False, s) | s <- "DFxYyCBbhmdejfVUW"] 453 454instance HasFormatCodes TimeOfDay where 455 allFormatCodes _ = [(False, s) | s <- "RTXrPpHkIlMSqQ"] 456 457instance HasFormatCodes LocalTime where 458 allFormatCodes _ = allFormatCodes (Proxy :: Proxy Day) ++ allFormatCodes (Proxy :: Proxy TimeOfDay) 459 460instance HasFormatCodes TimeZone where 461 allFormatCodes _ = [(a, s) | a <- [False, True], s <- "zZ"] 462 463instance HasFormatCodes ZonedTime where 464 allFormatCodes _ = 465 [(False, s) | s <- "cs"] ++ 466 allFormatCodes (Proxy :: Proxy LocalTime) ++ allFormatCodes (Proxy :: Proxy TimeZone) 467 468instance HasFormatCodes UTCTime where 469 allFormatCodes _ = [(False, s) | s <- "cs"] ++ allFormatCodes (Proxy :: Proxy LocalTime) 470 incompleteS = Just $ UTCTime (fromGregorian 2000 1 1) 0 471 472instance HasFormatCodes UniversalTime where 473 allFormatCodes _ = allFormatCodes (Proxy :: Proxy LocalTime) 474 475-- 476-- * crashes in parse 477-- 478newtype Input = 479 Input String 480 481instance Show Input where 482 show (Input s) = s 483 484instance Arbitrary Input where 485 arbitrary = liftM Input $ list cs 486 where 487 cs = elements (['0' .. '9'] ++ ['-', ' ', '/'] ++ ['a' .. 'z'] ++ ['A' .. 'Z']) 488 list g = sized (\n -> choose (0, n) >>= \l -> replicateM l g) 489 490instance CoArbitrary Input where 491 coarbitrary (Input s) = coarbitrary (sum (map ord s)) 492 493prop_no_crash_bad_input :: (Eq t, ParseTime t) => FormatString t -> Input -> Property 494prop_no_crash_bad_input fs@(FormatString f) (Input s) = 495 property $ 496 case parse False f s of 497 Nothing -> True 498 Just t -> t == t `asTypeOf` formatType fs 499 500-- 501-- 502-- 503newtype FormatString a = 504 FormatString String 505 506formatType :: FormatString t -> t 507formatType _ = undefined 508 509instance Show (FormatString a) where 510 show (FormatString f) = show f 511 512typedTests :: (forall t. (Eq t, FormatTime t, ParseTime t, Show t) => FormatString t -> t -> Result) -> [TestTree] 513typedTests prop = 514 [ nameTest "Day" $ tgroup dayFormats prop 515 -- , nameTest "Month" $ tgroup monthFormats prop 516 , nameTest "TimeOfDay" $ tgroup timeOfDayFormats prop 517 , nameTest "LocalTime" $ tgroup localTimeFormats prop 518 , nameTest "TimeZone" $ tgroup timeZoneFormats prop 519 , nameTest "ZonedTime" $ tgroup zonedTimeFormats prop 520 , nameTest "ZonedTime" $ 521 tgroup zonedTimeAlmostFormats $ \fmt t -> (todSec $ localTimeOfDay $ zonedTimeToLocalTime t) < 60 ==> prop fmt t 522 , nameTest "UTCTime" $ tgroup utcTimeAlmostFormats $ \fmt t -> utctDayTime t < 86400 ==> prop fmt t 523 , nameTest "UniversalTime" $ tgroup universalTimeFormats prop 524 -- time-compat doesn't have instances 525 -- , nameTest "CalendarDiffDays" $ tgroup calendarDiffDaysFormats prop 526 -- , nameTest "CalenderDiffTime" $ tgroup calendarDiffTimeFormats prop 527 -- , nameTest "DiffTime" $ tgroup diffTimeFormats prop 528 -- , nameTest "NominalDiffTime" $ tgroup nominalDiffTimeFormats prop 529 ] 530 531allTypes :: 532 (forall t. (Eq t, Show t, Arbitrary t, FormatTime t, ParseTime t, HasFormatCodes t) => String -> Proxy t -> r) 533 -> [r] 534allTypes f = 535 [ f "Day" (Proxy :: Proxy Day) 536 , f "TimeOfDay" (Proxy :: Proxy TimeOfDay) 537 , f "LocalTime" (Proxy :: Proxy LocalTime) 538 , f "TimeZone" (Proxy :: Proxy TimeZone) 539 , f "ZonedTime" (Proxy :: Proxy ZonedTime) 540 , f "UTCTime" (Proxy :: Proxy UTCTime) 541 , f "UniversalTime" (Proxy :: Proxy UniversalTime) 542 ] 543 544allLeapSecondTypes :: 545 (forall t. (Eq t, Show t, Arbitrary t, FormatTime t, ParseTime t, HasFormatCodes t) => String -> t -> r) 546 -> [r] 547allLeapSecondTypes f = let 548 day :: Day 549 day = fromGregorian 2000 01 01 550 lsTimeOfDay :: TimeOfDay 551 lsTimeOfDay = TimeOfDay 23 59 60.5 552 lsLocalTime :: LocalTime 553 lsLocalTime = LocalTime day lsTimeOfDay 554 lsZonedTime :: ZonedTime 555 lsZonedTime = ZonedTime lsLocalTime utc 556 lsUTCTime :: UTCTime 557 lsUTCTime = UTCTime day 86400.5 558 in 559 [ f "TimeOfDay" lsTimeOfDay 560 , f "LocalTime" lsLocalTime 561 , f "ZonedTime" lsZonedTime 562 , f "UTCTime" lsUTCTime 563 ] 564 565parseEmptyTest :: 566 forall t. ParseTime t 567 => Proxy t 568 -> Assertion 569parseEmptyTest _ = 570 case parse False "" "" :: Maybe t of 571 Just _ -> return () 572 Nothing -> assertFailure "failed" 573 574parseEmptyTests :: TestTree 575parseEmptyTests = nameTest "parse empty" $ allTypes $ \name p -> nameTest name $ parseEmptyTest p 576 577formatParseFormatTests :: TestTree 578formatParseFormatTests = nameTest "format_parse_format" 579 [ 580 localOption (QuickCheckTests 50000) $ 581 nameTest "general" $ allTypes $ \name p -> nameTest name $ prop_format_parse_format p, 582 nameTest "leapsecond" $ allLeapSecondTypes $ \name t -> nameTest name $ \fc -> prop_format_parse_format Proxy fc t 583 ] 584 585badInputTests :: TestTree 586badInputTests = 587 nameTest 588 "no_crash_bad_input" 589 [ nameTest "Day" $ tgroup (dayFormats ++ partialDayFormats ++ failingPartialDayFormats) prop_no_crash_bad_input 590 , nameTest "TimeOfDay" $ tgroup (timeOfDayFormats ++ partialTimeOfDayFormats) prop_no_crash_bad_input 591 , nameTest "LocalTime" $ tgroup (localTimeFormats ++ partialLocalTimeFormats) prop_no_crash_bad_input 592 , nameTest "TimeZone" $ tgroup (timeZoneFormats) prop_no_crash_bad_input 593 , nameTest "ZonedTime" $ 594 tgroup (zonedTimeFormats ++ zonedTimeAlmostFormats ++ partialZonedTimeFormats) prop_no_crash_bad_input 595 , nameTest "UTCTime" $ tgroup (utcTimeAlmostFormats ++ partialUTCTimeFormats) prop_no_crash_bad_input 596 , nameTest "UniversalTime" $ 597 tgroup (universalTimeFormats ++ partialUniversalTimeFormats) prop_no_crash_bad_input 598 ] 599 600readShowTests :: TestTree 601readShowTests = 602 nameTest 603 "read_show" 604 [ nameTest "Day" (prop_read_show :: Day -> Result) 605 , nameTest "Month" (prop_read_show :: Month -> Result) 606 , nameTest "QuarterOfYear" (prop_read_show :: QuarterOfYear -> Result) 607 , nameTest "Quarter" (prop_read_show :: Quarter -> Result) 608 , nameTest "TimeOfDay" (prop_read_show :: TimeOfDay -> Result) 609 , nameTest "LocalTime" (prop_read_show :: LocalTime -> Result) 610 , nameTest "TimeZone" (prop_read_show :: TimeZone -> Result) 611 , nameTest "ZonedTime" (prop_read_show :: ZonedTime -> Result) 612 , nameTest "UTCTime" (prop_read_show :: UTCTime -> Result) 613 , nameTest "UTCTime (zoned)" prop_read_show_ZonedUTC 614 , nameTest "UTCTime (local)" prop_read_show_LocalUTC 615 , nameTest "UniversalTime" (prop_read_show :: UniversalTime -> Result) 616 , nameTest "NominalDiffTime" (prop_read_show :: NominalDiffTime -> Result) 617 , nameTest "DiffTime" (prop_read_show :: DiffTime -> Result) 618 --nameTest "CalendarDiffDays" (prop_read_show :: CalendarDiffDays -> Result), 619 --nameTest "CalendarDiffTime" (prop_read_show :: CalendarDiffTime -> Result) 620 ] 621 622parseShowTests :: TestTree 623parseShowTests = 624 nameTest 625 "parse_show" 626 [ nameTest "showWeekDate" prop_parse_showWeekDate 627 , nameTest "showGregorian" prop_parse_showGregorian 628 , nameTest "showOrdinalDate" prop_parse_showOrdinalDate 629 ] 630 631propertyTests :: TestTree 632propertyTests = 633 localOption (QuickCheckTests 2000) $ 634 nameTest 635 "properties" 636 [ readShowTests 637 , parseShowTests 638 , nameTest "fromMondayStartWeek" prop_fromMondayStartWeek 639 , nameTest "fromSundayStartWeek" prop_fromSundayStartWeek 640 , nameTest "parse_format" $ typedTests prop_parse_format 641 , nameTest "parse_format_lower" $ typedTests prop_parse_format_lower 642 , nameTest "parse_format_upper" $ typedTests prop_parse_format_upper 643 , parseEmptyTests 644 , formatParseFormatTests 645 , badInputTests 646 ] 647 648dayFormats :: [FormatString Day] 649dayFormats = 650 map FormatString 651 -- numeric year, month, day 652 [ "%Y-%m-%d" 653 , "%Y%m%d" 654 , "%C%y%m%d" 655 , "%Y %m %e" 656 , "%m/%d/%Y" 657 , "%d/%m/%Y" 658 , "%Y/%d/%m" 659 , "%D %C" 660 , "%F" 661 -- month names 662 , "%Y-%B-%d" 663 , "%Y-%b-%d" 664 , "%Y-%h-%d" 665 , "%C-%y-%B-%d" 666 , "%C-%y-%b-%d" 667 , "%C-%y-%h-%d" 668 -- ordinal dates 669 , "%Y-%j" 670 , "%C-%y-%j" 671 -- ISO week dates 672 , "%G-%V-%u" 673 , "%G-%V-%a" 674 , "%G-%V-%A" 675 , "%G-%V-%w" 676 , "%A week %V, %G" 677 , "day %V, week %A, %G" 678 , "%G-W%V-%u" 679 , "%f%g-%V-%u" 680 , "%f%g-%V-%a" 681 , "%f%g-%V-%A" 682 , "%f%g-%V-%w" 683 , "%A week %V, %f%g" 684 , "day %V, week %A, %f%g" 685 , "%f%g-W%V-%u" 686 -- monday and sunday week dates 687 , "%Y-w%U-%A" 688 , "%Y-w%W-%A" 689 , "%Y-%A-w%U" 690 , "%Y-%A-w%W" 691 , "%A week %U, %Y" 692 , "%A week %W, %Y" 693 ] 694 695monthFormats :: [FormatString Month] 696monthFormats = 697 map FormatString 698 -- numeric year, month 699 [ "%Y-%m" 700 , "%Y%m" 701 , "%C%y%m" 702 , "%Y %m" 703 , "%m/%Y" 704 , "%m/%Y" 705 , "%Y/%m" 706 , "%C %y %m" 707 -- month names 708 , "%Y-%B" 709 , "%Y-%b" 710 , "%Y-%h" 711 , "%C-%y-%B" 712 , "%C-%y-%b" 713 , "%C-%y-%h" 714 ] 715 716timeOfDayFormats :: [FormatString TimeOfDay] 717timeOfDayFormats = 718 map FormatString 719 -- 24 h formats 720 [ "%H:%M:%S.%q" 721 , "%k:%M:%S.%q" 722 , "%H%M%S.%q" 723 , "%T.%q" 724 , "%X.%q" 725 , "%R:%S.%q" 726 , "%H:%M:%S%Q" 727 , "%k:%M:%S%Q" 728 , "%H%M%S%Q" 729 , "%T%Q" 730 , "%X%Q" 731 , "%R:%S%Q" 732 -- 12 h formats 733 , "%I:%M:%S.%q %p" 734 , "%I:%M:%S.%q %P" 735 , "%l:%M:%S.%q %p" 736 , "%r %q" 737 , "%I:%M:%S%Q %p" 738 , "%I:%M:%S%Q %P" 739 , "%l:%M:%S%Q %p" 740 , "%r %Q" 741 ] 742 743localTimeFormats :: [FormatString LocalTime] 744localTimeFormats = map FormatString [] {-"%Q","%Q ","%QX"-} 745 746timeZoneFormats :: [FormatString TimeZone] 747timeZoneFormats = map FormatString ["%z", "%z%Z", "%Z%z", "%Z", "%Ez", "%EZ"] 748 749zonedTimeFormats :: [FormatString ZonedTime] 750zonedTimeFormats = 751 map FormatString 752 [ "%a, %d %b %Y %H:%M:%S.%q %z" 753 , "%a, %d %b %Y %H:%M:%S%Q %z" 754 , "%a, %d %b %Y %H:%M:%S.%q %Z" 755 , "%a, %d %b %Y %H:%M:%S%Q %Z" 756 ] 757 758zonedTimeAlmostFormats :: [FormatString ZonedTime] 759zonedTimeAlmostFormats = map FormatString ["%s.%q %z", "%s%Q %z", "%s.%q %Z", "%s%Q %Z"] 760 761utcTimeAlmostFormats :: [FormatString UTCTime] 762utcTimeAlmostFormats = map FormatString ["%s.%q", "%s%Q"] 763 764universalTimeFormats :: [FormatString UniversalTime] 765universalTimeFormats = map FormatString [] 766 767calendarDiffDaysFormats :: [FormatString CalendarDiffDays] 768calendarDiffDaysFormats = map FormatString ["%yy%Bm%ww%Dd", "%yy%Bm%dd", "%bm%ww%Dd", "%bm%dd"] 769 770calendarDiffTimeFormats :: [FormatString CalendarDiffTime] 771calendarDiffTimeFormats = 772 map FormatString 773 [ "%yy%Bm%ww%Dd%Hh%Mm%ESs" 774 , "%bm%ww%Dd%Hh%Mm%ESs" 775 , "%bm%dd%Hh%Mm%ESs" 776 , "%bm%hh%Mm%ESs" 777 , "%bm%mm%ESs" 778 , "%bm%mm%0ESs" 779 , "%bm%Ess" 780 , "%bm%0Ess" 781 ] 782 783diffTimeFormats :: [FormatString DiffTime] 784diffTimeFormats = 785 map FormatString ["%ww%Dd%Hh%Mm%ESs", "%dd%Hh%Mm%ESs", "%hh%Mm%ESs", "%mm%ESs", "%mm%0ESs", "%Ess", "%0Ess"] 786 787nominalDiffTimeFormats :: [FormatString NominalDiffTime] 788nominalDiffTimeFormats = 789 map FormatString ["%ww%Dd%Hh%Mm%ESs", "%dd%Hh%Mm%ESs", "%hh%Mm%ESs", "%mm%ESs", "%mm%0ESs", "%Ess", "%0Ess"] 790 791-- 792-- * Formats that do not include all the information 793-- 794partialDayFormats :: [FormatString Day] 795partialDayFormats = map FormatString [] 796 797partialTimeOfDayFormats :: [FormatString TimeOfDay] 798partialTimeOfDayFormats = map FormatString ["%H", "%M", "%S", "%H:%M"] 799 800partialLocalTimeFormats :: [FormatString LocalTime] 801partialLocalTimeFormats = map FormatString [] 802 803partialZonedTimeFormats :: [FormatString ZonedTime] 804partialZonedTimeFormats = 805 map FormatString 806 -- %s does not include second decimals 807 [ "%s %z" 808 -- %S does not include second decimals 809 , "%c" 810 , "%a, %d %b %Y %H:%M:%S %Z" 811 ] 812 813partialUTCTimeFormats :: [FormatString UTCTime] 814partialUTCTimeFormats = 815 map FormatString 816 -- %s does not include second decimals 817 [ "%s" 818 -- %c does not include second decimals 819 , "%c" 820 ] 821 822partialUniversalTimeFormats :: [FormatString UniversalTime] 823partialUniversalTimeFormats = map FormatString [] 824 825failingPartialDayFormats :: [FormatString Day] 826failingPartialDayFormats = 827 map FormatString 828 -- ISO week dates with two digit year. 829 -- This can fail in the beginning or the end of a year where 830 -- the ISO week date year does not match the gregorian year. 831 ["%g-%V-%u", "%g-%V-%a", "%g-%V-%A", "%g-%V-%w", "%A week %V, %g", "day %V, week %A, %g", "%g-W%V-%u"] 832