3 , ExistentialQuantification
9 module Network.HTTP.Lucu.StatusCode.Internal
15 import Control.Applicative
16 import Data.Ascii (Ascii)
17 import qualified Data.Ascii as A
18 import Data.Attoparsec.Char8 as P
19 import Data.Attoparsec.Lazy as LP
20 import qualified Data.ByteString.Lazy.Char8 as Lazy
23 import Language.Haskell.TH.Lib
24 import Language.Haskell.TH.Syntax
25 import Language.Haskell.TH.Quote
26 import Network.HTTP.Lucu.Parser
27 import Prelude.Unicode
29 -- |The type class for HTTP status codes.
31 -- Declaring types for each statuses is surely a pain. See:
34 -- Minimal complete definition: 'numericCode' and 'textualStatus'.
35 class (Eq sc, Show sc, Typeable sc) ⇒ StatusCode sc where
36 -- |Return the 3-digit integer for this status e.g. @200@
37 numericCode ∷ sc → Int
38 -- |Return the combination of 3-digit integer and reason phrase
39 -- for this status e.g. @200 OK@
40 textualStatus ∷ sc → Ascii
41 -- |Wrap the status code into 'SomeStatusCode'.
42 fromStatusCode ∷ sc → SomeStatusCode
43 fromStatusCode = SomeStatusCode
44 -- |Cast the status code from 'SomeStatusCode'.
45 toStatusCode ∷ SomeStatusCode → Maybe sc
46 toStatusCode (SomeStatusCode sc) = cast sc
48 -- |Container type for 'StatusCode' type class.
50 = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
53 instance Show SomeStatusCode where
54 show (SomeStatusCode sc) = show sc
56 -- |Two 'StatusCode's @a@ and @b@ are said to be equivalent iff
57 -- @'numericCode' a == 'numericCode' b@.
58 instance Eq SomeStatusCode where
59 (SomeStatusCode α) == (SomeStatusCode β)
60 = numericCode α ≡ numericCode β
62 instance StatusCode SomeStatusCode where
63 numericCode (SomeStatusCode sc) = numericCode sc
64 textualStatus (SomeStatusCode sc) = textualStatus sc
68 -- |'QuasiQuoter' for 'StatusCode' declarations.
76 -- 405 Method Not Allowed
83 -- data OK = OK deriving ('Eq', 'Show', 'Typeable')
85 -- 'numericCode' _ = 200
86 -- 'textualStatus' _ = 'A.unsafeFromString' \"200 OK\"
88 -- data BadRequest = BadRequest deriving ('Eq', 'Show', 'Typeable')
89 -- instance BadRequest where
90 -- 'numericCode' _ = 400
91 -- 'textualStatus' _ = 'A.unsafeFromString' \"400 Bad Request\"
93 -- data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show', 'Typeable')
94 -- instance MethodNotAllowed where
95 -- 'numericCode' _ = 405
96 -- 'textualStatus' _ = 'A.unsafeFromString' \"405 Method Not Allowed\"
98 statusCodes ∷ QuasiQuoter
99 statusCodes = QuasiQuoter {
100 quoteExp = const unsupported
101 , quotePat = const unsupported
102 , quoteType = const unsupported
103 , quoteDec = (concat <$>) ∘ mapM statusDecl ∘ parseStatusCodes ∘ Lazy.pack
106 unsupported ∷ Monad m ⇒ m α
107 unsupported = fail "Unsupported usage of statusCodes quasi-quoter."
109 parseStatusCodes ∷ Lazy.ByteString → [(Int, [Ascii])]
111 = case LP.parse pairs src of
113 → error $ "Unparsable status codes: "
114 ⧺ intercalate ", " eCtx
120 pairs ∷ Parser [(Int, [Ascii])]
121 pairs = do skipMany endOfLine
122 xs ← sepBy pair (skipMany1 endOfLine)
129 pair ∷ Parser (Int, [Ascii])
133 phrase ← sepBy1 word $ skipWhile1 (≡ '\x20')
139 word = A.unsafeFromByteString <$> P.takeWhile1 isAlpha_ascii
141 statusDecl ∷ (Int, [Ascii]) → Q [Dec]
142 statusDecl (num, phrase)
148 name = mkName $ concatMap A.toString phrase
151 dataDecl = dataD (cxt [])
160 instanceDecl ∷ Q [Dec]
162 = [d| instance StatusCode $typ where
163 {-# INLINE numericCode #-}
164 numericCode _ = $(lift num)
165 {-# INLINE textualStatus #-}
166 textualStatus _ = $txt
173 con = return $ NormalC name []
176 txt = [| A.unsafeFromString $(lift txt') |]
179 txt' = concat $ intersperse "\x20"
180 $ show num : map A.toString phrase