% 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; if not, write to the Free Software Foundation, % Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. \begin{code} module IsoDate ( getIsoDateTime, readDate, parseDate, 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 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 case parse date_time "" 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 [cvs_date_time, 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 return (CalendarTime y mon d h m s 0 Monday 0 "" 0 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) 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 = do y <- manyN 4 digit return (read y :: Int) month_num :: CharParser a Month month_num = do mn <- manyNtoM 1 2 digit mo <- return (read mn :: Int) case mo of 1 -> return January 2 -> return February 3 -> return March 4 -> return April 5 -> return May 6 -> return June 7 -> return July 8 -> return August 9 -> return September 10-> return October 11 -> return November 12 -> return December _ -> 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 = do r <- count 2 digit return (read r :: Int) minute :: CharParser a Int minute = do r <- count 2 digit return (read r :: Int) second :: CharParser a Int second = do r <- count 2 digit return (read r :: Int) 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'] } \end{code}