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 -- Minimal complete definition: 'numericCode' and 'textualStatus'.
32 class (Eq sc, Show sc, Typeable sc) ⇒ StatusCode sc where
33 -- |Return the 3-digit integer for this status e.g. @200@
34 numericCode ∷ sc → Int
35 -- |Return the combination of 3-digit integer and reason phrase
36 -- for this status e.g. @200 OK@
37 textualStatus ∷ sc → Ascii
38 -- |Wrap the status code into 'SomeStatusCode'.
39 fromStatusCode ∷ sc → SomeStatusCode
40 fromStatusCode = SomeStatusCode
41 -- |Cast the status code from 'SomeStatusCode'.
42 toStatusCode ∷ SomeStatusCode → Maybe sc
43 toStatusCode (SomeStatusCode sc) = cast sc
47 = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
50 instance Show SomeStatusCode where
51 show (SomeStatusCode sc) = show sc
53 instance Eq SomeStatusCode where
54 (SomeStatusCode α) == (SomeStatusCode β)
55 = numericCode α ≡ numericCode β
57 instance StatusCode SomeStatusCode where
58 numericCode (SomeStatusCode sc) = numericCode sc
59 textualStatus (SomeStatusCode sc) = textualStatus sc
64 statusCodes ∷ QuasiQuoter
65 statusCodes = QuasiQuoter {
66 quoteExp = const unsupported
67 , quotePat = const unsupported
68 , quoteType = const unsupported
69 , quoteDec = (concat <$>) ∘ mapM statusDecl ∘ parseStatusCodes ∘ Lazy.pack
72 unsupported ∷ Monad m ⇒ m α
73 unsupported = fail "Unsupported usage of statusCodes quasi-quoter."
75 parseStatusCodes ∷ Lazy.ByteString → [(Int, [Ascii])]
77 = case LP.parse pairs src of
79 → error $ "Unparsable status codes: "
80 ⧺ intercalate ", " eCtx
86 pairs ∷ Parser [(Int, [Ascii])]
87 pairs = do skipMany endOfLine
88 xs ← sepBy pair (skipMany1 endOfLine)
95 pair ∷ Parser (Int, [Ascii])
99 phrase ← sepBy1 word $ skipWhile1 (≡ '\x20')
105 word = A.unsafeFromByteString <$> P.takeWhile1 isAlpha_ascii
107 statusDecl ∷ (Int, [Ascii]) → Q [Dec]
108 statusDecl (num, phrase)
114 name = mkName $ concatMap A.toString phrase
117 dataDecl = dataD (cxt [])
126 instanceDecl ∷ Q [Dec]
128 = [d| instance StatusCode $typ where
129 {-# INLINE numericCode #-}
130 numericCode _ = $(lift num)
131 {-# INLINE textualStatus #-}
132 textualStatus _ = $txt
139 con = return $ NormalC name []
142 txt = [| A.unsafeFromString $(lift txt') |]
145 txt' = concat $ intersperse "\x20"
146 $ show num : map A.toString phrase