50049bc93d5f448417c053a13912ea2b00976ebe
[packages/time.git] / test / TestParseTime.hs
1 {-# OPTIONS -Wall -Werror -fno-warn-type-defaults -fno-warn-unused-binds #-}
2
3 import Control.Monad
4 import Data.Char
5 import Data.Ratio
6 import Data.Time
7 import Data.Time.Calendar.OrdinalDate
8 import Data.Time.Calendar.WeekDate
9 import Data.Time.Clock
10 import Data.Time.Clock.POSIX
11 import System.Locale
12 import Test.QuickCheck
13
14
15 ntest :: Int
16 ntest = 1000
17
18 main :: IO ()
19 main = do putStrLn "Should work:"
20 checkAll properties
21 putStrLn "Known failures:"
22 checkAll knownFailures
23
24 checkAll :: [NamedProperty] -> IO ()
25 checkAll ps = mapM_ (checkOne config) ps
26 where config = defaultConfig { configMaxTest = ntest }
27
28 checkOne :: Config -> NamedProperty -> IO ()
29 checkOne config (n,p) =
30 do putStr (rpad 65 ' ' n)
31 check config p
32 where rpad n' c xs = xs ++ replicate (n' - length xs) c
33
34
35 parse :: ParseTime t => String -> String -> Maybe t
36 parse f t = parseTime defaultTimeLocale f t
37
38 format :: (FormatTime t) => String -> t -> String
39 format f t = formatTime defaultTimeLocale f t
40
41
42 instance Arbitrary Day where
43 arbitrary = liftM ModifiedJulianDay $ choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31
44 coarbitrary (ModifiedJulianDay d) = coarbitrary d
45
46 instance Arbitrary DiffTime where
47 arbitrary = oneof [intSecs, fracSecs] -- up to 1 leap second
48 where intSecs = liftM secondsToDiffTime' $ choose (0, 86400)
49 fracSecs = liftM picosecondsToDiffTime' $ choose (0, 86400 * 10^12)
50 secondsToDiffTime' :: Integer -> DiffTime
51 secondsToDiffTime' = fromInteger
52 picosecondsToDiffTime' :: Integer -> DiffTime
53 picosecondsToDiffTime' x = fromRational (x % 10^12)
54 coarbitrary t = coarbitrary (fromEnum t)
55
56 instance Arbitrary TimeOfDay where
57 arbitrary = liftM timeToTimeOfDay arbitrary
58 coarbitrary t = coarbitrary (timeOfDayToTime t)
59
60 instance Arbitrary LocalTime where
61 arbitrary = liftM2 LocalTime arbitrary arbitrary
62 coarbitrary t = coarbitrary (truncate (utcTimeToPOSIXSeconds (localTimeToUTC utc t)) :: Integer)
63
64 instance Arbitrary TimeZone where
65 arbitrary = liftM minutesToTimeZone $ choose (-720,720)
66 coarbitrary tz = coarbitrary (timeZoneMinutes tz)
67
68 instance Arbitrary ZonedTime where
69 arbitrary = liftM2 ZonedTime arbitrary arbitrary
70 coarbitrary t = coarbitrary (truncate (utcTimeToPOSIXSeconds (zonedTimeToUTC t)) :: Integer)
71
72 instance Arbitrary UTCTime where
73 arbitrary = liftM2 UTCTime arbitrary arbitrary
74 coarbitrary t = coarbitrary (truncate (utcTimeToPOSIXSeconds t) :: Integer)
75
76 -- missing from the time package
77 instance Eq ZonedTime where
78 ZonedTime t1 tz1 == ZonedTime t2 tz2 = t1 == t2 && tz1 == tz2
79
80 --
81 -- * tests for dbugging failing cases
82 --
83
84 test_parse_format :: (FormatTime t,ParseTime t,Show t) => String -> t -> (String,String,Maybe t)
85 test_parse_format f t = let s = format f t in (show t, s, parse f s `asTypeOf` Just t)
86
87 --
88 -- * show and read
89 --
90
91 prop_read_show :: (Read a, Show a, Eq a) => a -> Bool
92 prop_read_show t = read (show t) == t
93
94 --
95 -- * special show functions
96 --
97
98 prop_parse_showWeekDate :: Day -> Bool
99 prop_parse_showWeekDate d = parse "%G-W%V-%u" (showWeekDate d) == Just d
100
101 prop_parse_showGregorian :: Day -> Bool
102 prop_parse_showGregorian d = parse "%Y-%m-%d" (showGregorian d) == Just d
103
104 prop_parse_showOrdinalDate :: Day -> Bool
105 prop_parse_showOrdinalDate d = parse "%Y-%j" (showOrdinalDate d) == Just d
106
107 --
108 -- * fromMondayStartWeek and fromSundayStartWeek
109 --
110
111 prop_fromMondayStartWeek :: Day -> Bool
112 prop_fromMondayStartWeek d =
113 let (w,wd) = mondayStartWeek d
114 (y,_,_) = toGregorian d
115 in fromMondayStartWeek y w wd == d
116
117 prop_fromSundayStartWeek :: Day -> Bool
118 prop_fromSundayStartWeek d =
119 let (w,wd) = sundayStartWeek d
120 (y,_,_) = toGregorian d
121 in fromSundayStartWeek y w wd == d
122
123 --
124 -- * format and parse
125 --
126
127 prop_parse_format :: (Eq t, FormatTime t, ParseTime t) => FormatString t -> t -> Bool
128 prop_parse_format (FormatString f) t = parse f (format f t) == Just t
129
130 prop_parse_format_named :: (Arbitrary t, Eq t, Show t, FormatTime t, ParseTime t)
131 => String -> FormatString t -> NamedProperty
132 prop_parse_format_named typeName f =
133 ("prop_parse_format " ++ typeName ++ " " ++ show f,
134 property (prop_parse_format f))
135
136 prop_format_parse_format :: (FormatTime t, ParseTime t) => FormatString t -> t -> Bool
137 prop_format_parse_format (FormatString f) t =
138 fmap (format f) (parse f (format f t) `asTypeOf` Just t) == Just (format f t)
139
140 prop_format_parse_format_named :: (Arbitrary t, Show t, FormatTime t, ParseTime t)
141 => String -> FormatString t -> NamedProperty
142 prop_format_parse_format_named typeName f =
143 ("prop_format_parse_format " ++ typeName ++ " " ++ show f,
144 property (prop_format_parse_format f))
145
146 --
147 -- * crashes in parse
148 --
149
150 newtype Input = Input String
151
152 instance Show Input where
153 show (Input s) = s
154
155 instance Arbitrary Input where
156 arbitrary = liftM Input $ list cs
157 where cs = elements (['0'..'9'] ++ ['-',' ','/'] ++ ['a'..'z'] ++ ['A' .. 'Z'])
158 list g = sized (\n -> choose (0,n) >>= \l -> replicateM l g)
159 coarbitrary (Input s) = coarbitrary (sum (map ord s))
160
161 prop_no_crash_bad_input :: (Eq t, ParseTime t) => FormatString t -> Input -> Property
162 prop_no_crash_bad_input fs@(FormatString f) (Input s) = property $
163 case parse f s of
164 Nothing -> True
165 Just t -> t == t `asTypeOf` formatType fs
166 where
167 prop_no_crash_bad_input_named :: (Eq t, ParseTime t)
168 => String -> FormatString t -> NamedProperty
169 prop_no_crash_bad_input_named typeName f =
170 ("prop_no_crash_bad_input " ++ typeName ++ " " ++ show f,
171 property (prop_no_crash_bad_input f))
172
173 --
174 --
175 --
176
177 newtype FormatString a = FormatString String
178
179 formatType :: FormatString t -> t
180 formatType _ = undefined
181
182 castFormatString :: FormatString a -> FormatString b
183 castFormatString (FormatString f) = FormatString f
184
185 instance Show (FormatString a) where
186 show (FormatString f) = show f
187
188 type NamedProperty = (String, Property)
189
190 properties :: [NamedProperty]
191 properties =
192 [("prop_fromMondayStartWeek", property prop_fromMondayStartWeek),
193 ("prop_fromSundayStartWeek", property prop_fromSundayStartWeek)]
194 ++ [("prop_read_show Day", property (prop_read_show :: Day -> Bool)),
195 ("prop_read_show TimeOfDay", property (prop_read_show :: TimeOfDay -> Bool)),
196 ("prop_read_show LocalTime", property (prop_read_show :: LocalTime -> Bool)),
197 ("prop_read_show TimeZone", property (prop_read_show :: TimeZone -> Bool)),
198 ("prop_read_show ZonedTime", property (prop_read_show :: ZonedTime -> Bool)),
199 ("prop_read_show UTCTime", property (prop_read_show :: UTCTime -> Bool))]
200 ++ [("prop_parse_showWeekDate", property prop_parse_showWeekDate),
201 ("prop_parse_showGregorian", property prop_parse_showGregorian),
202 ("prop_parse_showOrdinalDate", property prop_parse_showOrdinalDate)]
203
204 ++ map (prop_parse_format_named "Day") dayFormats
205 ++ map (prop_parse_format_named "TimeOfDay") timeOfDayFormats
206 ++ map (prop_parse_format_named "LocalTime") localTimeFormats
207 ++ map (prop_parse_format_named "TimeZone") timeZoneFormats
208 ++ map (prop_parse_format_named "ZonedTime") zonedTimeFormats
209 ++ map (prop_parse_format_named "UTCTime") utcTimeFormats
210
211 ++ map (prop_format_parse_format_named "Day") partialDayFormats
212 ++ map (prop_format_parse_format_named "TimeOfDay") partialTimeOfDayFormats
213 ++ map (prop_format_parse_format_named "LocalTime") partialLocalTimeFormats
214 ++ map (prop_format_parse_format_named "ZonedTime") partialZonedTimeFormats
215 ++ map (prop_format_parse_format_named "UTCTime") partialUTCTimeFormats
216
217 ++ map (prop_no_crash_bad_input_named "Day") (dayFormats ++ partialDayFormats ++ failingPartialDayFormats)
218 ++ map (prop_no_crash_bad_input_named "TimeOfDay") (timeOfDayFormats ++ partialTimeOfDayFormats)
219 ++ map (prop_no_crash_bad_input_named "LocalTime") (localTimeFormats ++ partialLocalTimeFormats)
220 ++ map (prop_no_crash_bad_input_named "TimeZone") (timeZoneFormats)
221 ++ map (prop_no_crash_bad_input_named "ZonedTime") (zonedTimeFormats ++ partialZonedTimeFormats)
222 ++ map (prop_no_crash_bad_input_named "UTCTime") (utcTimeFormats ++ partialUTCTimeFormats)
223
224
225
226 dayFormats :: [FormatString Day]
227 dayFormats = map FormatString
228 [
229 -- numeric year, month, day
230 "%Y-%m-%d","%Y%m%d","%C%y%m%d","%Y %m %e","%m/%d/%Y","%d/%m/%Y","%Y/%d/%m","%D %C","%F",
231 -- month names
232 "%Y-%B-%d","%Y-%b-%d","%Y-%h-%d",
233 -- ordinal dates
234 "%Y-%j",
235 -- ISO week dates
236 "%G-%V-%u","%G-%V-%a","%G-%V-%A","%G-%V-%w", "%A week %V, %G", "day %V, week %A, %G",
237 "%G-W%V-%u",
238 "%f%g-%V-%u","%f%g-%V-%a","%f%g-%V-%A","%f%g-%V-%w", "%A week %V, %f%g", "day %V, week %A, %f%g",
239 "%f%g-W%V-%u",
240 -- monday and sunday week dates
241 "%Y-w%U-%A", "%Y-w%W-%A", "%Y-%A-w%U", "%Y-%A-w%W", "%A week %U, %Y", "%A week %W, %Y"
242 ]
243
244 timeOfDayFormats :: [FormatString TimeOfDay]
245 timeOfDayFormats = map FormatString
246 [
247 -- 24 h formats
248 "%H:%M:%S.%q","%k:%M:%S.%q","%H%M%S.%q","%T.%q","%X.%q","%R:%S.%q",
249 "%H:%M:%S%Q","%k:%M:%S%Q","%H%M%S%Q","%T%Q","%X%Q","%R:%S%Q",
250 -- 12 h formats
251 "%I:%M:%S.%q %p","%I:%M:%S.%q %P","%l:%M:%S.%q %p","%r %q",
252 "%I:%M:%S%Q %p","%I:%M:%S%Q %P","%l:%M:%S%Q %p","%r %Q"
253 ]
254
255 localTimeFormats :: [FormatString LocalTime]
256 localTimeFormats = map FormatString $
257 []
258 {-
259 -- there's soo many of them...
260 concat [ [df ++ " " ++ tf, tf ++ " " ++ df] | FormatString df <- dayFormats,
261 FormatString tf <- timeOfDayFormats]
262 -}
263
264 timeZoneFormats :: [FormatString TimeZone]
265 timeZoneFormats = map FormatString ["%z","%z%Z","%Z%z","%Z"]
266
267 zonedTimeFormats :: [FormatString ZonedTime]
268 zonedTimeFormats = map FormatString
269 ["%a, %d %b %Y %H:%M:%S.%q %z", "%a, %d %b %Y %H:%M:%S%Q %z", "%s.%q %z", "%s%Q %z",
270 "%a, %d %b %Y %H:%M:%S.%q %Z", "%a, %d %b %Y %H:%M:%S%Q %Z", "%s.%q %Z", "%s%Q %Z"]
271
272 utcTimeFormats :: [FormatString UTCTime]
273 utcTimeFormats = map FormatString
274 ["%s.%q","%s%Q"]
275
276 --
277 -- * Formats that do not include all the information
278 --
279
280 partialDayFormats :: [FormatString Day]
281 partialDayFormats = map FormatString
282 [ ]
283
284 partialTimeOfDayFormats :: [FormatString TimeOfDay]
285 partialTimeOfDayFormats = map FormatString
286 [ ]
287
288 partialLocalTimeFormats :: [FormatString LocalTime]
289 partialLocalTimeFormats = map FormatString
290 [
291 -- %c does not include second decimals
292 "%c"
293 ]
294
295 partialZonedTimeFormats :: [FormatString ZonedTime]
296 partialZonedTimeFormats = map FormatString
297 [
298 -- %s does not include second decimals
299 "%s %z",
300 -- %S does not include second decimals
301 "%c", "%a, %d %b %Y %H:%M:%S %Z"
302 ]
303
304 partialUTCTimeFormats :: [FormatString UTCTime]
305 partialUTCTimeFormats = map FormatString
306 [
307 -- %s does not include second decimals
308 "%s",
309 -- %c does not include second decimals
310 "%c"
311 ]
312
313
314 --
315 -- * Known failures
316 --
317
318 knownFailures :: [NamedProperty]
319 knownFailures =
320 map (prop_format_parse_format_named "Day") failingPartialDayFormats
321
322 failingPartialDayFormats :: [FormatString Day]
323 failingPartialDayFormats = map FormatString
324 [ -- ISO week dates with two digit year.
325 -- This can fail in the beginning or the end of a year where
326 -- the ISO week date year does not match the gregorian year.
327 "%g-%V-%u","%g-%V-%a","%g-%V-%A","%g-%V-%w", "%A week %V, %g", "day %V, week %A, %g",
328 "%g-W%V-%u"
329 ]