Integrate MultiVerb into servant package

This commit is Part 1 of the integration, where only the
`servant` package is touched. `Verb` is redefined as an alias for
`MultiVerb1` in order to make the transition transparent to users of
`Verb`.

Sponsored-by: Scrive AB

cabal.project

@@ -10,7 +10,7 @@ packages:
   servant-client/
   servant-docs/
   servant-foreign/
-  servant-http-streams/
+  -- servant-http-streams/
   servant-quickcheck/
   servant-server/
   servant-swagger/

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

@@ -64,7 +64,6 @@ import           Servant.API
                  NoContentVerb,
                  ReflectMethod (..),
                  StreamBody',
-                 Verb,
                  getResponse, AuthProtect, BasicAuth, BasicAuthData, Capture', CaptureAll, DeepQuery, Description, Fragment, FramingRender (..), FramingUnrender (..), Header', Headers (..), HttpVersion, MimeRender (mimeRender), NoContent (NoContent), QueryFlag, QueryParam', QueryParams, QueryString, Raw, RawM, RemoteHost, ReqBody', SBoolI, Stream, Summary, ToHttpApiData, ToSourceIO (..), Vault, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList, toEncodedUrlPiece, NamedRoutes)
 import           Servant.API.Generic
                  (GenericMode(..), ToServant, ToServantApi
@@ -87,6 +86,7 @@ import           Servant.Client.Core.ClientError
 import           Servant.Client.Core.Request
 import           Servant.Client.Core.Response
 import           Servant.Client.Core.RunClient
+import Servant.API.MultiVerb (MultiVerb)
 
 -- * Accessing APIs as a Client
 
@@ -240,8 +240,8 @@ instance {-# OVERLAPPABLE #-}
   -- Note [Non-Empty Content Types]
   ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
   , KnownNat status
-  ) => HasClient m (Verb method status cts' a) where
-  type Client m (Verb method status cts' a) = m a
+  ) => HasClient m (MultiVerb method status cts' a) where
+  type Client m (MultiVerb method status cts' a) = m a
   clientWithRoute _pm Proxy req = do
     response <- runRequestAcceptStatus (Just [status]) req
       { requestAccept = fromList $ toList accept
@@ -257,8 +257,8 @@ instance {-# OVERLAPPABLE #-}
 
 instance {-# OVERLAPPING #-}
   ( RunClient m, ReflectMethod method, KnownNat status
-  ) => HasClient m (Verb method status cts NoContent) where
-  type Client m (Verb method status cts NoContent)
+  ) => HasClient m (MultiVerb method status cts NoContent) where
+  type Client m (MultiVerb method status cts NoContent)
     = m NoContent
   clientWithRoute _pm Proxy req = do
     _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
@@ -283,8 +283,8 @@ instance {-# OVERLAPPING #-}
   -- Note [Non-Empty Content Types]
   ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
   , ReflectMethod method, cts' ~ (ct ': cts)
-  ) => HasClient m (Verb method status cts' (Headers ls a)) where
-  type Client m (Verb method status cts' (Headers ls a))
+  ) => HasClient m (MultiVerb method status cts' (Headers ls a)) where
+  type Client m (MultiVerb method status cts' (Headers ls a))
     = m (Headers ls a)
   clientWithRoute _pm Proxy req = do
     response <- runRequestAcceptStatus (Just [status]) req
@@ -304,8 +304,8 @@ instance {-# OVERLAPPING #-}
 
 instance {-# OVERLAPPING #-}
   ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
-  ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
-  type Client m (Verb method status cts (Headers ls NoContent))
+  ) => HasClient m (MultiVerb method status cts (Headers ls NoContent)) where
+  type Client m (MultiVerb method status cts (Headers ls NoContent))
     = m (Headers ls NoContent)
   clientWithRoute _pm Proxy req = do
     response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }

servant-client-core/src/Servant/Client/Core/Response.hs

@@ -1,6 +1,4 @@
 {-# LANGUAGE DeriveDataTypeable    #-}
-{-# LANGUAGE DeriveFoldable        #-}
-{-# LANGUAGE DeriveFunctor         #-}
 {-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE DeriveTraversable     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}

servant-client/test/Servant/ClientTestUtils.hs

@@ -124,7 +124,7 @@ data OtherRoutes mode = OtherRoutes
   } deriving Generic
 
 -- Get for HTTP 307 Temporary Redirect
-type Get307 = Verb 'GET 307
+type Get307 contentType returnType = Verb 'GET 307 contentType returnType
 
 data Filter = Filter
   { ageFilter :: Integer

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                   #-}
+{-# LANGUAGE DeriveTraversable #-}
 
 module Servant.Server.Internal
   ( module Servant.Server.Internal
@@ -32,6 +33,8 @@ import           Data.Kind
                  (Type)
 import           Data.Maybe
                  (fromMaybe, isNothing, mapMaybe, maybeToList)
+import           Data.Sequence
+                 (Seq)
 import           Data.String
                  (IsString (..))
 import           Data.Tagged
@@ -56,7 +59,7 @@ import           Servant.API
                  Header', If, IsSecure (..), NoContentVerb, QueryFlag,
                  QueryParam', QueryParams, QueryString, Raw, RawM, ReflectMethod (reflectMethod),
                  RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
-                 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
+                 Stream, StreamBody', Summary, ToSourceIO (..), Vault,
                  WithNamedContext, WithResource, NamedRoutes)
 import           Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
 import           Servant.API.ContentTypes
@@ -89,6 +92,8 @@ import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServerError
 
 import           Servant.API.TypeLevel (AtMostOneFragment, FragmentUnique)
+import           Servant.API.MultiVerb (MultiVerb)
+import Network.HTTP.Types (Header)
 
 class HasServer api context where
   -- | The type of a server for this API, given a monad to run effects in.
@@ -315,9 +320,9 @@ noContentRouter method status action = leafRouter route'
 
 instance {-# OVERLAPPABLE #-}
          ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
-         ) => HasServer (Verb method status ctypes a) context where
+         ) => HasServer (MultiVerb method status ctypes a) context where
 
-  type ServerT (Verb method status ctypes a) m = m a
+  type ServerT (MultiVerb method status ctypes a) m = m a
   hoistServerWithContext _ _ nt s = nt s
 
   route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
@@ -327,9 +332,9 @@ instance {-# OVERLAPPABLE #-}
 instance {-# OVERLAPPING #-}
          ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
          , GetHeaders (Headers h a)
-         ) => HasServer (Verb method status ctypes (Headers h a)) context where
+         ) => HasServer (MultiVerb method status ctypes (Headers h a)) context where
 
-  type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
+  type ServerT (MultiVerb method status ctypes (Headers h a)) m = m (Headers h a)
   hoistServerWithContext _ _ nt s = nt s
 
   route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
@@ -1114,3 +1119,9 @@ instance
             toServant server
           servantSrvN :: ServerT (ToServantApi api) n =
             hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM
+
+data InternalResponse a = InternalResponse
+  { statusCode :: Status
+  , headers :: Seq Header
+  , responseBody :: a
+  } deriving stock (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)

servant/servant.cabal

@@ -106,10 +106,12 @@ library
     Servant.API.Sub
     Servant.API.TypeErrors
     Servant.API.TypeLevel
+    Servant.API.TypeLevel.List
     Servant.API.UVerb
     Servant.API.UVerb.Union
     Servant.API.Vault
     Servant.API.Verbs
+    Servant.API.MultiVerb
     Servant.API.WithNamedContext
     Servant.API.WithResource
 
@@ -133,6 +135,7 @@ library
     , containers    >=0.6      && <0.8
     , mtl           ^>=2.2.2   || ^>=2.3.1
     , sop-core      >=0.4.0.0  && <0.6
+    , generics-sop  ^>=0.5.1
     , text          >=1.2.3.0  && <2.2
     , transformers  >=0.5.2.0  && <0.7
 

servant/src/Servant/API/Alternative.hs

@@ -35,7 +35,6 @@ instance (Semigroup a, Semigroup b) => Semigroup (a :<|> b) where
 
 instance (Monoid a, Monoid b) => Monoid (a :<|> b) where
     mempty = mempty :<|> mempty
-    (a :<|> b) `mappend` (a' :<|> b') = (a `mappend` a') :<|> (b `mappend` b')
 
 instance Bifoldable (:<|>) where
     bifoldMap f g ~(a :<|> b) = f a `mappend` g b