From f9994cf0b76a955309b937849b53a6a8a08dda82 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ga=C3=ABl=20Deest?= <gael.deest@tweag.io>
Date: Tue, 22 Feb 2022 11:56:56 +0100
Subject: [PATCH] =?UTF-8?q?Remove=20overlapping=20instance=20for=20`HasSer?=
 =?UTF-8?q?ver=20(Verb=20=E2=80=A6=20(Headers=20x=20a))`?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 servant-server/src/Servant/Server/Internal.hs | 44 +++++++++++++------
 1 file changed, 30 insertions(+), 14 deletions(-)

diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
index e2df2c4ac..942726165 100644
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@@ -292,26 +292,42 @@ noContentRouter method status action = leafRouter route'
                     env request respond $ \ _output ->
                       Route $ responseLBS status [] ""
 
-instance {-# OVERLAPPABLE #-}
-         ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
-         ) => HasServer (Verb method status ctypes a) context where
+newtype Naked a = Naked a
 
-  type ServerT (Verb method status ctypes a) m = m a
-  hoistServerWithContext _ _ nt s = nt s
+type family Wrap a where
+  Wrap (Headers x a) = Headers x a
+  Wrap a = Naked a
 
-  route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
-    where method = reflectMethod (Proxy :: Proxy method)
-          status = statusFromNat (Proxy :: Proxy status)
+class ExtractHeadersResponse orig wrapped where
+  type HandlerResponse orig wrapped :: *
+  type ExtractedValue orig wrapped :: *
 
-instance {-# OVERLAPPING #-}
-         ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
-         , GetHeaders (Headers h a)
-         ) => HasServer (Verb method status ctypes (Headers h a)) context where
+  extractHeadersResponse :: HandlerResponse orig wrapped -> (([(HeaderName, B.ByteString)]), ExtractedValue orig wrapped)
 
-  type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
+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)
+
+instance ( AllCTRender ctypes (ExtractedValue a (Wrap a))
+         , ReflectMethod method, KnownNat status
+         , ExtractHeadersResponse a (Wrap a)
+         , a ~ HandlerResponse a (Wrap a)
+         ) => HasServer (Verb method status ctypes a) context where
+
+  type ServerT (Verb method status ctypes a) m = m a
   hoistServerWithContext _ _ nt s = nt s
 
-  route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
+  route Proxy _ = methodRouter (extractHeadersResponse @a @(Wrap a)) method (Proxy :: Proxy ctypes) status
     where method = reflectMethod (Proxy :: Proxy method)
           status = statusFromNat (Proxy :: Proxy status)