    -- Copyright (C) 2003 Peter Simons
    -- Copyright (C) 2003,2008 David Roundy
    --
    -- This program is free software; you can redistribute it and/or modify
    -- it under the terms of the GNU General Public License as published by
    -- the Free Software Foundation; either version 2, or (at your option)
    -- any later version.
    --
    -- This program is distributed in the hope that it will be useful,
    -- but WITHOUT ANY WARRANTY; without even the implied warranty of
    -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    -- GNU General Public License for more details.
    --
    -- You should have received a copy of the GNU General Public License
    -- along with this program; see the file COPYING.  If not, write to
    -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
    -- Boston, MA 02110-1301, USA.

    -- This module is intended to provide backwards-compatibility in the parsing
    -- of darcs patches.  In other words: don't change it, new features don't get
    -- added here.  The only user should be Darcs.Patch.Info.

    module Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) where

    import Text.ParserCombinators.Parsec
    import System.Time
    import Data.Char ( toUpper, isDigit )
    import Control.Monad ( liftM, liftM2 )
    import qualified Data.ByteString.Char8 as B
    import Data.Maybe ( fromMaybe )

    -- | Read/interpret a date string, assuming UTC if timezone
    --   is not specified in the string
    readUTCDate :: String -> CalendarTime
    readUTCDate = readDate 0

    readDate :: Int -> String -> CalendarTime
    readDate tz d =
                 case parseDate tz d of
                 Left e -> error e
                 Right ct -> ct

    parseDate :: Int -> String -> Either String CalendarTime
    parseDate tz d =
                  if length d >= 14 && B.all isDigit bd
                  then Right $
                       CalendarTime (readI $ B.take 4 bd)
                                    (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd)
                                    (readI $ B.take 2 $ B.drop 6 bd) -- Day
                                    (readI $ B.take 2 $ B.drop 8 bd) -- Hour
                                    (readI $ B.take 2 $ B.drop 10 bd) -- Minute
                                    (readI $ B.take 2 $ B.drop 12 bd) -- Second
                                    0 Sunday 0 -- Picosecond, weekday and day of year unknown
                                    "GMT" 0 False
                  else let dt = do { x <- date_time tz; eof; return x }
                       in case parse dt "" d of
                          Left e -> Left $ "bad date: "++d++" - "++show e
                          Right ct -> Right ct
      where bd = B.pack (take 14 d)
            readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s)

    showIsoDateTime :: CalendarTime -> String
    showIsoDateTime ct = concat [ show $ ctYear ct
                                , twoDigit . show . (+1) . fromEnum $ ctMonth ct
                                , twoDigit . show $ ctDay ct
                                , twoDigit . show $ ctHour ct
                                , twoDigit . show $ ctMin ct
                                , twoDigit . show $ ctSec ct
                                ]
        where twoDigit []          = undefined
              twoDigit x@(_:[])    = '0' : x
              twoDigit x@(_:_:[])  = x
              twoDigit _           = undefined

    ----- Parser Combinators ---------------------------------------------

    -- |Case-insensitive variant of Parsec's 'char' function.

    caseChar        :: Char -> GenParser Char a Char
    caseChar c       = satisfy (\x -> toUpper x == toUpper c)

    -- |Case-insensitive variant of Parsec's 'string' function.

    caseString      :: String -> GenParser Char a ()
    caseString cs    = mapM_ caseChar cs <?> cs

    -- |Match a parser at least @n@ times.

    manyN           :: Int -> GenParser a b c -> GenParser a b [c]
    manyN n p
        | n <= 0     = return []
        | otherwise  = liftM2 (++) (count n p) (many p)

    -- |Match a parser at least @n@ times, but no more than @m@ times.

    manyNtoM        :: Int -> Int -> GenParser a b c -> GenParser a b [c]
    manyNtoM n m p
        | n < 0      = return []
        | n > m      = return []
        | n == m     = count n p
        | n == 0     = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))
        | otherwise  = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)

    ----- Date/Time Parser -----------------------------------------------

    date_time :: Int -> CharParser a CalendarTime
    date_time tz =
                choice [try $ cvs_date_time tz,
                        try $ iso8601_date_time tz,
                        old_date_time]

    cvs_date_time :: Int -> CharParser a CalendarTime
    cvs_date_time tz =
                    do y <- year
                       char '/'
                       mon <- month_num
                       char '/'
                       d <- day
                       my_spaces
                       h <- hour
                       char ':'
                       m <- minute
                       char ':'
                       s <- second
                       z <- option tz $ my_spaces >> zone
                       return (CalendarTime y mon d h m s 0 Monday 0 "" z False)

    old_date_time   :: CharParser a CalendarTime
    old_date_time    = do wd <- day_name
                          my_spaces
                          mon <- month_name
                          my_spaces
                          d <- day
                          my_spaces
                          h <- hour
                          char ':'
                          m <- minute
                          char ':'
                          s <- second
                          my_spaces
                          z <- zone
                          my_spaces
                          y <- year
                          return (CalendarTime y mon d h m s 0 wd 0 "" z False)

    {- FIXME: In case you ever want to use this outside of darcs, you should note
       that this implementation of ISO 8601 is not complete.

       reluctant to implement (ambiguous!):
         * years > 9999
         * truncated representations with implied century (89 for 1989)
       unimplemented:
         * repeated durations (not relevant)
         * lowest order component fractions in intervals
         * negative dates (BC)
       unverified or too relaxed:
         * the difference between 24h and 0h
         * allows stuff like 2005-1212; either you use the hyphen all the way
           (2005-12-12) or you don't use it at all (20051212), but you don't use
           it halfway, likewise with time
         * No bounds checking whatsoever on intervals!
           (next action: read iso doc to see if bounds-checking required?) -}
    iso8601_date_time   :: Int -> CharParser a CalendarTime
    iso8601_date_time localTz = try $
      do d <- iso8601_date
         t <- option id $ try $ do optional $ oneOf " T"
                                   iso8601_time
         return $ t $ d { ctTZ = localTz }

    iso8601_date :: CharParser a CalendarTime
    iso8601_date =
      do d <- calendar_date <|> week_date <|> ordinal_date
         return $ foldr ($) nullCalendar d
      where
        calendar_date = -- yyyy-mm-dd
          try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]
                   -- allow other variants to be parsed correctly
                   notFollowedBy (digit <|> char 'W')
                   return d
        week_date = --yyyy-Www-dd
          try $ do yfn <- year_
                   optional dash
                   char 'W'
                   -- offset human 'week 1' -> computer 'week 0'
                   w'  <- (\x -> x-1) `liftM` two_digits
                   wd  <- option 1 $ do { optional dash; n_digits 1 }
                   let y = yfn nullCalendar
                       firstDay = ctWDay y
                   -- things that make this complicated
                   -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday
                   -- 2. the first week is the one that contains at least Thursday
                   --    if the year starts after Thursday, then some days of the year
                   --    will have already passed before the first week
                   let afterThursday = firstDay == Sunday || firstDay > Thursday
                       w  = if afterThursday then w'+1 else w'
                       diff c = c { ctDay = (7 * w) + wd - (fromEnum firstDay) }
                   return [(toUTCTime.toClockTime.diff.yfn)]
        ordinal_date = -- yyyy-ddd
          try $ optchain year_ [ (dash, yearDay_) ]
        --
        year_  = try $ do y <- four_digits <?> "year (0000-9999)"
                          return $ \c -> c { ctYear = y }
        month_ = try $ do m <- two_digits <?> "month (1 to 12)"
                          -- we (artificially) use ctPicosec to indicate
                          -- whether the month has been specified.
                          return $ \c -> c { ctMonth = intToMonth m, ctPicosec = 0 }
        day_   = try $ do d <- two_digits <?> "day in month (1 to 31)"
                          return $ \c -> c { ctDay = d }
        yearDay_ = try $ do d <- n_digits 3 <?> "day in year (1 to 366)"
                            return $ \c -> c { ctYDay = d }
        dash = char '-'

    -- we return a function which sets the time on another calendar
    iso8601_time :: CharParser a (CalendarTime -> CalendarTime)
    iso8601_time = try $
      do ts <- optchain hour_ [ (colon     , min_)
                              , (colon     , sec_)
                              , (oneOf ",.", pico_) ]
         z  <- option id $ choice [ zulu , offset ]
         return $ foldr (.) id (z:ts)
      where
        hour_ = do h <- two_digits
                   return $ \c -> c { ctHour = h }
        min_  = do m <- two_digits
                   return $ \c -> c { ctMin = m }
        sec_  = do s <- two_digits
                   return $ \c -> c { ctSec = s }
        pico_ = do digs <- many digit
                   let picoExp = 12
                       digsExp = length digs
                   let frac | null digs = 0
                            | digsExp > picoExp = read $ take picoExp digs
                            | otherwise = 10 ^ (picoExp - digsExp) * (read digs)
                   return $ \c -> c { ctPicosec = frac }
        zulu   = do { char 'Z'; return (\c -> c { ctTZ = 0 }) }
        offset = do sign <- choice [ do { char '+' >> return   1  }
                                   , do { char '-' >> return (-1) } ]
                    h <- two_digits
                    m <- option 0 $ do { optional colon; two_digits }
                    return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) }
        colon = char ':'

    optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]
    optchain p next = try $
      do r1 <- p
         r2 <- case next of
               [] -> return []
               ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }
         return (r1:r2)

    n_digits :: Int -> CharParser a Int
    n_digits n = read `liftM` count n digit

    two_digits, four_digits :: CharParser a Int
    two_digits = n_digits 2
    four_digits = n_digits 4

    my_spaces :: CharParser a String
    my_spaces = manyN 1 $ char ' '

    day_name        :: CharParser a Day
    day_name         = choice
                           [ caseString "Mon"       >> return Monday
                           , try (caseString "Tue") >> return Tuesday
                           , caseString "Wed"       >> return Wednesday
                           , caseString "Thu"       >> return Thursday
                           , caseString "Fri"       >> return Friday
                           , try (caseString "Sat") >> return Saturday
                           , caseString "Sun"       >> return Sunday
                           ]

    year            :: CharParser a Int
    year             = four_digits

    month_num       :: CharParser a Month
    month_num = do mn <- manyNtoM 1 2 digit
                   return $ intToMonth $ (read mn :: Int)

    intToMonth :: Int -> Month
    intToMonth 1 = January
    intToMonth 2 = February
    intToMonth 3 = March
    intToMonth 4 = April
    intToMonth 5 = May
    intToMonth 6 = June
    intToMonth 7 = July
    intToMonth 8 = August
    intToMonth 9 = September
    intToMonth 10 = October
    intToMonth 11 = November
    intToMonth 12 = December
    intToMonth _  = error "invalid month!"

    month_name      :: CharParser a Month
    month_name       = choice
                           [ try (caseString "Jan") >> return January
                           , caseString "Feb"       >> return February
                           , try (caseString "Mar") >> return March
                           , try (caseString "Apr") >> return April
                           , caseString "May"       >> return May
                           , try (caseString "Jun") >> return June
                           , caseString "Jul"       >> return July
                           , caseString "Aug"       >> return August
                           , caseString "Sep"       >> return September
                           , caseString "Oct"       >> return October
                           , caseString "Nov"       >> return November
                           , caseString "Dec"       >> return December
                           ]

    day             :: CharParser a Int
    day              = do d <- manyNtoM 1 2 digit
                          return (read d :: Int)

    hour            :: CharParser a Int
    hour             = two_digits

    minute          :: CharParser a Int
    minute           = two_digits

    second          :: CharParser a Int
    second           = two_digits

    zone            :: CharParser a Int
    zone             = choice
                           [ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }
                           , do { char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) }
                           , mkZone "UTC"  0
                           , mkZone "UT"  0
                           , mkZone "GMT" 0
                           , mkZone "EST" (-5)
                           , mkZone "EDT" (-4)
                           , mkZone "CST" (-6)
                           , mkZone "CDT" (-5)
                           , mkZone "MST" (-7)
                           , mkZone "MDT" (-6)
                           , mkZone "PST" (-8)
                           , mkZone "PDT" (-7)
                           , mkZone "CEST" 2
                           , mkZone "EEST" 3
                             -- if we don't understand it, just give a GMT answer...
                           , do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' '])
                                           (lookAhead space_digit);
                                  return 0 }
                           ]
         where mkZone n o  = try $ do { caseString n; return (o*60*60) }
               space_digit = try $ do { char ' '; oneOf ['0'..'9'] }

    nullCalendar :: CalendarTime
    nullCalendar = CalendarTime 0 January 0 0 0 0 1 Sunday 0 "" 0 False