[WIP] Swagger instance for UVerb.

cabal.project

@@ -1,2 +1,6 @@
-packages: .
+packages:
+  ./
+  ../servant/servant/
+  ../servant/servant-server/
+
 allow-newer: aeson-pretty-0.8.7:base-compat

servant-swagger.cabal

@@ -82,7 +82,7 @@ library
                      , http-media                >=0.7.1.3  && <0.9
                      , insert-ordered-containers >=0.2.1.0  && <0.3
                      , lens                      >=4.17     && <4.20
-                     , servant                   >=0.17     && <0.18
+                     , servant                   >=0.17     && <0.20
                      , singleton-bool            >=0.1.4    && <0.2
                      , swagger2                  >=2.3.0.1  && <2.7
                      , text                      >=1.2.3.0  && <1.3

src/Servant/Swagger/Internal.hs

@@ -7,12 +7,23 @@
 {-# LANGUAGE PolyKinds            #-}
 {-# LANGUAGE RankNTypes           #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE StandaloneDeriving   #-}
 {-# LANGUAGE TypeOperators        #-}
 #if __GLASGOW_HASKELL__ >= 806
 {-# LANGUAGE UndecidableInstances #-}
 #endif
 module Servant.Swagger.Internal where
 
+-- TODO: shuffle this into the other imports.
+#if MIN_VERSION_servant(0,18,0)
+import Control.Applicative ((<|>))
+import qualified Data.HashMap.Strict.InsOrd as I
+import Data.Proxy (Proxy (Proxy))
+import Data.Swagger (ToSchema, Swagger(..), PathItem(..))
+import Servant.API.Verbs (Verb)
+import Servant.API.UVerb (HasStatus, StatusOf, UVerb, WithStatus(WithStatus))
+#endif
+
 import Prelude ()
 import Prelude.Compat
 
@@ -183,6 +194,60 @@ instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options
 instance SwaggerMethod 'HEAD    where swaggerMethod _ = head_
 instance SwaggerMethod 'PATCH   where swaggerMethod _ = patch
 
+-- TODO: lower version bound must be 0.19
+#if MIN_VERSION_servant(0,18,0)
+instance HasSwagger (UVerb method cs '[]) where
+  toSwagger _ = mempty
+
+-- | @since <TODO>
+instance
+  ( ToSchema a,
+    HasStatus a,
+    AllAccept cs,
+    SwaggerMethod method,
+    HasSwagger (UVerb method cs as)
+  ) =>
+  HasSwagger (UVerb method cs (a ': as))
+  where
+  toSwagger _ =
+    toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a))
+      `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))
+    where
+      -- workaround for https://github.com/GetShopTV/swagger2/issues/218
+      -- We'd like to juse use (<>) but the instances are wrong
+      combinePathItem :: PathItem -> PathItem -> PathItem
+      combinePathItem s t = PathItem
+        { _pathItemGet = _pathItemGet s <> _pathItemGet t
+        , _pathItemPut = _pathItemPut s <> _pathItemPut t
+        , _pathItemPost = _pathItemPost s <> _pathItemPost t
+        , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t
+        , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t
+        , _pathItemHead = _pathItemHead s <> _pathItemHead t
+        , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t
+        , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t
+        }
+
+      combineSwagger :: Swagger -> Swagger -> Swagger
+      combineSwagger s t = Swagger
+        { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t
+        , _swaggerHost = _swaggerHost s <|> _swaggerHost t
+        , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t
+        , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t
+        , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t
+        , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t
+        , _swaggerPaths = I.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t)
+        , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t
+        , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t
+        , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t
+        , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t
+        , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t
+        , _swaggerTags = _swaggerTags s <> _swaggerTags t
+        , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t
+        }
+
+deriving instance ToSchema a => ToSchema (WithStatus s a)
+#endif
+
 instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where
   toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a)))
 
@@ -352,7 +417,7 @@ instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription
         & schema    .~ ParamBody ref
 
 -- | This instance is an approximation.
--- 
+--
 -- @since 1.1.7
 instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where
   toSwagger _ = toSwagger (Proxy :: Proxy sub)

stack.yaml

@@ -1,4 +1,6 @@
-resolver: lts-13.25
+resolver: lts-16.7
 packages:
 - '.'
 - example/
+- ../servant/servant
+- ../servant/servant-server