, MultiParamTypeClasses
, OverlappingInstances
, TemplateHaskell
+ , TypeFamilies
, UndecidableInstances
, UnicodeSyntax
, ViewPatterns
module Network.HTTP.Lucu.StatusCode.Internal
( StatusCode(..)
, SomeStatusCode
- , (≈)
- , (≉)
, statusCodes
)
where
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
+import Data.Eq.Indirect
import Data.List
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
-- '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
fromStatusCode ∷ sc → SomeStatusCode
fromStatusCode = SomeStatusCode
-instance StatusCode sc ⇒ Eq sc where
- (==) = (≈)
+-- |Equivalence of 'StatusCode's. Two 'StatusCode's @a@ and @b@ are
+-- said to be equivalent iff @'numericCode' a '==' 'numericCode' b@.
+instance StatusCode sc ⇒ Eq' sc where
+ type Unified sc = Int
+ {-# INLINE CONLIKE unify #-}
+ unify = numericCode
-- |Container type for the 'StatusCode' type class.
data SomeStatusCode
= ∀sc. StatusCode sc ⇒ SomeStatusCode sc
+instance Eq SomeStatusCode where
+ {-# INLINE CONLIKE (==) #-}
+ (==) = (≡:)
+
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
-- 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)
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