{-# 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
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 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 → AsciiBuilder
    -- |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 = 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' _ = 'cs' (\"200 OK\" ∷ Ascii)
--
--   data BadRequest = BadRequest deriving ('Show')
--   instance BadRequest where
--     'numericCode'   _ = 400
--     'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
--
--   data MethodNotAllowed = MethodNotAllowed deriving ('Show')
--   instance 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 ∷ 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 <$> 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 cs 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 = [| cs ($(lift txt') ∷ Ascii) |]

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