fixup! Use full header type in response header instances

Author: worm2fed

servant-server/test/Servant/ServerSpec.hs

@@ -54,11 +54,11 @@ import           Servant.API
                  ((:<|>) (..), (:>), AuthProtect, BasicAuth,
                  BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
                  Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
-                 Headers, HttpVersion, IsSecure (..), JSON, Lenient,
+                 Header', Headers, HttpVersion, IsSecure (..), JSON, Lenient,
                  NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
                  PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,
                  RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
-                 UVerb, Union, Verb, WithStatus (..), addHeader)
+                 UVerb, Union, Verb, WithStatus (..), Optional, addHeader)
 import           Servant.Server
                  (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..),
                  emptyServer, err401, err403, err404, hoistServer, respond, serve,
@@ -746,7 +746,7 @@ type UVerbResponseHeadersApi =
        Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
 
 uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
-uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String)
+uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" @_ @_ @_ @('[Optional, Strict]) (5 :: Int) $ ("foo" :: String)
 uverbResponseHeadersServer False = respond .  WithStatus @404 $ ("bar" :: String)
 
 uverbResponseHeadersSpec :: Spec

servant/src/Servant/API/ResponseHeaders.hs

@@ -53,6 +53,8 @@ import           Prelude ()
 import           Prelude.Compat
 import           Servant.API.Header
                  (Header, Header')
+import           Servant.API.Modifiers 
+                 (Optional, Strict)
 import           Servant.API.UVerb.Union
 import qualified Data.SOP.BasicFunctors as SOP
 import qualified Data.SOP.NS as SOP
@@ -158,35 +160,35 @@ instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)
 -- * Adding headers
 
 -- We need all these fundeps to save type inference
-class AddHeader (mods :: [*]) h v orig new
-    | mods h v orig -> new, new -> mods, new -> h, new -> v, new -> orig where
+class AddHeader h v orig new (mods :: [*])
+    | h v orig mods -> new, new -> h, new -> v, new -> orig, new -> mods where
   addOptionalHeader :: ResponseHeader h v -> orig -> new  -- ^ N.B.: The same header can't be added multiple times
 
 -- In this instance, we add a Header on top of something that is already decorated with some headers
 instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
-         => AddHeader mods h v (Headers (fst ': rest)  a) (Headers (Header' mods h v  ': fst ': rest) a) where
+         => AddHeader h v (Headers (fst ': rest) a) (Headers (Header' mods h v  ': fst ': rest) a) mods where
     addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)
 
 -- In this instance, 'a' parameter is decorated with a Header.
 instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header' mods h v] a)
-         => AddHeader mods h v a new where
+         => AddHeader h v a new mods where
     addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
 
 -- Instances to decorate all responses in a 'Union' with headers. The functional
 -- dependencies force us to consider singleton lists as the base case in the
 -- recursion (it is impossible to determine h and v otherwise from old / new
 -- responses if the list is empty).
-instance (AddHeader mods h v old new) => AddHeader mods h v (Union '[old]) (Union '[new]) where
+instance (AddHeader h v old new mods) => AddHeader h v (Union '[old]) (Union '[new]) mods where
   addOptionalHeader hdr resp =
     SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ $ resp
 
 instance
-  ( AddHeader mods h v old new, AddHeader mods h v (Union oldrest) (Union newrest)
+  ( AddHeader h v old new mods, AddHeader h v (Union oldrest) (Union newrest) mods
   -- This ensures that the remainder of the response list is _not_ empty
   -- It is necessary to prevent the two instances for union types from
   -- overlapping.
   , oldrest ~ (a ': as), newrest ~ (b ': bs))
-  => AddHeader mods h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where
+  => AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) mods where
   addOptionalHeader hdr resp = case resp of
     SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead
     SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers
@@ -211,15 +213,15 @@ instance
 -- Note that while in your handlers type annotations are not required, since
 -- the type can be inferred from the API type, in other cases you may find
 -- yourself needing to add annotations.
-addHeader :: AddHeader mods h v orig new => v -> orig -> new
+addHeader :: AddHeader h v orig new mods => v -> orig -> new
 addHeader = addOptionalHeader . Header
 
 -- | Deliberately do not add a header to a value.
 --
 -- >>> let example1 = noHeader "hi" :: Headers '[Header "someheader" Int] String
 -- >>> getHeaders example1
 -- []
-noHeader :: AddHeader mods h v orig new => orig -> new
+noHeader :: AddHeader h v orig new mods => orig -> new
 noHeader = addOptionalHeader MissingHeader
 
 class HasResponseHeader h a headers where