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

-- #hide
module Data.Time.Format.Parse 
    (
    -- * UNIX-style parsing
    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)


-- | 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
-- | 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

-- | 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)

--
-- * 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

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_ =
    -- 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))
    ]