, FlexibleInstances
, MultiParamTypeClasses
, OverlappingInstances
+ , OverloadedStrings
, TemplateHaskell
- , TypeFamilies
, UndecidableInstances
, UnicodeSyntax
, ViewPatterns
#-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Network.HTTP.Lucu.StatusCode.Internal
+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 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
textualStatus ∷ sc → AsciiBuilder
-- |Wrap the status code into 'SomeStatusCode'.
fromStatusCode ∷ sc → SomeStatusCode
+ {-# INLINE CONLIKE fromStatusCode #-}
fromStatusCode = SomeStatusCode
instance StatusCode sc ⇒ ConvertSuccess sc SomeStatusCode where
-- |Container type for the 'StatusCode' type class.
data SomeStatusCode
- = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
+ = ∀sc. StatusCode sc ⇒ SomeStatusCode !sc
-- |Equivalence of 'StatusCode's. Two 'StatusCode's @α@ and
-- @β@ are said to be equivalent iff @'numericCode' α '=='
show (SomeStatusCode sc) = show sc
instance StatusCode SomeStatusCode where
- numericCode (SomeStatusCode sc) = numericCode sc
+ {-# INLINE numericCode #-}
+ numericCode (SomeStatusCode sc) = numericCode sc
+ {-# INLINE textualStatus #-}
textualStatus (SomeStatusCode sc) = textualStatus sc
+ {-# INLINE CONLIKE fromStatusCode #-}
fromStatusCode = id
-- |'QuasiQuoter' for 'StatusCode' declarations.
--
-- @
-- data OK = OK deriving ('Eq', 'Show')
--- instance OK where
+-- instance 'StatusCode' OK where
-- 'numericCode' _ = 200
-- 'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
--
-- data BadRequest = BadRequest deriving ('Eq', 'Show')
--- instance BadRequest where
+-- instance 'StatusCode' BadRequest where
-- 'numericCode' _ = 400
-- 'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
--
-- data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show')
--- instance MethodNotAllowed where
+-- instance 'StatusCode' MethodNotAllowed where
-- 'numericCode' _ = 405
-- 'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
-- @
quoteExp = const unsupported
, quotePat = const unsupported
, quoteType = const unsupported
- , quoteDec = (concat <$>) ∘ mapM statusDecl ∘ parseStatusCodes ∘ Lazy.pack
+ , 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 ∷ Monad m ⇒ Lazy.ByteString → m [(Int, [Ascii])]
parseStatusCodes src
= case LP.parse pairs src of
LP.Fail _ eCtx e
- → error $ "Unparsable status codes: "
- ⧺ intercalate ", " eCtx
- ⧺ ": "
- ⧺ e
+ → fail $ "Unparsable status codes: "
+ ⧺ intercalate ", " eCtx
+ ⧺ ": "
+ ⧺ e
LP.Done _ xs
- → xs
+ → return xs
where
pairs ∷ Parser [(Int, [Ascii])]
pairs = do skipMany endOfLine
word = A.unsafeFromByteString <$> takeWhile1 isAlpha_ascii
statusDecl ∷ (Int, [Ascii]) → Q [Dec]
-statusDecl (num, phrase)
- = do a ← dataDecl
- bs ← instanceDecl
- return (a:bs)
+statusDecl (num, phrase) = (:) <$> dataDecl ⊛ instanceDecl
where
+ dataDecl ∷ Q Dec
+ dataDecl = dataD (cxt []) name [] [con] [''Eq, ''Show]
+
name ∷ Name
name = mkName $ concatMap cs phrase
- dataDecl ∷ Q Dec
- dataDecl = dataD (cxt []) name [] [con] [''Eq, ''Show]
+ con ∷ Q Con
+ con = normalC name []
instanceDecl ∷ Q [Dec]
instanceDecl
= [d| instance StatusCode $typ where
{-# INLINE CONLIKE numericCode #-}
numericCode _ = $(lift num)
- {-# INLINE CONLIKE textualStatus #-}
- textualStatus _ = $txt
+ {-# INLINE textualStatus #-}
+ textualStatus _ = cs $(lift 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
+ txt ∷ Ascii
+ txt = mconcat $ intersperse "\x20"
+ $ A.unsafeFromString (show num) : phrase