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