{-# OPTIONS -fno-warn-orphans #-}
#include "HsConfigure.h"
module Data.Time.Format.Parse
(
#if LANGUAGE_Rank2Types
parseTimeM, parseTimeOrError, readSTime, readPTime,
parseTime, readTime, readsTime,
#endif
ParseTime(..),
module Data.Time.Format.Locale
) where
import Text.Read(readMaybe)
import Data.Time.Clock.Internal.UniversalTime
import Data.Time.Clock.POSIX
import Data.Time.Clock.Internal.UTCTime
import Data.Time.Calendar.Days
import Data.Time.Calendar.Gregorian
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar.Private(clipValid)
import Data.Time.LocalTime.Internal.TimeZone
import Data.Time.LocalTime.Internal.TimeOfDay
import Data.Time.LocalTime.Internal.LocalTime
import Data.Time.LocalTime.Internal.ZonedTime
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>),(<*>))
#endif
#if LANGUAGE_Rank2Types
import Control.Monad
#endif
import Data.Char
import Data.Fixed
import Data.List
import Data.Maybe
import Data.Ratio
import Data.Time.Format.Locale
#if LANGUAGE_Rank2Types
import Text.ParserCombinators.ReadP hiding (char, string)
#endif
#if LANGUAGE_Rank2Types
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
#endif
up :: String -> String
up = map toUpper
class ParseTime t where
buildTime :: TimeLocale
-> [(Char,String)]
-> Maybe t
#if LANGUAGE_Rank2Types
parseTimeM :: (Monad m,ParseTime t) =>
Bool
-> TimeLocale
-> String
-> String
-> m t
parseTimeM acceptWS l fmt s = case parseTimeList acceptWS l fmt s of
[t] -> return t
[] -> fail $ "parseTimeM: no parse of " ++ show s
_ -> fail $ "parseTimeM: multiple parses of " ++ show s
parseTimeOrError :: ParseTime t =>
Bool
-> TimeLocale
-> String
-> String
-> t
parseTimeOrError acceptWS l fmt s = case parseTimeList acceptWS l fmt s of
[t] -> t
[] -> error $ "parseTimeOrError: no parse of " ++ show s
_ -> error $ "parseTimeOrError: multiple parses of " ++ show s
parseTimeList :: ParseTime t =>
Bool
-> TimeLocale
-> String
-> String
-> [t]
parseTimeList False l fmt s = [t | (t,"") <- readSTime False l fmt s]
parseTimeList True l fmt s = [t | (t,r) <- readSTime True l fmt s, all isSpace r]
readSTime :: ParseTime t =>
Bool
-> TimeLocale
-> String
-> ReadS t
readSTime acceptWS l f = readP_to_S (readPTime acceptWS l f)
readPTime :: ParseTime t =>
Bool
-> TimeLocale
-> String
-> ReadP t
readPTime False l f = readPOnlyTime l f
readPTime True l f = (skipSpaces >> readPOnlyTime l f) <++ readPOnlyTime l f
readPOnlyTime :: ParseTime t =>
TimeLocale
-> String
-> ReadP t
readPOnlyTime l f = do
mt <- liftM (buildTime l) (parseInput l (parseFormat l f))
case mt of
Just t -> return t
Nothing -> pfail
{-# DEPRECATED parseTime "use \"parseTimeM True\" instead" #-}
parseTime :: ParseTime t =>
TimeLocale
-> String
-> String
-> Maybe t
parseTime = parseTimeM True
{-# DEPRECATED readTime "use \"parseTimeOrError True\" instead" #-}
readTime :: ParseTime t =>
TimeLocale
-> String
-> String
-> t
readTime = parseTimeOrError True
{-# DEPRECATED readsTime "use \"readSTime True\" instead" #-}
readsTime :: ParseTime t =>
TimeLocale
-> String
-> ReadS t
readsTime = readSTime True
data Padding = NoPadding | SpacePadding | ZeroPadding
deriving Show
type DateFormat = [DateFormatSpec]
data DateFormatSpec = Value (Maybe Padding) Char
| WhiteSpace
| Literal Char
deriving Show
parseFormat :: TimeLocale -> String -> DateFormat
parseFormat l = p
where p "" = []
p ('%': '-' : c :cs) = (pc (Just NoPadding) c) ++ p cs
p ('%': '_' : c :cs) = (pc (Just SpacePadding) c) ++ p cs
p ('%': '0' : c :cs) = (pc (Just ZeroPadding) c) ++ p cs
p ('%': c :cs) = (pc Nothing c) ++ p cs
p (c:cs) | isSpace c = WhiteSpace : p cs
p (c:cs) = Literal c : p cs
pc _ 'c' = p (dateTimeFmt l)
pc _ 'R' = p "%H:%M"
pc _ 'T' = p "%H:%M:%S"
pc _ 'X' = p (timeFmt l)
pc _ 'r' = p (time12Fmt l)
pc _ 'D' = p "%m/%d/%y"
pc _ 'F' = p "%Y-%m-%d"
pc _ 'x' = p (dateFmt l)
pc _ 'h' = p "%b"
pc _ '%' = [Literal '%']
pc mpad c = [Value mpad c]
parseInput :: TimeLocale -> DateFormat -> ReadP [(Char,String)]
parseInput _ [] = return []
parseInput l (Value mpad c:ff) = do
s <- parseValue l mpad c
r <- parseInput l ff
return ((c,s):r)
parseInput l (Literal c:ff) = do
_ <- char c
parseInput l ff
parseInput l (WhiteSpace:ff) = do
_ <- satisfy isSpace
case ff of
(WhiteSpace:_) -> return ()
_ -> skipSpaces
parseInput l ff
parseValue :: TimeLocale -> Maybe Padding -> Char -> ReadP String
parseValue l mpad c =
case c of
'C' -> digits SpacePadding 2
'f' -> digits SpacePadding 2
'Y' -> digits SpacePadding 4
'G' -> digits SpacePadding 4
'y' -> digits ZeroPadding 2
'g' -> digits ZeroPadding 2
'B' -> oneOf (map fst (months l))
'b' -> oneOf (map snd (months l))
'm' -> digits ZeroPadding 2
'd' -> digits ZeroPadding 2
'e' -> digits SpacePadding 2
'V' -> digits ZeroPadding 2
'U' -> digits ZeroPadding 2
'W' -> digits ZeroPadding 2
'u' -> oneOf $ map (:[]) ['1'..'7']
'a' -> oneOf (map snd (wDays l))
'A' -> oneOf (map fst (wDays l))
'w' -> oneOf $ map (:[]) ['0'..'6']
'j' -> digits ZeroPadding 3
'P' -> oneOf (let (am,pm) = amPm l in [am, pm])
'p' -> oneOf (let (am,pm) = amPm l in [am, pm])
'H' -> digits ZeroPadding 2
'k' -> digits SpacePadding 2
'I' -> digits ZeroPadding 2
'l' -> digits SpacePadding 2
'M' -> digits ZeroPadding 2
'S' -> digits ZeroPadding 2
'q' -> digits ZeroPadding 12
'Q' -> liftM2 (:) (char '.') (munch isDigit) <++ return ""
'z' -> numericTZ
'Z' -> munch1 isAlpha <++
numericTZ <++
return ""
's' -> (char '-' >> liftM ('-':) (munch1 isDigit))
<++ munch1 isDigit
_ -> fail $ "Unknown format character: " ++ show c
where
oneOf = choice . map string
digitsforce ZeroPadding n = count n (satisfy isDigit)
digitsforce SpacePadding _n = skipSpaces >> many1 (satisfy isDigit)
digitsforce NoPadding _n = many1 (satisfy isDigit)
digits pad = digitsforce (fromMaybe pad mpad)
numericTZ = do s <- choice [char '+', char '-']
h <- digitsforce ZeroPadding 2
optional (char ':')
m <- digitsforce ZeroPadding 2
return (s:h++m)
#endif
data DayComponent = Century Integer
| CenturyYear Integer
| YearMonth Int
| MonthDay Int
| YearDay Int
| WeekDay Int
| YearWeek WeekType Int
data WeekType = ISOWeek | SundayWeek | MondayWeek
instance ParseTime Day where
buildTime l = let
f :: Char -> String -> Maybe [DayComponent]
f c x = let
ra :: (Read a) => Maybe a
ra = readMaybe x
zeroBasedListIndex :: [String] -> Maybe Int
zeroBasedListIndex ss = elemIndex (up x) $ fmap up ss
oneBasedListIndex :: [String] -> Maybe Int
oneBasedListIndex ss = do
index <- zeroBasedListIndex ss
return $ 1 + index
in case c of
'C' -> do
a <- ra
return [Century a]
'f' -> do
a <- ra
return [Century a]
'Y' -> do
a <- ra
return [Century (a `div` 100), CenturyYear (a `mod` 100)]
'G' -> do
a <- ra
return [Century (a `div` 100), CenturyYear (a `mod` 100)]
'y' -> do
a <- ra
return [CenturyYear a]
'g' -> do
a <- ra
return [CenturyYear a]
'B' -> do
a <- oneBasedListIndex $ fmap fst $ months l
return [YearMonth a]
'b' -> do
a <- oneBasedListIndex $ fmap snd $ months l
return [YearMonth a]
'm' -> do
raw <- ra
a <- clipValid 1 12 raw
return [YearMonth a]
'd' -> do
raw <- ra
a <- clipValid 1 31 raw
return [MonthDay a]
'e' -> do
raw <- ra
a <- clipValid 1 31 raw
return [MonthDay a]
'V' -> do
raw <- ra
a <- clipValid 1 53 raw
return [YearWeek ISOWeek a]
'U' -> do
raw <- ra
a <- clipValid 0 53 raw
return [YearWeek SundayWeek a]
'W' -> do
raw <- ra
a <- clipValid 0 53 raw
return [YearWeek MondayWeek a]
'u' -> do
raw <- ra
a <- clipValid 1 7 raw
return [WeekDay a]
'a' -> do
a' <- zeroBasedListIndex $ fmap snd $ wDays l
let a = if a' == 0 then 7 else a'
return [WeekDay a]
'A' -> do
a' <- zeroBasedListIndex $ fmap fst $ wDays l
let a = if a' == 0 then 7 else a'
return [WeekDay a]
'w' -> do
raw <- ra
a' <- clipValid 0 6 raw
let a = if a' == 0 then 7 else a'
return [WeekDay a]
'j' -> do
raw <- ra
a <- clipValid 1 366 raw
return [YearDay a]
_ -> return []
buildDay :: [DayComponent] -> Maybe Day
buildDay cs = let
safeLast x xs = last (x:xs)
y = let
d = safeLast 70 [x | CenturyYear x <- cs]
c = safeLast (if d >= 69 then 19 else 20) [x | Century x <- cs]
in 100 * c + d
rest (YearMonth m:_) = let
d = safeLast 1 [x | MonthDay x <- cs]
in fromGregorianValid y m d
rest (YearDay d:_) = fromOrdinalDateValid y d
rest (YearWeek wt w:_) = let
d = safeLast 4 [x | WeekDay x <- cs]
in case wt of
ISOWeek -> fromWeekDateValid y w d
SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7)
MondayWeek -> fromMondayStartWeekValid y w d
rest (_:xs) = rest xs
rest [] = rest [YearMonth 1]
in rest cs
in \pairs -> do
components <- mapM (uncurry f) pairs
buildDay $ concat components
mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a
mfoldl f = let
mf ma b = do
a <- ma
f a b
in foldl mf
instance ParseTime TimeOfDay where
buildTime l = let
f t@(TimeOfDay h m s) (c,x) = let
ra :: (Read a) => Maybe a
ra = readMaybe x
getAmPm = let
upx = up x
(amStr,pmStr) = amPm l
in if upx == amStr
then Just $ TimeOfDay (h `mod` 12) m s
else if upx == pmStr
then Just $ TimeOfDay (if h < 12 then h + 12 else h) m s
else Nothing
in case c of
'P' -> getAmPm
'p' -> getAmPm
'H' -> do
a <- ra
return $ TimeOfDay a m s
'I' -> do
a <- ra
return $ TimeOfDay a m s
'k' -> do
a <- ra
return $ TimeOfDay a m s
'l' -> do
a <- ra
return $ TimeOfDay a m s
'M' -> do
a <- ra
return $ TimeOfDay h a s
'S' -> do
a <- ra
return $ TimeOfDay h m (fromInteger a)
'q' -> do
a <- ra
return $ TimeOfDay h m (mkPico (floor s) a)
'Q' -> if null x then Just t else do
ps <- readMaybe $ take 12 $ rpad 12 '0' $ drop 1 x
return $ TimeOfDay h m (mkPico (floor s) ps)
_ -> Just t
in mfoldl f (Just midnight)
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)
enumDiff :: (Enum a) => a -> a -> Int
enumDiff a b = (fromEnum a) - (fromEnum b)
getMilZoneHours :: Char -> Maybe Int
getMilZoneHours c | c < 'A' = Nothing
getMilZoneHours c | c <= 'I' = Just $ 1 + enumDiff c 'A'
getMilZoneHours 'J' = Nothing
getMilZoneHours c | c <= 'M' = Just $ 10 + enumDiff c 'K'
getMilZoneHours c | c <= 'Y' = Just $ (enumDiff 'N' c) - 1
getMilZoneHours 'Z' = Just 0
getMilZoneHours _ = Nothing
getMilZone :: Char -> Maybe TimeZone
getMilZone c = let
yc = toUpper c
in do
hours <- getMilZoneHours yc
return $ TimeZone (hours * 60) False [yc]
getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone
getKnownTimeZone locale x = find (\tz -> up x == timeZoneName tz) (knownTimeZones locale)
instance ParseTime TimeZone where
buildTime l = let
f (TimeZone _ dst name) ('z',x) | Just offset <- readTzOffset x = TimeZone offset dst name
f t ('Z',"") = t
f _ ('Z',x) | Just zone <- getKnownTimeZone l x = zone
f _ ('Z',[c]) | Just zone <- getMilZone c = zone
f (TimeZone offset dst _) ('Z',x) | isAlpha (head x) = TimeZone offset dst (up x)
f (TimeZone _ dst name) ('Z',x) | Just offset <- readTzOffset x = TimeZone offset dst name
f t _ = t
in Just . foldl f (minutesToTimeZone 0)
readTzOffset :: String -> Maybe Int
readTzOffset str = let
getSign '+' = Just 1
getSign '-' = Just (-1)
getSign _ = Nothing
calc s h1 h2 m1 m2 = do
sign <- getSign s
h <- readMaybe [h1,h2]
m <- readMaybe [m1,m2]
return $ sign * (60 * h + m)
in 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
_ -> Nothing
instance ParseTime ZonedTime where
buildTime l xs = let
f (ZonedTime (LocalTime _ tod) z) ('s',x) = do
a <- readMaybe x
let
s = fromInteger a
(_,ps) = properFraction (todSec tod) :: (Integer,Pico)
s' = s + fromRational (toRational ps)
return $ utcToZonedTime z (posixSecondsToUTCTime s')
f t _ = Just t
in mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs
instance ParseTime UTCTime where
buildTime l xs = zonedTimeToUTC <$> buildTime l xs
instance ParseTime UniversalTime where
buildTime l xs = localTimeToUT1 0 <$> buildTime l xs
#if LANGUAGE_Rank2Types
instance Read Day where
readsPrec _ = readParen False $ readSTime True defaultTimeLocale "%Y-%m-%d"
instance Read TimeOfDay where
readsPrec _ = readParen False $ readSTime True defaultTimeLocale "%H:%M:%S%Q"
instance Read LocalTime where
readsPrec _ = readParen False $ readSTime True defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q"
instance Read TimeZone where
readsPrec _ = readParen False $ readSTime True 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 ]
instance Read UniversalTime where
readsPrec n s = [ (localTimeToUT1 0 t, r) | (t,r) <- readsPrec n s ]
#endif