{-# LANGUAGE
    DeriveDataTypeable
  , ExistentialQuantification
  , FlexibleInstances
  , TemplateHaskell
  , UnicodeSyntax
  , ViewPatterns
  #-}
module Network.HTTP.Lucu.StatusCode.Internal
    ( StatusCode(..)
    , SomeStatusCode(..)
    , statusCodes
    )
    where
import Control.Applicative
import Data.Ascii (Ascii)
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.List
import Data.Typeable
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 (Eq sc, Show sc, Typeable 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
    -- |Cast the status code from 'SomeStatusCode'.
    toStatusCode ∷ SomeStatusCode → Maybe sc
    toStatusCode (SomeStatusCode sc) = cast sc

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

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

-- |Two 'StatusCode's @a@ and @b@ are said to be equivalent iff
-- @'numericCode' a == 'numericCode' b@.
instance Eq SomeStatusCode where
    (SomeStatusCode α) == (SomeStatusCode β)
        = numericCode α ≡ numericCode β

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

-- |'QuasiQuoter' for 'StatusCode' declarations.
--
-- Top-level splicing
--
-- @
--   ['statusCodes'|
--   200 OK
--   400 Bad Request
--   405 Method Not Allowed
--   |]
-- @
--
-- becomes:
--
-- @
--   data OK = OK deriving ('Eq', 'Show', 'Typeable')
--   instance OK where
--     'numericCode'   _ = 200
--     'textualStatus' _ = 'A.unsafeFromString' \"200 OK\"
--
--   data BadRequest = BadRequest deriving ('Eq', 'Show', 'Typeable')
--   instance BadRequest where
--     'numericCode'   _ = 400
--     'textualStatus' _ = 'A.unsafeFromString' \"400 Bad Request\"
--
--   data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show', 'Typeable')
--   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]
                       [ mkName "Eq"
                       , mkName "Show"
                       , mkName "Typeable"
                       ]

      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