module Codec.MIME.String.Date
      (FullDate(FullDate), DOW(..), Date(Date), Day, Month(..), Year,
       Time(Time), Zone, TimeOfDay(TimeOfDay), Hour, Minute, Second,
       show_full_date, show_mbox_full_date, get_date, p_date_time,
       get_current_date, epochDate,
      )
      where

import Codec.MIME.String.Internal.ABNF
      (
       Parser, parse,
       (<$>), (<$), (<*>), (<*), (<|>),
       pEOI, pPred, pChar, pAtLeast, pFromTo, pExactly, pMaybe,
      )
import Codec.MIME.String.Headers (cws, p_ci_string)
import Codec.MIME.String.Internal.Utils

import Control.Monad.Trans (MonadIO, liftIO)
import System.Time hiding (Month(May), Day)
import qualified System.Time as Time (Month(May))

data FullDate = FullDate (Maybe DOW) Date Time
    deriving (Show, Read)

data DOW = Mon | Tue | Wed | Thu | Fri | Sat | Sun
    deriving (Show, Read)

data Date = Date Day Month Year
    deriving (Show, Read)
type Day = Int
data Month = Jan | Feb | Mar | Apr | May | Jun
           | Jul | Aug | Sep | Oct | Nov | Dec
    deriving (Show, Read)
type Year = Int

data Time = Time TimeOfDay Zone
    deriving (Show, Read)
type Zone = Int
data TimeOfDay = TimeOfDay Hour Minute (Maybe Second)
    deriving (Show, Read)
type Hour = Int
type Minute = Int
type Second = Int

epochDate :: FullDate
epochDate = FullDate (Just Thu) (Date 01 Jan 1970)
                     (Time (TimeOfDay 0 0 (Just 0)) 0)

------------------------ Showing

show_full_date :: FullDate -> String
show_full_date (FullDate m_dow date time)
 = shown_dow ++ show_date date ++ " " ++ show_time time
    where shown_dow = case m_dow of
                          Nothing -> ""
                          Just dow -> show dow ++ ", "

show_date :: Date -> String
show_date (Date day month year)
  = show_int 2 day ++ " " ++ show month ++ " " ++ show year

show_time :: Time -> String
show_time (Time tod zone) = show_tod tod ++ " " ++ show_zone zone

show_tod :: TimeOfDay -> String
show_tod (TimeOfDay h m m_s)
 = show_int 2 h ++ ":" ++ show_int 2 m ++ shown_s
    where shown_s = case m_s of
                        Nothing -> ""
                        Just s -> ":" ++ show_int 2 s

show_zone :: Zone -> String
show_zone z = (if z < 0 then '-' else '+'):show_int 4 (abs z)

show_int :: Int -> Int -> String
show_int digits int = let s = show int
                      in replicate (digits - length s) '0' ++ s

-- Showing for the "From " line in mboxes is sadly a slightly different format

show_mbox_full_date :: FullDate -> String
show_mbox_full_date (FullDate m_dow (Date day month year) (Time tod _))
 = shown_dow ++ show month ++ " " ++ show_int 2 day ++ " " ++
   show_tod tod ++ " " ++ show year
    where shown_dow = case m_dow of
                          Nothing -> ""
                          Just dow -> show dow ++ " "

------------------------ Parsing

get_date :: String -> Maybe FullDate
get_date xs
 = case parse ph_date xs of
       Left f -> Just f
       Right _ -> Nothing

ph_date :: Parser Char FullDate
ph_date = id
      <$  cws
      <*> p_date_time
      <*  cws
      <*  pEOI

p_date_time :: Parser Char FullDate
p_date_time = FullDate
          <$> pMaybe (    id
                      <$> p_dow
                      <*  cws
                      <*  pChar ','
                      <*  cws)
          <*> p_date
          <*  cws
          <*> p_time

p_dow :: Parser Char DOW
p_dow = Mon <$  p_ci_string "Mon"
    <|> Tue <$  p_ci_string "Tue"
    <|> Wed <$  p_ci_string "Wed"
    <|> Thu <$  p_ci_string "Thu"
    <|> Fri <$  p_ci_string "Fri"
    <|> Sat <$  p_ci_string "Sat"
    <|> Sun <$  p_ci_string "Sun"

p_date :: Parser Char Date
p_date = Date
     <$> p_day
     <*  cws
     <*> p_month
     <*  cws
     <*> p_year

-- obs-year merged in
p_year :: Parser Char Year
p_year = (\ds -> let y = read ds
                 in case ds of
                        [_, _, _] -> 2000 + y
                        [_, _]
                         | y < 50 -> 1900 + y
                         | otherwise -> 2000 + y
                        _ -> y)
     <$> pAtLeast 2 (pPred isAsciiDigit)

p_month :: Parser Char Month
p_month = Jan <$  p_ci_string "Jan"
      <|> Feb <$  p_ci_string "Feb"
      <|> Mar <$  p_ci_string "Mar"
      <|> Apr <$  p_ci_string "Apr"
      <|> May <$  p_ci_string "May"
      <|> Jun <$  p_ci_string "Jun"
      <|> Jul <$  p_ci_string "Jul"
      <|> Aug <$  p_ci_string "Aug"
      <|> Sep <$  p_ci_string "Sep"
      <|> Oct <$  p_ci_string "Oct"
      <|> Nov <$  p_ci_string "Nov"
      <|> Dec <$  p_ci_string "Dec"

p_day :: Parser Char Day
p_day = read <$> pFromTo 1 2 (pPred isAsciiDigit)

p_time :: Parser Char Time
p_time = Time
     <$> p_time_of_day
     <*  cws
     <*> p_zone

p_time_of_day :: Parser Char TimeOfDay
p_time_of_day = TimeOfDay
            <$> p_hour
            <*  cws
            <*  pChar ':'
            <*  cws
            <*> p_minute
            <*> pMaybe (    id
                        <$  cws
                        <*  pChar ':'
                        <*  cws
                        <*> p_second)

p_hour :: Parser Char Hour
p_hour = read <$> pExactly 2 (pPred isAsciiDigit)

p_minute :: Parser Char Minute
p_minute = read <$> pExactly 2 (pPred isAsciiDigit)

p_second :: Parser Char Second
p_second = read <$> pExactly 2 (pPred isAsciiDigit)

p_zone :: Parser Char Zone
p_zone = (\f n -> f $ read n)
     <$> (id <$  pChar '+' <|> negate <$  pChar '-')
     <*> pExactly 4 (pPred isAsciiDigit)
 <|> p_obs_zone

p_obs_zone :: Parser Char Zone
p_obs_zone = 0 <$  p_ci_string "UT"
         <|> 0 <$  p_ci_string "GMT"
         <|> -500 <$  p_ci_string "EST"
         <|> -400 <$  p_ci_string "EDT"
         <|> -600 <$  p_ci_string "CST"
         <|> -500 <$  p_ci_string "CDT"
         <|> -700 <$  p_ci_string "MST"
         <|> -600 <$  p_ci_string "MDT"
         <|> -800 <$  p_ci_string "PST"
         <|> -700 <$  p_ci_string "PDT"
         -- Military time zones. Strictly we shouldn't accept [jJ]
         -- but no harm done.
         -- 'they SHOULD all be considered equivalent to "-0000"' as
         -- RFC 822 defined them incorrectly.
         <|> 0 <$  pPred isAsciiAlpha

get_current_date :: MonadIO m => m FullDate
get_current_date
 = do clt <- liftIO getClockTime
      cat <- liftIO $ toCalendarTime clt
      let fd = FullDate (Just dow) date time
          get_dow Sunday    = Sun
          get_dow Monday    = Mon
          get_dow Tuesday   = Tue
          get_dow Wednesday = Wed
          get_dow Thursday  = Thu
          get_dow Friday    = Fri
          get_dow Saturday  = Sat
          get_month January   = Jan
          get_month February  = Feb
          get_month March     = Mar
          get_month April     = Apr
          get_month Time.May  = May
          get_month June      = Jun
          get_month July      = Jul
          get_month August    = Aug
          get_month September = Sep
          get_month October   = Oct
          get_month November  = Nov
          get_month December  = Dec
          dow = get_dow (ctWDay cat)
          date = Date (ctDay cat) (get_month (ctMonth cat)) (ctYear cat)
          time = Time tod (ctTZ cat `div` 36)
          tod = TimeOfDay (ctHour cat) (ctMin cat) (Just (ctSec cat))
      return fd