@@ -20,24 +20,31 @@
2020#include "overlapping-compat.h"
2121module Servant.Docs.Internal where
2222
23−import Prelude ()
23+import Prelude ()
2424import Prelude.Compat
25+
2526import Control.Applicative
2627import Control.Arrow (second)
27−import Control.Lens (makeLenses, mapped, over, traversed, view, (%~),
28− (&), (.~), (<>~), (^.), (|>))
28+import Control.Lens (makeLenses, mapped, over,
29+ traversed, view, (%~), (&), (.~),
30+ (<>~), (^.), (|>))
2931import qualified Control.Monad.Omega as Omega
30−import Data.ByteString.Lazy.Char8 (ByteString)
3132import qualified Data.ByteString.Char8 as BSC
33+import Data.ByteString.Lazy.Char8 (ByteString)
3234import qualified Data.CaseInsensitive as CI
35+import Data.Foldable (fold)
3336import Data.Hashable (Hashable)
3437import Data.HashMap.Strict (HashMap)
3538import Data.List.Compat (intercalate, intersperse, sort)
39+import Data.List.NonEmpty (NonEmpty ((:|)), groupWith)
40+import qualified Data.List.NonEmpty as NE
3641import Data.Maybe
37−import Data.Monoid (All (..), Any (..), Sum (..), Product (..), First (..), Last (..), Dual (..))
38−import Data.Semigroup (Semigroup (..))
42+import Data.Monoid (All (..), Any (..), Dual (..),
43+ First (..), Last (..),
44+ Product (..), Sum (..))
3945import Data.Ord (comparing)
40−import Data.Proxy (Proxy(Proxy))
46+import Data.Proxy (Proxy (Proxy))
47+import Data.Semigroup (Semigroup (..))
4148import Data.String.Conversions (cs)
4249import Data.Text (Text, unpack)
4350import GHC.Generics
@@ -291,6 +298,23 @@ defAction =
291298single :: Endpoint -> Action -> API
292299single e a = API mempty (HM.singleton e a)
293300
301+-- | How many examples should be shown?
302+data ShowContentTypes = AllContentTypes | FirstContentType
303+ deriving (Eq, Ord, Show, Read, Bounded, Enum)
304+
305+-- | Customise how an 'API' is converted into documentation.
306+data ApiOptions = ApiOptions
307+ { _requestExamples :: !ShowContentTypes
308+ , _responseExamples :: !ShowContentTypes
309+ } deriving (Show)
310+
311+-- | Default API generation options.
312+defApiOptions :: ApiOptions
313+defApiOptions = ApiOptions
314+ { _requestExamples = AllContentTypes
315+ , _responseExamples = AllContentTypes
316+ }
317+
294318-- gimme some lenses
295319makeLenses ''DocAuthentication
296320makeLenses ''DocOptions
@@ -302,6 +326,7 @@ makeLenses ''DocIntro
302326makeLenses ''DocNote
303327makeLenses ''Response
304328makeLenses ''Action
329+makeLenses ''ApiOptions
305330
306331-- | Generate the docs for a given API that implements 'HasDocs'. This is the
307332-- default way to create documentation.
@@ -518,7 +543,10 @@ class ToAuthInfo a where
518543-- | Generate documentation in Markdown format for
519544-- the given 'API'.
520545markdown :: API -> String
521−markdown api = unlines $
546+markdown = markdownWith defApiOptions
547+
548+markdownWith :: ApiOptions -> API -> String
549+markdownWith ApiOptions{..} api = unlines $
522550 introsStr (api ^. apiIntros)
523551 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
524552
@@ -632,19 +660,34 @@ markdown api = unlines $
632660 rqbodyStr types s =
633661 ["#### Request:", ""]
634662 <> formatTypes types
635− <> formatBodies s
663+ <> formatBodies _requestExamples s
636664
637665 formatTypes [] = []
638666 formatTypes ts = ["- Supported content types are:", ""]
639667 <> map (\t -> " - `" <> show t <> "`") ts
640668 <> [""]
641669
642− formatBodies :: [(Text, M.MediaType, ByteString)] -> [String]
643− formatBodies = concatMap formatBody
644−
645− formatBody (t, m, b) =
646− "- " <> cs t <> " (`" <> cs (show m) <> "`):" :
647− contentStr m b
670+ -- This assumes that when the bodies are created, identical
671+ -- labels and representations are located next to each other.
672+ formatBodies :: ShowContentTypes -> [(Text, M.MediaType, ByteString)] -> [String]
673+ formatBodies ex bds = concatMap formatBody (select bodyGroups)
674+ where
675+ bodyGroups :: [(Text, NonEmpty M.MediaType, ByteString)]
676+ bodyGroups =
677+ map (\grps -> let (t,_,b) = NE.head grps in (t, fmap (\(_,m,_) -> m) grps, b))
678+ . groupWith (\(t,_,b) -> (t,b))
679+ $ bds
680+
681+ select = case ex of
682+ AllContentTypes -> id
683+ FirstContentType -> map (\(t,ms,b) -> (t, NE.head ms :| [], b))
684+
685+ formatBody :: (Text, NonEmpty M.MediaType, ByteString) -> [String]
686+ formatBody (t, ms, b) =
687+ "- " <> cs t <> " (" <> mediaList ms <> "):" :
688+ contentStr (NE.head ms) b
689+ where
690+ mediaList = fold . NE.intersperse ", " . fmap (\m -> "`" ++ show m ++ "`")
648691
649692 markdownForType mime_type =
650693 case (M.mainType mime_type, M.subType mime_type) of
@@ -679,7 +722,10 @@ markdown api = unlines $
679722 [] -> ["- No response body\n"]
680723 [("", t, r)] -> "- Response body as below." : contentStr t r
681724 xs ->
682− formatBodies xs
725+ formatBodies _responseExamples xs
726+
727+uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
728+uncurry3 f (a,b,c) = f a b c
683729
684730-- * Instances
685731