1{-# OPTIONS -fno-warn-orphans #-}
2module Data.Time.Format.Parse.Instances() where
3
4#if !MIN_VERSION_base(4,8,0)
5import Control.Applicative ((<$>),(<*>))
6#endif
7import Data.Char
8import Data.Fixed
9import Data.List
10import Data.Ratio
11import Data.Traversable
12import Text.Read(readMaybe)
13import Data.Time.Clock.Internal.DiffTime
14import Data.Time.Clock.Internal.NominalDiffTime
15import Data.Time.Clock.Internal.UniversalTime
16import Data.Time.Clock.POSIX
17import Data.Time.Clock.Internal.UTCTime
18import Data.Time.Calendar.Days
19import Data.Time.Calendar.Gregorian
20import Data.Time.Calendar.CalendarDiffDays
21import Data.Time.Calendar.OrdinalDate
22import Data.Time.Calendar.WeekDate
23import Data.Time.Calendar.Private(clipValid)
24import Data.Time.LocalTime.Internal.CalendarDiffTime
25import Data.Time.LocalTime.Internal.TimeZone
26import Data.Time.LocalTime.Internal.TimeOfDay
27import Data.Time.LocalTime.Internal.LocalTime
28import Data.Time.LocalTime.Internal.ZonedTime
29import Data.Time.Format.Locale
30import Data.Time.Format.Parse.Class
31
32data 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
40data WeekType = ISOWeek | SundayWeek | MondayWeek
41
42instance 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
180mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a
181mfoldl f = let
182    mf ma b = do
183        a <- ma
184        f a b
185    in foldl mf
186
187instance 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
241rpad :: Int -> a -> [a] -> [a]
242rpad n c xs = xs ++ replicate (n - length xs) c
243
244mkPico :: Integer -> Integer -> Pico
245mkPico i f = fromInteger i + fromRational (f % 1000000000000)
246
247instance ParseTime LocalTime where
248    substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
249    parseTimeSpecifier _ = timeParseTimeSpecifier
250    buildTime l xs = LocalTime <$> (buildTime l xs) <*> (buildTime l xs)
251
252enumDiff :: (Enum a) => a -> a -> Int
253enumDiff a b = (fromEnum a) - (fromEnum b)
254
255getMilZoneHours :: Char -> Maybe Int
256getMilZoneHours c | c < 'A' = Nothing
257getMilZoneHours c | c <= 'I' = Just $ 1 + enumDiff c 'A'
258getMilZoneHours 'J' = Nothing
259getMilZoneHours c | c <= 'M' = Just $ 10 + enumDiff c 'K'
260getMilZoneHours c | c <= 'Y' = Just $ (enumDiff 'N' c) - 1
261getMilZoneHours 'Z' = Just 0
262getMilZoneHours _ = Nothing
263
264getMilZone :: Char -> Maybe TimeZone
265getMilZone c = let
266    yc = toUpper c
267    in do
268        hours <- getMilZoneHours yc
269        return $ TimeZone (hours * 60) False [yc]
270
271getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone
272getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (knownTimeZones locale)
273
274instance 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
289readTzOffset :: String -> Maybe Int
290readTzOffset 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
307instance 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
321instance ParseTime UTCTime where
322    substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
323    parseTimeSpecifier _ = timeParseTimeSpecifier
324    buildTime l xs = zonedTimeToUTC <$> buildTime l xs
325
326instance ParseTime UniversalTime where
327    substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
328    parseTimeSpecifier _ = timeParseTimeSpecifier
329    buildTime l xs = localTimeToUT1 0 <$> buildTime l xs
330
331buildTimeMonths :: [(Char,String)] -> Maybe Integer
332buildTimeMonths 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
340buildTimeDays :: [(Char,String)] -> Maybe Integer
341buildTimeDays 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
349buildTimeSeconds :: [(Char,String)] -> Maybe Pico
350buildTimeSeconds 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
366instance 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
373instance 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
380instance ParseTime CalendarDiffDays where
381    parseTimeSpecifier _ = durationParseTimeSpecifier
382    buildTime _ xs = do
383        mm <- buildTimeMonths xs
384        dd <- buildTimeDays xs
385        return $ CalendarDiffDays mm dd
386
387instance 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
393