StatusCode is now a type class, not an algebraic data type.

[Lucu.git] / Network / HTTP / Lucu / StatusCode / Internal.hs

diff --git a/Network/HTTP/Lucu/StatusCode/Internal.hs b/Network/HTTP/Lucu/StatusCode/Internal.hs
new file mode 100644 (file)
index 0000000..9269c5d
--- /dev/null
+++ b/Network/HTTP/Lucu/StatusCode/Internal.hs
@@ -0,0 +1,146 @@
+{-# 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.
+--
+-- 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
+
+-- |FIXME: doc
+data SomeStatusCode
+    = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
+      deriving Typeable
+
+instance Show SomeStatusCode where
+    show (SomeStatusCode sc) = show sc
+
+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
+
+-- |FIXME: doc
+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