{-# OPTIONS -fno-warn-orphans #-}
#include "HsConfigure.h"

-- #hide
module Data.Time.Format.Parse 
    (
    -- * UNIX-style parsing
#if LANGUAGE_Rank2Types
    parseTime, readTime, readsTime,
#endif
    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

#if LANGUAGE_Rank2Types
import Control.Monad
#endif
import Data.Char
import Data.Fixed
import Data.List
import Data.Maybe
import Data.Ratio
import System.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).
    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'. Leading and trailing whitespace is accepted. 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@.
--
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 l fmt s = case readsTime l fmt s of
                      [(t,r)] | all isSpace r -> Just t
                      _        -> Nothing

-- | Parse a time value given a format string. Fails if the input could
-- not be parsed using the given format. See 'parseTime' for details.
readTime :: ParseTime t =>
            TimeLocale -- ^ Time locale.
         -> String     -- ^ Format string.
         -> String     -- ^ Input string.
         -> t          -- ^ The time value.
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

-- | Parse a time value given a format string.  See 'parseTime' for details.
readsTime :: ParseTime t =>
             TimeLocale -- ^ Time locale.
          -> String     -- ^ Format string
          -> ReadS t
readsTime l f = readP_to_S (liftM (buildTime l) r)
  where r = skipSpaces >> parseInput l (parseFormat l f)

--
-- * Internals
--

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

-- | Get the string corresponding to the given format specifier.
parseValue :: TimeLocale -> Char -> ReadP String
parseValue l c = 
    case c of
      'z' -> numericTZ
      'Z' -> munch1 isAlpha <++
             numericTZ <++
             return "" -- produced by %Z for LocalTime
      '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 (n-1) x) <++ return []
    numericTZ = do s <- choice [char '+', char '-']
                   h <- digits 2
                   optional (char ':')
                   m <- digits 2
                   return (s:h++m)
#endif

--
-- * Instances for the time package types
--

data DayComponent = Year Integer -- 0-99, last two digits of both real years and week years
                  | Century Integer -- century of all years
                  | Month Int -- 1-12
                  | Day Int -- 1-31
                  | YearDay Int -- 1-366
                  | WeekDay Int -- 1-7 (mon-sun)
                  | Week 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
          -- %Y: year
          'Y' -> let y = read x in [Century (y `div` 100), Year (y `mod` 100)]
          -- %y: last two digits of year, 00 - 99
          'y' -> [Year (read x)]
          -- %C: century (being the first two digits of the year), 00 - 99
          'C' -> [Century (read x)]
          -- %B: month name, long form (fst from months locale), January - December
          'B' -> [Month (1 + fromJust (elemIndex (up x) (map (up . fst) (months l))))]
          -- %b: month name, short form (snd from months locale), Jan - Dec
          'b' -> [Month (1 + fromJust (elemIndex (up x) (map (up . snd) (months l))))]
          -- %m: month of year, leading 0 as needed, 01 - 12
          'm' -> [Month (read x)]
          -- %d: day of month, leading 0 as needed, 01 - 31
          'd' -> [Day (read x)]
          -- %e: day of month, leading space as needed, 1 - 31
          'e' -> [Day (read x)]
          -- %j: day of year for Ordinal Date format, 001 - 366
          'j' -> [YearDay (read x)]
          -- %G: year for Week Date format
          'G' -> let y = read x in [Century (y `div` 100), Year (y `mod` 100)]
          -- %g: last two digits of year for Week Date format, 00 - 99
          'g' -> [Year (read x)]
          -- %f century (first two digits of year) for Week Date format, 00 - 99
          'f' -> [Century (read x)]
          -- %V: week for Week Date format, 01 - 53
          'V' -> [Week ISOWeek (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)]
          -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 01 - 53
          'U' -> [Week SundayWeek (read x)]
          -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday)
          'w' -> [WeekDay (((read x + 6) `mod` 7) + 1)]
          -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 01 - 53
          '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

-- * Read instances for time package types

#if LANGUAGE_Rank2Types
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 ]
#endif

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_ =
    -- New Zealand Daylight-Saving Time
    [("NZDT",    (readTzOffset "+13:00", True))
    -- International Date Line, East
    ,("IDLE",    (readTzOffset "+12:00", False))
    -- New Zealand Standard Time
    ,("NZST",    (readTzOffset "+12:00", False))
    -- New Zealand Time
    ,("NZT",     (readTzOffset "+12:00", False))
    -- Australia Eastern Summer Standard Time
    ,("AESST",   (readTzOffset "+11:00", False))
    -- Central Australia Summer Standard Time
    ,("ACSST",   (readTzOffset "+10:30", False))
    -- Central Australia Daylight-Saving Time
    ,("CADT",    (readTzOffset "+10:30", True))
    -- South Australian Daylight-Saving Time
    ,("SADT",    (readTzOffset "+10:30", True))
    -- Australia Eastern Standard Time
    ,("AEST",    (readTzOffset "+10:00", False))
    -- East Australian Standard Time
    ,("EAST",    (readTzOffset "+10:00", False))
    -- Guam Standard Time, Russia zone 9
    ,("GST",     (readTzOffset "+10:00", False))
    -- Melbourne, Australia
    ,("LIGT",    (readTzOffset "+10:00", False))
    -- South Australia Standard Time
    ,("SAST",    (readTzOffset "+09:30", False))
    -- Central Australia Standard Time
    ,("CAST",    (readTzOffset "+09:30", False))
    -- Australia Western Summer Standard Time
    ,("AWSST",   (readTzOffset "+09:00", False))
    -- Japan Standard Time, Russia zone 8
    ,("JST",     (readTzOffset "+09:00", False))
    -- Korea Standard Time
    ,("KST",     (readTzOffset "+09:00", False))
    -- Kwajalein Time
    ,("MHT",     (readTzOffset "+09:00", False))
    -- West Australian Daylight-Saving Time
    ,("WDT",     (readTzOffset "+09:00", True))
    -- Moluccas Time
    ,("MT",      (readTzOffset "+08:30", False))
    -- Australia Western Standard Time
    ,("AWST",    (readTzOffset "+08:00", False))
    -- China Coastal Time
    ,("CCT",     (readTzOffset "+08:00", False))
    -- West Australian Daylight-Saving Time
    ,("WADT",    (readTzOffset "+08:00", True))
    -- West Australian Standard Time
    ,("WST",     (readTzOffset "+08:00", False))
    -- Java Time
    ,("JT",      (readTzOffset "+07:30", False))
    -- Almaty Summer Time
    ,("ALMST",   (readTzOffset "+07:00", False))
    -- West Australian Standard Time
    ,("WAST",    (readTzOffset "+07:00", False))
    -- Christmas (Island) Time
    ,("CXT",     (readTzOffset "+07:00", False))
    -- Myanmar Time
    ,("MMT",     (readTzOffset "+06:30", False))
    -- Almaty Time
    ,("ALMT",    (readTzOffset "+06:00", False))
    -- Mawson (Antarctica) Time
    ,("MAWT",    (readTzOffset "+06:00", False))
    -- Indian Chagos Time
    ,("IOT",     (readTzOffset "+05:00", False))
    -- Maldives Island Time
    ,("MVT",     (readTzOffset "+05:00", False))
    -- Kerguelen Time
    ,("TFT",     (readTzOffset "+05:00", False))
    -- Afghanistan Time
    ,("AFT",     (readTzOffset "+04:30", False))
    -- Antananarivo Summer Time
    ,("EAST",    (readTzOffset "+04:00", False))
    -- Mauritius Island Time
    ,("MUT",     (readTzOffset "+04:00", False))
    -- Reunion Island Time
    ,("RET",     (readTzOffset "+04:00", False))
    -- Mahe Island Time
    ,("SCT",     (readTzOffset "+04:00", False))
    -- Iran Time
    ,("IRT",     (readTzOffset "+03:30", False))
    -- Iran Time
    ,("IT",      (readTzOffset "+03:30", False))
    -- Antananarivo, Comoro Time
    ,("EAT",     (readTzOffset "+03:00", False))
    -- Baghdad Time
    ,("BT",      (readTzOffset "+03:00", False))
    -- Eastern Europe Daylight-Saving Time
    ,("EETDST",  (readTzOffset "+03:00", True))
    -- Hellas Mediterranean Time (?)
    ,("HMT",     (readTzOffset "+03:00", False))
    -- British Double Summer Time
    ,("BDST",    (readTzOffset "+02:00", False))
    -- Central European Summer Time
    ,("CEST",    (readTzOffset "+02:00", False))
    -- Central European Daylight-Saving Time
    ,("CETDST",  (readTzOffset "+02:00", True))
    -- Eastern European Time, Russia zone 1
    ,("EET",     (readTzOffset "+02:00", False))
    -- French Winter Time
    ,("FWT",     (readTzOffset "+02:00", False))
    -- Israel Standard Time
    ,("IST",     (readTzOffset "+02:00", False))
    -- Middle European Summer Time
    ,("MEST",    (readTzOffset "+02:00", False))
    -- Middle Europe Daylight-Saving Time
    ,("METDST",  (readTzOffset "+02:00", True))
    -- Swedish Summer Time
    ,("SST",     (readTzOffset "+02:00", False))
    -- British Summer Time
    ,("BST",     (readTzOffset "+01:00", False))
    -- Central European Time
    ,("CET",     (readTzOffset "+01:00", False))
    -- Dansk Normal Tid
    ,("DNT",     (readTzOffset "+01:00", False))
    -- French Summer Time
    ,("FST",     (readTzOffset "+01:00", False))
    -- Middle European Time
    ,("MET",     (readTzOffset "+01:00", False))
    -- Middle European Winter Time
    ,("MEWT",    (readTzOffset "+01:00", False))
    -- Mitteleuropaeische Zeit
    ,("MEZ",     (readTzOffset "+01:00", False))
    -- Norway Standard Time
    ,("NOR",     (readTzOffset "+01:00", False))
    -- Seychelles Time
    ,("SET",     (readTzOffset "+01:00", False))
    -- Swedish Winter Time
    ,("SWT",     (readTzOffset "+01:00", False))
    -- Western European Daylight-Saving Time
    ,("WETDST",  (readTzOffset "+01:00", True))
    --  Greenwich Mean Time
    ,("GMT",     (readTzOffset "+00:00", False))
    --  Universal Time
    ,("UT",      (readTzOffset "+00:00", False))
    --  Universal Coordinated Time
    ,("UTC",     (readTzOffset "+00:00", False))
    --  Same as UTC
    ,("Z",       (readTzOffset "+00:00", False))
    --  Same as UTC
    ,("ZULU",    (readTzOffset "+00:00", False))
    --  Western European Time
    ,("WET",     (readTzOffset "+00:00", False))
    -- West Africa Time
    ,("WAT",     (readTzOffset "-01:00", False))
    -- Fernando de Noronha Summer Time
    ,("FNST",    (readTzOffset "-01:00", False))
    -- Fernando de Noronha Time
    ,("FNT",     (readTzOffset "-02:00", False))
    -- Brasilia Summer Time
    ,("BRST",    (readTzOffset "-02:00", False))
    -- Newfoundland Daylight-Saving Time
    ,("NDT",     (readTzOffset "-02:30", True))
    -- Atlantic Daylight-Saving Time
    ,("ADT",     (readTzOffset "-03:00", True))
    -- (unknown)
    ,("AWT",     (readTzOffset "-03:00", False))
    -- Brasilia Time
    ,("BRT",     (readTzOffset "-03:00", False))
    -- Newfoundland Standard Time
    ,("NFT",     (readTzOffset "-03:30", False))
    -- Newfoundland Standard Time
    ,("NST",     (readTzOffset "-03:30", False))
    -- Atlantic Standard Time (Canada)
    ,("AST",     (readTzOffset "-04:00", False))
    -- Atlantic/Porto Acre Summer Time
    ,("ACST",    (readTzOffset "-04:00", False))
    -- Eastern Daylight-Saving Time
    ,("EDT",     (readTzOffset "-04:00", True))
    -- Atlantic/Porto Acre Standard Time
    ,("ACT",     (readTzOffset "-05:00", False))
    -- Central Daylight-Saving Time
    ,("CDT",     (readTzOffset "-05:00", True))
    -- Eastern Standard Time
    ,("EST",     (readTzOffset "-05:00", False))
    -- Central Standard Time
    ,("CST",     (readTzOffset "-06:00", False))
    -- Mountain Daylight-Saving Time
    ,("MDT",     (readTzOffset "-06:00", True))
    -- Mountain Standard Time
    ,("MST",     (readTzOffset "-07:00", False))
    -- Pacific Daylight-Saving Time
    ,("PDT",     (readTzOffset "-07:00", True))
    -- Alaska Daylight-Saving Time
    ,("AKDT",    (readTzOffset "-08:00", True))
    -- Pacific Standard Time
    ,("PST",     (readTzOffset "-08:00", False))
    -- Yukon Daylight-Saving Time
    ,("YDT",     (readTzOffset "-08:00", True))
    -- Alaska Standard Time
    ,("AKST",    (readTzOffset "-09:00", False))
    -- Hawaii/Alaska Daylight-Saving Time
    ,("HDT",     (readTzOffset "-09:00", True))
    -- Yukon Standard Time
    ,("YST",     (readTzOffset "-09:00", False))
    -- Marquesas Time
    ,("MART",    (readTzOffset "-09:30", False))
    -- Alaska/Hawaii Standard Time
    ,("AHST",    (readTzOffset "-10:00", False))
    -- Hawaii Standard Time
    ,("HST",     (readTzOffset "-10:00", False))
    -- Central Alaska Time
    ,("CAT",     (readTzOffset "-10:00", False))
    -- Nome Time
    ,("NT",      (readTzOffset "-11:00", False))
    -- International Date Line, West
    ,("IDLW",    (readTzOffset "-12:00", False))
    ]