Merge branch 'convertible'

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

diff --git a/Network/HTTP/Lucu/StatusCode/Internal.hs b/Network/HTTP/Lucu/StatusCode/Internal.hs
index d6e892b52259156bb7bcdf591b2983a9e7023a53..21210375bbfa3ae5d34cd84fe759bf8c6ecbe7ad 100644 (file)
--- a/Network/HTTP/Lucu/StatusCode/Internal.hs
+++ b/Network/HTTP/Lucu/StatusCode/Internal.hs
@@ -1,10 +1,13 @@
 {-# LANGUAGE
     ExistentialQuantification
   , FlexibleInstances
 {-# LANGUAGE
     ExistentialQuantification
   , FlexibleInstances

+  , MultiParamTypeClasses
+  , OverlappingInstances

   , TemplateHaskell
   , UnicodeSyntax
   , ViewPatterns
   #-}
   , TemplateHaskell
   , UnicodeSyntax
   , ViewPatterns
   #-}

+{-# OPTIONS_GHC -fno-warn-orphans #-}

 module Network.HTTP.Lucu.StatusCode.Internal
     ( StatusCode(..)
     , SomeStatusCode(..)
 module Network.HTTP.Lucu.StatusCode.Internal
     ( StatusCode(..)
     , SomeStatusCode(..)


@@ -14,11 +17,14 @@ module Network.HTTP.Lucu.StatusCode.Internal
     )
     where
 import Control.Applicative
     )
     where
 import Control.Applicative

-import Data.Ascii (Ascii)
+import Data.Ascii (Ascii, AsciiBuilder)

 import qualified Data.Ascii as A
 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 qualified Data.ByteString.Lazy.Char8 as Lazy

+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils

 import Data.List
 import Language.Haskell.TH.Lib
 import Language.Haskell.TH.Syntax
 import Data.List
 import Language.Haskell.TH.Lib
 import Language.Haskell.TH.Syntax


@@ -37,7 +43,7 @@ class Show sc ⇒ StatusCode sc where
     numericCode ∷ sc → Int
     -- |Return the combination of 3-digit integer and reason phrase
     -- for this status e.g. @200 OK@
     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
     -- |Wrap the status code into 'SomeStatusCode'.
     fromStatusCode ∷ sc → SomeStatusCode
     fromStatusCode = SomeStatusCode


@@ -73,6 +79,22 @@ instance StatusCode SomeStatusCode where
     textualStatus (SomeStatusCode sc) = textualStatus sc
     fromStatusCode = id
 
     textualStatus (SomeStatusCode sc) = textualStatus sc
     fromStatusCode = id
 

+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 Ascii where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = return ∘ cs
+
+instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = return ∘ cs
+

 -- |'QuasiQuoter' for 'StatusCode' declarations.
 --
 -- Top-level splicing
 -- |'QuasiQuoter' for 'StatusCode' declarations.
 --
 -- Top-level splicing


@@ -91,17 +113,17 @@ instance StatusCode SomeStatusCode where
 --   data OK = OK deriving ('Show')
 --   instance OK where
 --     'numericCode'   _ = 200
 --   data OK = OK deriving ('Show')
 --   instance OK where
 --     'numericCode'   _ = 200

---     'textualStatus' _ = 'A.unsafeFromString' \"200 OK\"
+--     'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)

 --
 --   data BadRequest = BadRequest deriving ('Show')
 --   instance BadRequest where
 --     'numericCode'   _ = 400
 --
 --   data BadRequest = BadRequest deriving ('Show')
 --   instance BadRequest where
 --     'numericCode'   _ = 400

---     'textualStatus' _ = 'A.unsafeFromString' \"400 Bad Request\"
+--     'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)

 --
 --   data MethodNotAllowed = MethodNotAllowed deriving ('Show')
 --   instance MethodNotAllowed where
 --     'numericCode'   _ = 405
 --
 --   data MethodNotAllowed = MethodNotAllowed deriving ('Show')
 --   instance MethodNotAllowed where
 --     'numericCode'   _ = 405

---     'textualStatus' _ = 'A.unsafeFromString' \"405 Method Not Allowed\"
+--     'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)

 -- @
 statusCodes ∷ QuasiQuoter
 statusCodes = QuasiQuoter {
 -- @
 statusCodes ∷ QuasiQuoter
 statusCodes = QuasiQuoter {


@@ -144,7 +166,7 @@ parseStatusCodes src
              "pair"
 
       word ∷ Parser Ascii
              "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)
 
 statusDecl ∷ (Int, [Ascii]) → Q [Dec]
 statusDecl (num, phrase)


@@ -153,7 +175,7 @@ statusDecl (num, phrase)
          return (a:bs)
     where
       name ∷ Name
          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] [''Show]
 
       dataDecl ∷ Q Dec
       dataDecl = dataD (cxt []) name [] [con] [''Show]


@@ -174,8 +196,8 @@ statusDecl (num, phrase)
       con = return $ NormalC name []
 
       txt ∷ Q Exp
       con = return $ NormalC name []
 
       txt ∷ Q Exp

-      txt = [| A.unsafeFromString $(lift txt') |]
+      txt = [| cs ($(lift txt') ∷ Ascii) |]

 
       txt' ∷ String
       txt' = concat $ intersperse "\x20"
 
       txt' ∷ String
       txt' = concat $ intersperse "\x20"

-                    $ show num : map A.toString phrase
+                    $ show num : map cs phrase