format everything with hindent
[packages/time.git] / lib / Data / Time / Format / Parse / Instances.hs
1 {-# OPTIONS -fno-warn-orphans #-}
2
3 module Data.Time.Format.Parse.Instances
4 (
5 ) where
6
7 import Control.Applicative ((<$>), (<*>))
8 import Data.Char
9 import Data.Fixed
10 import Data.List
11 import Data.Ratio
12 import Data.Time.Calendar.CalendarDiffDays
13 import Data.Time.Calendar.Days
14 import Data.Time.Calendar.Gregorian
15 import Data.Time.Calendar.OrdinalDate
16 import Data.Time.Calendar.Private (clipValid)
17 import Data.Time.Calendar.WeekDate
18 import Data.Time.Clock.Internal.DiffTime
19 import Data.Time.Clock.Internal.NominalDiffTime
20 import Data.Time.Clock.Internal.UTCTime
21 import Data.Time.Clock.Internal.UniversalTime
22 import Data.Time.Clock.POSIX
23 import Data.Time.Format.Locale
24 import Data.Time.Format.Parse.Class
25 import Data.Time.LocalTime.Internal.CalendarDiffTime
26 import Data.Time.LocalTime.Internal.LocalTime
27 import Data.Time.LocalTime.Internal.TimeOfDay
28 import Data.Time.LocalTime.Internal.TimeZone
29 import Data.Time.LocalTime.Internal.ZonedTime
30 import Data.Traversable
31 import Text.Read (readMaybe)
32
33 data DayComponent
34 = Century Integer -- century of all years
35 | CenturyYear Integer -- 0-99, last two digits of both real years and week years
36 | YearMonth Int -- 1-12
37 | MonthDay Int -- 1-31
38 | YearDay Int -- 1-366
39 | WeekDay Int -- 1-7 (mon-sun)
40 | YearWeek WeekType
41 Int -- 1-53 or 0-53
42
43 data WeekType
44 = ISOWeek
45 | SundayWeek
46 | MondayWeek
47
48 instance ParseTime Day where
49 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
50 parseTimeSpecifier _ = timeParseTimeSpecifier
51 buildTime l = let
52 -- 'Nothing' indicates a parse failure,
53 -- while 'Just []' means no information
54 f :: Char -> String -> Maybe [DayComponent]
55 f c x = let
56 ra :: (Read a) => Maybe a
57 ra = readMaybe x
58 zeroBasedListIndex :: [String] -> Maybe Int
59 zeroBasedListIndex ss = elemIndex (map toUpper x) $ fmap (map toUpper) ss
60 oneBasedListIndex :: [String] -> Maybe Int
61 oneBasedListIndex ss = do
62 index <- zeroBasedListIndex ss
63 return $ 1 + index
64 in case c of
65 -- %C: century (all but the last two digits of the year), 00 - 99
66 'C' -> do
67 a <- ra
68 return [Century a]
69 -- %f century (all but the last two digits of the year), 00 - 99
70 'f' -> do
71 a <- ra
72 return [Century a]
73 -- %Y: year
74 'Y' -> do
75 a <- ra
76 return [Century (a `div` 100), CenturyYear (a `mod` 100)]
77 -- %G: year for Week Date format
78 'G' -> do
79 a <- ra
80 return [Century (a `div` 100), CenturyYear (a `mod` 100)]
81 -- %y: last two digits of year, 00 - 99
82 'y' -> do
83 a <- ra
84 return [CenturyYear a]
85 -- %g: last two digits of year for Week Date format, 00 - 99
86 'g' -> do
87 a <- ra
88 return [CenturyYear a]
89 -- %B: month name, long form (fst from months locale), January - December
90 'B' -> do
91 a <- oneBasedListIndex $ fmap fst $ months l
92 return [YearMonth a]
93 -- %b: month name, short form (snd from months locale), Jan - Dec
94 'b' -> do
95 a <- oneBasedListIndex $ fmap snd $ months l
96 return [YearMonth a]
97 -- %m: month of year, leading 0 as needed, 01 - 12
98 'm' -> do
99 raw <- ra
100 a <- clipValid 1 12 raw
101 return [YearMonth a]
102 -- %d: day of month, leading 0 as needed, 01 - 31
103 'd' -> do
104 raw <- ra
105 a <- clipValid 1 31 raw
106 return [MonthDay a]
107 -- %e: day of month, leading space as needed, 1 - 31
108 'e' -> do
109 raw <- ra
110 a <- clipValid 1 31 raw
111 return [MonthDay a]
112 -- %V: week for Week Date format, 01 - 53
113 'V' -> do
114 raw <- ra
115 a <- clipValid 1 53 raw
116 return [YearWeek ISOWeek a]
117 -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 00 - 53
118 'U' -> do
119 raw <- ra
120 a <- clipValid 0 53 raw
121 return [YearWeek SundayWeek a]
122 -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 00 - 53
123 'W' -> do
124 raw <- ra
125 a <- clipValid 0 53 raw
126 return [YearWeek MondayWeek a]
127 -- %u: day for Week Date format, 1 - 7
128 'u' -> do
129 raw <- ra
130 a <- clipValid 1 7 raw
131 return [WeekDay a]
132 -- %a: day of week, short form (snd from wDays locale), Sun - Sat
133 'a' -> do
134 a' <- zeroBasedListIndex $ fmap snd $ wDays l
135 let
136 a =
137 if a' == 0
138 then 7
139 else a'
140 return [WeekDay a]
141 -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday
142 'A' -> do
143 a' <- zeroBasedListIndex $ fmap fst $ wDays l
144 let
145 a =
146 if a' == 0
147 then 7
148 else a'
149 return [WeekDay a]
150 -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday)
151 'w' -> do
152 raw <- ra
153 a' <- clipValid 0 6 raw
154 let
155 a =
156 if a' == 0
157 then 7
158 else a'
159 return [WeekDay a]
160 -- %j: day of year for Ordinal Date format, 001 - 366
161 'j' -> do
162 raw <- ra
163 a <- clipValid 1 366 raw
164 return [YearDay a]
165 -- unrecognised, pass on to other parsers
166 _ -> return []
167 buildDay :: [DayComponent] -> Maybe Day
168 buildDay cs = let
169 safeLast x xs = last (x : xs)
170 y = let
171 d = safeLast 70 [x | CenturyYear x <- cs]
172 c =
173 safeLast
174 (if d >= 69
175 then 19
176 else 20)
177 [x | Century x <- cs]
178 in 100 * c + d
179 rest (YearMonth m:_) = let
180 d = safeLast 1 [x | MonthDay x <- cs]
181 in fromGregorianValid y m d
182 rest (YearDay d:_) = fromOrdinalDateValid y d
183 rest (YearWeek wt w:_) = let
184 d = safeLast 4 [x | WeekDay x <- cs]
185 in case wt of
186 ISOWeek -> fromWeekDateValid y w d
187 SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7)
188 MondayWeek -> fromMondayStartWeekValid y w d
189 rest (_:xs) = rest xs
190 rest [] = rest [YearMonth 1]
191 in rest cs
192 in \pairs -> do
193 components <- for pairs $ \(c, x) -> f c x
194 buildDay $ concat components
195
196 mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a
197 mfoldl f = let
198 mf ma b = do
199 a <- ma
200 f a b
201 in foldl mf
202
203 instance ParseTime TimeOfDay where
204 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
205 parseTimeSpecifier _ = timeParseTimeSpecifier
206 buildTime l = let
207 f t@(TimeOfDay h m s) (c, x) = let
208 ra :: (Read a) => Maybe a
209 ra = readMaybe x
210 getAmPm = let
211 upx = map toUpper x
212 (amStr, pmStr) = amPm l
213 in if upx == amStr
214 then Just $ TimeOfDay (h `mod` 12) m s
215 else if upx == pmStr
216 then Just $
217 TimeOfDay
218 (if h < 12
219 then h + 12
220 else h)
221 m
222 s
223 else Nothing
224 in case c of
225 'P' -> getAmPm
226 'p' -> getAmPm
227 'H' -> do
228 raw <- ra
229 a <- clipValid 0 23 raw
230 return $ TimeOfDay a m s
231 'I' -> do
232 raw <- ra
233 a <- clipValid 1 12 raw
234 return $ TimeOfDay a m s
235 'k' -> do
236 raw <- ra
237 a <- clipValid 0 23 raw
238 return $ TimeOfDay a m s
239 'l' -> do
240 raw <- ra
241 a <- clipValid 1 12 raw
242 return $ TimeOfDay a m s
243 'M' -> do
244 raw <- ra
245 a <- clipValid 0 59 raw
246 return $ TimeOfDay h a s
247 'S' -> do
248 raw <- ra
249 a <- clipValid 0 60 raw
250 return $ TimeOfDay h m (fromInteger a)
251 'q' -> do
252 a <- ra
253 return $ TimeOfDay h m (mkPico (floor s) a)
254 'Q' ->
255 if null x
256 then Just t
257 else do
258 ps <- readMaybe $ take 12 $ rpad 12 '0' $ drop 1 x
259 return $ TimeOfDay h m (mkPico (floor s) ps)
260 _ -> Just t
261 in mfoldl f (Just midnight)
262
263 rpad :: Int -> a -> [a] -> [a]
264 rpad n c xs = xs ++ replicate (n - length xs) c
265
266 mkPico :: Integer -> Integer -> Pico
267 mkPico i f = fromInteger i + fromRational (f % 1000000000000)
268
269 instance ParseTime LocalTime where
270 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
271 parseTimeSpecifier _ = timeParseTimeSpecifier
272 buildTime l xs = LocalTime <$> (buildTime l xs) <*> (buildTime l xs)
273
274 enumDiff :: (Enum a) => a -> a -> Int
275 enumDiff a b = (fromEnum a) - (fromEnum b)
276
277 getMilZoneHours :: Char -> Maybe Int
278 getMilZoneHours c
279 | c < 'A' = Nothing
280 getMilZoneHours c
281 | c <= 'I' = Just $ 1 + enumDiff c 'A'
282 getMilZoneHours 'J' = Nothing
283 getMilZoneHours c
284 | c <= 'M' = Just $ 10 + enumDiff c 'K'
285 getMilZoneHours c
286 | c <= 'Y' = Just $ (enumDiff 'N' c) - 1
287 getMilZoneHours 'Z' = Just 0
288 getMilZoneHours _ = Nothing
289
290 getMilZone :: Char -> Maybe TimeZone
291 getMilZone c = let
292 yc = toUpper c
293 in do
294 hours <- getMilZoneHours yc
295 return $ TimeZone (hours * 60) False [yc]
296
297 getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone
298 getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (knownTimeZones locale)
299
300 instance ParseTime TimeZone where
301 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
302 parseTimeSpecifier _ = timeParseTimeSpecifier
303 buildTime l = let
304 f :: Char -> String -> TimeZone -> Maybe TimeZone
305 f 'z' str (TimeZone _ dst name)
306 | Just offset <- readTzOffset str = Just $ TimeZone offset dst name
307 f 'z' _ _ = Nothing
308 f 'Z' str _
309 | Just offset <- readTzOffset str = Just $ TimeZone offset False ""
310 f 'Z' str _
311 | Just zone <- getKnownTimeZone l str = Just zone
312 f 'Z' "UTC" _ = Just utc
313 f 'Z' [c] _
314 | Just zone <- getMilZone c = Just zone
315 f 'Z' _ _ = Nothing
316 f _ _ tz = Just tz
317 in foldl (\mt (c, s) -> mt >>= f c s) (Just $ minutesToTimeZone 0)
318
319 readTzOffset :: String -> Maybe Int
320 readTzOffset str = let
321 getSign '+' = Just 1
322 getSign '-' = Just (-1)
323 getSign _ = Nothing
324 calc s h1 h2 m1 m2 = do
325 sign <- getSign s
326 h <- readMaybe [h1, h2]
327 m <- readMaybe [m1, m2]
328 return $ sign * (60 * h + m)
329 in case str of
330 (s:h1:h2:':':m1:m2:[]) -> calc s h1 h2 m1 m2
331 (s:h1:h2:m1:m2:[]) -> calc s h1 h2 m1 m2
332 _ -> Nothing
333
334 instance ParseTime ZonedTime where
335 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
336 parseTimeSpecifier _ = timeParseTimeSpecifier
337 buildTime l xs = let
338 f (ZonedTime (LocalTime _ tod) z) ('s', x) = do
339 a <- readMaybe x
340 let
341 s = fromInteger a
342 (_, ps) = properFraction (todSec tod) :: (Integer, Pico)
343 s' = s + fromRational (toRational ps)
344 return $ utcToZonedTime z (posixSecondsToUTCTime s')
345 f t _ = Just t
346 in mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs
347
348 instance ParseTime UTCTime where
349 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
350 parseTimeSpecifier _ = timeParseTimeSpecifier
351 buildTime l xs = zonedTimeToUTC <$> buildTime l xs
352
353 instance ParseTime UniversalTime where
354 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
355 parseTimeSpecifier _ = timeParseTimeSpecifier
356 buildTime l xs = localTimeToUT1 0 <$> buildTime l xs
357
358 buildTimeMonths :: [(Char, String)] -> Maybe Integer
359 buildTimeMonths xs = do
360 tt <-
361 for xs $ \(c, s) ->
362 case c of
363 'y' -> fmap ((*) 12) $ readMaybe s
364 'b' -> readMaybe s
365 'B' -> readMaybe s
366 _ -> return 0
367 return $ sum tt
368
369 buildTimeDays :: [(Char, String)] -> Maybe Integer
370 buildTimeDays xs = do
371 tt <-
372 for xs $ \(c, s) ->
373 case c of
374 'w' -> fmap ((*) 7) $ readMaybe s
375 'd' -> readMaybe s
376 'D' -> readMaybe s
377 _ -> return 0
378 return $ sum tt
379
380 buildTimeSeconds :: [(Char, String)] -> Maybe Pico
381 buildTimeSeconds xs = do
382 tt <-
383 for xs $ \(c, s) -> let
384 readInt :: Integer -> Maybe Pico
385 readInt t = do
386 i <- readMaybe s
387 return $ fromInteger $ i * t
388 in case c of
389 'h' -> readInt 3600
390 'H' -> readInt 3600
391 'm' -> readInt 60
392 'M' -> readInt 60
393 's' -> readMaybe s
394 'S' -> readMaybe s
395 _ -> return 0
396 return $ sum tt
397
398 instance ParseTime NominalDiffTime where
399 parseTimeSpecifier _ = durationParseTimeSpecifier
400 buildTime _ xs = do
401 dd <- buildTimeDays xs
402 tt <- buildTimeSeconds xs
403 return $ (fromInteger dd * 86400) + realToFrac tt
404
405 instance ParseTime DiffTime where
406 parseTimeSpecifier _ = durationParseTimeSpecifier
407 buildTime _ xs = do
408 dd <- buildTimeDays xs
409 tt <- buildTimeSeconds xs
410 return $ (fromInteger dd * 86400) + realToFrac tt
411
412 instance ParseTime CalendarDiffDays where
413 parseTimeSpecifier _ = durationParseTimeSpecifier
414 buildTime _ xs = do
415 mm <- buildTimeMonths xs
416 dd <- buildTimeDays xs
417 return $ CalendarDiffDays mm dd
418
419 instance ParseTime CalendarDiffTime where
420 parseTimeSpecifier _ = durationParseTimeSpecifier
421 buildTime locale xs = do
422 mm <- buildTimeMonths xs
423 tt <- buildTime locale xs
424 return $ CalendarDiffTime mm tt