Implement HasServer (NamedRoutes routes)

We define `ServerT (NamedRoutes api) m` as `api (AsServerT m)`, so that
the server of an record-defined API is a record of handlers.

The implementation piggy backs on the instance for “vanilla” servant
types with `(:<|>)`, using the `GServantProduct` for converting backd
and forth between the record / vanilla servers.

The main difficulty is that GHC needs to know that this operation is
legit, which can be expressed as the fact that:

```
GToServant (Rep (ServerT (NamedRoutes api))) m ~
ServerT (GToServant (Rep (api AsApi))) m
```

plus a few additional constraints.

This is easy enough for `route`, as we know that `m ~ Handler`. But in
the case of `hoistServerWithContext`, the two involved monads are
unknown ; in other words, this constraint needs to hold `forall m.`

Switching `-XQuantifiedConstraints` on is not sufficient, as our
constraints involve type families (`Rep` and `ServerT`). Our trick is to
use an intermediary typeclass, `GServer`, as a provider of evidence (in
the form of a `Dict`) that our constraints are indeed satisfied for a
particular monad.

The only instance of `GServer` is defined along with it, so it is
practically invisible to users.

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,20 @@
-{-# LANGUAGE ConstraintKinds      #-}
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
-{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE AllowAmbiguousTypes    #-}
-{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE ConstraintKinds        #-}
-{-# LANGUAGE KindSignatures       #-}
+{-# LANGUAGE DataKinds              #-}
-{-# LANGUAGE RankNTypes           #-}
+{-# LANGUAGE DefaultSignatures      #-}
-{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE FlexibleContexts       #-}
-{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE FlexibleInstances      #-}
-{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE InstanceSigs           #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE KindSignatures         #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE QuantifiedConstraints  #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeApplications       #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
 -- | @since 0.14.1
 module Servant.Server.Generic (
     AsServerT,
@@ -16,13 +24,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 +112,64 @@ genericServerT
     => routes (AsServerT m)
     -> ToServant routes (AsServerT m)
 genericServerT = toServant
+
+-- | 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