diff --git a/changelog.d/issue1240 b/changelog.d/issue1240 new file mode 100644 index 00000000..95f6b05e --- /dev/null +++ b/changelog.d/issue1240 @@ -0,0 +1,15 @@ +synopsis: Merge documentation from duplicate routes +prs: #1241 +issues: #1240 + +description: { + +Servant supports defining the same route multiple times with different +content-types and result-types, but servant-docs was only documenting +the first of copy of such duplicated routes. It now combines the +documentation from all the copies. + +Unfortunately, it is not yet possible for the documentation to specify +multiple status codes. + +} diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index d5b51d93..402fd427 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -131,7 +131,8 @@ instance Semigroup API where (<>) = mappend instance Monoid API where - API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2) + API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) + (HM.unionWith combineAction b1 b2) mempty = API mempty mempty -- | An empty 'API' @@ -240,6 +241,15 @@ data Response = Response , _respHeaders :: [HTTP.Header] } deriving (Eq, Ord, Show) +-- | Combine two Responses, we can't make a monoid because merging Status breaks +-- the laws. +-- +-- As such, we invent a non-commutative, left associative operation +-- 'combineResponse' to mush two together taking the status from the very left. +combineResponse :: Response -> Response -> Response +Response s ts bs hs `combineResponse` Response _ ts' bs' hs' + = Response s (ts <> ts') (bs <> bs') (hs <> hs') + -- | Default response: status code 200, no response body. -- -- Can be tweaked with four lenses. @@ -284,11 +294,10 @@ data Action = Action -- laws. -- -- As such, we invent a non-commutative, left associative operation --- 'combineAction' to mush two together taking the response, body and content --- types from the very left. +-- 'combineAction' to mush two together taking the response from the very left. combineAction :: Action -> Action -> Action -Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ = - Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp +Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' = + Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp') -- | Default 'Action'. Has no 'captures', no query 'params', expects -- no request body ('rqbody') and the typical response is 'defResponse'. diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index bda291a6..8a297b4d 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -66,8 +66,10 @@ spec = describe "Servant.Docs" $ do golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs) describe "markdown" $ do - let md = markdown (docs (Proxy :: Proxy TestApi1)) - tests md + let md1 = markdown (docs (Proxy :: Proxy TestApi1)) + tests1 md1 + let md2 = markdown (docs (Proxy :: Proxy TestApi2)) + tests2 md2 describe "markdown with extra info" $ do let @@ -79,7 +81,7 @@ spec = describe "Servant.Docs" $ do (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1)) (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]]) md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1)) - tests md + tests1 md it "contains the extra info provided" $ do md `shouldContain` "Get an Integer" md `shouldContain` "Post data" @@ -107,7 +109,7 @@ spec = describe "Servant.Docs" $ do where - tests md = do + tests1 md = do it "mentions supported content-types" $ do md `shouldContain` "application/json" md `shouldContain` "text/plain;charset=utf-8" @@ -130,6 +132,11 @@ spec = describe "Servant.Docs" $ do it "does not generate any docs mentioning the 'empty-api' path" $ md `shouldNotContain` "empty-api" + tests2 md = do + it "mentions the content-types from both copies of the route" $ do + md `shouldContain` "application/json" + md `shouldContain` "text/plain;charset=utf-8" + -- * APIs @@ -156,6 +163,10 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) :<|> Header "X-Test" Int :> Put '[JSON] Int :<|> "empty-api" :> EmptyAPI +type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1 + :<|> "duplicate-endpoint" :> Get '[PlainText] Int + + data TT = TT1 | TT2 deriving (Show, Eq) data UT = UT1 | UT2 deriving (Show, Eq)