Skip to content

Commit fca5955

Browse files
author
Gaël Deest
committed
Code reorganization
Move `HasServer (NamedRoutes routes)` instance The instance has been moved to `Servant.Server.Internal`, as the instances for other combinators. It is necessary so that the instance can be re-exported from `Servant.Server` without circular imports. Otherwise, users have to import `Servant.Server.Generic` manually ; forgetting to do so will produce confusing error messages about the missing instance. Move `HasClient (NamedRoutes routes)` instance Moved so that the instance is made available when importing `Servant.Client`, avoiding possibly confusing errors when `Servant.Client.Generic` isn't imported.
1 parent b033871 commit fca5955

File tree

9 files changed

+162
-162
lines changed

9 files changed

+162
-162
lines changed

‎servant-client-core/src/Servant/Client/Core/HasClient.hs

Lines changed: 56 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -18,10 +18,15 @@
1818
#define HAS_TYPE_ERROR
1919
#endif
2020

21+
#if __GLASGOW_HASKELL__ >= 806
22+
{-# LANGUAGE QuantifiedConstraints #-}
23+
#endif
24+
2125
module Servant.Client.Core.HasClient (
2226
clientIn,
2327
HasClient (..),
2428
EmptyClient (..),
29+
AsClientT,
2530
foldMapUnion,
2631
matchUnion,
2732
) where
@@ -39,6 +44,7 @@ import Data.ByteString.Builder
3944
import qualified Data.ByteString.Lazy as BL
4045
import Data.Either
4146
(partitionEithers)
47+
import Data.Constraint (Dict(..))
4248
import Data.Foldable
4349
(toList)
4450
import Data.List
@@ -79,7 +85,10 @@ import Servant.API
7985
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
8086
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
8187
Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
82-
getResponse, toEncodedUrlPiece, toUrlPiece)
88+
getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
89+
import Servant.API.Generic
90+
(GenericMode(..), ToServant, ToServantApi
91+
, GenericServant, toServant, fromServant)
8392
import Servant.API.ContentTypes
8493
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
8594
import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
@@ -816,6 +825,52 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
816825
hoistClientMonad pm _ f cl = \bauth ->
817826
hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
818827

828+
-- | A type that specifies that an API record contains a client implementation.
829+
data AsClientT (m :: * -> *)
830+
instance GenericMode (AsClientT m) where
831+
type AsClientT m :- api = Client m api
832+
833+
#if __GLASGOW_HASKELL__ >= 806
834+
835+
type GClientConstraints api m =
836+
( GenericServant api (AsClientT m)
837+
, Client m (ToServantApi api) ~ ToServant api (AsClientT m)
838+
)
839+
840+
class GClient (api :: * -> *) m where
841+
proof :: Dict (GClientConstraints api m)
842+
843+
instance GClientConstraints api m => GClient api m where
844+
proof = Dict
845+
846+
instance
847+
( forall n. GClient api n
848+
, HasClient m (ToServantApi api)
849+
, RunClient m
850+
)
851+
=> HasClient m (NamedRoutes api) where
852+
type Client m (NamedRoutes api) = api (AsClientT m)
853+
854+
clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
855+
clientWithRoute pm _ request =
856+
case proof @api @m of
857+
Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
858+
859+
hoistClientMonad
860+
:: forall ma mb.
861+
Proxy m
862+
-> Proxy (NamedRoutes api)
863+
-> (forall x. ma x -> mb x)
864+
-> Client ma (NamedRoutes api)
865+
-> Client mb (NamedRoutes api)
866+
hoistClientMonad _ _ nat clientA =
867+
case (proof @api @ma, proof @api @mb) of
868+
(Dict, Dict) ->
869+
fromServant @api @(AsClientT mb) $
870+
hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
871+
toServant @api @(AsClientT ma) clientA
872+
873+
#endif
819874

820875

821876
{- Note [Non-Empty Content Types]

‎servant-client-core/src/Servant/Client/Generic.hs

Lines changed: 1 addition & 59 deletions
Original file line numberDiff line numberDiff line change
@@ -1,38 +1,22 @@
11
{-# OPTIONS_GHC -fno-warn-orphans #-}
2-
{-# LANGUAGE ConstraintKinds #-}
3-
{-# LANGUAGE CPP #-}
42
{-# LANGUAGE FlexibleContexts #-}
5-
{-# LANGUAGE FlexibleInstances #-}
6-
{-# LANGUAGE InstanceSigs #-}
73
{-# LANGUAGE KindSignatures #-}
8-
{-# LANGUAGE MultiParamTypeClasses #-}
94
{-# LANGUAGE RankNTypes #-}
105
{-# LANGUAGE ScopedTypeVariables #-}
11-
{-# LANGUAGE TypeApplications #-}
126
{-# LANGUAGE TypeFamilies #-}
13-
{-# LANGUAGE UndecidableInstances #-}
14-
15-
#if __GLASGOW_HASKELL__ >= 806
16-
{-# LANGUAGE QuantifiedConstraints #-}
17-
#endif
187

198
module Servant.Client.Generic (
209
AsClientT,
2110
genericClient,
2211
genericClientHoist,
2312
) where
2413

25-
import Data.Constraint (Dict(..))
2614
import Data.Proxy
2715
(Proxy (..))
2816

2917
import Servant.API.Generic
3018
import Servant.Client.Core
31-
32-
-- | A type that specifies that an API record contains a client implementation.
33-
data AsClientT (m :: * -> *)
34-
instance GenericMode (AsClientT m) where
35-
type AsClientT m :- api = Client m api
19+
import Servant.Client.Core.HasClient (AsClientT)
3620

3721
-- | Generate a record of client functions.
3822
genericClient
@@ -62,45 +46,3 @@ genericClientHoist nt
6246
where
6347
m = Proxy :: Proxy m
6448
api = Proxy :: Proxy (ToServantApi routes)
65-
66-
#if __GLASGOW_HASKELL__ >= 806
67-
68-
type GClientConstraints api m =
69-
( GenericServant api (AsClientT m)
70-
, Client m (ToServantApi api) ~ ToServant api (AsClientT m)
71-
)
72-
73-
class GClient (api :: * -> *) m where
74-
proof :: Dict (GClientConstraints api m)
75-
76-
instance GClientConstraints api m => GClient api m where
77-
proof = Dict
78-
79-
instance
80-
( forall n. GClient api n
81-
, HasClient m (ToServantApi api)
82-
, RunClient m
83-
)
84-
=> HasClient m (NamedRoutes api) where
85-
type Client m (NamedRoutes api) = api (AsClientT m)
86-
87-
clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
88-
clientWithRoute pm _ request =
89-
case proof @api @m of
90-
Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
91-
92-
hoistClientMonad
93-
:: forall ma mb.
94-
Proxy m
95-
-> Proxy (NamedRoutes api)
96-
-> (forall x. ma x -> mb x)
97-
-> Client ma (NamedRoutes api)
98-
-> Client mb (NamedRoutes api)
99-
hoistClientMonad _ _ nat clientA =
100-
case (proof @api @ma, proof @api @mb) of
101-
(Dict, Dict) ->
102-
fromServant @api @(AsClientT mb) $
103-
hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
104-
toServant @api @(AsClientT ma) clientA
105-
106-
#endif

‎servant-server/src/Servant/Server/Generic.hs

Lines changed: 2 additions & 95 deletions
Original file line numberDiff line numberDiff line change
@@ -1,25 +1,9 @@
1-
{-# OPTIONS_GHC -fno-warn-orphans #-}
2-
{-# LANGUAGE AllowAmbiguousTypes #-}
3-
{-# LANGUAGE ConstraintKinds #-}
4-
{-# LANGUAGE CPP #-}
51
{-# LANGUAGE DataKinds #-}
6-
{-# LANGUAGE DefaultSignatures #-}
72
{-# LANGUAGE FlexibleContexts #-}
8-
{-# LANGUAGE FlexibleInstances #-}
9-
{-# LANGUAGE InstanceSigs #-}
10-
{-# LANGUAGE KindSignatures #-}
11-
{-# LANGUAGE MultiParamTypeClasses #-}
12-
{-# LANGUAGE QuantifiedConstraints #-}
133
{-# LANGUAGE RankNTypes #-}
144
{-# LANGUAGE ScopedTypeVariables #-}
15-
{-# LANGUAGE TypeApplications #-}
165
{-# LANGUAGE TypeFamilies #-}
176
{-# LANGUAGE TypeOperators #-}
18-
{-# LANGUAGE UndecidableInstances #-}
19-
20-
#if __GLASGOW_HASKELL__ >= 806
21-
{-# LANGUAGE QuantifiedConstraints #-}
22-
#endif
237

248
-- | @since 0.14.1
259
module Servant.Server.Generic (
@@ -29,29 +13,16 @@ module Servant.Server.Generic (
2913
genericServeT,
3014
genericServeTWithContext,
3115
genericServer,
32-
genericServerT,
33-
-- * Internal machinery
34-
GServerConstraints,
35-
GServer,
36-
-- * Re-exports
37-
NamedRoutes
16+
genericServerT
3817
) where
3918

40-
import Data.Constraint
4119
import Data.Proxy
4220
(Proxy (..))
4321

44-
import Servant.API.Generic
4522
import Servant.Server
23+
import Servant.API.Generic
4624
import Servant.Server.Internal
4725

48-
-- | A type that specifies that an API record contains a server implementation.
49-
data AsServerT (m :: * -> *)
50-
instance GenericMode (AsServerT m) where
51-
type AsServerT m :- api = ServerT api m
52-
53-
type AsServer = AsServerT Handler
54-
5526
-- | Transform a record of routes into a WAI 'Application'.
5627
genericServe
5728
:: forall routes.
@@ -119,67 +90,3 @@ genericServerT
11990
-> ToServant routes (AsServerT m)
12091
genericServerT = toServant
12192

122-
#if __GLASGOW_HASKELL__ >= 806
123-
124-
-- | Set of constraints required to convert to / from vanilla server types.
125-
type GServerConstraints api m =
126-
( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
127-
, GServantProduct (Rep (api (AsServerT m)))
128-
)
129-
130-
-- | This class is a necessary evil: in the implementation of 'HasServer' for
131-
-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall
132-
-- m. 'GServerConstraints' m@ to hold.
133-
--
134-
-- We cannot require do that directly as the definition of 'GServerConstraints'
135-
-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide
136-
-- those type family applications behind a typeclass providing evidence for
137-
-- @'GServerConstraints' api m@ in the form of a dictionary, and require that
138-
-- @forall m. 'GServer' api m@ instead.
139-
--
140-
-- Users shouldn't have to worry about this class, as the only possible instance
141-
-- is provided in this module for all record APIs.
142-
143-
class GServer (api :: * -> *) (m :: * -> *) where
144-
proof :: Dict (GServerConstraints api m)
145-
146-
instance
147-
( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
148-
, GServantProduct (Rep (api (AsServerT m)))
149-
) => GServer api m where
150-
proof = Dict
151-
152-
instance
153-
( HasServer (ToServantApi api) context
154-
, forall m. Generic (api (AsServerT m))
155-
, forall m. GServer api m
156-
) => HasServer (NamedRoutes api) context where
157-
158-
type ServerT (NamedRoutes api) m = api (AsServerT m)
159-
160-
route
161-
:: Proxy (NamedRoutes api)
162-
-> Context context
163-
-> Delayed env (api (AsServerT Handler))
164-
-> Router env
165-
route _ ctx delayed =
166-
case proof @api @Handler of
167-
Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)
168-
169-
hoistServerWithContext
170-
:: forall m n. Proxy (NamedRoutes api)
171-
-> Proxy context
172-
-> (forall x. m x -> n x)
173-
-> api (AsServerT m)
174-
-> api (AsServerT n)
175-
hoistServerWithContext _ pctx nat server =
176-
case (proof @api @m, proof @api @n) of
177-
(Dict, Dict) ->
178-
fromServant servantSrvN
179-
where
180-
servantSrvM :: ServerT (ToServantApi api) m =
181-
toServant server
182-
servantSrvN :: ServerT (ToServantApi api) n =
183-
hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM
184-
185-
#endif

0 commit comments

Comments
 (0)