| blob | 908dfdcce5840dad09a44074a66fe0ea7f48210c |
1 % Copyright (C) 2003 Peter Simons
2 % Copyright (C) 2003 David Roundy
3 %
4 % This program is free software; you can redistribute it and/or modify
5 % it under the terms of the GNU General Public License as published by
6 % the Free Software Foundation; either version 2, or (at your option)
7 % any later version.
8 %
9 % This program is distributed in the hope that it will be useful,
10 % but WITHOUT ANY WARRANTY; without even the implied warranty of
11 % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 % GNU General Public License for more details.
13 %
14 % You should have received a copy of the GNU General Public License
15 % along with this program; see the file COPYING. If not, write to
16 % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
17 % Boston, MA 02110-1301, USA.
20 \begin{code}
21 module IsoDate ( getIsoDateTime, readLocalDate, readUTCDate,
22 parseDate, getLocalTz,
23 englishDateTime, englishInterval, englishLast,
24 iso8601_interval, iso8601_duration,
25 cleanLocalDate, resetCalendar,
26 MCalendarTime(..), subtractFromMCal, addToMCal,
27 toMCalendarTime, unsafeToCalendarTime,
28 unsetTime,
29 ) where
31 import Text.ParserCombinators.Parsec
32 import System.Time
33 import System.IO.Unsafe ( unsafePerformIO )
34 import Data.Char ( toUpper, isDigit )
35 import Data.Maybe ( fromMaybe )
36 import Control.Monad ( liftM, liftM2 )
38 -- | Read/interpret a date string, assuming UTC if timezone
39 -- is not specified in the string (see 'readDate')
40 -- Warning! This errors out if we fail to interpret the
41 -- date
42 readUTCDate :: String -> CalendarTime
43 readUTCDate = readDate 0
45 -- | Convert a date string into ISO 8601 format (yyyymmdd variant)
46 -- assuming local timezone if not specified in the string
47 -- Warning! This errors out if we fail to interpret the date
48 cleanLocalDate :: String -> String
49 cleanLocalDate = showIsoDateTime . resetCalendar
50 . readDate (unsafePerformIO getLocalTz)
52 -- | Read/interpret a date string, assuming local timezone if not
53 -- specified in the string
54 readLocalDate :: String -> CalendarTime
55 readLocalDate = readDate (unsafePerformIO getLocalTz)
57 -- | Return the local timezone offset from UTC in seconds
58 getLocalTz :: IO Int
59 getLocalTz = ctTZ `liftM` (getClockTime >>= toCalendarTime)
61 -- | Parse a date string with 'parseDate'
62 -- Warning! This errors out if we fail to interpret the date
63 -- Uses its first argument as the default time zone.
64 readDate :: Int -> String -> CalendarTime
65 readDate tz d =
66 case parseDate tz d of
67 Left e -> error $ "bad date: "++d++" - "++show e
68 Right ct -> resetCalendar $ unsafeToCalendarTime ct
70 -- | Parse a date string, assuming a default timezone if
71 -- the date string does not specify one. The date formats
72 -- understood are those of 'showIsoDateTime' and 'date_time'
73 parseDate :: Int -> String -> Either ParseError MCalendarTime
74 parseDate tz d =
75 if length d >= 14 && and (map isDigit $ take 14 d)
76 then Right $ toMCalendarTime $
77 CalendarTime (read $ take 4 d)
78 (toEnum $ (+ (-1)) $ read $ take 2 $ drop 4 d)
79 (read $ take 2 $ drop 6 d) -- Day
80 (read $ take 2 $ drop 8 d) -- Hour
81 (read $ take 2 $ drop 10 d) -- Minute
82 (read $ take 2 $ drop 12 d) -- Second
83 0 Sunday 0 -- Picosecond, weekday and day of year unknown
84 "GMT" 0 False
85 else let dt = do { x <- date_time tz; eof; return x }
86 in parse dt "" d
88 -- | Display a 'CalendarTime' in the ISO 8601 format without any
89 -- separators, e.g. 20080825142503
90 showIsoDateTime :: CalendarTime -> String
91 showIsoDateTime ct = concat [ show $ ctYear ct
92 , twoDigit . show . (+1) . fromEnum $ ctMonth ct
93 , twoDigit . show $ ctDay ct
94 , twoDigit . show $ ctHour ct
95 , twoDigit . show $ ctMin ct
96 , twoDigit . show $ ctSec ct
97 ]
98 where twoDigit [] = undefined
99 twoDigit x@(_:[]) = '0' : x
100 twoDigit x@(_:_:[]) = x
101 twoDigit _ = undefined
103 -- | The current time in the format returned by 'showIsoDateTime'
104 getIsoDateTime :: IO String
105 getIsoDateTime = (showIsoDateTime . toUTCTime) `liftM` getClockTime
107 ----- Parser Combinators ---------------------------------------------
109 -- | Case-insensitive variant of Parsec's 'char' function.
110 caseChar :: Char -> GenParser Char a Char
111 caseChar c = satisfy (\x -> toUpper x == toUpper c)
113 -- | Case-insensitive variant of Parsec's 'string' function.
114 caseString :: String -> GenParser Char a ()
115 caseString cs = mapM_ caseChar cs <?> cs
117 -- | Match a parser at least @n@ times.
118 manyN :: Int -> GenParser a b c -> GenParser a b [c]
119 manyN n p
120 | n <= 0 = return []
121 | otherwise = liftM2 (++) (count n p) (many p)
123 -- | Match a parser at least @n@ times, but no more than @m@ times.
124 manyNtoM :: Int -> Int -> GenParser a b c -> GenParser a b [c]
125 manyNtoM n m p
126 | n < 0 = return []
127 | n > m = return []
128 | n == m = count n p
129 | n == 0 = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))
130 | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)
133 ----- Date/Time Parser -----------------------------------------------
135 -- | Try each of these date parsers in the following order
136 --
137 -- (1) 'cvs_date_time'
138 --
139 -- (2) 'iso8601_date_time'
140 --
141 -- (3) 'old_date_time
142 date_time :: Int -> CharParser a MCalendarTime
143 date_time tz =
144 choice [try $ toMCalendarTime `fmap` cvs_date_time tz,
145 try $ iso8601_date_time tz,
146 toMCalendarTime `fmap` old_date_time]
148 -- | CVS-style date/times, e.g.
149 -- 2007/08/25 14:25:39 GMT
150 -- Note that time-zones are optional here.
151 cvs_date_time :: Int -> CharParser a CalendarTime
152 cvs_date_time tz =
153 do y <- year
154 char '/'
155 mon <- month_num
156 char '/'
157 d <- day
158 my_spaces
159 h <- hour
160 char ':'
161 m <- minute
162 char ':'
163 s <- second
164 z <- option tz $ my_spaces >> zone
165 return (CalendarTime y mon d h m s 0 Monday 0 "" z False)
167 -- | \"Old\"-style dates, e.g.
168 -- Tue Jan 3 14:08:07 EST 1999
169 -- darcs-doc: Question (what does the "old" stand for really?)
170 old_date_time :: CharParser a CalendarTime
171 old_date_time = do wd <- day_name
172 my_spaces
173 mon <- month_name
174 my_spaces
175 d <- day
176 my_spaces
177 h <- hour
178 char ':'
179 m <- minute
180 char ':'
181 s <- second
182 my_spaces
183 z <- zone
184 my_spaces
185 y <- year
186 return (CalendarTime y mon d h m s 0 wd 0 "" z False)
188 -- | ISO 8601 dates and times. Please note the following flaws:
189 --
190 -- I am reluctant to implement:
191 --
192 -- * years > 9999
193 --
194 -- * truncated representations with implied century (89 for 1989)
195 --
196 -- I have not implemented:
197 --
198 -- * repeated durations (not relevant)
199 --
200 -- * lowest order component fractions in intervals
201 --
202 -- * negative dates (BC)
203 --
204 -- I have not verified or have left too relaxed:
205 --
206 -- * the difference between 24h and 0h
207 --
208 -- * allows stuff like 2005-1212; either you use the hyphen all the way
209 -- (2005-12-12) or you don't use it at all (20051212), but you don't use
210 -- it halfway, likewise with time
211 --
212 -- * No bounds checking whatsoever on intervals!
213 -- (next action: read iso doc to see if bounds-checking required?) -}
214 iso8601_date_time :: Int -> CharParser a MCalendarTime
215 iso8601_date_time localTz = try $
216 do d <- iso8601_date
217 t <- option id $ try $ do optional $ oneOf " T"
218 iso8601_time
219 return $ t $ d { mctTZ = Just localTz }
221 -- | Three types of ISO 8601 date:
222 --
223 -- * calendar date, e.g., 1997-07-17, 1997-07, 199707, 1997
224 --
225 -- * week+day in year, e.g., 1997-W32-4
226 --
227 -- * day in year, e.g, 1997-273
228 iso8601_date :: CharParser a MCalendarTime
229 iso8601_date =
230 do d <- calendar_date <|> week_date <|> ordinal_date
231 return $ foldr ($) nullMCalendar d
232 where
233 calendar_date = -- yyyy-mm-dd
234 try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]
235 -- allow other variants to be parsed correctly
236 notFollowedBy (digit <|> char 'W')
237 return d
238 week_date = --yyyy-Www-d
239 try $ do yfn <- year_
240 optional dash
241 char 'W'
242 -- offset human 'week 1' -> computer 'week 0'
243 w' <- (\x -> x-1) `liftM` two_digits
244 mwd <- option Nothing $ do { optional dash; Just `fmap` n_digits 1 }
245 let y = resetCalendar . unsafeToCalendarTime . yfn $ nullMCalendar { mctDay = Just 1 }
246 firstDay = ctWDay y
247 -- things that make this complicated
248 -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday
249 -- 2. the first week is the one that contains at least Thursday
250 -- if the year starts after Thursday, then some days of the year
251 -- will have already passed before the first week
252 let afterThursday = firstDay == Sunday || firstDay > Thursday
253 w = if afterThursday then w'+1 else w'
254 yday = (7 * w) + fromMaybe 1 mwd
255 diff c = c { mctWeek = True
256 , mctWDay = toEnum `fmap` mwd
257 , mctDay = Just yday }
258 return [(diff.yfn)]
259 ordinal_date = -- yyyy-ddd
260 try $ optchain year_ [ (dash, yearDay_) ]
261 --
262 year_ = try $ do y <- four_digits <?> "year (0000-9999)"
263 return $ \c -> c { mctYear = Just y }
264 month_ = try $ do m <- two_digits <?> "month (1 to 12)"
265 return $ \c -> c { mctMonth = Just $ intToMonth m }
266 day_ = try $ do d <- two_digits <?> "day in month (1 to 31)"
267 return $ \c -> c { mctDay = Just d }
268 yearDay_ = try $ do d <- n_digits 3 <?> "day in year (001 to 366)"
269 return $ \c -> c { mctDay = Just d
270 , mctYDay = Just (d - 1) }
271 dash = char '-'
273 -- | Note that this returns a function which sets the time on
274 -- another calendar (see 'iso8601_date_time' for a list of
275 -- flaws
276 iso8601_time :: CharParser a (MCalendarTime -> MCalendarTime)
277 iso8601_time = try $
278 do ts <- optchain hour_ [ (colon , min_)
279 , (colon , sec_)
280 , (oneOf ",.", pico_) ]
281 z <- option id $ choice [ zulu , offset ]
282 return $ foldr (.) id (z:ts)
283 where
284 hour_ = do h <- two_digits
285 return $ \c -> c { mctHour = Just h }
286 min_ = do m <- two_digits
287 return $ \c -> c { mctMin = Just m }
288 sec_ = do s <- two_digits
289 return $ \c -> c { mctSec = Just s }
290 pico_ = do digs <- many digit
291 let picoExp = 12
292 digsExp = length digs
293 let frac | null digs = 0
294 | digsExp > picoExp = read $ take picoExp digs
295 | otherwise = 10 ^ (picoExp - digsExp) * (read digs)
296 return $ \c -> c { mctPicosec = Just $ frac }
297 zulu = do { char 'Z'; return (\c -> c { mctTZ = Just 0 }) }
298 offset = do sign <- choice [ do { char '+' >> return 1 }
299 , do { char '-' >> return (-1) } ]
300 h <- two_digits
301 m <- option 0 $ do { optional colon; two_digits }
302 return $ \c -> c { mctTZ = Just $ sign * 60 * ((h*60)+m) }
303 colon = char ':'
305 -- | Intervals in ISO 8601, e.g.,
306 --
307 -- * 2008-09/2012-08-17T16:30
308 --
309 -- * 2008-09/P2Y11MT16H30M
310 --
311 -- * P2Y11MT16H30M/2012-08-17T16:30
312 --
313 -- See 'iso8601_duration'
314 iso8601_interval :: Int -> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime))
315 iso8601_interval localTz = leftDur <|> rightDur where
316 leftDur =
317 do dur <- iso8601_duration
318 end <- option Nothing $ do { char '/'; Just `liftM` isoDt }
319 return $ case end of
320 Nothing -> Left dur
321 Just e -> Right (dur `subtractFromMCal` e, e)
322 rightDur =
323 do start <- isoDt
324 char '/'
325 durOrEnd <- Left `liftM` iso8601_duration <|> Right `liftM` isoDt
326 return $ case durOrEnd of
327 Left dur -> Right (start, dur `addToMCal` start)
328 Right end -> Right (start, end)
329 isoDt = iso8601_date_time localTz
331 -- | Durations in ISO 8601, e.g.,
332 --
333 -- * P4Y (four years)
334 --
335 -- * P5M (five months)
336 --
337 -- * P4Y5M (four years and five months)
338 --
339 -- * P4YT3H6S (four years, three hours and six seconds)
340 iso8601_duration :: CharParser a TimeDiff
341 iso8601_duration =
342 do char 'P'
343 y <- block 0 'Y'
344 mon <- block 0 'M'
345 d <- block 0 'D'
346 (h,m,s) <- option (0,0,0) $
347 do char 'T'
348 h' <- block (-1) 'H'
349 m' <- block (-1) 'M'
350 s' <- block (-1) 'S'
351 let unset = (== (-1))
352 if all unset [h',m',s']
353 then fail "T should be omitted if time is unspecified"
354 else let clear x = if (unset x) then 0 else x
355 in return (clear h', clear m', clear s')
356 --
357 return $ TimeDiff y mon d h m s 0
358 where block d c = option d $ try $
359 do n <- many1 digit
360 char c
361 return $ read n
363 -- | 'optchain' @p xs@ parses a string with the obligatory
364 -- parser @p@. If this suceeds, it continues on to the
365 -- rest of the input using the next parsers down the
366 -- chain. Each part of the chain consists of a parser
367 -- for a separator and for the content itself. The
368 -- separator is optional.
369 --
370 -- A good use of this function is to help in parsing ISO
371 -- ISO 8601 dates and times. For example, the parser
372 -- @optchain year [(dash, month), (dash, day)]@ accepts
373 -- dates like 2007 (only the year is used), 2007-07 (only
374 -- the year and month), 200707 (only the year and month
375 -- with no separator), 2007-07-19 (year, month and day).
376 optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]
377 optchain p next = try $
378 do r1 <- p
379 r2 <- case next of
380 [] -> return []
381 ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }
382 return (r1:r2)
384 n_digits :: Int -> CharParser a Int
385 n_digits n = read `liftM` count n digit
387 two_digits, four_digits :: CharParser a Int
388 two_digits = n_digits 2
389 four_digits = n_digits 4
391 -- | One or more space.
392 -- WARNING! This only matches on the space character, not on
393 -- whitespace in general
394 my_spaces :: CharParser a String
395 my_spaces = manyN 1 $ char ' '
397 -- | English three-letter day abbreviations (e.g. Mon, Tue, Wed)
398 day_name :: CharParser a Day
399 day_name = choice
400 [ caseString "Mon" >> return Monday
401 , try (caseString "Tue") >> return Tuesday
402 , caseString "Wed" >> return Wednesday
403 , caseString "Thu" >> return Thursday
404 , caseString "Fri" >> return Friday
405 , try (caseString "Sat") >> return Saturday
406 , caseString "Sun" >> return Sunday
407 ]
409 -- | Four-digit year
410 year :: CharParser a Int
411 year = four_digits
413 -- | One or two digit month (e.g. 3 for March, 11 for November)
414 month_num :: CharParser a Month
415 month_num = do mn <- manyNtoM 1 2 digit
416 return $ intToMonth $ (read mn :: Int)
418 -- | January is 1, February is 2, etc
419 intToMonth :: Int -> Month
420 intToMonth 1 = January
421 intToMonth 2 = February
422 intToMonth 3 = March
423 intToMonth 4 = April
424 intToMonth 5 = May
425 intToMonth 6 = June
426 intToMonth 7 = July
427 intToMonth 8 = August
428 intToMonth 9 = September
429 intToMonth 10 = October
430 intToMonth 11 = November
431 intToMonth 12 = December
432 intToMonth _ = error "invalid month!"
434 -- | English three-letter month abbreviations (e.g. Jan, Feb, Mar)
435 month_name :: CharParser a Month
436 month_name = choice
437 [ try (caseString "Jan") >> return January
438 , caseString "Feb" >> return February
439 , try (caseString "Mar") >> return March
440 , try (caseString "Apr") >> return April
441 , caseString "May" >> return May
442 , try (caseString "Jun") >> return June
443 , caseString "Jul" >> return July
444 , caseString "Aug" >> return August
445 , caseString "Sep" >> return September
446 , caseString "Oct" >> return October
447 , caseString "Nov" >> return November
448 , caseString "Dec" >> return December
449 ]
451 -- | day in one or two digit notation
452 day :: CharParser a Int
453 day = do d <- manyNtoM 1 2 digit
454 return (read d :: Int)
456 -- | hour in two-digit notation
457 hour :: CharParser a Int
458 hour = two_digits
460 -- | minute in two-digit notation
461 minute :: CharParser a Int
462 minute = two_digits
464 -- | second in two-digit notation
465 second :: CharParser a Int
466 second = two_digits
468 -- | limited timezone support
469 --
470 -- * +HHMM or -HHMM
471 --
472 -- * Universal timezones: UTC, UT
473 --
474 -- * Some American timezones: EST, EDT, CST, CDT, MST, MDT, PST, PDT
475 --
476 -- * Some European timezones: UT, GMT, CEST, EEST
477 --
478 -- * any sequence of alphabetic characters (WARNING! treated as 0!)
479 zone :: CharParser a Int
480 zone = choice
481 [ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }
482 , do { char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) }
483 , mkZone "UTC" 0
484 , mkZone "UT" 0
485 , mkZone "GMT" 0
486 , mkZone "EST" (-5)
487 , mkZone "EDT" (-4)
488 , mkZone "CST" (-6)
489 , mkZone "CDT" (-5)
490 , mkZone "MST" (-7)
491 , mkZone "MDT" (-6)
492 , mkZone "PST" (-8)
493 , mkZone "PDT" (-7)
494 , mkZone "CEST" 2
495 , mkZone "EEST" 3
496 -- if we don't understand it, just give a GMT answer...
497 , do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' '])
498 (lookAhead space_digit);
499 return 0 }
500 ]
501 where mkZone n o = try $ do { caseString n; return (o*60*60) }
502 space_digit = try $ do { char ' '; oneOf ['0'..'9'] }
504 ----- English dates and intervals -----------------------------------------------
506 -- | In English, either a date followed by a time, or vice-versa, e.g,
507 --
508 -- * yesterday at noon
509 --
510 -- * yesterday tea time
511 --
512 -- * 12:00 yesterday
513 --
514 -- See 'englishDate' and 'englishTime'
515 -- Uses its first argument as "now", i.e. the time relative to which
516 -- "yesterday", "today" etc are to be interpreted
517 englishDateTime :: CalendarTime -> CharParser a CalendarTime
518 englishDateTime now =
519 try $ dateMaybeAtTime <|> timeThenDate
520 where
521 -- yesterday (at) noon
522 dateMaybeAtTime = try $
523 do ed <- englishDate now
524 t <- option Nothing $ try $
525 do { space; optional $ caseString "at "; Just `liftM` englishTime }
526 return $ fromMaybe id t $ ed
527 -- tea time 2005-12-04
528 timeThenDate = try $
529 do t <- englishTime
530 optional $ char ','
531 space
532 ed <- englishDate now
533 return $ t $ unsetTime $ ed
535 -- | Specific dates in English as specific points of time, e.g,
536 --
537 -- * today
538 --
539 -- * yesterday
540 --
541 -- * last week (i.e. the beginning of that interval)
542 --
543 -- * 4 months ago (via 'englishAgo')
544 --
545 -- The first argument is "now".
546 englishDate :: CalendarTime -> CharParser a CalendarTime
547 englishDate now = try $
548 (caseString "today" >> (return $ resetCalendar now))
549 <|> (caseString "yesterday" >> (return $ oneDay `subtractFromCal` now) )
550 <|> fst `fmap` englishLast now
551 <|> englishAgo now
552 where oneDay = TimeDiff 0 0 1 0 0 0 0
554 -- | English expressions for points in the past, e.g.
555 --
556 -- * 4 months ago
557 --
558 -- * 1 day ago
559 --
560 -- * day before yesterday
561 --
562 -- See 'englishDuration'
563 englishAgo :: CalendarTime -> CharParser a CalendarTime
564 englishAgo now =
565 try $ do p <- englishDuration
566 try $ do space
567 (m,ref) <- (try $ caseString "ago" >> return ((-1), now))
568 <|> do m <- beforeMod <|> afterMod
569 space
570 d <- englishDate now
571 <|> fst `fmap` englishLast now
572 <|> unsafeToCalendarTime `fmap` iso8601_date_time (ctTZ now)
573 return (m,d)
574 return $ multiplyDiff m p `addToCal` ref
575 where
576 beforeMod = try $ caseString "before" >> return (-1)
577 afterMod = try $ caseString "after" >> return 1
579 -- | English expressions for intervals of time,
580 --
581 -- * before tea time (i.e. from the beginning of time)
582 --
583 -- * after 14:00 last month (i.e. till now)
584 --
585 -- * between last year and last month
586 --
587 -- * in the last three months (i.e. from then till now)
588 --
589 -- * 4 months ago (i.e. till now; see 'englishAgo')
590 englishInterval :: CalendarTime -> CharParser a (CalendarTime, CalendarTime)
591 englishInterval now = twixt <|> before <|> after <|> inTheLast <|> lastetc
592 where
593 englishDT = (unsafeToCalendarTime `fmap` iso8601_date_time (ctTZ now)
594 <|> englishDateTime now)
595 before = try $
596 do caseString "before"
597 space
598 end <- englishDT
599 return (theBeginning, end)
600 after = try $
601 do caseString "after"
602 space
603 start <- englishDT
604 return (start, now)
605 twixt = try $
606 do caseString "between"
607 space
608 start <- englishDT
609 space
610 caseString "and"
611 space
612 end <- englishDT
613 return (start, end)
614 inTheLast = try $
615 do caseString "in the last"
616 space
617 dur <- englishDuration
618 return (dur `subtractFromCal` now, now)
619 lastetc =
620 do l <- englishAgo now
621 return (l, now)
623 -- | Durations in English that begin with the word \"last\",
624 -- E.g. \"last 4 months\" is treated as the duration between
625 -- 4 months ago and now
626 englishLast :: CalendarTime -> CharParser a (CalendarTime, CalendarTime)
627 englishLast now =
628 -- last year, last week, last 3 years, etc
629 try $ do caseString "last"
630 space
631 d <- englishDuration
632 return (d `subtractFromCal` now, now)
634 -- | Either an 'iso8601_time' or one of several common
635 -- English time expressions like 'noon' or 'tea time'
636 englishTime :: CharParser a (CalendarTime->CalendarTime)
637 englishTime = try $
638 choice [ wrapM `fmap` iso8601_time
639 , namedTime "noon" 12 0
640 , namedTime "midnight" 0 0
641 , namedTime "tea time" 16 30
642 , namedTime "bed time" 2 30
643 , namedTime "proper bed time" 21 30 ]
644 where namedTime name h m = try $
645 do caseString name
646 return $ \c -> c { ctHour = h, ctMin = m }
647 wrapM f = unsafeToCalendarTime . f . toMCalendarTime
649 -- | Some English durations, e.g.
650 --
651 -- * day
652 --
653 -- * 4 score
654 --
655 -- * 7 years
656 --
657 -- * 12 months
658 --
659 -- This is not particularly strict about what it accepts.
660 -- For example, "7 yeares", "4 scores" or "1 days" are
661 -- just fine.
662 englishDuration :: CharParser a TimeDiff
663 englishDuration = try $
664 do n <- option 1 $ do { x <- many1 digit; space; (return $ read x) }
665 b <- base
666 optional (caseString "es" <|> caseString "s")
667 let current = multiplyDiff n b
668 next <- option noTimeDiff $ try $ do
669 { optional space; char ',' ; optional space ; englishDuration }
670 return $ addDiff current next
671 where
672 base = choice
673 [ try $ caseString "score" >> (return $ TimeDiff 20 0 0 0 0 0 0) -- why not?
674 , caseString "year" >> (return $ TimeDiff 1 0 0 0 0 0 0)
675 , try $ caseString "month" >> (return $ TimeDiff 0 1 0 0 0 0 0)
676 , caseString "fortnight" >> (return $ TimeDiff 0 0 14 0 0 0 0)
677 , caseString "week" >> (return $ TimeDiff 0 0 7 0 0 0 0)
678 , caseString "day" >> (return $ TimeDiff 0 0 1 0 0 0 0)
679 , caseString "hour" >> (return $ TimeDiff 0 0 0 1 0 0 0)
680 , caseString "minute" >> (return $ TimeDiff 0 0 0 0 1 0 0)
681 , caseString "second" >> (return $ TimeDiff 0 0 0 0 0 1 0) ]
683 ----- Calendar and TimeDiff manipulation ---------------------------------------------
685 -- | The very beginning of time, i.e. 1970-01-01
686 theBeginning :: CalendarTime
687 theBeginning = unsafePerformIO $ toCalendarTime $ TOD 0 0
689 -- | An 'MCalenderTime' is an underspecified 'CalendarTime'
690 -- It is used for parsing dates. For example, if you want to parse
691 -- the date '4 January', it may be useful to underspecify the year
692 -- by setting it to 'Nothing'. This uses almost the same fields as
693 -- 'System.Time.CalendarTime', a notable exception being that we
694 -- introduce 'mctWeek' to indicate if a weekday was specified or not
695 data MCalendarTime = MCalendarTime
696 { mctYear :: Maybe Int
697 , mctMonth :: Maybe Month
698 , mctDay :: Maybe Int
699 , mctHour :: Maybe Int
700 , mctMin :: Maybe Int
701 , mctSec :: Maybe Int
702 , mctPicosec :: Maybe Integer
703 , mctWDay :: Maybe Day
704 , mctYDay :: Maybe Int
705 , mctTZName :: Maybe String
706 , mctTZ :: Maybe Int
707 , mctIsDST :: Maybe Bool
708 , mctWeek :: Bool -- is set or not
709 } deriving Show
711 -- | Trivially convert a 'CalendarTime' to a fully specified
712 -- 'MCalendarTime' (note that this sets the 'mctWeek' flag to
713 -- @False@
714 toMCalendarTime :: CalendarTime -> MCalendarTime
715 toMCalendarTime (CalendarTime a b c d e f g h i j k l) =
716 MCalendarTime (Just a) (Just b) (Just c) (Just d) (Just e) (Just f)
717 (Just g) (Just h) (Just i) (Just j) (Just k) (Just l)
718 False
720 -- | Returns the first 'CalendarTime' that falls within a 'MCalendarTime'
721 -- This is only unsafe in the sense that it plugs in default values
722 -- for fields that have not been set, e.g. @January@ for the month
723 -- or @0@ for the seconds field.
724 -- Maybe we should rename it something happier.
725 -- See also 'resetCalendar'
726 unsafeToCalendarTime :: MCalendarTime -> CalendarTime
727 unsafeToCalendarTime m =
728 CalendarTime
729 { ctYear = fromMaybe 0 $ mctYear m
730 , ctMonth = fromMaybe January $ mctMonth m
731 , ctDay = fromMaybe 1 $ mctDay m
732 , ctHour = fromMaybe 0 $ mctHour m
733 , ctMin = fromMaybe 0 $ mctMin m
734 , ctSec = fromMaybe 0 $ mctSec m
735 , ctPicosec = fromMaybe 0 $ mctPicosec m
736 , ctWDay = fromMaybe Sunday $ mctWDay m
737 , ctYDay = fromMaybe 0 $ mctYDay m
738 , ctTZName = fromMaybe "" $ mctTZName m
739 , ctTZ = fromMaybe 0 $ mctTZ m
740 , ctIsDST = fromMaybe False $ mctIsDST m
741 }
743 addToCal :: TimeDiff -> CalendarTime -> CalendarTime
744 addToCal td = toUTCTime . addToClockTime td . toClockTime
746 subtractFromCal :: TimeDiff -> CalendarTime -> CalendarTime
747 subtractFromCal = addToCal . multiplyDiff (-1)
749 addToMCal :: TimeDiff -> MCalendarTime -> MCalendarTime
750 addToMCal td mc =
751 copyCalendar (addToCal td $ unsafeToCalendarTime mc) mc
753 subtractFromMCal :: TimeDiff -> MCalendarTime -> MCalendarTime
754 subtractFromMCal = addToMCal . multiplyDiff (-1)
756 -- surely there is a more concise way to express these
757 addDiff :: TimeDiff -> TimeDiff -> TimeDiff
758 addDiff (TimeDiff a1 a2 a3 a4 a5 a6 a7) (TimeDiff b1 b2 b3 b4 b5 b6 b7) =
759 TimeDiff (a1+b1) (a2+b2) (a3+b3) (a4+b4) (a5+b5) (a6+b6) (a7 + b7)
761 -- | 'multiplyDiff' @i d@ multiplies every field in @d@ with @i@
762 --
763 -- FIXME; this seems like a terrible idea! it seems like
764 -- we should get rid of it if at all possible, maybe adding an
765 -- invertDiff function
766 multiplyDiff :: Int -> TimeDiff -> TimeDiff
767 multiplyDiff m (TimeDiff a1 a2 a3 a4 a5 a6 a7) =
768 TimeDiff (a1*m) (a2*m) (a3*m) (a4*m) (a5*m) (a6*m) (a7 * (toInteger m))
770 nullMCalendar :: MCalendarTime
771 nullMCalendar = MCalendarTime Nothing Nothing Nothing Nothing Nothing Nothing
772 Nothing Nothing Nothing Nothing Nothing Nothing
773 False
775 -- | Set a calendar to UTC time any eliminate any inconsistencies within
776 -- (for example, where the weekday is given as @Thursday@, but this does not
777 -- match what the numerical date would lead one to expect)
778 resetCalendar :: CalendarTime -> CalendarTime
779 resetCalendar = toUTCTime . toClockTime
781 -- | 'copyCalendar' @c mc@ replaces any field which is
782 -- specified in @mc@ with the equivalent field in @c@
783 -- @copyCalendar c nullMCalendar == nullMCalendar@
784 copyCalendar :: CalendarTime -> MCalendarTime -> MCalendarTime
785 copyCalendar c mc = mc
786 { mctYear = mctYear mc >> Just (ctYear c)
787 , mctMonth = mctMonth mc >> Just (ctMonth c)
788 , mctDay = mctDay mc >> Just (ctDay c)
789 , mctHour = mctHour mc >> Just (ctHour c)
790 , mctMin = mctMin mc >> Just (ctMin c)
791 , mctSec = mctSec mc >> Just (ctSec c)
792 , mctPicosec = mctPicosec mc >> Just (ctPicosec c)
793 , mctWDay = mctWDay mc >> Just (ctWDay c)
794 , mctYDay = mctYDay mc >> Just (ctYDay c)
795 , mctTZName = mctTZName mc >> Just (ctTZName c)
796 , mctTZ = mctTZ mc >> Just (ctTZ c)
797 , mctIsDST = mctIsDST mc >> Just (ctIsDST c)
798 }
800 -- | Zero the time fields of a 'CalendarTime'
801 unsetTime :: CalendarTime -> CalendarTime
802 unsetTime mc = mc
803 { ctHour = 0
804 , ctMin = 0
805 , ctSec = 0
806 , ctPicosec = 0
807 }
808 \end{code}