{-# LANGUAGE
    ExistentialQuantification
  , FlexibleInstances
  , MultiParamTypeClasses
  , OverlappingInstances
  , TemplateHaskell
  , UnicodeSyntax
  , ViewPatterns
  #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Network.HTTP.Lucu.StatusCode.Internal
    ( StatusCode(..)
    , SomeStatusCode(..)
    , (≈)
    , (≉)
    , statusCodes
    )
    where
import Control.Applicative
import Data.Ascii (Ascii, AsciiBuilder)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8 as P
import 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 Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Network.HTTP.Lucu.Parser
import Prelude.Unicode

-- |The type class for HTTP status codes.
--
-- Declaring types for each statuses is surely a pain. See:
-- 'statusCodes'
--
-- Minimal complete definition: 'numericCode' and 'textualStatus'.
class 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 → Ascii
    -- |Wrap the status code into 'SomeStatusCode'.
    fromStatusCode ∷ sc → SomeStatusCode
    fromStatusCode = SomeStatusCode

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

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

instance Eq SomeStatusCode where
    (SomeStatusCode α) == (SomeStatusCode β) = α ≈ β

infix 4 ≈, ≉
-- |Equivalence of 'StatusCode's. Two 'StatusCode's @a@ and @b@ are
-- said to be equivalent iff @'numericCode' a '==' 'numericCode' b@.
--
-- U+2248, ALMOST EQUAL TO
(≈) ∷ (StatusCode α, StatusCode β) ⇒ α → β → Bool
{-# INLINE (≈) #-}
α ≈ β = numericCode α ≡ numericCode β

-- |@(a ≉ b) '==' 'not' (a ≈ b)@
--
-- U+2249, NOT ALMOST EQUAL TO
(≉) ∷ (StatusCode α, StatusCode β) ⇒ α → β → Bool
{-# INLINE (≉) #-}
(≉) = ((¬) ∘) ∘ (≈)

instance StatusCode SomeStatusCode where
    numericCode   (SomeStatusCode sc) = numericCode   sc
    textualStatus (SomeStatusCode sc) = textualStatus sc
    fromStatusCode = id

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

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

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

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

-- |'QuasiQuoter' for 'StatusCode' declarations.
--
-- Top-level splicing
--
-- @
--   ['statusCodes'|
--   200 OK
--   400 Bad Request
--   405 Method Not Allowed
--   |]
-- @
--
-- becomes:
--
-- @
--   data OK = OK deriving ('Show')
--   instance OK where
--     'numericCode'   _ = 200
--     'textualStatus' _ = 'A.unsafeFromString' \"200 OK\"
--
--   data BadRequest = BadRequest deriving ('Show')
--   instance BadRequest where
--     'numericCode'   _ = 400
--     'textualStatus' _ = 'A.unsafeFromString' \"400 Bad Request\"
--
--   data MethodNotAllowed = MethodNotAllowed deriving ('Show')
--   instance MethodNotAllowed where
--     'numericCode'   _ = 405
--     'textualStatus' _ = 'A.unsafeFromString' \"405 Method Not Allowed\"
-- @
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 ∷ Lazy.ByteString → [(Int, [Ascii])]
parseStatusCodes src
    = case LP.parse pairs src of
        LP.Fail _ eCtx e
            → error $ "Unparsable status codes: "
                    ⧺ intercalate ", " eCtx
                    ⧺ ": "
                    ⧺ e
        LP.Done _ xs
            → 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 <$> P.takeWhile1 isAlpha_ascii

statusDecl ∷ (Int, [Ascii]) → Q [Dec]
statusDecl (num, phrase)
    = do a  ← dataDecl
         bs ← instanceDecl
         return (a:bs)
    where
      name ∷ Name
      name = mkName $ concatMap A.toString phrase

      dataDecl ∷ Q Dec
      dataDecl = dataD (cxt []) name [] [con] [''Show]

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

      typ ∷ Q Type
      typ = conT name

      con ∷ Q Con
      con = return $ NormalC name []

      txt ∷ Q Exp
      txt = [| A.unsafeFromString $(lift txt') |]

      txt' ∷ String
      txt' = concat $ intersperse "\x20"
                    $ show num : map A.toString phrase