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