X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponse%2FStatusCode%2FInternal.hs;fp=Network%2FHTTP%2FLucu%2FStatusCode%2FInternal.hs;h=7d0da98d263b9c3b87d908fc8e5daab194791559;hp=026b1a88b16bfdcb7094b8ae2d0dfe66f6f6508d;hb=243b99439640480fc148d2e175247dacce04a222;hpb=9ee424cdca5d3030f8ef38d82b1c59d83fd6a98d

diff --git a/Network/HTTP/Lucu/StatusCode/Internal.hs b/Network/HTTP/Lucu/Response/StatusCode/Internal.hs
similarity index 79%
rename from Network/HTTP/Lucu/StatusCode/Internal.hs
rename to Network/HTTP/Lucu/Response/StatusCode/Internal.hs
index 026b1a8..7d0da98 100644
--- a/Network/HTTP/Lucu/StatusCode/Internal.hs
+++ b/Network/HTTP/Lucu/Response/StatusCode/Internal.hs
@@ -3,20 +3,22 @@
   , 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
@@ -26,9 +28,11 @@ import Data.Convertible.Base
 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
 
@@ -46,6 +50,7 @@ class (Eq sc, Show sc) ⇒ StatusCode sc where
     textualStatus ∷ sc → AsciiBuilder
     -- |Wrap the status code into 'SomeStatusCode'.
     fromStatusCode ∷ sc → SomeStatusCode
+    {-# INLINE CONLIKE fromStatusCode #-}
     fromStatusCode = SomeStatusCode
 
 instance StatusCode sc ⇒ ConvertSuccess sc SomeStatusCode where
@@ -74,7 +79,7 @@ instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder 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' α '=='
@@ -87,8 +92,11 @@ instance Show SomeStatusCode where
     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.
@@ -107,17 +115,17 @@ instance StatusCode SomeStatusCode where
 --
 -- @
 --   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)
 -- @
@@ -126,22 +134,25 @@ statusCodes = QuasiQuoter {
                 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
@@ -165,35 +176,29 @@ parseStatusCodes src
       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