Merge pull request #971 from phadej/get-headers-no-overlap

Implement GetHeaders instances without overlapping

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
+-- | Auxiliary class for @'GetHeaders' ('HList' hs)@ instance
-    getHeaders _ = []
+class GetHeadersFromHList hs where
+    getHeadersFromHList :: HList hs  -> [HTTP.Header]
 
-instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData x, GetHeaders (HList xs) )
+instance GetHeadersFromHList hs => GetHeaders (HList hs) where
-         => GetHeaders (HList (Header h x ': xs)) where
+    getHeaders = getHeadersFromHList
-    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 OVERLAPPING_ GetHeaders (Headers '[] a) where
+instance GetHeadersFromHList '[] where
-    getHeaders _ = []
+    getHeadersFromHList _ = []
 
-instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v )
+instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs)
-         => GetHeaders (Headers (Header h v ': rest) a) where
+    => GetHeadersFromHList (Header h x ': xs)
-    getHeaders hs = getHeaders $ getHeadersHList hs
+  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