X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FStatusCode%2FInternal.hs;h=026b1a88b16bfdcb7094b8ae2d0dfe66f6f6508d;hb=eb77281b24b8d7218e1fd80164f941836cef1d5a;hp=9269c5d07625c3f8f16251519c2a72061d76ab7a;hpb=51eda5b02d4528e2e240cbfc228de02b1c83799a;p=Lucu.git

diff --git a/Network/HTTP/Lucu/StatusCode/Internal.hs b/Network/HTTP/Lucu/StatusCode/Internal.hs
index 9269c5d..026b1a8 100644
--- a/Network/HTTP/Lucu/StatusCode/Internal.hs
+++ b/Network/HTTP/Lucu/StatusCode/Internal.hs
@@ -1,66 +1,126 @@
 {-# LANGUAGE
-    DeriveDataTypeable
-  , ExistentialQuantification
+    ExistentialQuantification
   , FlexibleInstances
+  , MultiParamTypeClasses
+  , OverlappingInstances
   , TemplateHaskell
+  , TypeFamilies
+  , UndecidableInstances
   , UnicodeSyntax
   , ViewPatterns
   #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Network.HTTP.Lucu.StatusCode.Internal
     ( StatusCode(..)
-    , SomeStatusCode(..)
+    , SomeStatusCode
     , statusCodes
     )
     where
 import Control.Applicative
-import Data.Ascii (Ascii)
+import Data.Ascii (Ascii, AsciiBuilder)
 import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
-import Data.Attoparsec.Lazy as LP
+import Data.Attoparsec.Char8
+import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString.Lazy.Char8 as Lazy
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
 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.
+-- |Type class for HTTP status codes.
+--
+-- Declaring types for each statuses is surely a pain. See:
+-- 'statusCodes' quasi-quoter.
 --
 -- Minimal complete definition: 'numericCode' and 'textualStatus'.
-class (Eq sc, Show sc, Typeable sc) ⇒ StatusCode sc where
+class (Eq sc, Show 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
+    textualStatus ∷ sc → AsciiBuilder
     -- |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
+instance StatusCode sc ⇒ ConvertSuccess sc SomeStatusCode where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = fromStatusCode
+
+instance StatusCode sc ⇒ ConvertSuccess sc Ascii where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance StatusCode sc ⇒ ConvertSuccess sc AsciiBuilder where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = textualStatus
+
+instance StatusCode sc ⇒ ConvertAttempt sc SomeStatusCode where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = return ∘ cs
+
+instance StatusCode sc ⇒ ConvertAttempt sc Ascii where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = return ∘ cs
+
+instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = return ∘ cs
+
+-- |Container type for the 'StatusCode' type class.
 data SomeStatusCode
     = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
-      deriving Typeable
+
+-- |Equivalence of 'StatusCode's. Two 'StatusCode's @α@ and
+-- @β@ are said to be equivalent iff @'numericCode' α '=='
+-- 'numericCode' β@.
+instance Eq SomeStatusCode where
+    {-# INLINE (==) #-}
+    (==) = (∘ numericCode) ∘ (==) ∘ numericCode
 
 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
+-- |'QuasiQuoter' for 'StatusCode' declarations.
+--
+-- Top-level splicing
+--
+-- @
+--   ['statusCodes'|
+--   200 OK
+--   400 Bad Request
+--   405 Method Not Allowed
+--   |]
+-- @
+--
+-- becomes:
+--
+-- @
+--   data OK = OK deriving ('Eq', 'Show')
+--   instance OK where
+--     'numericCode'   _ = 200
+--     'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
+--
+--   data BadRequest = BadRequest deriving ('Eq', 'Show')
+--   instance BadRequest where
+--     'numericCode'   _ = 400
+--     'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
+--
+--   data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show')
+--   instance MethodNotAllowed where
+--     'numericCode'   _ = 405
+--     'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
+-- @
 statusCodes ∷ QuasiQuoter
 statusCodes = QuasiQuoter {
                 quoteExp  = const unsupported
@@ -102,7 +162,7 @@ parseStatusCodes src
              "pair"
 
       word ∷ Parser Ascii
-      word = A.unsafeFromByteString <$> P.takeWhile1 isAlpha_ascii
+      word = A.unsafeFromByteString <$> takeWhile1 isAlpha_ascii
 
 statusDecl ∷ (Int, [Ascii]) → Q [Dec]
 statusDecl (num, phrase)
@@ -111,24 +171,17 @@ statusDecl (num, phrase)
          return (a:bs)
     where
       name ∷ Name
-      name = mkName $ concatMap A.toString phrase
+      name = mkName $ concatMap cs phrase
 
       dataDecl ∷ Q Dec
-      dataDecl = dataD (cxt [])
-                       name
-                       []
-                       [con]
-                       [ mkName "Eq"
-                       , mkName "Show"
-                       , mkName "Typeable"
-                       ]
+      dataDecl = dataD (cxt []) name [] [con] [''Eq, ''Show]
 
       instanceDecl ∷ Q [Dec]
       instanceDecl
           = [d| instance StatusCode $typ where
-                  {-# INLINE numericCode #-}
+                  {-# INLINE CONLIKE numericCode #-}
                   numericCode _ = $(lift num)
-                  {-# INLINE textualStatus #-}
+                  {-# INLINE CONLIKE textualStatus #-}
                   textualStatus _ = $txt
               |]
 
@@ -139,8 +192,8 @@ statusDecl (num, phrase)
       con = return $ NormalC name []
 
       txt ∷ Q Exp
-      txt = [| A.unsafeFromString $(lift txt') |]
+      txt = [| cs ($(lift txt') ∷ Ascii) |]
 
       txt' ∷ String
       txt' = concat $ intersperse "\x20"
-                    $ show num : map A.toString phrase
+                    $ show num : map cs phrase