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