Fix servant-docs

haskell-servant · Jul 10, 2024 · 37a25c1 · 37a25c1
1 parent d56e9d7
commit 37a25c1
Show file tree

Hide file tree

Showing 3 changed files with 6 additions and 26 deletions.
diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs
@@ -71,6 +71,7 @@ import qualified Data.HashMap.Strict        as HM
 import qualified Data.Text                  as T
 import qualified Network.HTTP.Media         as M
 import qualified Network.HTTP.Types         as HTTP
+import Servant.API.MultiVerb (MultiVerb, Respond)
 
 -- | An 'Endpoint' type that holds the 'path' and the 'method'.
 --
@@ -950,7 +951,7 @@ instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)
 instance {-# OVERLAPPABLE #-}
         (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
         , ReflectMethod method)
-    => HasDocs (Verb method status (ct ': cts) a) where
+    => HasDocs (MultiVerb method (ct ': cts) '[Respond status (desc :: Symbol) a] a) where
   docsFor Proxy (endpoint, action) DocOptions{..} =
     single endpoint' action'
 
@@ -996,7 +997,7 @@ instance {-# OVERLAPPABLE #-}
 instance {-# OVERLAPPING #-}
         (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
         , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))
-    => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where
+    => HasDocs (MultiVerb method (ct ': cts) '[Respond status (desc :: Symbol) (Headers ls a)] (Headers ls a)) where
   docsFor Proxy (endpoint, action) DocOptions{..} =
     single endpoint' action'
 

diff --git a/servant-docs/src/Servant/Docs/Internal/Pretty.hs b/servant-docs/src/Servant/Docs/Internal/Pretty.hs
@@ -19,6 +19,7 @@ import           Network.HTTP.Media
                  ((//))
 import           Servant.API
 import           Servant.API.Verbs
+import Servant.API.MultiVerb (MultiVerb, Respond)
 
 -- | PrettyJSON content type.
 data PrettyJSON
@@ -42,29 +43,7 @@ pretty Proxy = Proxy
 type family Pretty (api :: k) :: k where
     Pretty (x :<|> y)     = Pretty x :<|> Pretty y
     Pretty (x :> y)       = Pretty x :> Pretty y
-    Pretty (Get cs r)     = Get     (Pretty cs) r
-    Pretty (Post cs r)    = Post    (Pretty cs) r
-    Pretty (Put cs r)     = Put     (Pretty cs) r
-    Pretty (Delete cs r)  = Delete  (Pretty cs) r
-    Pretty (Patch cs r)   = Patch   (Pretty cs) r
-    Pretty (GetPartialContent cs r)      = GetPartialContent      (Pretty cs) r
-    Pretty (PutResetContent cs r)        = PutResetContent        (Pretty cs) r
-    Pretty (PatchResetContent cs r)      = PatchResetContent      (Pretty cs) r
-    Pretty (DeleteResetContent cs r)     = DeleteResetContent     (Pretty cs) r
-    Pretty (PostResetContent cs r)       = PostResetContent       (Pretty cs) r
-    Pretty (GetResetContent cs r)        = GetResetContent        (Pretty cs) r
-    Pretty (PutNonAuthoritative cs r)    = PutNonAuthoritative    (Pretty cs) r
-    Pretty (PatchNonAuthoritative cs r)  = PatchNonAuthoritative  (Pretty cs) r
-    Pretty (DeleteNonAuthoritative cs r) = DeleteNonAuthoritative (Pretty cs) r
-    Pretty (PostNonAuthoritative cs r)   = PostNonAuthoritative   (Pretty cs) r
-    Pretty (GetNonAuthoritative cs r)    = GetNonAuthoritative    (Pretty cs) r
-    Pretty (PutAccepted cs r)            = PutAccepted            (Pretty cs) r
-    Pretty (PatchAccepted cs r)          = PatchAccepted          (Pretty cs) r
-    Pretty (DeleteAccepted cs r)         = DeleteAccepted         (Pretty cs) r
-    Pretty (PostAccepted cs r)           = PostAccepted           (Pretty cs) r
-    Pretty (GetAccepted cs r)            = GetAccepted            (Pretty cs) r
-    Pretty (PutCreated cs r)             = PutCreated             (Pretty cs) r
-    Pretty (PostCreated cs r)            = PostCreated            (Pretty cs) r
+    Pretty (MultiVerb method contentTypes '[Respond status "" returnType] returnType) = method (Pretty contentTypes) returnType 
     Pretty (ReqBody cs r) = ReqBody (Pretty cs) r
     Pretty (JSON ': xs)   = PrettyJSON ': xs
     Pretty (x ': xs)      = x ': Pretty xs

diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs
@@ -30,7 +30,7 @@ import Servant.API.MultiVerb (MultiVerb1, Respond)
 --
 -- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a
 -- data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [Type]) (a :: Type)
-type Verb (method :: StdMethod) (statusCode :: Nat) (contentTypes :: [Type]) (returnType :: Type)
+type Verb (method :: k) (statusCode :: Nat) (contentTypes :: [Type]) (returnType :: Type)
     = MultiVerb1 method contentTypes (Respond statusCode "" returnType) 
 
 -- | @NoContentVerb@ is a specific type to represent 'NoContent' responses.