From 42aad5a1889cf99c7c26ae7573bcc888e840ae66 Mon Sep 17 00:00:00 2001 From: PHO Date: Thu, 22 Dec 2011 22:30:34 +0900 Subject: [PATCH] New module: Data.Eq.Indirect providing Eq' type class. Ditz-issue: e6ec5a54d14cad8f79c456e23e92770fbbd3577e --- Data/Eq/Indirect.hs | 50 ++++++++++++++++++++++++ Lucu.cabal | 1 + Network/HTTP/Lucu/DefaultPage.hs | 27 +++++++------ Network/HTTP/Lucu/Postprocess.hs | 11 +++--- Network/HTTP/Lucu/Resource.hs | 3 +- Network/HTTP/Lucu/Response.hs | 9 ++--- Network/HTTP/Lucu/StatusCode/Internal.hs | 42 ++++++++------------ 7 files changed, 94 insertions(+), 49 deletions(-) create mode 100644 Data/Eq/Indirect.hs diff --git a/Data/Eq/Indirect.hs b/Data/Eq/Indirect.hs new file mode 100644 index 0000000..a7aa8d1 --- /dev/null +++ b/Data/Eq/Indirect.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE + FlexibleContexts + , TypeFamilies + , UnicodeSyntax + #-} +-- |FIXME: doc +module Data.Eq.Indirect + ( Eq'(..) + , (==:) + , (/=:) + , (≡:) + , (≢:) + , (≠:) + ) + where +import Prelude.Unicode + +infix 4 ==:{-, /=:, ≡:, ≢:, ≠:-} + +-- |FIXME: doc +class Eq (Unified α) ⇒ Eq' α where + -- |FIXME: doc + type Unified α + -- |FIXME: doc + unify ∷ α → Unified α + +-- |FIXME: doc +(==:) ∷ (Eq' α, Eq' β, Unified α ~ Unified β) ⇒ α → β → Bool +{-# INLINE (==:) #-} +(==:) = (∘ unify) ∘ (≡) ∘ unify + +-- |FIXME: doc +(/=:) ∷ (Eq' α, Eq' β, Unified α ~ Unified β) ⇒ α → β → Bool +{-# INLINE (/=:) #-} +(/=:) = ((¬) ∘) ∘ (==:) + +-- |FIXME: doc +(≡:) ∷ (Eq' α, Eq' β, Unified α ~ Unified β) ⇒ α → β → Bool +{-# INLINE CONLIKE (≡:) #-} +(≡:) = (==:) + +-- |FIXME: doc +(≢:) ∷ (Eq' α, Eq' β, Unified α ~ Unified β) ⇒ α → β → Bool +{-# INLINE CONLIKE (≢:) #-} +(≢:) = (/=:) + +-- |FIXME: doc +(≠:) ∷ (Eq' α, Eq' β, Unified α ~ Unified β) ⇒ α → β → Bool +{-# INLINE CONLIKE (≠:) #-} +(≠:) = (/=:) diff --git a/Lucu.cabal b/Lucu.cabal index d07f14f..c6dfa35 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -88,6 +88,7 @@ Library -DHAVE_SSL Exposed-Modules: + Data.Eq.Indirect Data.Collections.Newtype.TH Network.HTTP.Lucu Network.HTTP.Lucu.Abortion diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index c5ae6f5..a54bd59 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -16,6 +16,7 @@ import Data.Ascii (Ascii) import qualified Data.CaseInsensitive as CI import Data.Convertible.Base import Data.Convertible.Utils +import Data.Eq.Indirect import Data.Maybe import Data.Monoid.Unicode import Data.Text (Text) @@ -65,28 +66,28 @@ defaultMessage req res@(Response {..}) -- 1xx responses don't have a body. -- 2xx responses don't need a body to be completed. -- 3xx: - | resStatus ≈ MovedPermanently + | resStatus ≡: MovedPermanently = do unsafeByteString "The resource at " path unsafeByteString " has been moved to " a ! href (toValue loc) $ toHtml loc unsafeByteString " permanently." - | resStatus ≈ Found + | resStatus ≡: Found = do unsafeByteString "The resource at " path unsafeByteString " is currently located at " a ! href (toValue loc) $ toHtml loc unsafeByteString ". This is not a permanent relocation." - | resStatus ≈ SeeOther + | resStatus ≡: SeeOther = do unsafeByteString "The resource at " path unsafeByteString " can be found at " a ! href (toValue loc) $ toHtml loc unsafeByteString "." - | resStatus ≈ TemporaryRedirect + | resStatus ≡: TemporaryRedirect = do unsafeByteString "The resource at " path unsafeByteString " is temporarily located at " @@ -94,31 +95,31 @@ defaultMessage req res@(Response {..}) unsafeByteString "." -- 4xx: - | resStatus ≈ BadRequest + | resStatus ≡: BadRequest = unsafeByteString "The server could not understand the request you sent." - | resStatus ≈ Unauthorized + | resStatus ≡: Unauthorized = unsafeByteString "You need a valid authentication to access " ⊕ path - | resStatus ≈ Forbidden + | resStatus ≡: Forbidden = unsafeByteString "You don't have permission to access " ⊕ path - | resStatus ≈ NotFound + | resStatus ≡: NotFound = do unsafeByteString "The requested URL " path unsafeByteString " was not found on this server." - | resStatus ≈ Gone + | resStatus ≡: Gone = do unsafeByteString "The resource at " path unsafeByteString " was here in past times, but has gone permanently." - | resStatus ≈ RequestEntityTooLarge + | resStatus ≡: RequestEntityTooLarge = do unsafeByteString "The request entity you sent for " path unsafeByteString " was too large to accept." - | resStatus ≈ RequestURITooLarge + | resStatus ≡: RequestURITooLarge = unsafeByteString "The request URI you sent was too large to accept." -- 5xx: - | resStatus ≈ InternalServerError + | resStatus ≡: InternalServerError = unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path - | resStatus ≈ ServiceUnavailable + | resStatus ≡: ServiceUnavailable = unsafeByteString "The service is temporarily unavailable. Try later." | otherwise diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 7157b7d..c3aec8e 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -14,6 +14,7 @@ import Control.Monad import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import Data.Convertible.Base +import Data.Eq.Indirect import Data.Maybe import Data.Monoid.Unicode import GHC.Conc (unsafeIOToSTM) @@ -47,16 +48,16 @@ abortOnCertainConditions (NI {..}) $ cs ("Inappropriate status code for a response: " ∷ Ascii) ⊕ cs resStatus - when ( resStatus ≈ MethodNotAllowed ∧ - hasHeader "Allow" res ) + when ( resStatus ≡: MethodNotAllowed ∧ + (¬) (hasHeader "Allow" res) ) $ abort' $ cs ("The status was " ∷ Ascii) ⊕ cs resStatus ⊕ cs (" but no \"Allow\" header." ∷ Ascii) - when ( resStatus ≉ NotModified ∧ - isRedirection resStatus ∧ - hasHeader "Location" res ) + when ( resStatus ≢: NotModified ∧ + isRedirection resStatus ∧ + (¬) (hasHeader "Location" res) ) $ abort' $ cs ("The status code was " ∷ Ascii) ⊕ cs resStatus diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 1abf14b..fad0a62 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -159,6 +159,7 @@ import Data.Convertible.Base import Data.Convertible.Instances.Text () import Data.Convertible.Utils import Data.Default +import Data.Eq.Indirect import Data.List (intersperse, sort) import Data.Maybe import Data.Monoid @@ -624,7 +625,7 @@ getForm limit -- 'isRedirection' or it raises an error. redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc () redirect sc uri - = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc)) + = do when (sc ≡: NotModified ∨ (¬) (isRedirection sc)) $ abort $ mkAbortion' InternalServerError $ cs diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 1ff9ae7..f318fcf 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -21,8 +21,6 @@ module Network.HTTP.Lucu.Response , setStatusCode , resCanHaveBody - , (≈) - , (≉) , isInformational , isSuccessful , isRedirection @@ -35,6 +33,7 @@ import Data.Ascii (Ascii, AsciiBuilder) import Data.Convertible.Base import Data.Convertible.Instances.Ascii () import Data.Convertible.Utils +import Data.Eq.Indirect import Data.Monoid.Unicode import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion @@ -92,9 +91,9 @@ resCanHaveBody ∷ Response → Bool {-# INLINEABLE resCanHaveBody #-} resCanHaveBody (Response {..}) | isInformational resStatus = False - | resStatus ≈ NoContent = False - | resStatus ≈ ResetContent = False - | resStatus ≈ NotModified = False + | resStatus ≡: NoContent = False + | resStatus ≡: ResetContent = False + | resStatus ≡: NotModified = False | otherwise = True -- |@'isInformational' sc@ returns 'True' iff @sc '<' 200@. diff --git a/Network/HTTP/Lucu/StatusCode/Internal.hs b/Network/HTTP/Lucu/StatusCode/Internal.hs index e3122da..ec06f3e 100644 --- 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 @@ -26,6 +25,7 @@ import qualified Data.ByteString.Lazy.Char8 as Lazy 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 @@ -39,7 +39,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,32 +49,24 @@ class Show sc ⇒ StatusCode sc where 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 @@ -111,17 +103,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 +171,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 -- 2.40.0