Implementation of HasClient

Follows the same design as `HasServer` in the previous commit.

A test has been added (which incidentally acts as a test for the
HasServer instance).

servant-client-core/servant-client-core.cabal

@@ -52,6 +52,7 @@ library
   build-depends:
       base                  >= 4.9      && < 4.16
     , bytestring            >= 0.10.8.1 && < 0.12
+    , constraints
     , containers            >= 0.5.7.1  && < 0.7
     , deepseq               >= 1.4.2.0  && < 1.5
     , text                  >= 1.2.3.0  && < 1.3

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

@@ -1,15 +1,23 @@
-{-# LANGUAGE ConstraintKinds     #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE KindSignatures      #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies        #-}
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE InstanceSigs          #-}
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
 module  Servant.Client.Generic (
     AsClientT,
     genericClient,
     genericClientHoist,
     ) where
 
+import           Data.Constraint (Dict(..))
 import           Data.Proxy
                  (Proxy (..))
 
@@ -49,3 +57,41 @@ genericClientHoist nt
   where
     m = Proxy :: Proxy m
     api = Proxy :: Proxy (ToServantApi routes)
+
+type GClientConstraints api m =
+  ( GenericServant api (AsClientT m)
+  , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
+  )
+
+class GClient (api :: * -> *) m where
+  proof :: Dict (GClientConstraints api m)
+
+instance GClientConstraints api m => GClient api m where
+  proof = Dict
+
+instance
+  ( forall n. GClient api n
+  , HasClient m (ToServantApi api)
+  , RunClient m
+  )
+  => HasClient m (NamedRoutes api) where
+  type Client m (NamedRoutes api) = api (AsClientT m)
+
+  clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
+  clientWithRoute pm _ request =
+    case proof @api @m of
+      Dict -> fromServant $ clientWithRoute  pm (Proxy @(ToServantApi api)) request
+
+  hoistClientMonad
+    :: forall ma mb.
+       Proxy m
+    -> Proxy (NamedRoutes api)
+    -> (forall x. ma x -> mb x)
+    -> Client ma (NamedRoutes api)
+    -> Client mb (NamedRoutes api)
+  hoistClientMonad _ _ nat clientA =
+    case (proof @api @ma, proof @api @mb) of
+      (Dict, Dict) ->
+        fromServant @api @(AsClientT mb) $
+        hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
+        toServant @api @(AsClientT ma) clientA

servant-client/servant-client.cabal

@@ -93,6 +93,7 @@ test-suite spec
       Servant.ConnectionErrorSpec
       Servant.FailSpec
       Servant.GenAuthSpec
+      Servant.GenericSpec
       Servant.HoistClientSpec
       Servant.StreamSpec
       Servant.SuccessSpec

servant-client/test/Servant/ClientTestUtils.hs

@@ -65,9 +65,12 @@ import           Servant.API
                  NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
                  QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
                  WithStatus (WithStatus), addHeader)
+import           Servant.API.Generic
 import           Servant.Client
+import           Servant.Client.Generic
 import qualified Servant.Client.Core.Auth         as Auth
 import           Servant.Server
+import           Servant.Server.Generic
 import           Servant.Server.Experimental.Auth
 import           Servant.Test.ComprehensiveAPI
 
@@ -107,6 +110,16 @@ carol = Person "Carol" 17
 
 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
 
+data RecordRoutes mode = RecordRoutes
+  { version :: mode :- "version" :> Get '[JSON] Int
+  , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String
+  , otherRoutes :: mode :- "other" :> NamedRoutes OtherRoutes
+  } deriving Generic
+
+data OtherRoutes mode = OtherRoutes
+  { something :: mode :- "something" :> Get '[JSON] [String]
+  } deriving Generic
+
 type Api =
   Get '[JSON] Person
   :<|> "get" :> Get '[JSON] Person
@@ -141,6 +154,7 @@ type Api =
             UVerb 'GET '[PlainText] '[WithStatus 200 Person,
                                       WithStatus 301 Text]
   :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
+  :<|> NamedRoutes RecordRoutes
 
 
 api :: Proxy Api
@@ -192,7 +206,8 @@ getRoot
   :<|> getRedirectWithCookie
   :<|> EmptyClient
   :<|> uverbGetSuccessOrRedirect
-  :<|> uverbGetCreated = client api
+  :<|> uverbGetCreated
+  :<|> recordRoutes = client api
 
 server :: Application
 server = serve api (
@@ -229,6 +244,13 @@ server = serve api (
                               then respond (WithStatus @301 ("redirecting" :: Text))
                               else respond (WithStatus @200 alice ))
   :<|> respond (WithStatus @201 carol)
+  :<|> RecordRoutes
+         { version = pure 42
+         , echo = pure
+         , otherRoutes = OtherRoutes
+             { something = pure ["foo", "bar", "pweet"]
+             }
+         }
   )
 
 type FailApi =

servant-client/test/Servant/GenericSpec.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE CPP                    #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE GADTs                  #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+{-# OPTIONS_GHC -freduction-depth=100 #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.GenericSpec (spec) where
+
+import           Data.Function ((&))
+import           Test.Hspec
+
+import           Servant.ClientTestUtils
+
+spec :: Spec
+spec = describe "Servant.GenericSpec" $ do
+    genericSpec
+
+genericSpec :: Spec
+genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
+  context "Record clients work as expected" $ do
+
+    it "Client functions return expected values" $ \(_,baseUrl) -> do
+      runClient (recordRoutes & version) baseUrl `shouldReturn` Right 42
+      runClient (recordRoutes & echo $ "foo") baseUrl `shouldReturn` Right "foo"
+    it "Clients can be nested" $ \(_,baseUrl) -> do
+      runClient (recordRoutes & otherRoutes & something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]