, 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, 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 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'
+-- 'statusCodes' quasi-quoter.
--
-- Minimal complete definition: 'numericCode' and 'textualStatus'.
-class Show 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
--- |Container type for 'StatusCode' type class.
-data SomeStatusCode
- = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
-
-instance Show SomeStatusCode where
- show (SomeStatusCode sc) = show sc
-
-instance Eq SomeStatusCode where
- (SomeStatusCode α) == (SomeStatusCode β) = α ≈ β
-
-infix 4 ≈, ≉
--- |Equivalence of 'StatusCode's. Two 'StatusCode's @a@ and @b@ are
--- said to be equivalent iff @'numericCode' a '==' 'numericCode' b@.
---
--- U+2248, ALMOST EQUAL TO
-(≈) ∷ (StatusCode α, StatusCode β) ⇒ α → β → Bool
-{-# INLINE (≈) #-}
-α ≈ β = numericCode α ≡ numericCode β
-
--- |@(a ≉ b) '==' 'not' (a ≈ b)@
---
--- U+2249, NOT ALMOST EQUAL TO
-(≉) ∷ (StatusCode α, StatusCode β) ⇒ α → β → Bool
-{-# INLINE (≉) #-}
-(≉) = ((¬) ∘) ∘ (≈)
-
-instance StatusCode SomeStatusCode where
- numericCode (SomeStatusCode sc) = numericCode sc
- textualStatus (SomeStatusCode sc) = textualStatus sc
- fromStatusCode = id
+instance StatusCode sc ⇒ ConvertSuccess sc SomeStatusCode where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = fromStatusCode
instance StatusCode sc ⇒ ConvertSuccess sc Ascii where
{-# INLINE convertSuccess #-}
instance StatusCode sc ⇒ ConvertSuccess sc AsciiBuilder where
{-# INLINE convertSuccess #-}
- convertSuccess = cs ∘ textualStatus
+ convertSuccess = textualStatus
+
+instance StatusCode sc ⇒ ConvertAttempt sc SomeStatusCode where
+ {-# INLINE convertAttempt #-}
+ convertAttempt = return ∘ cs
instance StatusCode sc ⇒ ConvertAttempt sc Ascii where
{-# INLINE convertAttempt #-}
{-# INLINE convertAttempt #-}
convertAttempt = return ∘ cs
+-- |Container type for the 'StatusCode' type class.
+data SomeStatusCode
+ = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
+
+-- |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 StatusCode SomeStatusCode where
+ numericCode (SomeStatusCode sc) = numericCode sc
+ textualStatus (SomeStatusCode sc) = textualStatus sc
+ fromStatusCode = id
+
-- |'QuasiQuoter' for 'StatusCode' declarations.
--
-- Top-level splicing
-- becomes:
--
-- @
--- data OK = OK deriving ('Show')
+-- data OK = OK deriving ('Eq', 'Show')
-- instance OK where
-- 'numericCode' _ = 200
--- 'textualStatus' _ = 'A.unsafeFromString' \"200 OK\"
+-- 'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
--
--- data BadRequest = BadRequest deriving ('Show')
+-- data BadRequest = BadRequest deriving ('Eq', 'Show')
-- instance BadRequest where
-- 'numericCode' _ = 400
--- 'textualStatus' _ = 'A.unsafeFromString' \"400 Bad Request\"
+-- 'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
--
--- data MethodNotAllowed = MethodNotAllowed deriving ('Show')
+-- data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show')
-- instance MethodNotAllowed where
-- 'numericCode' _ = 405
--- 'textualStatus' _ = 'A.unsafeFromString' \"405 Method Not Allowed\"
+-- 'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
-- @
statusCodes ∷ QuasiQuoter
statusCodes = QuasiQuoter {
"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)
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 = 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
|]
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