module Data.Time.Format.Parse
(
parseTime, readTime, readsTime,
ParseTime(..)
) where
import Data.Time.Clock.POSIX
import Data.Time.Clock
import Data.Time.Calendar
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Data.Time.LocalTime
import Control.Monad
import Data.Char
import Data.Fixed
import Data.List
import Data.Maybe
import Data.Ratio
import System.Locale
import Text.ParserCombinators.ReadP hiding (char, string)
char :: Char -> ReadP Char
char c = satisfy (\x -> toUpper c == toUpper x)
string :: String -> ReadP String
string this = do s <- look; scan this s
where
scan [] _ = do return this
scan (x:xs) (y:ys) | toUpper x == toUpper y = do get; scan xs ys
scan _ _ = do pfail
up :: String -> String
up = map toUpper
class ParseTime t where
buildTime :: TimeLocale
-> [(Char,String)]
-> t
parseTime :: ParseTime t =>
TimeLocale
-> String
-> String
-> Maybe t
parseTime l fmt s = case readsTime l fmt s of
[(t,r)] | all isSpace r -> Just t
_ -> Nothing
readTime :: ParseTime t =>
TimeLocale
-> String
-> String
-> t
readTime l fmt s = case readsTime l fmt s of
[(t,r)] | all isSpace r -> t
[(_,x)] -> error $ "readTime: junk at end of " ++ show x
_ -> error $ "readsTime: bad input " ++ show s
readsTime :: ParseTime t =>
TimeLocale
-> String
-> ReadS t
readsTime l f = readP_to_S (liftM (buildTime l) r)
where r = skipSpaces >> parseInput l (parseFormat l f)
type DateFormat = [DateFormatSpec]
data DateFormatSpec = Value Char
| WhiteSpace
| Literal Char
deriving Show
parseFormat :: TimeLocale -> String -> DateFormat
parseFormat l = p
where p "" = []
p ('%': c :cs) = s ++ p cs
where s = case c of
'c' -> p (dateTimeFmt l)
'R' -> p "%H:%M"
'T' -> p "%H:%M:%S"
'X' -> p (timeFmt l)
'r' -> p (time12Fmt l)
'D' -> p "%m/%d/%y"
'F' -> p "%Y-%m-%d"
'x' -> p (dateFmt l)
'h' -> p "%b"
'%' -> [Literal '%']
_ -> [Value c]
p (c:cs) | isSpace c = WhiteSpace : p cs
p (c:cs) = Literal c : p cs
parseInput :: TimeLocale -> DateFormat -> ReadP [(Char,String)]
parseInput l = liftM catMaybes . mapM p
where p (Value c) = parseValue l c >>= return . Just . (,) c
p WhiteSpace = skipSpaces >> return Nothing
p (Literal c) = char c >> return Nothing
parseValue :: TimeLocale -> Char -> ReadP String
parseValue l c =
case c of
'z' -> numericTZ
'Z' -> munch1 isAlpha <++
numericTZ <++
return ""
'P' -> oneOf (let (am,pm) = amPm l in [am, pm])
'p' -> oneOf (let (am,pm) = amPm l in [am, pm])
'H' -> digits 2
'I' -> digits 2
'k' -> spdigits 2
'l' -> spdigits 2
'M' -> digits 2
'S' -> digits 2
'q' -> digits 12
'Q' -> liftM2 (:) (char '.') (munch isDigit) <++ return ""
's' -> (char '-' >> liftM ('-':) (munch1 isDigit))
<++ munch1 isDigit
'Y' -> digits 4
'y' -> digits 2
'C' -> digits 2
'B' -> oneOf (map fst (months l))
'b' -> oneOf (map snd (months l))
'm' -> digits 2
'd' -> digits 2
'e' -> spdigits 2
'j' -> digits 3
'G' -> digits 4
'g' -> digits 2
'f' -> digits 2
'V' -> digits 2
'u' -> oneOf $ map (:[]) ['1'..'7']
'a' -> oneOf (map snd (wDays l))
'A' -> oneOf (map fst (wDays l))
'U' -> digits 2
'w' -> oneOf $ map (:[]) ['0'..'6']
'W' -> digits 2
_ -> fail $ "Unknown format character: " ++ show c
where
oneOf = choice . map string
digits n = count n (satisfy isDigit)
spdigits n = skipSpaces >> upTo n (satisfy isDigit)
upTo :: Int -> ReadP a -> ReadP [a]
upTo 0 _ = return []
upTo n x = liftM2 (:) x (upTo (n1) x) <++ return []
numericTZ = do s <- choice [char '+', char '-']
h <- digits 2
optional (char ':')
m <- digits 2
return (s:h++m)
data DayComponent = Year Integer
| Century Integer
| Month Int
| Day Int
| YearDay Int
| WeekDay Int
| Week WeekType Int
data WeekType = ISOWeek | SundayWeek | MondayWeek
instance ParseTime Day where
buildTime l = buildDay . concatMap (uncurry f)
where
f c x =
case c of
'Y' -> let y = read x in [Century (y `div` 100), Year (y `mod` 100)]
'y' -> [Year (read x)]
'C' -> [Century (read x)]
'B' -> [Month (1 + fromJust (elemIndex (up x) (map (up . fst) (months l))))]
'b' -> [Month (1 + fromJust (elemIndex (up x) (map (up . snd) (months l))))]
'm' -> [Month (read x)]
'd' -> [Day (read x)]
'e' -> [Day (read x)]
'j' -> [YearDay (read x)]
'G' -> let y = read x in [Century (y `div` 100), Year (y `mod` 100)]
'g' -> [Year (read x)]
'f' -> [Century (read x)]
'V' -> [Week ISOWeek (read x)]
'u' -> [WeekDay (read x)]
'a' -> [WeekDay (1 + (fromJust (elemIndex (up x) (map (up . snd) (wDays l))) + 6) `mod` 7)]
'A' -> [WeekDay (1 + (fromJust (elemIndex (up x) (map (up . fst) (wDays l))) + 6) `mod` 7)]
'U' -> [Week SundayWeek (read x)]
'w' -> [WeekDay (((read x + 6) `mod` 7) + 1)]
'W' -> [Week MondayWeek (read x)]
_ -> []
buildDay cs = rest cs
where
y = let c = safeLast 19 [x | Century x <- cs]
d = safeLast 70 [x | Year x <- cs]
in 100 * c + d
rest (Month m:_) = let d = safeLast 1 [x | Day x <- cs]
in fromGregorian y m d
rest (YearDay d:_) = fromOrdinalDate y d
rest (Week wt w:_) = let d = safeLast 4 [x | WeekDay x <- cs]
in case wt of
ISOWeek -> fromWeekDate y w d
SundayWeek -> fromSundayStartWeek y w (d `mod` 7)
MondayWeek -> fromMondayStartWeek y w d
rest (_:xs) = rest xs
rest [] = rest [Month 1]
safeLast x xs = last (x:xs)
instance ParseTime TimeOfDay where
buildTime l = foldl f midnight
where
f t@(TimeOfDay h m s) (c,x) =
case c of
'P' -> if up x == fst (amPm l) then am else pm
'p' -> if up x == fst (amPm l) then am else pm
'H' -> TimeOfDay (read x) m s
'I' -> TimeOfDay (read x) m s
'k' -> TimeOfDay (read x) m s
'l' -> TimeOfDay (read x) m s
'M' -> TimeOfDay h (read x) s
'S' -> TimeOfDay h m (fromInteger (read x))
'q' -> TimeOfDay h m (mkPico (truncate s) (read x))
'Q' -> if null x then t
else let ps = read $ take 12 $ rpad 12 '0' $ drop 1 x
in TimeOfDay h m (mkPico (truncate s) ps)
_ -> t
where am = TimeOfDay (h `mod` 12) m s
pm = TimeOfDay (if h < 12 then h + 12 else h) m s
rpad :: Int -> a -> [a] -> [a]
rpad n c xs = xs ++ replicate (n length xs) c
mkPico :: Integer -> Integer -> Pico
mkPico i f = fromInteger i + fromRational (f % 1000000000000)
instance ParseTime LocalTime where
buildTime l xs = LocalTime (buildTime l xs) (buildTime l xs)
instance ParseTime TimeZone where
buildTime _ = foldl f (minutesToTimeZone 0)
where
f t@(TimeZone offset dst name) (c,x) =
case c of
'z' -> zone
'Z' | null x -> t
| isAlpha (head x) -> let y = up x in
case lookup y _TIMEZONES_ of
Just (offset', dst') -> TimeZone offset' dst' y
Nothing -> TimeZone offset dst y
| otherwise -> zone
_ -> t
where zone = TimeZone (readTzOffset x) dst name
instance ParseTime ZonedTime where
buildTime l xs = foldl f (ZonedTime (buildTime l xs) (buildTime l xs)) xs
where
f t@(ZonedTime (LocalTime _ tod) z) (c,x) =
case c of
's' -> let s = fromInteger (read x)
(_,ps) = properFraction (todSec tod) :: (Integer,Pico)
s' = s + fromRational (toRational ps)
in utcToZonedTime z (posixSecondsToUTCTime s')
_ -> t
instance ParseTime UTCTime where
buildTime l = zonedTimeToUTC . buildTime l
instance Read Day where
readsPrec _ = readParen False $ readsTime defaultTimeLocale "%Y-%m-%d"
instance Read TimeOfDay where
readsPrec _ = readParen False $ readsTime defaultTimeLocale "%H:%M:%S%Q"
instance Read LocalTime where
readsPrec _ = readParen False $ readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q"
instance Read TimeZone where
readsPrec _ = readParen False $ readsTime defaultTimeLocale "%Z"
instance Read ZonedTime where
readsPrec n = readParen False $ \s ->
[(ZonedTime t z, r2) | (t,r1) <- readsPrec n s, (z,r2) <- readsPrec n r1]
instance Read UTCTime where
readsPrec n s = [ (zonedTimeToUTC t, r) | (t,r) <- readsPrec n s ]
readTzOffset :: String -> Int
readTzOffset str =
case str of
(s:h1:h2:':':m1:m2:[]) -> calc s h1 h2 m1 m2
(s:h1:h2:m1:m2:[]) -> calc s h1 h2 m1 m2
_ -> 0
where calc s h1 h2 m1 m2 = sign * (60 * h + m)
where sign = if s == '-' then 1 else 1
h = read [h1,h2]
m = read [m1,m2]
_TIMEZONES_ :: [(String, (Int, Bool))]
_TIMEZONES_ =
[("NZDT", (readTzOffset "+13:00", True))
,("IDLE", (readTzOffset "+12:00", False))
,("NZST", (readTzOffset "+12:00", False))
,("NZT", (readTzOffset "+12:00", False))
,("AESST", (readTzOffset "+11:00", False))
,("ACSST", (readTzOffset "+10:30", False))
,("CADT", (readTzOffset "+10:30", True))
,("SADT", (readTzOffset "+10:30", True))
,("AEST", (readTzOffset "+10:00", False))
,("EAST", (readTzOffset "+10:00", False))
,("GST", (readTzOffset "+10:00", False))
,("LIGT", (readTzOffset "+10:00", False))
,("SAST", (readTzOffset "+09:30", False))
,("CAST", (readTzOffset "+09:30", False))
,("AWSST", (readTzOffset "+09:00", False))
,("JST", (readTzOffset "+09:00", False))
,("KST", (readTzOffset "+09:00", False))
,("MHT", (readTzOffset "+09:00", False))
,("WDT", (readTzOffset "+09:00", True))
,("MT", (readTzOffset "+08:30", False))
,("AWST", (readTzOffset "+08:00", False))
,("CCT", (readTzOffset "+08:00", False))
,("WADT", (readTzOffset "+08:00", True))
,("WST", (readTzOffset "+08:00", False))
,("JT", (readTzOffset "+07:30", False))
,("ALMST", (readTzOffset "+07:00", False))
,("WAST", (readTzOffset "+07:00", False))
,("CXT", (readTzOffset "+07:00", False))
,("MMT", (readTzOffset "+06:30", False))
,("ALMT", (readTzOffset "+06:00", False))
,("MAWT", (readTzOffset "+06:00", False))
,("IOT", (readTzOffset "+05:00", False))
,("MVT", (readTzOffset "+05:00", False))
,("TFT", (readTzOffset "+05:00", False))
,("AFT", (readTzOffset "+04:30", False))
,("EAST", (readTzOffset "+04:00", False))
,("MUT", (readTzOffset "+04:00", False))
,("RET", (readTzOffset "+04:00", False))
,("SCT", (readTzOffset "+04:00", False))
,("IRT", (readTzOffset "+03:30", False))
,("IT", (readTzOffset "+03:30", False))
,("EAT", (readTzOffset "+03:00", False))
,("BT", (readTzOffset "+03:00", False))
,("EETDST", (readTzOffset "+03:00", True))
,("HMT", (readTzOffset "+03:00", False))
,("BDST", (readTzOffset "+02:00", False))
,("CEST", (readTzOffset "+02:00", False))
,("CETDST", (readTzOffset "+02:00", True))
,("EET", (readTzOffset "+02:00", False))
,("FWT", (readTzOffset "+02:00", False))
,("IST", (readTzOffset "+02:00", False))
,("MEST", (readTzOffset "+02:00", False))
,("METDST", (readTzOffset "+02:00", True))
,("SST", (readTzOffset "+02:00", False))
,("BST", (readTzOffset "+01:00", False))
,("CET", (readTzOffset "+01:00", False))
,("DNT", (readTzOffset "+01:00", False))
,("FST", (readTzOffset "+01:00", False))
,("MET", (readTzOffset "+01:00", False))
,("MEWT", (readTzOffset "+01:00", False))
,("MEZ", (readTzOffset "+01:00", False))
,("NOR", (readTzOffset "+01:00", False))
,("SET", (readTzOffset "+01:00", False))
,("SWT", (readTzOffset "+01:00", False))
,("WETDST", (readTzOffset "+01:00", True))
,("GMT", (readTzOffset "+00:00", False))
,("UT", (readTzOffset "+00:00", False))
,("UTC", (readTzOffset "+00:00", False))
,("Z", (readTzOffset "+00:00", False))
,("ZULU", (readTzOffset "+00:00", False))
,("WET", (readTzOffset "+00:00", False))
,("WAT", (readTzOffset "-01:00", False))
,("FNST", (readTzOffset "-01:00", False))
,("FNT", (readTzOffset "-02:00", False))
,("BRST", (readTzOffset "-02:00", False))
,("NDT", (readTzOffset "-02:30", True))
,("ADT", (readTzOffset "-03:00", True))
,("AWT", (readTzOffset "-03:00", False))
,("BRT", (readTzOffset "-03:00", False))
,("NFT", (readTzOffset "-03:30", False))
,("NST", (readTzOffset "-03:30", False))
,("AST", (readTzOffset "-04:00", False))
,("ACST", (readTzOffset "-04:00", False))
,("EDT", (readTzOffset "-04:00", True))
,("ACT", (readTzOffset "-05:00", False))
,("CDT", (readTzOffset "-05:00", True))
,("EST", (readTzOffset "-05:00", False))
,("CST", (readTzOffset "-06:00", False))
,("MDT", (readTzOffset "-06:00", True))
,("MST", (readTzOffset "-07:00", False))
,("PDT", (readTzOffset "-07:00", True))
,("AKDT", (readTzOffset "-08:00", True))
,("PST", (readTzOffset "-08:00", False))
,("YDT", (readTzOffset "-08:00", True))
,("AKST", (readTzOffset "-09:00", False))
,("HDT", (readTzOffset "-09:00", True))
,("YST", (readTzOffset "-09:00", False))
,("MART", (readTzOffset "-09:30", False))
,("AHST", (readTzOffset "-10:00", False))
,("HST", (readTzOffset "-10:00", False))
,("CAT", (readTzOffset "-10:00", False))
,("NT", (readTzOffset "-11:00", False))
,("IDLW", (readTzOffset "-12:00", False))
]