% Copyright (C) 2003 Peter Simons % Copyright (C) 2003 David Roundy % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2, or (at your option) % any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % You should have received a copy of the GNU General Public License % along with this program; see the file COPYING. If not, write to % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, % Boston, MA 02110-1301, USA. \begin{code} module IsoDate ( getIsoDateTime, readDate, parseDate, englishDateTime, englishInterval, iso8601_interval, iso8601_duration, addToCal, subtractFromCal, showIsoDateTime, cleanDate ) where import Text.ParserCombinators.Parsec import System.Time import Data.Char ( toUpper, isDigit ) import Control.Monad ( liftM, liftM2 ) cleanDate :: String -> String cleanDate d = showIsoDateTime $ readDate d readDate :: String -> CalendarTime readDate d = case parseDate d of Left e -> error e Right ct -> ct parseDate :: String -> Either String CalendarTime parseDate d = if length d >= 14 && and (map isDigit $ take 14 d) then Right $ CalendarTime (read $ take 4 d) (toEnum $ (+ (-1)) $ read $ take 2 $ drop 4 d) (read $ take 2 $ drop 6 d) -- Day (read $ take 2 $ drop 8 d) -- Hour (read $ take 2 $ drop 10 d) -- Minute (read $ take 2 $ drop 12 d) -- Second 0 Sunday 0 -- Picosecond, weekday and day of year unknown "GMT" 0 False else let dt = do { x <- date_time; eof; return x } in case parse dt "" d of Left e -> Left $ "bad date: "++d++" - "++show e Right ct -> Right ct showIsoDateTime :: CalendarTime -> String showIsoDateTime ct = concat [ show $ ctYear ct , twoDigit . show . (+1) . fromEnum $ ctMonth ct , twoDigit . show $ ctDay ct , twoDigit . show $ ctHour ct , twoDigit . show $ ctMin ct , twoDigit . show $ ctSec ct ] where twoDigit [] = undefined twoDigit x@(_:[]) = '0' : x twoDigit x@(_:_:[]) = x twoDigit _ = undefined getIsoDateTime :: IO String getIsoDateTime = (showIsoDateTime . toUTCTime) `liftM` getClockTime ----- Parser Combinators --------------------------------------------- -- |Case-insensitive variant of Parsec's 'char' function. caseChar :: Char -> GenParser Char a Char caseChar c = satisfy (\x -> toUpper x == toUpper c) -- |Case-insensitive variant of Parsec's 'string' function. caseString :: String -> GenParser Char a () caseString cs = mapM_ caseChar cs cs -- |Match a parser at least @n@ times. manyN :: Int -> GenParser a b c -> GenParser a b [c] manyN n p | n <= 0 = return [] | otherwise = liftM2 (++) (count n p) (many p) -- |Match a parser at least @n@ times, but no more than @m@ times. manyNtoM :: Int -> Int -> GenParser a b c -> GenParser a b [c] manyNtoM n m p | n < 0 = return [] | n > m = return [] | n == m = count n p | n == 0 = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m])) | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p) ----- Date/Time Parser ----------------------------------------------- date_time :: CharParser a CalendarTime date_time = choice [try cvs_date_time, -- FIXME: local time set to UTC which may be wrong! try $ iso8601_date_time 0, old_date_time] cvs_date_time :: CharParser a CalendarTime cvs_date_time = do y <- year char '/' mon <- month_num char '/' d <- day my_spaces h <- hour char ':' m <- minute char ':' s <- second z <- option 0 $ my_spaces >> zone return (CalendarTime y mon d h m s 0 Monday 0 "" z False) old_date_time :: CharParser a CalendarTime old_date_time = do wd <- day_name my_spaces mon <- month_name my_spaces d <- day my_spaces h <- hour char ':' m <- minute char ':' s <- second my_spaces z <- zone my_spaces y <- year return (CalendarTime y mon d h m s 0 wd 0 "" z False) {- FIXME: In case you ever want to use this outside of darcs, you should note that this implementation of ISO 8601 is not complete. reluctant to implement (ambiguous!): * years > 9999 * truncated representations with implied century (89 for 1989) unimplemented: * repeated durations (not relevant) * lowest order component fractions in intervals * negative dates (BC) unverified or too relaxed: * the difference between 24h and 0h * allows stuff like 2005-1212; either you use the hyphen all the way (2005-12-12) or you don't use it at all (20051212), but you don't use it halfway, likewise with time * No bounds checking whatsoever on intervals! (next action: read iso doc to see if bounds-checking required?) -} iso8601_date_time :: Int -> CharParser a CalendarTime iso8601_date_time localTz = try $ do d <- iso8601_date t <- option id $ try $ do optional $ oneOf " T" iso8601_time return $ t $ d { ctTZ = localTz } iso8601_date :: CharParser a CalendarTime iso8601_date = do d <- calendar_date <|> week_date <|> ordinal_date return $ foldr ($) nullCalendar d where calendar_date = -- yyyy-mm-dd try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ] -- allow other variants to be parsed correctly notFollowedBy (digit <|> char 'W') return d week_date = --yyyy-Www-dd try $ do yfn <- year_ optional dash char 'W' -- offset human 'week 1' -> computer 'week 0' w' <- (\x -> x-1) `liftM` two_digits wd <- option 1 $ do { optional dash; n_digits 1 } let y = yfn nullCalendar firstDay = ctWDay y -- things that make this complicated -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday -- 2. the first week is the one that contains at least Thursday -- if the year starts after Thursday, then some days of the year -- will have already passed before the first week let afterThursday = firstDay == Sunday || firstDay > Thursday w = if afterThursday then w'+1 else w' diff c = c { ctDay = (7 * w) + wd - (fromEnum firstDay) } return [(toUTCTime.toClockTime.diff.yfn)] ordinal_date = -- yyyy-ddd try $ optchain year_ [ (dash, yearDay_) ] -- year_ = try $ do y <- four_digits "year (0000-9999)" return $ \c -> c { ctYear = y } month_ = try $ do m <- two_digits "month (1 to 12)" return $ \c -> c { ctMonth = intToMonth m } day_ = try $ do d <- two_digits "day in month (1 to 31)" return $ \c -> c { ctDay = d } yearDay_ = try $ do d <- n_digits 3 "day in year (1 to 366)" return $ \c -> c { ctYDay = d } dash = char '-' -- we return a function which sets the time on another calendar iso8601_time :: CharParser a (CalendarTime -> CalendarTime) iso8601_time = try $ do ts <- optchain hour_ [ (colon , min_) , (colon , sec_) , (oneOf ",.", pico_) ] z <- option id $ choice [ zulu , offset ] return $ foldr (.) id (z:ts) where hour_ = do h <- two_digits return $ \c -> c { ctHour = h } min_ = do m <- two_digits return $ \c -> c { ctMin = m } sec_ = do s <- two_digits return $ \c -> c { ctSec = s } pico_ = do digs <- many digit let picoExp = 12 digsExp = length digs let frac | null digs = 0 | digsExp > picoExp = read $ take picoExp digs | otherwise = 10 ^ (picoExp - digsExp) * (read digs) return $ \c -> c { ctPicosec = frac } zulu = do { char 'Z'; return (\c -> c { ctTZ = 0 }) } offset = do sign <- choice [ do { char '+' >> return 1 } , do { char '-' >> return (-1) } ] h <- two_digits m <- option 0 $ do { optional colon; two_digits } return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) } colon = char ':' iso8601_interval :: Int -> CharParser a (Either TimeDiff (CalendarTime, CalendarTime)) iso8601_interval localTz = leftDur <|> rightDur where leftDur = do dur <- iso8601_duration end <- option Nothing $ do { char '/'; Just `liftM` isoDt } return $ case end of Nothing -> Left dur Just e -> Right (dur `subtractFromCal` e, e) rightDur = do start <- isoDt char '/' durOrEnd <- Left `liftM` iso8601_duration <|> Right `liftM` isoDt return $ case durOrEnd of Left dur -> Right (start, dur `addToCal` start) Right end -> Right (start, end) isoDt = iso8601_date_time localTz iso8601_duration :: CharParser a TimeDiff iso8601_duration = do char 'P' y <- block 0 'Y' mon <- block 0 'M' d <- block 0 'D' (h,m,s) <- option (0,0,0) $ do char 'T' h' <- block (-1) 'H' m' <- block (-1) 'M' s' <- block (-1) 'S' let unset = (== (-1)) if all unset [h',m',s'] then fail "T should be omitted if time is unspecified" else let clear x = if (unset x) then 0 else x in return (clear h', clear m', clear s') -- return $ TimeDiff y mon d h m s 0 where block d c = option d $ try $ do n <- many1 digit char c return $ read n optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b] optchain p next = try $ do r1 <- p r2 <- case next of [] -> return [] ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 } return (r1:r2) n_digits :: Int -> CharParser a Int n_digits n = read `liftM` count n digit two_digits, four_digits :: CharParser a Int two_digits = n_digits 2 four_digits = n_digits 4 my_spaces :: CharParser a String my_spaces = manyN 1 $ char ' ' day_name :: CharParser a Day day_name = choice [ caseString "Mon" >> return Monday , try (caseString "Tue") >> return Tuesday , caseString "Wed" >> return Wednesday , caseString "Thu" >> return Thursday , caseString "Fri" >> return Friday , try (caseString "Sat") >> return Saturday , caseString "Sun" >> return Sunday ] year :: CharParser a Int year = four_digits month_num :: CharParser a Month month_num = do mn <- manyNtoM 1 2 digit return $ intToMonth $ (read mn :: Int) intToMonth :: Int -> Month intToMonth 1 = January intToMonth 2 = February intToMonth 3 = March intToMonth 4 = April intToMonth 5 = May intToMonth 6 = June intToMonth 7 = July intToMonth 8 = August intToMonth 9 = September intToMonth 10 = October intToMonth 11 = November intToMonth 12 = December intToMonth _ = error "invalid month!" month_name :: CharParser a Month month_name = choice [ try (caseString "Jan") >> return January , caseString "Feb" >> return February , try (caseString "Mar") >> return March , try (caseString "Apr") >> return April , caseString "May" >> return May , try (caseString "Jun") >> return June , caseString "Jul" >> return July , caseString "Aug" >> return August , caseString "Sep" >> return September , caseString "Oct" >> return October , caseString "Nov" >> return November , caseString "Dec" >> return December ] day :: CharParser a Int day = do d <- manyNtoM 1 2 digit return (read d :: Int) hour :: CharParser a Int hour = two_digits minute :: CharParser a Int minute = two_digits second :: CharParser a Int second = two_digits zone :: CharParser a Int zone = choice [ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) } , do { char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) } , mkZone "UTC" 0 , mkZone "UT" 0 , mkZone "GMT" 0 , mkZone "EST" (-5) , mkZone "EDT" (-4) , mkZone "CST" (-6) , mkZone "CDT" (-5) , mkZone "MST" (-7) , mkZone "MDT" (-6) , mkZone "PST" (-8) , mkZone "PDT" (-7) , mkZone "CEST" 2 , mkZone "EEST" 3 -- if we don't understand it, just give a GMT answer... , do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' ']) (lookAhead space_digit); return 0 } ] where mkZone n o = try $ do { caseString n; return (o*60*60) } space_digit = try $ do { char ' '; oneOf ['0'..'9'] } ----- English dates and intervals ----------------------------------------------- englishDateTime :: CalendarTime -> CharParser a CalendarTime englishDateTime now = try $ dateMaybeAtTime <|> timeThenDate where -- yesterday (at) noon dateMaybeAtTime = try $ do ed <- englishDate now t <- option Nothing $ try $ do { space; optional $ caseString "at "; Just `liftM` englishTime } return $ case t of Nothing -> ed Just tfn -> (tfn.timeless) ed -- tea time 2005-12-04 timeThenDate = try $ do t <- englishTime optional $ char ',' space ed <- englishDate now return $ t $ timeless ed timeless x = x { ctHour = 0, ctMin = 0, ctSec = 0, ctPicosec = 0 } englishDate :: CalendarTime -> CharParser a CalendarTime englishDate now = try $ (caseString "today" >> (return now)) <|> (caseString "yesterday" >> (return $ oneDay `subtractFromCal` now) ) <|> -- last year, last week, last 3 years, etc (try $ do caseString "last" space d <- englishDuration return $ d `subtractFromCal` now ) <|> -- 4 months ago, 1 day ago, day before yesterday (try $ do p <- englishDuration try $ do space (m,ref) <- (try $ caseString "ago" >> return ((-1), now)) <|> do m <- beforeMod <|> afterMod space d <- (englishDate now) <|> iso8601_date return (m,d) return $ (multiplyDiff m p) `addToCal` ref ) where oneDay = TimeDiff 0 0 1 0 0 0 0 beforeMod = try $ caseString "before" >> return (-1) afterMod = try $ caseString "after" >> return (-1) englishInterval :: CalendarTime -> CharParser a (CalendarTime, CalendarTime) englishInterval now = twixt <|> before <|> after <|> inTheLast where englishDT = (iso8601_date_time (ctTZ now) <|> englishDateTime now) before = try $ do caseString "before" space end <- englishDT return (nullCalendar, end) after = try $ do caseString "after" space start <- englishDT return (start, now) twixt = try $ do caseString "between" space start <- englishDT space caseString "and" space end <- englishDT return (start, end) inTheLast = try $ do caseString "in the last" space dur <- englishDuration return (dur `subtractFromCal` now, now) englishTime :: CharParser a (CalendarTime->CalendarTime) englishTime = try $ choice [ iso8601_time , namedTime "noon" 12 0 , namedTime "midnight" 0 0 , namedTime "tea time" 16 30 , namedTime "bed time" 2 30 , namedTime "proper bed time" 21 30 ] where namedTime name h m = try $ do caseString name return $ \c -> c { ctHour = h, ctMin = m } -- this slightly overgenerates, but who cares? englishDuration :: CharParser a TimeDiff englishDuration = try $ do n <- option 1 $ do { x <- many1 digit; space; (return $ read x) } b <- base optional (caseString "es" <|> caseString "s") let current = multiplyDiff n b next <- option noTimeDiff $ try $ do { optional space; char ',' ; optional space ; englishDuration } return $ addDiff current next where base = choice [ try $ caseString "score" >> (return $ TimeDiff 20 0 0 0 0 0 0) -- why not? , caseString "year" >> (return $ TimeDiff 1 0 0 0 0 0 0) , try $ caseString "month" >> (return $ TimeDiff 0 1 0 0 0 0 0) , caseString "fortnight" >> (return $ TimeDiff 0 0 14 0 0 0 0) , caseString "week" >> (return $ TimeDiff 0 0 7 0 0 0 0) , caseString "day" >> (return $ TimeDiff 0 0 1 0 0 0 0) , caseString "hour" >> (return $ TimeDiff 0 0 0 1 0 0 0) , caseString "minute" >> (return $ TimeDiff 0 0 0 0 1 0 0) , caseString "second" >> (return $ TimeDiff 0 0 0 0 0 1 0) ] ----- Calendar and TimeDiff manipulation --------------------------------------------- addToCal :: TimeDiff -> CalendarTime -> CalendarTime addToCal td = toUTCTime . addToClockTime td . toClockTime subtractFromCal :: TimeDiff -> CalendarTime -> CalendarTime subtractFromCal = addToCal . multiplyDiff (-1) -- surely there is a more concise way to express these addDiff :: TimeDiff -> TimeDiff -> TimeDiff addDiff (TimeDiff a1 a2 a3 a4 a5 a6 a7) (TimeDiff b1 b2 b3 b4 b5 b6 b7) = TimeDiff (a1+b1) (a2+b2) (a3+b3) (a4+b4) (a5+b5) (a6+b6) (a7 + b7) multiplyDiff :: Int -> TimeDiff -> TimeDiff multiplyDiff m (TimeDiff a1 a2 a3 a4 a5 a6 a7) = TimeDiff (a1*m) (a2*m) (a3*m) (a4*m) (a5*m) (a6*m) (a7 * (toInteger m)) nullCalendar :: CalendarTime nullCalendar = CalendarTime 0 January 1 0 0 0 0 Sunday 0 "" 0 False \end{code}