@@ -20,6 +20,7 @@
20#include "overlapping-compat.h"
20#include "overlapping-compat.h"
21module Servant.Docs.Internal where
21module Servant.Docs.Internal where
23import Prelude ()
24import Prelude ()
24import Prelude.Compat
25import Prelude.Compat
@@ -116,7 +117,8 @@ instance Semigroup API where
116 (<>) = mappend
117 (<>) = mappend
118instance Monoid API where
119instance Monoid API where
119− API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2)
120+ API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2)
121+ (HM.unionWith combineAction b1 (traceShowId b2))
120 mempty = API mempty mempty
122 mempty = API mempty mempty
122-- | An empty 'API'
124-- | An empty 'API'
@@ -223,6 +225,15 @@ data Response = Response
223 , _respHeaders :: [HTTP.Header]
225 , _respHeaders :: [HTTP.Header]
224 } deriving (Eq, Ord, Show)
226 } deriving (Eq, Ord, Show)
228+-- | Combine two Responses, we can't make a monoid because merging Status breaks
231+-- As such, we invent a non-commutative, left associative operation
232+-- 'combineResponse' to mush two together taking the status from the very left.
233+combineResponse :: Response -> Response -> Response
234+Response s ts bs hs `combineResponse` Response _ ts' bs' hs'
235+ = Response s (ts <> ts') (bs <> bs') (hs <> hs')
226-- | Default response: status code 200, no response body.
237-- | Default response: status code 200, no response body.
228-- Can be tweaked with two lenses.
239-- Can be tweaked with two lenses.
@@ -265,11 +276,10 @@ data Action = Action
267-- As such, we invent a non-commutative, left associative operation
278-- As such, we invent a non-commutative, left associative operation
268−-- 'combineAction' to mush two together taking the response, body and content
279+-- 'combineAction' to mush two together taking the response from the very left.
269−-- types from the very left.
270combineAction :: Action -> Action -> Action
280combineAction :: Action -> Action -> Action
271−Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
281+Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' =
272− Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
282+ Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp')
274-- | Default 'Action'. Has no 'captures', no query 'params', expects
284-- | Default 'Action'. Has no 'captures', no query 'params', expects
275-- no request body ('rqbody') and the typical response is 'defResponse'.
285-- no request body ('rqbody') and the typical response is 'defResponse'.