Skip to content

Commit

Permalink
Add details about AddHeaders instances (#1490)
Browse files Browse the repository at this point in the history
* Add details about the instances of AddHeader

Also:

* Cleanup of extensions and imports
  • Loading branch information
tchoutri authored Nov 30, 2021
1 parent 9a39799 commit a975cfc
Show file tree
Hide file tree
Showing 2 changed files with 7 additions and 11 deletions.
1 change: 1 addition & 0 deletions .gitignore
Original file line number Diff line number Diff line change
Expand Up @@ -31,6 +31,7 @@ doc/venv
doc/tutorial/static/api.js
doc/tutorial/static/jq.js
shell.nix
.hspec-failures

# nix
result*
Expand Down
17 changes: 6 additions & 11 deletions servant/src/Servant/API/ResponseHeaders.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,10 +3,8 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
Expand Down Expand Up @@ -51,9 +49,6 @@ import Web.HttpApiData

import Prelude ()
import Prelude.Compat
import Servant.API.ContentTypes
(JSON, PlainText, FormUrlEncoded, OctetStream,
MimeRender(..))
import Servant.API.Header
(Header)

Expand Down Expand Up @@ -117,7 +112,7 @@ instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbo
`HCons` buildHeadersTo headers
Right h -> Header h `HCons` buildHeadersTo headers

-- * Getting
-- * Getting headers

class GetHeaders ls where
getHeaders :: ls -> [HTTP.Header]
Expand Down Expand Up @@ -158,20 +153,20 @@ instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)
where
getHeaders' hs = getHeadersFromHList $ getHeadersHList hs

-- * Adding
-- * Adding headers

-- We need all these fundeps to save type inference
class AddHeader h v orig new
| h v orig -> new, new -> h, new -> v, new -> orig 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 h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)

instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v
, new ~ (Headers '[Header h v] a) )
-- In this instance, 'a' parameter is decorated with a Header.
instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header h v] a)
=> AddHeader h v a new where
addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)

Expand Down

0 comments on commit a975cfc

Please sign in to comment.