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

    , longWeekDayName
    , longWeekDayNameP

    , shortMonthName
    , shortMonthNameP

    , longMonthName
    , longMonthNameP

    , show2
    , show4

    , read2
    , read4

    , show4digitsTZ
    , read4digitsTZ

    , assertWeekDayIsGood
    , assertGregorianDateIsGood
    , assertTimeOfDayIsGood
    )
    where
import Blaze.ByteString.Builder.ByteString as B
import Blaze.Text.Int as BT
import Control.Applicative
import Control.Monad
import Control.Monad.Unicode
import Data.Ascii (AsciiBuilder)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8 as P
import Data.Monoid.Unicode
import Data.Fixed
import Data.Time
import Data.Time.Calendar.WeekDate
import Prelude.Unicode

shortWeekDayName ∷ Num n ⇒ n → String
{-# INLINEABLE shortWeekDayName #-}
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: invalid week day: " ⧺ show n)

shortWeekDayNameP ∷ Num n ⇒ Parser n
{-# INLINEABLE shortWeekDayNameP #-}
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 ∷ Num n ⇒ n → String
{-# INLINEABLE longWeekDayName #-}
longWeekDayName 1 = "Monday"
longWeekDayName 2 = "Tuesday"
longWeekDayName 3 = "Wednesday"
longWeekDayName 4 = "Thursday"
longWeekDayName 5 = "Friday"
longWeekDayName 6 = "Saturday"
longWeekDayName 7 = "Sunday"
longWeekDayName n = error ("longWeekDayName: invalid week day: " ⧺ show n)

longWeekDayNameP ∷ Num n ⇒ Parser n
{-# INLINEABLE longWeekDayNameP #-}
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 ∷ Num n ⇒ n → String
{-# INLINEABLE shortMonthName #-}
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: invalid month: " ⧺ show n)

shortMonthNameP ∷ Num n ⇒ Parser n
{-# INLINEABLE shortMonthNameP #-}
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 ∷ Num n ⇒ n → String
{-# INLINEABLE longMonthName #-}
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: invalid month: " ⧺ show n)

longMonthNameP ∷ Num n ⇒ Parser n
{-# INLINEABLE longMonthNameP #-}
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 → AsciiBuilder
{-# INLINE show4 #-}
show4 = A.unsafeFromBuilder ∘ go
    where
      {-# INLINEABLE go #-}
      go i | i ≥ 0 ∧ i < 10    = B.fromByteString "000" ⊕ BT.digit    i
           | i ≥ 0 ∧ i < 100   = B.fromByteString "00"  ⊕ BT.integral i
           | i ≥ 0 ∧ i < 1000  = B.fromByteString "0"   ⊕ BT.integral i
           | i ≥ 0 ∧ i < 10000 =                          BT.integral i
           | otherwise         = error ("show4: the integer i must satisfy 0 <= i < 10000: " ⧺ show i)

show2 ∷ Integral i ⇒ i → AsciiBuilder
{-# INLINE show2 #-}
show2 = A.unsafeFromBuilder ∘ go
    where
      go i | i ≥ 0 ∧ i < 10  = B.fromByteString "0" ⊕ BT.digit    i
           | i ≥ 0 ∧ i < 100 =                        BT.integral i
           | otherwise       = error ("show2: the integer i must satisfy 0 <= i < 100: " ⧺ show i)

read4 ∷ Num n ⇒ Parser n
{-# INLINEABLE read4 #-}
read4 = do n1 ← digit'
           n2 ← digit'
           n3 ← digit'
           n4 ← digit'
           return (n1 * 1000 + n2 * 100 + n3 * 10 + n4)

read2 ∷ Num n ⇒ Parser n
{-# INLINEABLE read2 #-}
read2 = do n1 ← digit'
           n2 ← digit'
           return (n1 * 10 + n2)

digit' ∷ Num n ⇒ Parser n
digit' = fromC <$> P.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 → AsciiBuilder
show4digitsTZ tz
    = case timeZoneMinutes tz of
        offset | offset <  0 → A.toAsciiBuilder "-" ⊕ showTZ' (negate offset)
               | otherwise   → A.toAsciiBuilder "+" ⊕ showTZ' offset
    where
      showTZ' offset
          = let h = offset `div` 60
                m = offset - h * 60
            in
              show2 h ⊕ show2 m

read4digitsTZ ∷ Parser 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 ∷ Monad m ⇒ Int → Day → m ()
{-# INLINEABLE assertWeekDayIsGood #-}
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 ∷ Monad m ⇒ Integer → Int → Int → m Day
{-# INLINEABLE assertGregorianDateIsGood #-}
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 ∷ Monad m ⇒ Int → Int → Pico → m TimeOfDay
{-# INLINEABLE assertTimeOfDayIsGood #-}
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