From be42f3d6085a125e313e3ee7d92ab981ad1e0501 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Fri, 8 Jun 2018 15:10:38 +0300
Subject: [PATCH] Implement GetHeaders instances without overlapping

---
 servant/src/Servant/API/ResponseHeaders.hs | 46 +++++++++++++++-------
 1 file changed, 32 insertions(+), 14 deletions(-)

diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs
index cd6f1ad6..a0036c93 100644
--- a/servant/src/Servant/API/ResponseHeaders.hs
+++ b/servant/src/Servant/API/ResponseHeaders.hs
@@ -100,23 +100,41 @@ instance OVERLAPPABLE_ ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )
 class GetHeaders ls where
     getHeaders :: ls -> [HTTP.Header]
 
-instance OVERLAPPING_ GetHeaders (HList '[]) where
-    getHeaders _ = []
+-- | Auxiliary class for @'GetHeaders' ('HList' hs)@ instance
+class GetHeadersFromHList hs where
+    getHeadersFromHList :: HList hs  -> [HTTP.Header]
 
-instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData x, GetHeaders (HList xs) )
-         => GetHeaders (HList (Header h x ': xs)) where
-    getHeaders hdrs = case hdrs of
-        Header val `HCons` rest -> (headerName , toHeader val):getHeaders rest
-        UndecodableHeader h `HCons` rest -> (headerName,  h)  :getHeaders rest
-        MissingHeader `HCons` rest -> getHeaders rest
-      where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
+instance GetHeadersFromHList hs => GetHeaders (HList hs) where
+    getHeaders = getHeadersFromHList
 
-instance OVERLAPPING_ GetHeaders (Headers '[] a) where
-    getHeaders _ = []
+instance GetHeadersFromHList '[] where
+    getHeadersFromHList _ = []
 
-instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v )
-         => GetHeaders (Headers (Header h v ': rest) a) where
-    getHeaders hs = getHeaders $ getHeadersHList hs
+instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs)
+    => GetHeadersFromHList (Header h x ': xs)
+  where
+    getHeadersFromHList hdrs = case hdrs of
+        Header val `HCons` rest          -> (headerName , toHeader val) : getHeadersFromHList rest
+        UndecodableHeader h `HCons` rest -> (headerName,  h) : getHeadersFromHList rest
+        MissingHeader `HCons` rest       -> getHeadersFromHList rest
+      where
+        headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
+
+-- | Auxiliary class for @'GetHeaders' ('Headers' hs a)@ instance
+class GetHeaders' hs where
+    getHeaders' :: Headers hs a -> [HTTP.Header]
+
+instance GetHeaders' hs => GetHeaders (Headers hs a) where
+    getHeaders = getHeaders'
+
+-- | This instance is an optimisation
+instance GetHeaders' '[] where
+    getHeaders' _ = []
+
+instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)
+    => GetHeaders' (Header h v ': rest)
+  where
+    getHeaders' hs = getHeadersFromHList $ getHeadersHList hs
 
 -- * Adding