% 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, readLocalDate, readUTCDate, parseDate, getLocalTz, englishDateTime, englishInterval, englishLast, iso8601_interval, iso8601_duration, addToCal, subtractFromCal, showIsoDateTime, cleanLocalDate, resetCalendar, MCalendarTime(..), subtractFromMCal, addToMCal, nullMCalendar, toMCalendarTime, unsafeToCalendarTime, unsetTime, ) where import Text.ParserCombinators.Parsec import System.Time import System.IO.Unsafe ( unsafePerformIO ) import Data.Char ( toUpper, isDigit ) import Data.Maybe ( fromMaybe ) import Control.Monad ( liftM, liftM2 ) -- | Read/interpret a date string, assuming UTC if timezone -- is not specified in the string readUTCDate :: String -> CalendarTime readUTCDate = readDate 0 -- | Convert a date string into ISO 8601 format (yyyymmdd variant) -- assuming local timezone if not specified in the string cleanLocalDate :: String -> String cleanLocalDate = cleanDate (unsafePerformIO getLocalTz) -- | Read/interpret a date string, assuming local timezone if not -- specified in the string readLocalDate :: String -> CalendarTime readLocalDate = readDate (unsafePerformIO getLocalTz) -- | Return the local timezone offset from UTC in seconds getLocalTz :: IO Int getLocalTz = ctTZ `liftM` (getClockTime >>= toCalendarTime) cleanDate :: Int -> String -> String cleanDate tz d = showIsoDateTime.resetCalendar $ readDate tz d readDate :: Int -> String -> CalendarTime readDate tz d = case parseDate tz d of Left e -> error $ "bad date: "++d++" - "++show e Right ct -> resetCalendar $ unsafeToCalendarTime ct parseDate :: Int -> String -> Either ParseError MCalendarTime parseDate tz d = if length d >= 14 && and (map isDigit $ take 14 d) then Right $ toMCalendarTime $ 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 tz; eof; return x } in parse dt "" d 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 :: Int -> CharParser a MCalendarTime date_time tz = choice [try $ toMCalendarTime `fmap` cvs_date_time tz, try $ iso8601_date_time tz, toMCalendarTime `fmap` old_date_time] cvs_date_time :: Int -> CharParser a CalendarTime cvs_date_time tz = do y <- year char '/' mon <- month_num char '/' d <- day my_spaces h <- hour char ':' m <- minute char ':' s <- second z <- option tz $ 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 MCalendarTime iso8601_date_time localTz = try $ do d <- iso8601_date t <- option id $ try $ do optional $ oneOf " T" iso8601_time return $ t $ d { mctTZ = Just localTz } iso8601_date :: CharParser a MCalendarTime iso8601_date = do d <- calendar_date <|> week_date <|> ordinal_date return $ foldr ($) nullMCalendar 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 mwd <- option Nothing $ do { optional dash; Just `fmap` n_digits 1 } let y = resetCalendar . unsafeToCalendarTime . yfn $ nullMCalendar { mctDay = Just 1 } 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' yday = (7 * w) + fromMaybe 1 mwd diff c = c { mctWeek = True , mctWDay = toEnum `fmap` mwd , mctDay = Just yday } return [(diff.yfn)] ordinal_date = -- yyyy-ddd try $ optchain year_ [ (dash, yearDay_) ] -- year_ = try $ do y <- four_digits "year (0000-9999)" return $ \c -> c { mctYear = Just y } month_ = try $ do m <- two_digits "month (1 to 12)" return $ \c -> c { mctMonth = Just $ intToMonth m } day_ = try $ do d <- two_digits "day in month (1 to 31)" return $ \c -> c { mctDay = Just d } yearDay_ = try $ do d <- n_digits 3 "day in year (001 to 366)" return $ \c -> c { mctDay = Just d , mctYDay = Just (d - 1) } dash = char '-' -- we return a function which sets the time on another calendar iso8601_time :: CharParser a (MCalendarTime -> MCalendarTime) 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 { mctHour = Just h } min_ = do m <- two_digits return $ \c -> c { mctMin = Just m } sec_ = do s <- two_digits return $ \c -> c { mctSec = Just 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 { mctPicosec = Just $ frac } zulu = do { char 'Z'; return (\c -> c { mctTZ = Just 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 { mctTZ = Just $ sign * 60 * ((h*60)+m) } colon = char ':' iso8601_interval :: Int -> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime)) 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 `subtractFromMCal` e, e) rightDur = do start <- isoDt char '/' durOrEnd <- Left `liftM` iso8601_duration <|> Right `liftM` isoDt return $ case durOrEnd of Left dur -> Right (start, dur `addToMCal` 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 $ fromMaybe id t $ ed -- tea time 2005-12-04 timeThenDate = try $ do t <- englishTime optional $ char ',' space ed <- englishDate now return $ t $ unsetTime $ ed englishDate :: CalendarTime -> CharParser a CalendarTime englishDate now = try $ (caseString "today" >> (return $ resetCalendar now)) <|> (caseString "yesterday" >> (return $ oneDay `subtractFromCal` now) ) <|> fst `fmap` englishLast now <|> englishAgo now where oneDay = TimeDiff 0 0 1 0 0 0 0 englishAgo :: CalendarTime -> CharParser a CalendarTime englishAgo 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 <|> fst `fmap` englishLast now <|> unsafeToCalendarTime `fmap` iso8601_date_time (ctTZ now) return (m,d) return $ multiplyDiff m p `addToCal` ref where beforeMod = try $ caseString "before" >> return (-1) afterMod = try $ caseString "after" >> return 1 englishInterval :: CalendarTime -> CharParser a (CalendarTime, CalendarTime) englishInterval now = twixt <|> before <|> after <|> inTheLast <|> lastetc where englishDT = (unsafeToCalendarTime `fmap` iso8601_date_time (ctTZ now) <|> englishDateTime now) before = try $ do caseString "before" space end <- englishDT return (theBeginning, 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) lastetc = do l <- englishAgo now return (l, now) englishLast :: CalendarTime -> CharParser a (CalendarTime, CalendarTime) englishLast now = -- last year, last week, last 3 years, etc try $ do caseString "last" space d <- englishDuration return (d `subtractFromCal` now, now) englishTime :: CharParser a (CalendarTime->CalendarTime) englishTime = try $ choice [ wrapM `fmap` 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 } wrapM f = unsafeToCalendarTime . f . toMCalendarTime -- 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 --------------------------------------------- theBeginning :: CalendarTime theBeginning = unsafePerformIO $ toCalendarTime $ TOD 0 0 -- | See 'System.Time.CalendarTime', but note the following new fields: -- 'mctWeek' data MCalendarTime = MCalendarTime { mctYear :: Maybe Int , mctMonth :: Maybe Month , mctDay :: Maybe Int , mctHour :: Maybe Int , mctMin :: Maybe Int , mctSec :: Maybe Int , mctPicosec :: Maybe Integer , mctWDay :: Maybe Day , mctYDay :: Maybe Int , mctTZName :: Maybe String , mctTZ :: Maybe Int , mctIsDST :: Maybe Bool , mctWeek :: Bool -- is set or not } deriving Show toMCalendarTime :: CalendarTime -> MCalendarTime toMCalendarTime (CalendarTime a b c d e f g h i j k l) = MCalendarTime (Just a) (Just b) (Just c) (Just d) (Just e) (Just f) (Just g) (Just h) (Just i) (Just j) (Just k) (Just l) False -- | Unsafe in that it plugs in default values for unset fields. -- See also 'resetCalendar' unsafeToCalendarTime :: MCalendarTime -> CalendarTime unsafeToCalendarTime m = CalendarTime { ctYear = fromMaybe 0 $ mctYear m , ctMonth = fromMaybe January $ mctMonth m , ctDay = fromMaybe 1 $ mctDay m , ctHour = fromMaybe 0 $ mctHour m , ctMin = fromMaybe 0 $ mctMin m , ctSec = fromMaybe 0 $ mctSec m , ctPicosec = fromMaybe 0 $ mctPicosec m , ctWDay = fromMaybe Sunday $ mctWDay m , ctYDay = fromMaybe 0 $ mctYDay m , ctTZName = fromMaybe "" $ mctTZName m , ctTZ = fromMaybe 0 $ mctTZ m , ctIsDST = fromMaybe False $ mctIsDST m } addToCal :: TimeDiff -> CalendarTime -> CalendarTime addToCal td = toUTCTime . addToClockTime td . toClockTime subtractFromCal :: TimeDiff -> CalendarTime -> CalendarTime subtractFromCal = addToCal . multiplyDiff (-1) addToMCal :: TimeDiff -> MCalendarTime -> MCalendarTime addToMCal td mc = copyCalendar (addToCal td $ unsafeToCalendarTime mc) mc subtractFromMCal :: TimeDiff -> MCalendarTime -> MCalendarTime subtractFromMCal = addToMCal . 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)) nullMCalendar :: MCalendarTime nullMCalendar = MCalendarTime Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing False -- | set a calendar to UTC time any eliminate any inconsistencies within -- (for example, where the weekday is given as "Thursday", but this does not -- match what the numerical date would lead one to expect) resetCalendar :: CalendarTime -> CalendarTime resetCalendar = toUTCTime . toClockTime copyCalendar :: CalendarTime -> MCalendarTime -> MCalendarTime copyCalendar c mc = mc { mctYear = mctYear mc >> Just (ctYear c) , mctMonth = mctMonth mc >> Just (ctMonth c) , mctDay = mctDay mc >> Just (ctDay c) , mctHour = mctHour mc >> Just (ctHour c) , mctMin = mctMin mc >> Just (ctMin c) , mctSec = mctSec mc >> Just (ctSec c) , mctPicosec = mctPicosec mc >> Just (ctPicosec c) , mctWDay = mctWDay mc >> Just (ctWDay c) , mctYDay = mctYDay mc >> Just (ctYDay c) , mctTZName = mctTZName mc >> Just (ctTZName c) , mctTZ = mctTZ mc >> Just (ctTZ c) , mctIsDST = mctIsDST mc >> Just (ctIsDST c) } unsetTime :: CalendarTime -> CalendarTime unsetTime mc = mc { ctHour = 0 , ctMin = 0 , ctSec = 0 , ctPicosec = 0 } \end{code}