MissingH-0.18.2: src/System/Time/ParseDate.hs
{- |
Module : System.Time.ParseDate
Copyright : (c) by Björn Bringert
License : GPL2
Maintainer : Björn Bringert
Stability : provisional
Portability : portable
Utility for parsing dates.
-}
module System.Time.ParseDate (parseCalendarTime) where
import Control.Monad
import Data.Char (isSpace)
import Data.List (elemIndex)
import Data.Maybe (fromJust)
import System.Locale
import System.Time
import Text.ParserCombinators.Parsec
-- | Parse a date string as formatted by 'formatCalendarTime'.
--
-- The resulting 'CalendarTime' will only have those fields set that
-- are represented by a format specifier in the format string, and those
-- fields will be set to the values given in the date string.
-- If the same field is specified multiple times, the rightmost
-- occurence takes precedence.
--
-- The resulting date is not neccessarily a valid date. For example,
-- if there is no day of the week specifier in the format string,
-- the value of 'ctWDay' will most likely be invalid.
--
-- Format specifiers are % followed by some character. All other
-- characters are treated literally. Whitespace in the format string
-- matches zero or more arbitrary whitespace characters.
--
-- Format specifiers marked with * are matched, but do not set any
-- field in the output.
--
-- Some of the format specifiers are marked as space-padded or
-- zero-padded. Regardless of this, space-padded, zero-padded
-- or unpadded inputs are accepted. Note that strings using
-- unpadded fields without separating the fields may cause
-- strange parsing.
--
-- Supported format specfiers:
--
-- [%%] a % character.
--
-- [%a] locale's abbreviated weekday name (Sun ... Sat)
--
-- [%A] locale's full weekday name (Sunday .. Saturday)
--
-- [%b] locale's abbreviated month name (Jan..Dec)
--
-- [%B] locale's full month name (January..December)
--
-- [%c] locale's date and time format (Thu Mar 25 17:47:03 CET 2004)
--
-- [%C] century [00-99]
--
-- [%d] day of month, zero padded (01..31)
--
-- [%D] date (%m\/%d\/%y)
--
-- [%e] day of month, space padded ( 1..31)
--
-- [%h] same as %b
--
-- [%H] hour, 24-hour clock, zero padded (00..23)
--
-- [%I] hour, 12-hour clock, zero padded (01..12)
--
-- [%j] day of the year, zero padded (001..366)
--
-- [%k] hour, 24-hour clock, space padded ( 0..23)
--
-- [%l] hour, 12-hour clock, space padded ( 1..12)
--
-- [%m] month, zero padded (01..12)
--
-- [%M] minute, zero padded (00..59)
--
-- [%n] a newline character
--
-- [%p] locale's AM or PM indicator
--
-- [%r] locale's 12-hour time format (hh:mm:ss AM\/PM)
--
-- [%R] hours and minutes, 24-hour clock (hh:mm)
--
-- [%s] * seconds since '00:00:00 1970-01-01 UTC'
--
-- [%S] seconds, zero padded (00..59)
--
-- [%t] a horizontal tab character
--
-- [%T] time, 24-hour clock (hh:mm:ss)
--
-- [%u] numeric day of the week (1=Monday, 7=Sunday)
--
-- [%U] * week number, weeks starting on Sunday, zero padded (01-53)
--
-- [%V] * week number (as per ISO-8601),
-- week 1 is the first week with a Thursday,
-- zero padded, (01-53)
--
-- [%w] numeric day of the week, (0=Sunday, 6=Monday)
--
-- [%W] * week number, weeks starting on Monday, zero padded (01-53)
--
-- [%x] locale's preferred way of printing dates (%m\/%d\/%y)
--
-- [%X] locale's preferred way of printing time. (%H:%M:%S)
--
-- [%y] year, within century, zero padded (00..99)
--
-- [%Y] year, including century. Not padded
-- (this is probably a bug, but formatCalendarTime does
-- it this way). (0-9999)
--
-- [%Z] time zone abbreviation (e.g. CET) or RFC-822 style numeric
-- timezone (-0500)
parseCalendarTime ::
TimeLocale -- ^ Time locale
-> String -- ^ Date format
-> String -- ^ String to parse
-> Maybe CalendarTime -- ^ 'Nothing' if parsing failed.
parseCalendarTime l fmt s =
case runParser parser epoch "<date string>" s of
Left err -> Nothing
Right p -> Just p
where parser = pCalendarTime l fmt >> getState
-- FIXME: verify input
-- FIXME: years outside 1000-9999 probably don't work
-- FIXME: what about extra whitespace in input?
-- FIXME: set ctYDay
-- FIXME: set ctIsDST
-- FIXME: missing formats from GNU date(1):
-- %F same as %Y-%m-%d
-- %g the 2-digit year corresponding to the %V week number
-- %G the 4-digit year corresponding to the %V week number
-- %N nanoseconds (000000000..999999999)
-- %P locale's lower case am or pm indicator (blank in many locales)
-- %z RFC-822 style numeric timezone (-0500) (a nonstandard extension)
pCalendarTime :: TimeLocale -> String -> GenParser Char CalendarTime ()
pCalendarTime l fmt = doFmt fmt
where
-- not padded
-- FIXME: implement
doFmt ('%':'-':cs) = doFmt ('%':cs)
-- space padded
-- FIXME: implement
doFmt ('%':'_':cs) = doFmt ('%':cs)
doFmt ('%':c:cs) = decode c >> doFmt cs
doFmt (c:cs) = char c >> doFmt cs
doFmt "" = return ()
decode '%' = char '%' >> return ()
decode 'a' = (parseEnum $ map snd $ wDays l) >>= setWDay
decode 'A' = (parseEnum $ map fst $ wDays l) >>= setWDay
decode 'b' = (parseEnum $ map snd $ months l) >>= setMonth
decode 'B' = (parseEnum $ map fst $ months l) >>= setMonth
decode 'c' = doFmt (dateTimeFmt l)
decode 'C' = read2 >>= \c -> updateYear (\y -> c * 100 + y `rem` 100)
decode 'd' = read2 >>= \day -> if day > 31 || day < 1
then fail $ "Invalid day " ++ (show day)
else setDay day
decode 'D' = doFmt "%m/%d/%y"
decode 'e' = read2 >>= setDay
decode 'h' = decode 'b'
decode 'H' = read2 >>= setHour
decode 'I' = read2 >>= setHour12
decode 'j' = read3 >>= setYDay
decode 'k' = read2 >>= setHour
decode 'l' = read2 >>= setHour12
decode 'm' = read2 >>= \mon -> if (mon-1) > fromEnum (maxBound :: Month)
then fail $ "Invalid month " ++ (show mon)
else setMonth (toEnum (mon-1))
decode 'M' = read2 >>= setMin
-- FIXME: strptime(3) accepts "arbitrary whitespace" for %n
decode 'n' = char '\n' >> return ()
decode 'p' = do
x <- (string am >> return 0) <|> (string pm >> return 12)
updateHour (\h -> x + h `rem` 12)
where (am,pm) = amPm l
decode 'r' = doFmt (time12Fmt l)
decode 'R' = doFmt "%H:%M"
-- FIXME: implement %s.
-- FIXME: implement %s in formatCalendarTime
decode 's' = int >> return ()
decode 'S' = read2 >>= setSec
-- FIXME: strptime(3) accepts "arbitrary whitespace" for %t
decode 't' = char '\t' >> return ()
decode 'T' = doFmt "%H:%M:%S"
decode 'u' = readN 1 >>= setWDay . toEnum . (\w -> if w == 7 then 0 else w)
-- FIXME: implement %U.
decode 'U' = read2 >> return ()
-- FIXME: implement %V.
decode 'V' = read2 >> return ()
decode 'w' = readN 1 >>= setWDay . toEnum
-- FIXME: implement %W.
decode 'W' = read2 >> return ()
decode 'x' = doFmt (dateFmt l)
decode 'X' = doFmt (timeFmt l)
-- FIXME: should probably be zero padded,
-- need to change formatCalendarTime too
decode 'Y' = int >>= setYear
-- FIXME: maybe 04 should be 2004, not 1904?
decode 'y' = read2 >>= \c -> updateYear (\y -> (y `quot` 100) * 100 + c)
-- FIXME: are timezone names always [A-Z]+ ?
-- FIXME: set ctTZ when parsing timezone name and
-- ctTZName when parsing offset
decode 'Z' = tzname <|> tzoffset
where tzname = many1 (oneOf ['A'..'Z']) >>= setTZName
tzoffset = do
s <- sign
h <- read2
m <- read2
setTZ (s * (h * 3600 + m * 60))
-- following the example of strptime(3),
-- whitespace matches zero or more whitespace
-- characters in the input string
decode c | isSpace c = spaces >> return ()
decode c = char c >> return ()
epoch :: CalendarTime
epoch = CalendarTime {
ctYear = 1970,
ctMonth = January,
ctDay = 1,
ctHour = 0,
ctMin = 0,
ctSec = 0,
ctPicosec = 0,
ctWDay = Thursday,
ctYDay = 1,
ctTZName = "UTC",
ctTZ = 0,
ctIsDST = False
}
parseEnum :: Enum a => [String] -> CharParser st a
parseEnum ss = choice (zipWith tryString ss (enumFrom (toEnum 0)))
where tryString s x = try (string s) >> return x
setYear x = updateState (\t -> t{ ctYear = x })
setMonth x = updateState (\t -> t{ ctMonth = x })
setDay x = updateState (\t -> t{ ctDay = x })
setHour x = updateState (\t -> t{ ctHour = x })
setMin x = updateState (\t -> t{ ctMin = x })
setSec x = updateState (\t -> t{ ctSec = x })
setWDay x = updateState (\t -> t{ ctWDay = x })
setYDay x = updateState (\t -> t{ ctYDay = x })
setTZName x = updateState (\t -> t{ ctTZName = x })
setTZ x = updateState (\t -> t{ ctTZ = x })
updateYear f = updateState (\t -> t{ ctYear = f (ctYear t) })
updateHour f = updateState (\t -> t{ ctHour = f (ctHour t) })
setHour12 x = updateHour (\h -> (h `quot` 12) * 12 + from12 x)
where from12 h = if h == 12 then 0 else h
read2, read3 :: GenParser Char st Int
read2 = readN 2
read3 = readN 3
-- | Read up to a given number of digits, optionally left-padded
-- with whitespace and interpret them as an 'Int'.
readN :: Int -> GenParser Char st Int
readN n =
liftM read (spaces >> choice [try (count m digit) | m <- [n,n-1..1]])
int :: GenParser Char st Int
int = liftM read (many1 digit)
sign :: GenParser Char st Int
sign = (char '+' >> return 1) <|> (char '-' >> return (-1))