content: {-# OPTIONS -fno-warn-orphans #-}
  #include "HsConfigure.h"
  
  -- #hide
  module Data.Time.Format.Parse
      (
      -- * UNIX-style parsing
  #if LANGUAGE_Rank2Types
      parseTimeM, parseTimeOrError, readSTime, readPTime,
      parseTime, readTime, readsTime,
  #endif
      ParseTime(..),
      -- * Locale
      module Data.Time.Format.Locale
      ) 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
  
  #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
  -- | Case-insensitive version of 'Text.ParserCombinators.ReadP.char'.
  char :: Char -> ReadP Char
  char c = satisfy (\x -> toUpper c == toUpper x)
  -- | Case-insensitive version of 'Text.ParserCombinators.ReadP.string'.
  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
  -- | Convert string to upper case.
  up :: String -> String
  up = map toUpper
  
  
  -- | The class of types which can be parsed given a UNIX-style time format
  -- string.
  class ParseTime t where
      -- | Builds a time value from a parsed input string.
      -- If the input does not include all the information needed to
      -- construct a complete value, any missing parts should be taken
      -- from 1970-01-01 00:00:00 +0000 (which was a Thursday).
      -- In the absence of @%C@ or @%Y@, century is 1969 - 2068.
      buildTime :: TimeLocale -- ^ The time locale.
                -> [(Char,String)] -- ^ Pairs of format characters and the
                                   -- corresponding part of the input.
                -> t
  
  #if LANGUAGE_Rank2Types
  -- | Parses a time value given a format string.
  -- Supports the same %-codes as 'formatTime', including @%-@, @%_@ and @%0@ modifiers.
  -- Case is not significant.
  -- Some variations in the input are accepted:
  --
  -- [@%z@] accepts any of @-HHMM@ or @-HH:MM@.
  --
  -- [@%Z@] 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.
  --
  parseTimeM :: (Monad m,ParseTime t) =>
               Bool       -- ^ Accept leading and trailing whitespace?
            -> TimeLocale -- ^ Time locale.
            -> String     -- ^ Format string.
            -> String     -- ^ Input string.
            -> m t    -- ^ Return the time value, or fail if the input could
                          -- not be parsed using the given format.
  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
  
  -- | 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 =>
               Bool       -- ^ Accept leading and trailing whitespace?
            -> TimeLocale -- ^ Time locale.
            -> String     -- ^ Format string.
            -> String     -- ^ Input string.
            -> t          -- ^ The time value.
  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       -- ^ Accept leading and trailing whitespace?
            -> TimeLocale -- ^ Time locale.
            -> String     -- ^ Format string
            -> String     -- ^ Input 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]
  
  -- | Parse a time value given a format string.  See 'parseTimeM' for details.
  readSTime :: ParseTime t =>
               Bool       -- ^ Accept leading whitespace?
            -> TimeLocale -- ^ Time locale.
            -> String     -- ^ Format string
            -> ReadS t
  readSTime acceptWS l f = readP_to_S (readPTime acceptWS l f)
  
  -- | Parse a time value given a format string.  See 'parseTimeM' for details.
  readPTime :: ParseTime t =>
               Bool       -- ^ Accept leading whitespace?
            -> TimeLocale -- ^ Time locale.
            -> String     -- ^ Format string
            -> ReadP t
  readPTime False l f = readPOnlyTime l f
  readPTime True l f = (skipSpaces >> readPOnlyTime l f) <++ readPOnlyTime l f
  
  -- | Parse a time value given a format string (without allowing leading whitespace).  See 'parseTimeM' for details.
  readPOnlyTime :: ParseTime t =>
               TimeLocale -- ^ Time locale.
            -> String     -- ^ Format string
            -> ReadP t
  readPOnlyTime l f = liftM (buildTime l) (parseInput l (parseFormat l f))
  
  {-# DEPRECATED parseTime "use \"parseTimeM True\" instead" #-}
  parseTime :: ParseTime t =>
               TimeLocale -- ^ Time locale.
            -> String     -- ^ Format string.
            -> String     -- ^ Input string.
            -> Maybe t    -- ^ The time value, or 'Nothing' if the input could
                          -- not be parsed using the given format.
  parseTime = parseTimeM True
  
  {-# DEPRECATED readTime "use \"parseTimeOrError True\" instead" #-}
  readTime :: ParseTime t =>
              TimeLocale -- ^ Time locale.
           -> String     -- ^ Format string.
           -> String     -- ^ Input string.
           -> t          -- ^ The time value.
  readTime = parseTimeOrError True
  
  {-# DEPRECATED readsTime "use \"readSTime True\" instead" #-}
  readsTime :: ParseTime t =>
               TimeLocale -- ^ Time locale.
            -> String     -- ^ Format string
            -> ReadS t
  readsTime = readSTime True
  
  
  --
  -- * Internals
  --
  
  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
  
  -- | Get the string corresponding to the given format specifier.
  parseValue :: TimeLocale -> Maybe Padding -> Char -> ReadP String
  parseValue l mpad c =
      case c of
        -- century
        'C' -> digits SpacePadding 2
        'f' -> digits SpacePadding 2
  
        -- year
        'Y' -> digits SpacePadding 4
        'G' -> digits SpacePadding 4
  
        -- year of century
        'y' -> digits ZeroPadding 2
        'g' -> digits ZeroPadding 2
  
        -- month of year
        'B' -> oneOf (map fst (months l))
        'b' -> oneOf (map snd (months l))
        'm' -> digits ZeroPadding 2
  
        -- day of month
        'd' -> digits ZeroPadding 2
        'e' -> digits SpacePadding 2
  
        -- week of year
        'V' -> digits ZeroPadding 2
        'U' -> digits ZeroPadding 2
        'W' -> digits ZeroPadding 2
  
        -- day of week
        'u' -> oneOf $ map (:[]) ['1'..'7']
        'a' -> oneOf (map snd (wDays l))
        'A' -> oneOf (map fst (wDays l))
        'w' -> oneOf $ map (:[]) ['0'..'6']
  
        -- day of year
        'j' -> digits ZeroPadding 3
  
        -- dayhalf of day (i.e. AM or PM)
        'P' -> oneOf (let (am,pm) = amPm l in [am, pm])
        'p' -> oneOf (let (am,pm) = amPm l in [am, pm])
  
        -- hour of day (i.e. 24h)
        'H' -> digits ZeroPadding 2
        'k' -> digits SpacePadding 2
  
        -- hour of dayhalf (i.e. 12h)
        'I' -> digits ZeroPadding 2
        'l' -> digits SpacePadding 2
  
        -- minute of hour
        'M' -> digits ZeroPadding 2
  
        -- second of minute
        'S' -> digits ZeroPadding 2
  
        -- picosecond of second
        'q' -> digits ZeroPadding 12
        'Q' -> liftM2 (:) (char '.') (munch isDigit) <++ return ""
  
        -- time zone
        'z' -> numericTZ
        'Z' -> munch1 isAlpha <++
               numericTZ <++
               return "" -- produced by %Z for LocalTime
  
        -- seconds since epoch
        '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
  
  --
  -- * Instances for the time package types
  --
  
  data DayComponent = Century Integer -- century of all years
                    | CenturyYear Integer -- 0-99, last two digits of both real years and week years
                    | YearMonth Int -- 1-12
                    | MonthDay Int -- 1-31
                    | YearDay Int -- 1-366
                    | WeekDay Int -- 1-7 (mon-sun)
                    | YearWeek WeekType Int -- 1-53 or 0-53
  
  data WeekType = ISOWeek | SundayWeek | MondayWeek
  
  instance ParseTime Day where
      buildTime l = buildDay . concatMap (uncurry f)
       where
        f c x =
          case c of
            -- %C: century (all but the last two digits of the year), 00 - 99
            'C' -> [Century (read x)]
            -- %f century (all but the last two digits of the year), 00 - 99
            'f' -> [Century (read x)]
            -- %Y: year
            'Y' -> let y = read x in [Century (y `div` 100), CenturyYear (y `mod` 100)]
            -- %G: year for Week Date format
            'G' -> let y = read x in [Century (y `div` 100), CenturyYear (y `mod` 100)]
            -- %y: last two digits of year, 00 - 99
            'y' -> [CenturyYear (read x)]
            -- %g: last two digits of year for Week Date format, 00 - 99
            'g' -> [CenturyYear (read x)]
            -- %B: month name, long form (fst from months locale), January - December
            'B' -> [YearMonth (1 + fromJust (elemIndex (up x) (map (up . fst) (months l))))]
            -- %b: month name, short form (snd from months locale), Jan - Dec
            'b' -> [YearMonth (1 + fromJust (elemIndex (up x) (map (up . snd) (months l))))]
            -- %m: month of year, leading 0 as needed, 01 - 12
            'm' -> [YearMonth (read x)]
            -- %d: day of month, leading 0 as needed, 01 - 31
            'd' -> [MonthDay (read x)]
            -- %e: day of month, leading space as needed, 1 - 31
            'e' -> [MonthDay (read x)]
            -- %V: week for Week Date format, 01 - 53
            'V' -> [YearWeek ISOWeek (read x)]
            -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 01 - 53
            'U' -> [YearWeek SundayWeek (read x)]
            -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 01 - 53
            'W' -> [YearWeek MondayWeek (read x)]
            -- %u: day for Week Date format, 1 - 7
            'u' -> [WeekDay (read x)]
            -- %a: day of week, short form (snd from wDays locale), Sun - Sat
            'a' -> [WeekDay (1 + (fromJust (elemIndex (up x) (map (up . snd) (wDays l))) + 6) `mod` 7)]
            -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday
            'A' -> [WeekDay (1 + (fromJust (elemIndex (up x) (map (up . fst) (wDays l))) + 6) `mod` 7)]
            -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday)
            'w' -> [WeekDay (((read x + 6) `mod` 7) + 1)]
            -- %j: day of year for Ordinal Date format, 001 - 366
            'j' -> [YearDay (read x)]
            _   -> []
  
        buildDay cs = rest cs
          where
          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 fromGregorian y m d
          rest (YearDay d:_) = fromOrdinalDate y d
          rest (YearWeek 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 [YearMonth 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)
  
  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
  
  instance ParseTime TimeZone where
      buildTime l = 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 find (\tz -> y == timeZoneName tz) (knownTimeZones l) of
                          Just tz -> tz
                          Nothing -> case y of
                              [yc] | Just hours <- getMilZoneHours yc -> TimeZone (hours * 60) False y
                              _ -> TimeZone offset dst y
                    | otherwise        -> zone
                _   -> t
            where zone = TimeZone (readTzOffset x) dst name
  
  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]
  
  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
  
  -- * Read instances for time package types
  
  #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 ]
  #endif
  
  