From: PHO Date: Mon, 26 Dec 2011 05:14:20 +0000 (+0900) Subject: Destroy Data.Eq.Indirect X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=eb77281;p=Lucu.git Destroy Data.Eq.Indirect Ditz-issue: e6ec5a54d14cad8f79c456e23e92770fbbd3577e --- diff --git a/Data/Eq/Indirect.hs b/Data/Eq/Indirect.hs deleted file mode 100644 index 3c93da2..0000000 --- a/Data/Eq/Indirect.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE - FlexibleContexts - , TypeFamilies - , UnicodeSyntax - #-} --- |Indirect equality comparison. -module Data.Eq.Indirect - ( Eq'(..) - , (==:) - , (/=:) - , (≡:) - , (≢:) - , (≠:) - ) - where -import Prelude.Unicode - -infix 4 ==:, /=:, ≡:, ≢:, ≠: - --- |Type class for indirectly equality-comparable types. That is, any --- @α@ of @'Eq'' α@ has a monomorphism to some --- equality-comparable type @γ@ while @α@ itself isn't --- necessarily an instance of 'Eq'. This way we can generalise the --- '==' operator so that it can take two different types as long as --- they both have monomorphisms to the same 'Eq' type @γ@. --- --- Minimal complete definition: 'Unified' and 'unify'. -class Eq (Unified α) ⇒ Eq' α where - -- |The said equality-comparable type @γ@. - type Unified α - -- |Monomorphism from @α@ to @γ@. - 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 c6dfa35..d07f14f 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -88,7 +88,6 @@ 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 a54bd59..a5ad43c 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -16,7 +16,6 @@ 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) @@ -66,28 +65,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 ≡ cs MovedPermanently = do unsafeByteString "The resource at " path unsafeByteString " has been moved to " a ! href (toValue loc) $ toHtml loc unsafeByteString " permanently." - | resStatus ≡: Found + | resStatus ≡ cs 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 ≡ cs SeeOther = do unsafeByteString "The resource at " path unsafeByteString " can be found at " a ! href (toValue loc) $ toHtml loc unsafeByteString "." - | resStatus ≡: TemporaryRedirect + | resStatus ≡ cs TemporaryRedirect = do unsafeByteString "The resource at " path unsafeByteString " is temporarily located at " @@ -95,31 +94,31 @@ defaultMessage req res@(Response {..}) unsafeByteString "." -- 4xx: - | resStatus ≡: BadRequest + | resStatus ≡ cs BadRequest = unsafeByteString "The server could not understand the request you sent." - | resStatus ≡: Unauthorized + | resStatus ≡ cs Unauthorized = unsafeByteString "You need a valid authentication to access " ⊕ path - | resStatus ≡: Forbidden + | resStatus ≡ cs Forbidden = unsafeByteString "You don't have permission to access " ⊕ path - | resStatus ≡: NotFound + | resStatus ≡ cs NotFound = do unsafeByteString "The requested URL " path unsafeByteString " was not found on this server." - | resStatus ≡: Gone + | resStatus ≡ cs Gone = do unsafeByteString "The resource at " path unsafeByteString " was here in past times, but has gone permanently." - | resStatus ≡: RequestEntityTooLarge + | resStatus ≡ cs RequestEntityTooLarge = do unsafeByteString "The request entity you sent for " path unsafeByteString " was too large to accept." - | resStatus ≡: RequestURITooLarge + | resStatus ≡ cs RequestURITooLarge = unsafeByteString "The request URI you sent was too large to accept." -- 5xx: - | resStatus ≡: InternalServerError + | resStatus ≡ cs InternalServerError = unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path - | resStatus ≡: ServiceUnavailable + | resStatus ≡ cs 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 c3aec8e..b31c0ee 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -14,7 +14,6 @@ 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) @@ -48,14 +47,14 @@ abortOnCertainConditions (NI {..}) $ cs ("Inappropriate status code for a response: " ∷ Ascii) ⊕ cs resStatus - when ( resStatus ≡: MethodNotAllowed ∧ - (¬) (hasHeader "Allow" res) ) + when ( resStatus ≡ cs MethodNotAllowed ∧ + (¬) (hasHeader "Allow" res) ) $ abort' $ cs ("The status was " ∷ Ascii) ⊕ cs resStatus ⊕ cs (" but no \"Allow\" header." ∷ Ascii) - when ( resStatus ≢: NotModified ∧ + when ( resStatus ≢ cs NotModified ∧ isRedirection resStatus ∧ (¬) (hasHeader "Location" res) ) $ abort' diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index fad0a62..ce6c98a 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -8,6 +8,7 @@ , QuasiQuotes , RecordWildCards , UnicodeSyntax + , ViewPatterns #-} -- |This is the Resource Monad; monadic actions to define a behavior -- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it @@ -159,7 +160,6 @@ 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,13 +624,13 @@ getForm limit -- \"Location\" header field as @uri@. The @code@ must satisfy -- 'isRedirection' or it raises an error. redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc () -redirect sc uri - = do when (sc ≡: NotModified ∨ (¬) (isRedirection sc)) +redirect (fromStatusCode → sc) uri + = do when (sc ≡ cs NotModified ∨ (¬) (isRedirection sc)) $ abort $ mkAbortion' InternalServerError $ cs $ ("Attempted to redirect with status " ∷ Ascii) - ⊕ cs (fromStatusCode sc) + ⊕ cs sc setStatus sc setLocation uri diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index f318fcf..920449d 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -33,7 +33,6 @@ 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 @@ -90,11 +89,11 @@ setStatusCode sc res resCanHaveBody ∷ Response → Bool {-# INLINEABLE resCanHaveBody #-} resCanHaveBody (Response {..}) - | isInformational resStatus = False - | resStatus ≡: NoContent = False - | resStatus ≡: ResetContent = False - | resStatus ≡: NotModified = False - | otherwise = True + | isInformational resStatus = False + | resStatus ≡ cs NoContent = False + | resStatus ≡ cs ResetContent = False + | resStatus ≡ cs NotModified = False + | otherwise = True -- |@'isInformational' sc@ returns 'True' iff @sc '<' 200@. isInformational ∷ StatusCode sc ⇒ sc → Bool diff --git a/Network/HTTP/Lucu/StatusCode/Internal.hs b/Network/HTTP/Lucu/StatusCode/Internal.hs index e8785c3..026b1a8 100644 --- a/Network/HTTP/Lucu/StatusCode/Internal.hs +++ b/Network/HTTP/Lucu/StatusCode/Internal.hs @@ -25,7 +25,6 @@ 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 @@ -49,29 +48,9 @@ class (Eq sc, Show sc) ⇒ StatusCode sc where fromStatusCode ∷ sc → SomeStatusCode fromStatusCode = SomeStatusCode --- |Equivalence of 'StatusCode's. Two 'StatusCode's @α@ and --- @β@ are said to be equivalent iff @'numericCode' α '==' --- 'numericCode' β@. -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 - -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 #-} @@ -81,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 @@ -89,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