Exclude quantified constraints code for GHCJS

QuantifiedConstraints isn't available for GHC 8.4 (where our GHCJS
version is still stuck).

We may need to take a drastic decision for GHCJS at some point.

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,28 @@
-{-# LANGUAGE ConstraintKinds     #-}
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
-{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ConstraintKinds       #-}
-{-# LANGUAGE KindSignatures      #-}
+{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE InstanceSigs          #-}
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
+
+#if __GLASGOW_HASKELL__ >= 806
+{-# LANGUAGE QuantifiedConstraints  #-}
+#endif
+
 module  Servant.Client.Generic (
     AsClientT,
     genericClient,
     genericClientHoist,
     ) where
 
+import           Data.Constraint (Dict(..))
 import           Data.Proxy
                  (Proxy (..))
 
@@ -49,3 +62,45 @@ genericClientHoist nt
   where
     m = Proxy :: Proxy m
     api = Proxy :: Proxy (ToServantApi routes)
+
+#if __GLASGOW_HASKELL__ >= 806
+
+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
+
+#endif

servant-client/servant-client.cabal

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

servant-client/test/Servant/ClientTestUtils.hs

@@ -59,9 +59,12 @@ import           Servant.API
                  NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
                  QueryParams, Raw, ReqBody, StdMethod (GET), 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
 
@@ -101,6 +104,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
@@ -131,6 +144,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
@@ -180,7 +194,8 @@ getRoot
   :<|> getRedirectWithCookie
   :<|> EmptyClient
   :<|> uverbGetSuccessOrRedirect
-  :<|> uverbGetCreated = client api
+  :<|> uverbGetCreated
+  :<|> recordRoutes = client api
 
 server :: Application
 server = serve api (
@@ -210,6 +225,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-server/example/greet.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds         #-}
 {-# LANGUAGE TypeFamilies      #-}
@@ -16,6 +17,8 @@ import           Network.Wai
 import           Network.Wai.Handler.Warp
 
 import           Servant
+import           Servant.Server.Generic ()
+import           Servant.API.Generic
 
 -- * Example
 
@@ -38,6 +41,14 @@ type TestApi =
        -- DELETE /greet/:greetid
   :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent
 
+  :<|> NamedRoutes OtherRoutes
+
+data OtherRoutes mode = OtherRoutes
+  { version :: mode :- Get '[JSON] Int
+  , bye :: mode :- "bye" :> Capture "name" Text :> Get '[JSON] Text
+  }
+  deriving Generic
+
 testApi :: Proxy TestApi
 testApi = Proxy
 
@@ -48,9 +59,13 @@ testApi = Proxy
 --
 -- Each handler runs in the 'Handler' monad.
 server :: Server TestApi
-server = helloH :<|> postGreetH :<|> deleteGreetH
+server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes
+  where otherRoutes = OtherRoutes {..}
 
-  where helloH name Nothing = helloH name (Just False)
+        bye name = pure $ "Bye, " <> name <> " !"
+        version = pure 42
+
+        helloH name Nothing = helloH name (Just False)
         helloH name (Just False) = return . Greet $ "Hello, " <> name
         helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
 

servant-server/servant-server.cabal

@@ -62,6 +62,7 @@ library
   build-depends:
       base                >= 4.9      && < 4.16
     , bytestring          >= 0.10.8.1 && < 0.12
+    , constraints
     , containers          >= 0.5.7.1  && < 0.7
     , mtl                 >= 2.2.2    && < 2.3
     , text                >= 1.2.3.0  && < 1.3

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

@@ -1,12 +1,26 @@
-{-# LANGUAGE ConstraintKinds      #-}
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
-{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE AllowAmbiguousTypes    #-}
-{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE ConstraintKinds        #-}
-{-# LANGUAGE KindSignatures       #-}
+{-# LANGUAGE CPP                    #-}
-{-# LANGUAGE RankNTypes           #-}
+{-# LANGUAGE DataKinds              #-}
-{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE DefaultSignatures      #-}
-{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE FlexibleContexts       #-}
-{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE FlexibleInstances      #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE InstanceSigs           #-}
+{-# LANGUAGE KindSignatures         #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE QuantifiedConstraints  #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeApplications       #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+
+#if __GLASGOW_HASKELL__ >= 806
+{-# LANGUAGE QuantifiedConstraints  #-}
+#endif
+
 -- | @since 0.14.1
 module Servant.Server.Generic (
     AsServerT,
@@ -16,13 +30,20 @@ module Servant.Server.Generic (
     genericServeTWithContext,
     genericServer,
     genericServerT,
+    -- * Internal machinery
+    GServerConstraints,
+    GServer,
+    -- * Re-exports
+    NamedRoutes
   ) where
 
+import           Data.Constraint
 import           Data.Proxy
                  (Proxy (..))
 
 import           Servant.API.Generic
 import           Servant.Server
+import           Servant.Server.Internal
 
 -- | A type that specifies that an API record contains a server implementation.
 data AsServerT (m :: * -> *)
@@ -97,3 +118,68 @@ genericServerT
     => routes (AsServerT m)
     -> ToServant routes (AsServerT m)
 genericServerT = toServant
+
+#if __GLASGOW_HASKELL__ >= 806
+
+-- | Set of constraints required to convert to / from vanilla server types.
+type GServerConstraints api m =
+  ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
+  , GServantProduct (Rep (api (AsServerT m)))
+  )
+
+-- | This class is a necessary evil: in the implementation of 'HasServer' for
+--  @'NamedRoutes' api@, we essentially need the quantified constraint @forall
+--  m. 'GServerConstraints' m@ to hold.
+--
+-- We cannot require do that directly as the definition of 'GServerConstraints'
+-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide
+-- those type family applications behind a typeclass providing evidence for
+-- @'GServerConstraints' api m@ in the form of a dictionary, and require that
+-- @forall m. 'GServer' api m@ instead.
+--
+-- Users shouldn't have to worry about this class, as the only possible instance
+-- is provided in this module for all record APIs.
+
+class GServer (api :: * -> *) (m :: * -> *) where
+  proof :: Dict (GServerConstraints api m)
+
+instance
+  ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
+  , GServantProduct (Rep (api (AsServerT m)))
+  ) => GServer api m where
+  proof = Dict
+
+instance
+  ( HasServer (ToServantApi api) context
+  , forall m. Generic (api (AsServerT m))
+  , forall m. GServer api m
+  ) => HasServer (NamedRoutes api) context where
+
+  type ServerT (NamedRoutes api) m = api (AsServerT m)
+
+  route
+    :: Proxy (NamedRoutes api)
+    -> Context context
+    -> Delayed env (api (AsServerT Handler))
+    -> Router env
+  route _ ctx delayed =
+    case proof @api @Handler of
+      Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)
+
+  hoistServerWithContext
+    :: forall m n. Proxy (NamedRoutes api)
+    -> Proxy context
+    -> (forall x. m x -> n x)
+    -> api (AsServerT m)
+    -> api (AsServerT n)
+  hoistServerWithContext _ pctx nat server =
+    case (proof @api @m, proof @api @n) of
+      (Dict, Dict) ->
+        fromServant servantSrvN
+        where
+          servantSrvM :: ServerT (ToServantApi api) m =
+            toServant server
+          servantSrvN :: ServerT (ToServantApi api) n =
+            hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM
+
+#endif

servant/src/Servant/API/Generic.hs

@@ -37,6 +37,8 @@ module Servant.API.Generic (
     ToServant,
     toServant,
     fromServant,
+    -- * NamedRoutes combinator
+    NamedRoutes,
     -- * AsApi
     AsApi,
     ToServantApi,
@@ -120,6 +122,9 @@ genericApi
     -> Proxy (ToServantApi routes)
 genericApi _ = Proxy
 
+-- | Combinator for embedding a record of named routes into a Servant API type.
+data NamedRoutes (api :: * -> *)
+
 -------------------------------------------------------------------------------
 -- Class
 -------------------------------------------------------------------------------