git.iko.soy/servant
on master help sign in
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.

commitfca59556dd5cd196f0ed521beef89ce774e15aea authorGaël Deest <gael.deest@tweag.io> dateSun 3 Oct 2021, 17:09 (5 years ago) parentb033871
9 files changed+162−162
compare with master
unifiedsplit
servant-client-core/src/Servant/Client/Core/HasClient.hs+56−1 servant-client-core/src/Servant/Client/Generic.hs+1−59 servant-server/src/Servant/Server/Generic.hs+2−95 servant-server/src/Servant/Server/Internal.hs+84−1 servant/servant.cabal+2−1 servant/src/Servant/API.hs+5 servant/src/Servant/API/Generic.hs−5 servant/src/Servant/API/NamedRoutes.hs+10 servant/src/Servant/Links.hs+2
servant-client-core/src/Servant/Client/Core/HasClient.hs+56−1
@@ -18,10 +18,15 @@
1818#define HAS_TYPE_ERROR
1919#endif
2020
21+#if __GLASGOW_HASKELL__ >= 806
22+{-# LANGUAGE QuantifiedConstraints #-}
23+#endif
24+
2125module 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
3944import qualified Data.ByteString.Lazy as BL
4045import Data.Either
4146 (partitionEithers)
47+import Data.Constraint (Dict(..))
4248import Data.Foldable
4349 (toList)
4450import 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)
8392import Servant.API.ContentTypes
8493 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
8594import 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+1−59
@@ -1,20 +1,9 @@
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
198module Servant.Client.Generic (
209 AsClientT,
@@ -22,17 +11,12 @@ module Servant.Client.Generic (
2211 genericClientHoist,
2312 ) where
2413
25−import Data.Constraint (Dict(..))
2614import Data.Proxy
2715 (Proxy (..))
2816
2917import Servant.API.Generic
3018import 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.
3822genericClient
@@ -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+2−95
@@ -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
259module 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
4119import Data.Proxy
4220 (Proxy (..))
4321
44−import Servant.API.Generic
4522import Servant.Server
23+import Servant.API.Generic
4624import 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'.
5627genericServe
5728 :: forall routes.
@@ -119,67 +90,3 @@ genericServerT
11990 -> ToServant routes (AsServerT m)
12091genericServerT = 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
servant-server/src/Servant/Server/Internal.hs+84−1
@@ -1,15 +1,18 @@
11{-# LANGUAGE CPP #-}
2+{-# LANGUAGE AllowAmbiguousTypes #-}
23{-# LANGUAGE ConstraintKinds #-}
34{-# LANGUAGE DataKinds #-}
45{-# LANGUAGE DeriveDataTypeable #-}
56{-# LANGUAGE FlexibleContexts #-}
67{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE InstanceSigs #-}
79{-# LANGUAGE MultiParamTypeClasses #-}
810{-# LANGUAGE OverloadedStrings #-}
911{-# LANGUAGE PolyKinds #-}
1012{-# LANGUAGE RankNTypes #-}
1113{-# LANGUAGE ScopedTypeVariables #-}
1214{-# LANGUAGE TupleSections #-}
15+{-# LANGUAGE TypeApplications #-}
1316{-# LANGUAGE TypeFamilies #-}
1417{-# LANGUAGE TypeOperators #-}
1518{-# LANGUAGE UndecidableInstances #-}
@@ -18,6 +21,10 @@
1821#define HAS_TYPE_ERROR
1922#endif
2023
24+#if __GLASGOW_HASKELL__ >= 806
25+{-# LANGUAGE QuantifiedConstraints #-}
26+#endif
27+
2128module Servant.Server.Internal
2229 ( module Servant.Server.Internal
2330 , module Servant.Server.Internal.BasicAuth
@@ -42,6 +49,7 @@ import qualified Data.ByteString as B
4249import qualified Data.ByteString.Builder as BB
4350import qualified Data.ByteString.Char8 as BC8
4451import qualified Data.ByteString.Lazy as BL
52+import Data.Constraint (Dict(..))
4553import Data.Either
4654 (partitionEithers)
4755import Data.Maybe
@@ -54,6 +62,7 @@ import Data.Tagged
5462 (Tagged (..), retag, untag)
5563import qualified Data.Text as T
5664import Data.Typeable
65+import GHC.Generics
5766import GHC.TypeLits
5867 (KnownNat, KnownSymbol, natVal, symbolVal)
5968import qualified Network.HTTP.Media as NHM
@@ -75,7 +84,8 @@ import Servant.API
7584 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
7685 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
7786 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
78− WithNamedContext)
87+ WithNamedContext, NamedRoutes)
88+import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
7989import Servant.API.ContentTypes
8090 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
8191 AllMime, MimeRender (..), MimeUnrender (..), NoContent,
@@ -905,3 +915,76 @@ instance (HasServer api context)
905915
906916-- $setup
907917-- >>> import Servant
918+
919+-- | A type that specifies that an API record contains a server implementation.
920+data AsServerT (m :: * -> *)
921+instance GenericMode (AsServerT m) where
922+ type AsServerT m :- api = ServerT api m
923+
924+type AsServer = AsServerT Handler
925+
926+
927+#if __GLASGOW_HASKELL__ >= 806
928+
929+-- | Set of constraints required to convert to / from vanilla server types.
930+type GServerConstraints api m =
931+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
932+ , GServantProduct (Rep (api (AsServerT m)))
933+ )
934+
935+-- | This class is a necessary evil: in the implementation of 'HasServer' for
936+-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall
937+-- m. 'GServerConstraints' m@ to hold.
938+--
939+-- We cannot require do that directly as the definition of 'GServerConstraints'
940+-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide
941+-- those type family applications behind a typeclass providing evidence for
942+-- @'GServerConstraints' api m@ in the form of a dictionary, and require that
943+-- @forall m. 'GServer' api m@ instead.
944+--
945+-- Users shouldn't have to worry about this class, as the only possible instance
946+-- is provided in this module for all record APIs.
947+
948+class GServer (api :: * -> *) (m :: * -> *) where
949+ proof :: Dict (GServerConstraints api m)
950+
951+instance
952+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
953+ , GServantProduct (Rep (api (AsServerT m)))
954+ ) => GServer api m where
955+ proof = Dict
956+
957+instance
958+ ( HasServer (ToServantApi api) context
959+ , forall m. Generic (api (AsServerT m))
960+ , forall m. GServer api m
961+ ) => HasServer (NamedRoutes api) context where
962+
963+ type ServerT (NamedRoutes api) m = api (AsServerT m)
964+
965+ route
966+ :: Proxy (NamedRoutes api)
967+ -> Context context
968+ -> Delayed env (api (AsServerT Handler))
969+ -> Router env
970+ route _ ctx delayed =
971+ case proof @api @Handler of
972+ Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)
973+
974+ hoistServerWithContext
975+ :: forall m n. Proxy (NamedRoutes api)
976+ -> Proxy context
977+ -> (forall x. m x -> n x)
978+ -> api (AsServerT m)
979+ -> api (AsServerT n)
980+ hoistServerWithContext _ pctx nat server =
981+ case (proof @api @m, proof @api @n) of
982+ (Dict, Dict) ->
983+ fromServant servantSrvN
984+ where
985+ servantSrvM :: ServerT (ToServantApi api) m =
986+ toServant server
987+ servantSrvN :: ServerT (ToServantApi api) n =
988+ hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM
989+
990+#endif
servant/servant.cabal+2−1
@@ -46,6 +46,7 @@ library
4646 Servant.API.HttpVersion
4747 Servant.API.IsSecure
4848 Servant.API.Modifiers
49+ Servant.API.NamedRoutes
4950 Servant.API.QueryParam
5051 Servant.API.Raw
5152 Servant.API.RemoteHost
@@ -80,7 +81,7 @@ library
8081 build-depends:
8182 base >= 4.9 && < 4.16
8283 , bytestring >= 0.10.8.1 && < 0.12
83− , constraints
84+ , constraints >= 0.2
8485 , mtl >= 2.2.2 && < 2.3
8586 , sop-core >= 0.4.0.0 && < 0.6
8687 , transformers >= 0.5.2.0 && < 0.6
servant/src/Servant/API.hs+5
@@ -36,6 +36,9 @@ module Servant.API (
3636 module Servant.API.Verbs,
3737 module Servant.API.UVerb,
3838
39+ -- * Sub-APIs defined as records of routes
40+ module Servant.API.NamedRoutes,
41+
3942 -- * Streaming endpoints, distinguished by HTTP method
4043 module Servant.API.Stream,
4144
@@ -130,6 +133,8 @@ import Servant.API.UVerb
130133 Unique, WithStatus (..), inject, statusOf)
131134import Servant.API.Vault
132135 (Vault)
136+import Servant.API.NamedRoutes
137+ (NamedRoutes)
133138import Servant.API.Verbs
134139 (Delete, DeleteAccepted, DeleteNoContent,
135140 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
servant/src/Servant/API/Generic.hs−5
@@ -37,8 +37,6 @@ module Servant.API.Generic (
3737 ToServant,
3838 toServant,
3939 fromServant,
40− -- * NamedRoutes combinator
41− NamedRoutes,
4240 -- * AsApi
4341 AsApi,
4442 ToServantApi,
@@ -122,9 +120,6 @@ genericApi
122120 -> Proxy (ToServantApi routes)
123121genericApi _ = Proxy
124122
125−-- | Combinator for embedding a record of named routes into a Servant API type.
126−data NamedRoutes (api :: * -> *)
127−
128123-------------------------------------------------------------------------------
129124-- Class
130125-------------------------------------------------------------------------------
servant/src/Servant/API/NamedRoutes.hsnew file+10
@@ -0,0 +1,10 @@
1+{-# LANGUAGE KindSignatures #-}
2+{-# OPTIONS_HADDOCK not-home #-}
3+
4+module Servant.API.NamedRoutes (
5+ -- * NamedRoutes combinator
6+ NamedRoutes
7+ ) where
8+
9+-- | Combinator for embedding a record of named routes into a Servant API type.
10+data NamedRoutes (api :: * -> *)
servant/src/Servant/Links.hs+2
@@ -173,6 +173,8 @@ import Servant.API.IsSecure
173173 (IsSecure)
174174import Servant.API.Modifiers
175175 (FoldRequired)
176+import Servant.API.NamedRoutes
177+ (NamedRoutes)
176178import Servant.API.QueryParam
177179 (QueryFlag, QueryParam', QueryParams)
178180import Servant.API.Raw