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

    , longWeekDayName
    , longWeekDayNameP

    , shortMonthName
    , shortMonthNameP

    , longMonthName
    , longMonthNameP

    , show4
    , show2
    , show2'

    , read4
    , read2
    , read2'

    , show4digitsTZ
    , read4digitsTZ

    , assertWeekDayIsGood
    , assertGregorianDateIsGood
    , assertTimeOfDayIsGood

    , optionMaybe
    , finishOff

    , parseAttempt
    , parseAttempt'
    )
    where
import Blaze.ByteString.Builder.ByteString as B
import Blaze.Text.Int as BT
import Control.Applicative
import Control.Exception.Base
import Control.Monad
import Control.Monad.Unicode
import Data.Ascii (Ascii, AsciiBuilder)
import qualified Data.Ascii as A
import Data.Attempt
import Data.Attoparsec.Char8 as P
import Data.ByteString (ByteString)
import Data.Char
import Data.Monoid.Unicode
import Data.Fixed
import Data.Time
import Data.Time.Calendar.WeekDate
import Prelude.Unicode

shortWeekDayName ∷ Num n ⇒ n → AsciiBuilder
{-# INLINE shortWeekDayName #-}
shortWeekDayName = A.toAsciiBuilder ∘ go
    where
      {-# INLINEABLE go #-}
      go 1 = "Mon"
      go 2 = "Tue"
      go 3 = "Wed"
      go 4 = "Thu"
      go 5 = "Fri"
      go 6 = "Sat"
      go 7 = "Sun"
      go 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 → AsciiBuilder
{-# INLINE longWeekDayName #-}
longWeekDayName = A.toAsciiBuilder ∘ go
    where
      {-# INLINEABLE go #-}
      go 1 = "Monday"
      go 2 = "Tuesday"
      go 3 = "Wednesday"
      go 4 = "Thursday"
      go 5 = "Friday"
      go 6 = "Saturday"
      go 7 = "Sunday"
      go 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 → AsciiBuilder
{-# INLINE shortMonthName #-}
shortMonthName = A.toAsciiBuilder ∘ go
    where
      {-# INLINEABLE go #-}
      go  1 = "Jan"
      go  2 = "Feb"
      go  3 = "Mar"
      go  4 = "Apr"
      go  5 = "May"
      go  6 = "Jun"
      go  7 = "Jul"
      go  8 = "Aug"
      go  9 = "Sep"
      go 10 = "Oct"
      go 11 = "Nov"
      go 12 = "Dec"
      go  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 → AsciiBuilder
{-# INLINE longMonthName #-}
longMonthName = A.toAsciiBuilder ∘ go
    where
      {-# INLINEABLE go #-}
      go  1 = "January"
      go  2 = "February"
      go  3 = "March"
      go  4 = "April"
      go  5 = "May"
      go  6 = "June"
      go  7 = "July"
      go  8 = "August"
      go  9 = "September"
      go 10 = "October"
      go 11 = "November"
      go 12 = "December"
      go  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)

show2' ∷ Integral i ⇒ i → AsciiBuilder
{-# INLINE show2' #-}
show2' = A.unsafeFromBuilder ∘ go
    where
      go i | i ≥ 0 ∧ i < 10  = B.fromByteString " " ⊕ 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)

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

digit' ∷ Num n ⇒ Parser n
{-# INLINE digit' #-}
digit' = fromIntegral <$> fromC <$> P.digit
    where
      {-# INLINE fromC #-}
      fromC c = ord c - ord '0'

show4digitsTZ ∷ TimeZone → AsciiBuilder
{-# INLINEABLE show4digitsTZ #-}
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
{-# INLINEABLE read4digitsTZ #-}
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 "
                     , toStr $ longWeekDayName correctWD
                     , ", not "
                     , toStr $ longWeekDayName givenWD
                     ]
    where
      toStr ∷ AsciiBuilder → String
      toStr = A.toString ∘ A.fromAsciiBuilder

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

optionMaybe ∷ Alternative f ⇒ f a → f (Maybe a)
{-# INLINE optionMaybe #-}
optionMaybe p
    = option Nothing (Just <$> p)

finishOff ∷ Parser α → Parser α
{-# INLINE finishOff #-}
finishOff = ((endOfInput *>) ∘ return =≪)

parseAttempt ∷ Exception e
             ⇒ (String → e)
             → Parser α
             → ByteString
             → Attempt α
{-# INLINEABLE parseAttempt #-}
parseAttempt f p bs
    = case parseOnly (finishOff p) bs of
        Right α → Success α
        Left  e → Failure $ f e

parseAttempt' ∷ Parser α → Ascii → Attempt α
{-# INLINE parseAttempt' #-}
parseAttempt' = (∘ A.toByteString) ∘ parseAttempt StringException