Each instances of StatusCode should not be an instance of Eq.

[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 3addcf2abd748ea5125b710b56048ef6c003e6fd..24988eefb2707d4e94aede4ade56f8e1a937d177 100644 (file)
--- a/Network/HTTP/Lucu/StatusCode/Internal.hs
+++ b/Network/HTTP/Lucu/StatusCode/Internal.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE
-    DeriveDataTypeable
-  , ExistentialQuantification
+    ExistentialQuantification
   , FlexibleInstances
   , TemplateHaskell
   , UnicodeSyntax
@@ -9,6 +8,8 @@
 module Network.HTTP.Lucu.StatusCode.Internal
     ( StatusCode(..)
     , SomeStatusCode(..)
+    , (≈)
+    , (≉)
     , statusCodes
     )
     where
@@ -19,7 +20,6 @@ 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
@@ -32,7 +32,7 @@ import Prelude.Unicode
 -- 'statusCodes'
 --
 -- Minimal complete definition: 'numericCode' and 'textualStatus'.
-class (Eq sc, Show sc, Typeable sc) ⇒ StatusCode sc where
+class 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
@@ -41,29 +41,37 @@ class (Eq sc, Show sc, Typeable sc) ⇒ StatusCode sc where
     -- |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
 
 -- |Container type for 'StatusCode' type class.
 data SomeStatusCode
     = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
-      deriving Typeable
 
 instance Show SomeStatusCode where
     show (SomeStatusCode sc) = show sc
 
--- |Two 'StatusCode's @a@ and @b@ are said to be equivalent iff
--- @'numericCode' a == 'numericCode' b@.
 instance Eq SomeStatusCode where
-    (SomeStatusCode α) == (SomeStatusCode β)
-        = numericCode α ≡ numericCode β
+    (SomeStatusCode α) == (SomeStatusCode β) = α ≈ β
+
+infix 4 ≈, ≉
+-- |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
-    toStatusCode   = Just
 
 -- |'QuasiQuoter' for 'StatusCode' declarations.
 --
@@ -80,17 +88,17 @@ instance StatusCode SomeStatusCode where
 -- becomes:
 --
 -- @
---   data OK = OK deriving ('Eq', 'Show', 'Typeable')
+--   data OK = OK deriving ('Show')
 --   instance OK where
 --     'numericCode'   _ = 200
 --     'textualStatus' _ = 'A.unsafeFromString' \"200 OK\"
 --
---   data BadRequest = BadRequest deriving ('Eq', 'Show', 'Typeable')
+--   data BadRequest = BadRequest deriving ('Show')
 --   instance BadRequest where
 --     'numericCode'   _ = 400
 --     'textualStatus' _ = 'A.unsafeFromString' \"400 Bad Request\"
 --
---   data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show', 'Typeable')
+--   data MethodNotAllowed = MethodNotAllowed deriving ('Show')
 --   instance MethodNotAllowed where
 --     'numericCode'   _ = 405
 --     'textualStatus' _ = 'A.unsafeFromString' \"405 Method Not Allowed\"
@@ -148,14 +156,7 @@ statusDecl (num, phrase)
       name = mkName $ concatMap A.toString phrase
 
       dataDecl ∷ Q Dec
-      dataDecl = dataD (cxt [])
-                       name
-                       []
-                       [con]
-                       [ mkName "Eq"
-                       , mkName "Show"
-                       , mkName "Typeable"
-                       ]
+      dataDecl = dataD (cxt []) name [] [con] [''Show]
 
       instanceDecl ∷ Q [Dec]
       instanceDecl