{-# LANGUAGE Safe #-}

{-# OPTIONS -fno-warn-orphans #-}

module Data.Time.Format.Parse (
    -- * UNIX-style parsing
    parseTimeM,
    parseTimeMultipleM,
    parseTimeOrError,
    readSTime,
    readPTime,
    ParseTime (),

    -- * Locale
    module Data.Time.Format.Locale,
) where

import Control.Applicative ((<|>))
import Control.Monad.Fail
import Data.Char
import Data.Proxy
import Data.Time.Calendar.Days
import Data.Time.Clock.Internal.UTCTime
import Data.Time.Clock.Internal.UniversalTime
import Data.Time.Format.Locale
import Data.Time.Format.Parse.Class
import Data.Time.Format.Parse.Instances ()
import Data.Time.LocalTime.Internal.LocalTime
import Data.Time.LocalTime.Internal.TimeOfDay
import Data.Time.LocalTime.Internal.TimeZone
import Data.Time.LocalTime.Internal.ZonedTime
import Data.Traversable
import Text.ParserCombinators.ReadP hiding (char, string)
import Prelude hiding (fail)

-- | Parses a time value given a format string.
-- Missing information will be derived from 1970-01-01 00:00 UTC (which was a Thursday).
-- Supports the same %-codes as 'formatTime', including @%-@, @%_@ and @%0@ modifiers, however padding widths are not supported.
-- Case is not significant in the input string.
-- Some variations in the input are accepted:
--
-- [@%z@ @%Ez@] accepts any of @±HHMM@ or @±HH:MM@.
--
-- [@%Z@ @%EZ@] accepts any string of letters, or any of the formats accepted by @%z@.
--
-- [@%0Y@] accepts exactly four digits.
--
-- [@%0G@] accepts exactly four digits.
--
-- [@%0C@] accepts exactly two digits.
--
-- [@%0f@] accepts exactly two digits.
--
-- For example, to parse a date in YYYY-MM-DD format, while allowing the month
-- and date to have optional leading zeros (notice the @-@ modifier used for @%m@
-- and @%d@):
--
-- > Prelude Data.Time> parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2010-3-04" :: Maybe Day
-- > Just 2010-03-04
parseTimeM ::
    (MonadFail m, ParseTime t) =>
    -- | Accept leading and trailing whitespace?
    Bool ->
    -- | Time locale.
    TimeLocale ->
    -- | Format string.
    String ->
    -- | Input string.
    String ->
    -- | Return the time value, or fail if the input could not be parsed using the given format.
    m t
parseTimeM :: forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
acceptWS TimeLocale
l String
fmt String
s = Bool -> TimeLocale -> [(String, String)] -> m t
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [(String, String)] -> m t
parseTimeMultipleM Bool
acceptWS TimeLocale
l [(String
fmt, String
s)]

-- | Parses a time value given a list of pairs of format and input.
-- Resulting value is constructed from all provided specifiers.
parseTimeMultipleM' ::
    (MonadFail m, ParseTime t) =>
    Proxy t ->
    -- | Accept leading and trailing whitespace?
    Bool ->
    -- | Time locale.
    TimeLocale ->
    -- | Pairs of (format string, input string).
    [(String, String)] ->
    -- | Return the time value, or fail if the input could not be parsed using the given format.
    m t
parseTimeMultipleM' :: forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Proxy t -> Bool -> TimeLocale -> [(String, String)] -> m t
parseTimeMultipleM' Proxy t
pt Bool
acceptWS TimeLocale
l [(String, String)]
fmts = do
    specss <- [(String, String)]
-> ((String, String) -> m [(Char, String)]) -> m [[(Char, String)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(String, String)]
fmts (((String, String) -> m [(Char, String)]) -> m [[(Char, String)]])
-> ((String, String) -> m [(Char, String)]) -> m [[(Char, String)]]
forall a b. (a -> b) -> a -> b
$ \(String
fmt, String
s) -> Proxy t
-> Bool -> TimeLocale -> String -> String -> m [(Char, String)]
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Proxy t
-> Bool -> TimeLocale -> String -> String -> m [(Char, String)]
parseTimeSpecifiersM Proxy t
pt Bool
acceptWS TimeLocale
l String
fmt String
s
    case buildTime l $ mconcat specss of
        Just t
t -> t -> m t
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return t
t
        Maybe t
Nothing -> String -> m t
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parseTimeM: cannot construct"

-- | Parses a time value given a list of pairs of format and input.
-- Resulting value is constructed from all provided specifiers.
parseTimeMultipleM ::
    (MonadFail m, ParseTime t) =>
    -- | Accept leading and trailing whitespace?
    Bool ->
    -- | Time locale.
    TimeLocale ->
    -- | Pairs of (format string, input string).
    [(String, String)] ->
    -- | Return the time value, or fail if the input could not be parsed using the given format.
    m t
parseTimeMultipleM :: forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [(String, String)] -> m t
parseTimeMultipleM = Proxy t -> Bool -> TimeLocale -> [(String, String)] -> m t
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Proxy t -> Bool -> TimeLocale -> [(String, String)] -> m t
parseTimeMultipleM' Proxy t
forall {k} (t :: k). Proxy t
Proxy

-- | Parse a time value given a format string. Fails if the input could
-- not be parsed using the given format. See 'parseTimeM' for details.
parseTimeOrError ::
    ParseTime t =>
    -- | Accept leading and trailing whitespace?
    Bool ->
    -- | Time locale.
    TimeLocale ->
    -- | Format string.
    String ->
    -- | Input string.
    String ->
    -- | The time value.
    t
parseTimeOrError :: forall t.
ParseTime t =>
Bool -> TimeLocale -> String -> String -> t
parseTimeOrError Bool
acceptWS TimeLocale
l String
fmt String
s =
    case Bool -> TimeLocale -> String -> String -> [t]
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
acceptWS TimeLocale
l String
fmt String
s of
        [t
t] -> t
t
        [] -> String -> t
forall a. HasCallStack => String -> a
error (String -> t) -> String -> t
forall a b. (a -> b) -> a -> b
$ String
"parseTimeOrError: no parse of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s
        [t]
_ -> String -> t
forall a. HasCallStack => String -> a
error (String -> t) -> String -> t
forall a b. (a -> b) -> a -> b
$ String
"parseTimeOrError: multiple parses of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s

parseTimeSpecifiersM ::
    (MonadFail m, ParseTime t) =>
    Proxy t ->
    -- | Accept leading and trailing whitespace?
    Bool ->
    -- | Time locale.
    TimeLocale ->
    -- | Format string
    String ->
    -- | Input string.
    String ->
    m [(Char, String)]
parseTimeSpecifiersM :: forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Proxy t
-> Bool -> TimeLocale -> String -> String -> m [(Char, String)]
parseTimeSpecifiersM Proxy t
pt Bool
acceptWS TimeLocale
l String
fmt String
s =
    case Proxy t
-> Bool -> TimeLocale -> String -> String -> [[(Char, String)]]
forall t.
ParseTime t =>
Proxy t
-> Bool -> TimeLocale -> String -> String -> [[(Char, String)]]
parseTimeSpecifiers Proxy t
pt Bool
acceptWS TimeLocale
l String
fmt String
s of
        [[(Char, String)]
t] -> [(Char, String)] -> m [(Char, String)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Char, String)]
t
        [] -> String -> m [(Char, String)]
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m [(Char, String)]) -> String -> m [(Char, String)]
forall a b. (a -> b) -> a -> b
$ String
"parseTimeM: no parse of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s
        [[(Char, String)]]
_ -> String -> m [(Char, String)]
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m [(Char, String)]) -> String -> m [(Char, String)]
forall a b. (a -> b) -> a -> b
$ String
"parseTimeM: multiple parses of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s

parseTimeSpecifiers ::
    ParseTime t =>
    Proxy t ->
    -- | Accept leading and trailing whitespace?
    Bool ->
    -- | Time locale.
    TimeLocale ->
    -- | Format string
    String ->
    -- | Input string.
    String ->
    [[(Char, String)]]
parseTimeSpecifiers :: forall t.
ParseTime t =>
Proxy t
-> Bool -> TimeLocale -> String -> String -> [[(Char, String)]]
parseTimeSpecifiers Proxy t
pt Bool
False TimeLocale
l String
fmt String
s = [[(Char, String)]
t | ([(Char, String)]
t, String
"") <- ReadP [(Char, String)] -> ReadS [(Char, String)]
forall a. ReadP a -> ReadS a
readP_to_S (Proxy t -> Bool -> TimeLocale -> String -> ReadP [(Char, String)]
forall t.
ParseTime t =>
Proxy t -> Bool -> TimeLocale -> String -> ReadP [(Char, String)]
readPSpecifiers Proxy t
pt Bool
False TimeLocale
l String
fmt) String
s]
parseTimeSpecifiers Proxy t
pt Bool
True TimeLocale
l String
fmt String
s = [[(Char, String)]
t | ([(Char, String)]
t, String
r) <- ReadP [(Char, String)] -> ReadS [(Char, String)]
forall a. ReadP a -> ReadS a
readP_to_S (Proxy t -> Bool -> TimeLocale -> String -> ReadP [(Char, String)]
forall t.
ParseTime t =>
Proxy t -> Bool -> TimeLocale -> String -> ReadP [(Char, String)]
readPSpecifiers Proxy t
pt Bool
True TimeLocale
l String
fmt) String
s, (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
r]

-- | Parse a time value given a format string.  See 'parseTimeM' for details.
readSTime ::
    ParseTime t =>
    -- | Accept leading whitespace?
    Bool ->
    -- | Time locale.
    TimeLocale ->
    -- | Format string
    String ->
    ReadS t
readSTime :: forall t. ParseTime t => Bool -> TimeLocale -> String -> ReadS t
readSTime Bool
acceptWS TimeLocale
l String
f = ReadP t -> ReadS t
forall a. ReadP a -> ReadS a
readP_to_S (ReadP t -> ReadS t) -> ReadP t -> ReadS t
forall a b. (a -> b) -> a -> b
$ Bool -> TimeLocale -> String -> ReadP t
forall t. ParseTime t => Bool -> TimeLocale -> String -> ReadP t
readPTime Bool
acceptWS TimeLocale
l String
f

readPSpecifiers ::
    ParseTime t =>
    Proxy t ->
    -- | Accept leading whitespace?
    Bool ->
    -- | Time locale.
    TimeLocale ->
    -- | Format string
    String ->
    ReadP [(Char, String)]
readPSpecifiers :: forall t.
ParseTime t =>
Proxy t -> Bool -> TimeLocale -> String -> ReadP [(Char, String)]
readPSpecifiers Proxy t
pt Bool
False TimeLocale
l String
f = Proxy t -> TimeLocale -> String -> ReadP [(Char, String)]
forall t.
ParseTime t =>
Proxy t -> TimeLocale -> String -> ReadP [(Char, String)]
parseSpecifiers Proxy t
pt TimeLocale
l String
f
readPSpecifiers Proxy t
pt Bool
True TimeLocale
l String
f = (ReadP ()
skipSpaces ReadP () -> ReadP [(Char, String)] -> ReadP [(Char, String)]
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Proxy t -> TimeLocale -> String -> ReadP [(Char, String)]
forall t.
ParseTime t =>
Proxy t -> TimeLocale -> String -> ReadP [(Char, String)]
parseSpecifiers Proxy t
pt TimeLocale
l String
f) ReadP [(Char, String)]
-> ReadP [(Char, String)] -> ReadP [(Char, String)]
forall a. ReadP a -> ReadP a -> ReadP a
<++ Proxy t -> TimeLocale -> String -> ReadP [(Char, String)]
forall t.
ParseTime t =>
Proxy t -> TimeLocale -> String -> ReadP [(Char, String)]
parseSpecifiers Proxy t
pt TimeLocale
l String
f

-- | Parse a time value given a format string.  See 'parseTimeM' for details.
readPTime' ::
    ParseTime t =>
    Proxy t ->
    -- | Accept leading whitespace?
    Bool ->
    -- | Time locale.
    TimeLocale ->
    -- | Format string
    String ->
    ReadP t
readPTime' :: forall t.
ParseTime t =>
Proxy t -> Bool -> TimeLocale -> String -> ReadP t
readPTime' Proxy t
pt Bool
ws TimeLocale
l String
f = do
    pairs <- Proxy t -> Bool -> TimeLocale -> String -> ReadP [(Char, String)]
forall t.
ParseTime t =>
Proxy t -> Bool -> TimeLocale -> String -> ReadP [(Char, String)]
readPSpecifiers Proxy t
pt Bool
ws TimeLocale
l String
f
    case buildTime l pairs of
        Just t
t -> t -> ReadP t
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return t
t
        Maybe t
Nothing -> ReadP t
forall a. ReadP a
pfail

-- | Parse a time value given a format string.  See 'parseTimeM' for details.
readPTime ::
    ParseTime t =>
    -- | Accept leading whitespace?
    Bool ->
    -- | Time locale.
    TimeLocale ->
    -- | Format string
    String ->
    ReadP t
readPTime :: forall t. ParseTime t => Bool -> TimeLocale -> String -> ReadP t
readPTime = Proxy t -> Bool -> TimeLocale -> String -> ReadP t
forall t.
ParseTime t =>
Proxy t -> Bool -> TimeLocale -> String -> ReadP t
readPTime' Proxy t
forall {k} (t :: k). Proxy t
Proxy

-- * Read instances for time package types

instance Read Day where
    readsPrec :: Int -> ReadS Day
readsPrec Int
_ = Bool -> ReadS Day -> ReadS Day
forall a. Bool -> ReadS a -> ReadS a
readParen Bool
False (ReadS Day -> ReadS Day) -> ReadS Day -> ReadS Day
forall a b. (a -> b) -> a -> b
$ Bool -> TimeLocale -> String -> ReadS Day
forall t. ParseTime t => Bool -> TimeLocale -> String -> ReadS t
readSTime Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%d"

instance Read TimeOfDay where
    readsPrec :: Int -> ReadS TimeOfDay
readsPrec Int
_ = Bool -> ReadS TimeOfDay -> ReadS TimeOfDay
forall a. Bool -> ReadS a -> ReadS a
readParen Bool
False (ReadS TimeOfDay -> ReadS TimeOfDay)
-> ReadS TimeOfDay -> ReadS TimeOfDay
forall a b. (a -> b) -> a -> b
$ Bool -> TimeLocale -> String -> ReadS TimeOfDay
forall t. ParseTime t => Bool -> TimeLocale -> String -> ReadS t
readSTime Bool
True TimeLocale
defaultTimeLocale String
"%H:%M:%S%Q"

instance Read LocalTime where
    readsPrec :: Int -> ReadS LocalTime
readsPrec Int
_ = Bool -> ReadS LocalTime -> ReadS LocalTime
forall a. Bool -> ReadS a -> ReadS a
readParen Bool
False (ReadS LocalTime -> ReadS LocalTime)
-> ReadS LocalTime -> ReadS LocalTime
forall a b. (a -> b) -> a -> b
$ Bool -> TimeLocale -> String -> ReadS LocalTime
forall t. ParseTime t => Bool -> TimeLocale -> String -> ReadS t
readSTime Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%d %H:%M:%S%Q"

-- | This only works for @±HHMM@ format,
-- single-letter military time-zones,
-- and these time-zones: \"UTC\", \"UT\", \"GMT\", \"EST\", \"EDT\", \"CST\", \"CDT\", \"MST\", \"MDT\", \"PST\", \"PDT\",
-- per RFC 822 section 5.
instance Read TimeZone where
    readsPrec :: Int -> ReadS TimeZone
readsPrec Int
_ = Bool -> ReadS TimeZone -> ReadS TimeZone
forall a. Bool -> ReadS a -> ReadS a
readParen Bool
False (ReadS TimeZone -> ReadS TimeZone)
-> ReadS TimeZone -> ReadS TimeZone
forall a b. (a -> b) -> a -> b
$ Bool -> TimeLocale -> String -> ReadS TimeZone
forall t. ParseTime t => Bool -> TimeLocale -> String -> ReadS t
readSTime Bool
True TimeLocale
defaultTimeLocale String
"%Z"

-- | This only works for a 'zonedTimeZone' in @±HHMM@ format,
-- single-letter military time-zones,
-- and these time-zones: \"UTC\", \"UT\", \"GMT\", \"EST\", \"EDT\", \"CST\", \"CDT\", \"MST\", \"MDT\", \"PST\", \"PDT\",
-- per RFC 822 section 5.
instance Read ZonedTime where
    readsPrec :: Int -> ReadS ZonedTime
readsPrec Int
n = Bool -> ReadS ZonedTime -> ReadS ZonedTime
forall a. Bool -> ReadS a -> ReadS a
readParen Bool
False (ReadS ZonedTime -> ReadS ZonedTime)
-> ReadS ZonedTime -> ReadS ZonedTime
forall a b. (a -> b) -> a -> b
$ \String
s -> [(LocalTime -> TimeZone -> ZonedTime
ZonedTime LocalTime
t TimeZone
z, String
r2) | (LocalTime
t, String
r1) <- Int -> ReadS LocalTime
forall a. Read a => Int -> ReadS a
readsPrec Int
n String
s, (TimeZone
z, String
r2) <- Int -> ReadS TimeZone
forall a. Read a => Int -> ReadS a
readsPrec Int
n String
r1]

instance Read UTCTime where
    readsPrec :: Int -> ReadS UTCTime
readsPrec Int
n String
s = do
        (lt, s') <- Int -> ReadS LocalTime
forall a. Read a => Int -> ReadS a
readsPrec Int
n String
s
        (tz, s'') <- readsPrec n s' <|> pure (utc, s')
        return (localTimeToUTC tz lt, s'')

instance Read UniversalTime where
    readsPrec :: Int -> ReadS UniversalTime
readsPrec Int
n String
s = [(Rational -> LocalTime -> UniversalTime
localTimeToUT1 Rational
0 LocalTime
t, String
r) | (LocalTime
t, String
r) <- Int -> ReadS LocalTime
forall a. Read a => Int -> ReadS a
readsPrec Int
n String
s]