Destroy Data.Eq.Indirect

[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 e3122da1f55e21af4587abf5cf7d4175e8ccdd93..026b1a88b16bfdcb7094b8ae2d0dfe66f6f6508d 100644 (file)
--- a/Network/HTTP/Lucu/StatusCode/Internal.hs
+++ b/Network/HTTP/Lucu/StatusCode/Internal.hs
@@ -4,6 +4,7 @@
   , MultiParamTypeClasses
   , OverlappingInstances
   , TemplateHaskell
+  , TypeFamilies
   , UndecidableInstances
   , UnicodeSyntax
   , ViewPatterns
@@ -12,8 +13,6 @@
 module Network.HTTP.Lucu.StatusCode.Internal
     ( StatusCode(..)
     , SomeStatusCode
-    , (≈)
-    , (≉)
     , statusCodes
     )
     where
@@ -39,7 +38,7 @@ import Prelude.Unicode
 -- '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
@@ -49,36 +48,9 @@ class Show sc ⇒ StatusCode sc where
     fromStatusCode ∷ sc → SomeStatusCode
     fromStatusCode = SomeStatusCode
 
-instance StatusCode sc ⇒ Eq sc where
-    (==) = (≈)
-
--- |Container type for the 'StatusCode' type class.
-data SomeStatusCode
-    = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
-
-instance Show SomeStatusCode where
-    show (SomeStatusCode sc) = show sc
-
-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 #-}
@@ -88,6 +60,10 @@ 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
@@ -96,6 +72,25 @@ 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
+
+-- |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
@@ -111,17 +106,17 @@ instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where
 -- becomes:
 --
 -- @
---   data OK = OK deriving ('Show')
+--   data OK = OK deriving ('Eq', 'Show')
 --   instance OK where
 --     'numericCode'   _ = 200
 --     'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
 --
---   data BadRequest = BadRequest deriving ('Show')
+--   data BadRequest = BadRequest deriving ('Eq', 'Show')
 --   instance BadRequest where
 --     'numericCode'   _ = 400
 --     'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
 --
---   data MethodNotAllowed = MethodNotAllowed deriving ('Show')
+--   data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show')
 --   instance MethodNotAllowed where
 --     'numericCode'   _ = 405
 --     'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
@@ -179,7 +174,7 @@ statusDecl (num, 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