From 143091eb3f1a153d17b1bdae12fb70b768e07cf3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= <gelisam@simspace.com>
Date: Thu, 7 Nov 2019 18:53:41 -0500
Subject: [PATCH] merge documentation from duplicate routes

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 | 20 +++++++++++++++-----
 1 file changed, 15 insertions(+), 5 deletions(-)

diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs
index 4ba7c962..c102007e 100644
--- a/servant-docs/src/Servant/Docs/Internal.hs
+++ b/servant-docs/src/Servant/Docs/Internal.hs
@@ -20,6 +20,7 @@
 #include "overlapping-compat.h"
 module Servant.Docs.Internal where
 
+import Debug.Trace
 import           Prelude                    ()
 import           Prelude.Compat
 
@@ -116,7 +117,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 (traceShowId b2))
     mempty = API mempty mempty
 
 -- | An empty 'API'
@@ -223,6 +225,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 two lenses.
@@ -265,11 +276,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'.