Merge pull request #1241 from Simspace/issue-1240

merge documentation from duplicate routes

Author: phadej

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.
+
+}

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'.

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)