{-# LANGUAGE
    ExistentialQuantification
  , FlexibleInstances
  , MultiParamTypeClasses
  , OverlappingInstances
  , OverloadedStrings
  , TemplateHaskell
  , UndecidableInstances
  , UnicodeSyntax
  , ViewPatterns
  #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Network.HTTP.Lucu.Response.StatusCode.Internal
    ( StatusCode(..)
    , SomeStatusCode
    , statusCodes
    )
    where
import Control.Applicative
import Control.Applicative.Unicode
import Control.Monad.Unicode
import Data.Ascii (Ascii, AsciiBuilder)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8
import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString.Lazy.Char8 as Lazy
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
import Data.List
import Data.Monoid
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Network.HTTP.Lucu.OrphanInstances ()
import Network.HTTP.Lucu.Parser
import Prelude.Unicode

-- |Type class for HTTP status codes.
--
-- Declaring types for each statuses is surely a pain. See:
-- 'statusCodes' quasi-quoter.
--
-- Minimal complete definition: 'numericCode' and 'textualStatus'.
class (Eq sc, Show sc) ⇒ StatusCode sc where
    -- |Return the 3-digit integer for this status e.g. @200@
    numericCode ∷ sc → Int
    -- |Return the combination of 3-digit integer and reason phrase
    -- for this status e.g. @200 OK@
    textualStatus ∷ sc → AsciiBuilder
    -- |Wrap the status code into 'SomeStatusCode'.
    fromStatusCode ∷ sc → SomeStatusCode
    {-# INLINE CONLIKE fromStatusCode #-}
    fromStatusCode = SomeStatusCode

instance StatusCode sc ⇒ ConvertSuccess sc SomeStatusCode where
    {-# INLINE convertSuccess #-}
    convertSuccess = fromStatusCode

instance StatusCode sc ⇒ ConvertSuccess sc Ascii where
    {-# INLINE convertSuccess #-}
    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)

instance StatusCode sc ⇒ ConvertSuccess sc AsciiBuilder where
    {-# INLINE convertSuccess #-}
    convertSuccess = textualStatus

instance StatusCode sc ⇒ ConvertAttempt sc SomeStatusCode where
    {-# INLINE convertAttempt #-}
    convertAttempt = return ∘ cs

instance StatusCode sc ⇒ ConvertAttempt sc Ascii where
    {-# INLINE convertAttempt #-}
    convertAttempt = return ∘ cs

instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where
    {-# INLINE convertAttempt #-}
    convertAttempt = return ∘ cs

-- |Container type for the 'StatusCode' type class.
data SomeStatusCode
    = ∀sc. StatusCode sc ⇒ SomeStatusCode !sc

-- |Equivalence of 'StatusCode's. Two 'StatusCode's @α@ and
-- @β@ are said to be equivalent iff @'numericCode' α '=='
-- 'numericCode' β@.
instance Eq SomeStatusCode where
    {-# INLINE (==) #-}
    (==) = (∘ numericCode) ∘ (==) ∘ numericCode

instance Show SomeStatusCode where
    show (SomeStatusCode sc) = show sc

instance StatusCode SomeStatusCode where
    {-# INLINE numericCode #-}
    numericCode (SomeStatusCode sc) = numericCode sc
    {-# INLINE textualStatus #-}
    textualStatus (SomeStatusCode sc) = textualStatus sc
    {-# INLINE CONLIKE fromStatusCode #-}
    fromStatusCode = id

-- |'QuasiQuoter' for 'StatusCode' declarations.
--
-- Top-level splicing
--
-- @
--   ['statusCodes'|
--   200 OK
--   400 Bad Request
--   405 Method Not Allowed
--   |]
-- @
--
-- becomes:
--
-- @
--   data OK = OK deriving ('Eq', 'Show')
--   instance 'StatusCode' OK where
--     'numericCode'   _ = 200
--     'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
--
--   data BadRequest = BadRequest deriving ('Eq', 'Show')
--   instance 'StatusCode' BadRequest where
--     'numericCode'   _ = 400
--     'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
--
--   data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show')
--   instance 'StatusCode' MethodNotAllowed where
--     'numericCode'   _ = 405
--     'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
-- @
statusCodes ∷ QuasiQuoter
statusCodes = QuasiQuoter {
                quoteExp  = const unsupported
              , quotePat  = const unsupported
              , quoteType = const unsupported
              , quoteDec  = (concat <$>)
                            ∘ (mapM statusDecl =≪)
                            ∘ parseStatusCodes
                            ∘ Lazy.pack
              }
    where
      unsupported ∷ Monad m ⇒ m α
      unsupported = fail "Unsupported usage of statusCodes quasi-quoter."

parseStatusCodes ∷ Monad m ⇒ Lazy.ByteString → m [(Int, [Ascii])]
parseStatusCodes src
    = case LP.parse pairs src of
        LP.Fail _ eCtx e
            → fail $ "Unparsable status codes: "
                   ⧺ intercalate ", " eCtx
                   ⧺ ": "
                   ⧺ e
        LP.Done _ xs
            → return xs
    where
      pairs ∷ Parser [(Int, [Ascii])]
      pairs = do skipMany endOfLine
                 xs ← sepBy pair (skipMany1 endOfLine)
                 skipMany endOfLine
                 endOfInput
                 return xs
              <?>
              "pairs"

      pair ∷ Parser (Int, [Ascii])
      pair = do skipSpace
                num ← decimal
                skipSpace1
                phrase ← sepBy1 word $ skipWhile1 (≡ '\x20')
                return (num, phrase)
             <?>
             "pair"

      word ∷ Parser Ascii
      word = A.unsafeFromByteString <$> takeWhile1 isAlpha_ascii

statusDecl ∷ (Int, [Ascii]) → Q [Dec]
statusDecl (num, phrase) = (:) <$> dataDecl ⊛ instanceDecl
    where
      dataDecl ∷ Q Dec
      dataDecl = dataD (cxt []) name [] [con] [''Eq, ''Show]

      name ∷ Name
      name = mkName $ concatMap cs phrase

      con ∷ Q Con
      con = normalC name []

      instanceDecl ∷ Q [Dec]
      instanceDecl
          = [d| instance StatusCode $typ where
                  {-# INLINE CONLIKE numericCode #-}
                  numericCode _ = $(lift num)
                  {-# INLINE textualStatus #-}
                  textualStatus _ = cs $(lift txt)
              |]

      typ ∷ Q Type
      typ = conT name

      txt ∷ Ascii
      txt = mconcat $ intersperse "\x20"
                    $ A.unsafeFromString (show num) : phrase