{-# LANGUAGE FlexibleContexts #-}
module Data.Time.HTTP.Common
    ( shortWeekDayName
    , shortWeekDayNameP

    , longWeekDayName
    , longWeekDayNameP

    , shortMonthName
    , shortMonthNameP

    , longMonthName
    , longMonthNameP

    , show2
    , show4

    , read2
    , read4

    , show4digitsTZ
    , read4digitsTZ

    , assertWeekDayIsGood
    , assertGregorianDateIsGood
    , assertTimeOfDayIsGood
    )
    where

import Control.Monad
import Data.Fixed
import Data.Time
import Data.Time.Calendar.WeekDate
import Text.Parsec

shortWeekDayName :: Int -> String
shortWeekDayName 1 = "Mon"
shortWeekDayName 2 = "Tue"
shortWeekDayName 3 = "Wed"
shortWeekDayName 4 = "Thu"
shortWeekDayName 5 = "Fri"
shortWeekDayName 6 = "Sat"
shortWeekDayName 7 = "Sun"
shortWeekDayName n = error ("shortWeekDayName: unknown day number: " ++ show n)

shortWeekDayNameP :: Stream s m Char => ParsecT s u m Int
shortWeekDayNameP
    = choice [ string "Mon" >> return 1
             , char 'T'
               >> choice [ string "ue" >> return 2
                         , string "hu" >> return 4
                         ]
             , string "Wed" >> return 3
             , string "Fri" >> return 5
             , char 'S'
               >> choice [ string "at" >> return 6
                         , string "un" >> return 7
                         ]
             ]

longWeekDayName :: Int -> String
longWeekDayName 1 = "Monday"
longWeekDayName 2 = "Tuesday"
longWeekDayName 3 = "Wednesday"
longWeekDayName 4 = "Thursday"
longWeekDayName 5 = "Friday"
longWeekDayName 6 = "Saturday"
longWeekDayName 7 = "Sunday"

longWeekDayNameP :: Stream s m Char => ParsecT s u m Int
longWeekDayNameP
    = choice [ string "Monday" >> return 1
             , char 'T'
               >> choice [ string "uesday"  >> return 2
                         , string "hursday" >> return 4
                         ]
             , string "Wednesday" >> return 3
             , string "Friday"    >> return 5
             , char 'S'
               >> choice [ string "aturday" >> return 6
                         , string "unday"   >> return 7
                         ]
             ]

shortMonthName :: Int -> String
shortMonthName  1 = "Jan"
shortMonthName  2 = "Feb"
shortMonthName  3 = "Mar"
shortMonthName  4 = "Apr"
shortMonthName  5 = "May"
shortMonthName  6 = "Jun"
shortMonthName  7 = "Jul"
shortMonthName  8 = "Aug"
shortMonthName  9 = "Sep"
shortMonthName 10 = "Oct"
shortMonthName 11 = "Nov"
shortMonthName 12 = "Dec"
shortMonthName  n = error ("shortMonthName: unknown month number: " ++ show n)

shortMonthNameP :: Stream s m Char => ParsecT s u m Int
shortMonthNameP
    = choice [ char 'J'
               >> choice [ string "an" >> return 1
                         , char 'u'
                           >> choice [ char 'n' >> return 6
                                     , char 'l' >> return 7
                                     ]
                         ]
             , string "Feb" >> return 2
             , string "Ma"
               >> choice [ char 'r' >> return 3
                         , char 'y' >> return 5
                         ]
             , char 'A'
               >> choice [ string "pr" >> return 4
                         , string "ug" >> return 8
                         ]
             , string "Sep" >> return 9
             , string "Oct" >> return 10
             , string "Nov" >> return 11
             , string "Dec" >> return 12
             ]

longMonthName :: Int -> String
longMonthName  1 = "January"
longMonthName  2 = "February"
longMonthName  3 = "March"
longMonthName  4 = "April"
longMonthName  5 = "May"
longMonthName  6 = "June"
longMonthName  7 = "July"
longMonthName  8 = "August"
longMonthName  9 = "September"
longMonthName 10 = "October"
longMonthName 11 = "November"
longMonthName 12 = "December"
longMonthName  n = error ("longMonthName: unknown month number: " ++ show n)

longMonthNameP :: Stream s m Char => ParsecT s u m Int
longMonthNameP
    = choice [ char 'J'
               >> choice [ string "anuary" >> return 1
                         , char 'u'
                           >> choice [ string "ne" >> return 6
                                     , string "ly" >> return 7
                                     ]
                         ]
             , string "February" >> return 2
             , string "Ma"
               >> choice [ string "rch" >> return 3
                         , char 'y' >> return 5
                         ]
             , char 'A'
               >> choice [ string "pril" >> return 4
                         , string "ugust" >> return 8
                         ]
             , string "September" >> return 9
             , string "October"   >> return 10
             , string "November"  >> return 11
             , string "December"  >> return 12
             ]

show4 :: Integral i => i -> String
show4 i
    | i >= 0 && i < 10    = "000" ++ show i
    | i >= 0 && i < 100   = "00"  ++ show i
    | i >= 0 && i < 1000  = '0'    : show i
    | i >= 0 && i < 10000 = show i
    | otherwise          = error ("show4: the integer i must satisfy 0 <= i < 10000: " ++ show i)

show2 :: Integral i => i -> String
show2 i
    | i >= 0 && i < 10  = '0' : show i
    | i >= 0 && i < 100 = show i
    | otherwise         = error ("show2: the integer i must satisfy 0 <= i < 100: " ++ show i)

read4 :: (Stream s m Char, Num n) => ParsecT s u m n
read4 = do n1 <- digit'
           n2 <- digit'
           n3 <- digit'
           n4 <- digit'
           return (n1 * 1000 + n2 * 100 + n3 * 10 + n4)

read2 :: (Stream s m Char, Num n) => ParsecT s u m n
read2 = do n1 <- digit'
           n2 <- digit'
           return (n1 * 10 + n2)

digit' :: (Stream s m Char, Num n) => ParsecT s u m n
digit' = liftM fromC digit

fromC :: Num n => Char -> n
fromC '0' = 0
fromC '1' = 1
fromC '2' = 2
fromC '3' = 3
fromC '4' = 4
fromC '5' = 5
fromC '6' = 6
fromC '7' = 7
fromC '8' = 8
fromC '9' = 9
fromC _   = undefined

show4digitsTZ :: TimeZone -> String
show4digitsTZ tz
    = case timeZoneMinutes tz of
        offset | offset <  0 -> '-' : showTZ' (negate offset)
               | otherwise   -> '+' : showTZ' offset
    where
      showTZ' offset
          = let h = offset `div` 60
                m = offset - h * 60
            in
              show2 h ++ show2 m

read4digitsTZ :: Stream s m Char => ParsecT s u m TimeZone
read4digitsTZ
    = do sign   <- (char '+' >> return 1)
                   <|>
                   (char '-' >> return (-1))
         hour   <- read2
         minute <- read2
         let tz = TimeZone {
                    timeZoneMinutes    = sign * (hour * 60 + minute)
                  , timeZoneSummerOnly = False
                  , timeZoneName       = timeZoneOffsetString tz
                  }
         return tz

assertWeekDayIsGood :: Stream s m t => Int -> Day -> ParsecT s u m ()
assertWeekDayIsGood givenWD gregDay
    = let (_, _, correctWD ) = toWeekDate  gregDay
          (year, month, day) = toGregorian gregDay
      in
        unless (givenWD == correctWD)
                   $ fail
                   $ concat [ "Gregorian day "
                            , show year
                            , "-"
                            , show month
                            , "-"
                            , show day
                            , " is "
                            , longWeekDayName correctWD
                            , ", not "
                            , longWeekDayName givenWD
                            ]

assertGregorianDateIsGood :: Stream s m t => Integer -> Int -> Int -> ParsecT s u m Day
assertGregorianDateIsGood year month day
    = case fromGregorianValid year month day of
        Nothing
            -> fail $ concat [ "Invalid gregorian day: "
                             , show year
                             , "-"
                             , show month
                             , "-"
                             , show day
                             ]
        Just gregDay
            -> return gregDay

assertTimeOfDayIsGood :: Stream s m t => Int -> Int -> Pico -> ParsecT s u m TimeOfDay
assertTimeOfDayIsGood hour minute second
    = case makeTimeOfDayValid hour minute second of
        Nothing
            -> fail $ concat [ "Invalid time of day: "
                             , show hour
                             , ":"
                             , show minute
                             , ":"
                             , showFixed True second
                             ]
        Just tod
            -> return tod