From 4636a979096b5af6cad76f22a1d08723c263a358 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri?= Date: Thu, 11 Jul 2024 14:24:58 +0200 Subject: [PATCH] Replace overlappable HasServer instance with a tyfam --- cabal.project | 2 +- .../test/Servant/ClientTestUtils.hs | 1 + servant-server/src/Servant/Server/Internal.hs | 29 ++++++------------ servant/src/Servant/API/ResponseHeaders.hs | 30 +++++++++++++++++++ 4 files changed, 41 insertions(+), 21 deletions(-) diff --git a/cabal.project b/cabal.project index 54136b810..ee2154b09 100644 --- a/cabal.project +++ b/cabal.project @@ -57,7 +57,7 @@ optimization: False -- Development flags package * - ghc-options: -fshow-hole-constraints -fhide-source-paths + ghc-options: -fshow-hole-constraints -fhide-source-paths -fprint-potential-instances -- reorder-goals: True diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index cafdd1537..94d2357bc 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -16,6 +16,7 @@ {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fprint-potential-instances #-} module Servant.ClientTestUtils where diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index d63c94a37..deb548260 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -71,7 +71,7 @@ import Servant.API.Modifiers unfoldRequestArgument) import Servant.API.QueryString (FromDeepQuery(..)) import Servant.API.ResponseHeaders - (GetHeaders, Headers, getHeaders, getResponse) + (GetHeaders, Headers, getHeaders, getResponse, Wrap, ExtractHeadersResponse, ExtractedValue, HandlerResponse, extractHeadersResponse) import Servant.API.Status (statusFromNat) import qualified Servant.Types.SourceT as S @@ -93,7 +93,7 @@ import Servant.Server.Internal.ServerError import Servant.API.TypeLevel (AtMostOneFragment, FragmentUnique) import Servant.API.MultiVerb (MultiVerb, Respond) -import Network.HTTP.Types (Header) +import Network.HTTP.Types (Header) class HasServer api context where -- | The type of a server for this API, given a monad to run effects in. @@ -318,27 +318,16 @@ noContentRouter method status action = leafRouter route' env request respond $ \ _output -> Route $ responseLBS status [] "" -instance {-# OVERLAPPABLE #-} - ( AllCTRender contentTypes a, ReflectMethod method, KnownNat status - ) => HasServer (MultiVerb method contentTypes '[Respond status (desc :: Symbol) a] a) context where - - type ServerT (MultiVerb method contentTypes '[Respond status (desc :: Symbol) a] a) m = m a - hoistServerWithContext _ _ nt s = nt s - - route Proxy _ = methodRouter ([],) method (Proxy :: Proxy contentTypes) status - where method = reflectMethod (Proxy :: Proxy method) - status = statusFromNat (Proxy :: Proxy status) - -instance {-# OVERLAPPING #-} - ( AllCTRender contentTypes a, ReflectMethod method, KnownNat status - , GetHeaders (Headers h a) - ) => HasServer (MultiVerb method contentTypes '[Respond status (desc :: Symbol) (Headers h a)] (Headers h a)) context where - - type ServerT (MultiVerb method contentTypes '[Respond status (desc :: Symbol) (Headers h a)] (Headers h a)) m = m (Headers h a) +instance ( AllCTRender ctypes (ExtractedValue a (Wrap a)) + , ReflectMethod method, KnownNat status + , ExtractHeadersResponse a (Wrap a) + , a ~ HandlerResponse a (Wrap a) + ) => HasServer (MultiVerb method ctypes '[Respond status (desc :: Symbol) a]) context where + type ServerT (MultiVerb method ctypes '[Respond status (desc :: Symbol) a]) m = m a hoistServerWithContext _ _ nt s = nt s - route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy contentTypes) status + route Proxy _ = methodRouter (extractHeadersResponse @a @(Wrap a)) method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = statusFromNat (Proxy :: Proxy status) diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index 915611262..c306885fd 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -22,6 +22,8 @@ module Servant.API.ResponseHeaders , GetHeaders' , HeaderValMap , HList(..) + , Wrap + , ExtractHeadersResponse(..) ) where import Control.DeepSeq @@ -48,6 +50,8 @@ import Servant.API.Modifiers import Servant.API.UVerb.Union import qualified Data.SOP.BasicFunctors as SOP import qualified Data.SOP.NS as SOP +import qualified Data.ByteString as B +import Network.HTTP.Types (HeaderName) -- | Response Header objects. You should never need to construct one directly. -- Instead, use 'addOptionalHeader'. @@ -257,6 +261,32 @@ lookupResponseHeader :: (HasResponseHeader h a headers) => Headers headers r -> ResponseHeader h a lookupResponseHeader = hlistLookupHeader . getHeadersHList +newtype Naked a = Naked a + +type family Wrap a where + Wrap (Headers x a) = Headers x a + Wrap a = Naked a + +class ExtractHeadersResponse orig wrapped where + type HandlerResponse orig wrapped :: Type + type ExtractedValue orig wrapped :: Type + + extractHeadersResponse :: HandlerResponse orig wrapped -> ([(HeaderName, B.ByteString)], ExtractedValue orig wrapped) + +instance ExtractHeadersResponse a (Naked a) where + type HandlerResponse a (Naked a) = a + type ExtractedValue a (Naked a) = a + + extractHeadersResponse :: a -> ([(HeaderName, B.ByteString)], a) + extractHeadersResponse x = ([], x) + +instance GetHeaders (Headers x a) => ExtractHeadersResponse (Headers x a) (Headers x a) where + type HandlerResponse (Headers x a) (Headers x a) = Headers x a + type ExtractedValue (Headers x a) (Headers x a) = a + + extractHeadersResponse :: Headers x a -> ([(HeaderName, B.ByteString)], a) + extractHeadersResponse x = (getHeaders x, getResponse x) + -- $setup -- >>> :set -XFlexibleContexts -- >>> import Servant.API