@@ -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,35 @@ defAction =
291298single :: Endpoint -> Action -> API
292299single e a = API mempty (HM.singleton e a)
293300
301+-- | How many content-types for each example should be shown?
302+--
303+-- @since 0.11.1
304+data ShowContentTypes = AllContentTypes -- ^ For each example, show each content type.
305+ | FirstContentType -- ^ For each example, show only one content type.
306+ deriving (Eq, Ord, Show, Read, Bounded, Enum)
307+
308+-- | Customise how an 'API' is converted into documentation.
309+--
310+-- @since 0.11.1
311+data RenderingOptions = RenderingOptions
312+ { _requestExamples :: !ShowContentTypes
313+ -- ^ How many content types to display for request body examples?
314+ , _responseExamples :: !ShowContentTypes
315+ -- ^ How many content types to display for response body examples?
316+ } deriving (Show)
317+
318+-- | Default API generation options.
319+--
320+-- All content types are shown for both 'requestExamples' and
321+-- 'responseExamples'.
322+--
323+-- @since 0.11.1
324+defRenderingOptions :: RenderingOptions
325+defRenderingOptions = RenderingOptions
326+ { _requestExamples = AllContentTypes
327+ , _responseExamples = AllContentTypes
328+ }
329+
294330-- gimme some lenses
295331makeLenses ''DocAuthentication
296332makeLenses ''DocOptions
@@ -302,6 +338,7 @@ makeLenses ''DocIntro
302338makeLenses ''DocNote
303339makeLenses ''Response
304340makeLenses ''Action
341+makeLenses ''RenderingOptions
305342
306343-- | Generate the docs for a given API that implements 'HasDocs'. This is the
307344-- default way to create documentation.
@@ -517,8 +554,34 @@ class ToAuthInfo a where
517554
518555-- | Generate documentation in Markdown format for
519556-- the given 'API'.
557+--
558+-- This is equivalent to @'markdownWith' 'defRenderingOptions'@.
520559markdown :: API -> String
521−markdown api = unlines $
560+markdown = markdownWith defRenderingOptions
561+
562+-- | Generate documentation in Markdown format for
563+-- the given 'API' using the specified options.
564+--
565+-- These options allow you to customise aspects such as:
566+--
567+-- * Choose how many content-types for each request body example are
568+-- shown with 'requestExamples'.
569+--
570+-- * Choose how many content-types for each response body example
571+-- are shown with 'responseExamples'.
572+--
573+-- For example, to only show the first content-type of each example:
574+--
575+-- @
576+-- markdownWith ('defRenderingOptions'
577+-- & 'requestExamples' '.~' 'FirstContentType'
578+-- & 'responseExamples' '.~' 'FirstContentType' )
579+-- myAPI
580+-- @
581+--
582+-- @since 0.11.1
583+markdownWith :: RenderingOptions -> API -> String
584+markdownWith RenderingOptions{..} api = unlines $
522585 introsStr (api ^. apiIntros)
523586 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
524587
@@ -632,31 +695,55 @@ markdown api = unlines $
632695 rqbodyStr types s =
633696 ["#### Request:", ""]
634697 <> formatTypes types
635− <> concatMap formatBody s
698+ <> formatBodies _requestExamples s
636699
637700 formatTypes [] = []
638701 formatTypes ts = ["- Supported content types are:", ""]
639702 <> map (\t -> " - `" <> show t <> "`") ts
640703 <> [""]
641704
642− formatBody (t, m, b) =
643− "- Example (" <> cs t <> "): `" <> cs (show m) <> "`" :
644− contentStr m b
705+ -- This assumes that when the bodies are created, identical
706+ -- labels and representations are located next to each other.
707+ formatBodies :: ShowContentTypes -> [(Text, M.MediaType, ByteString)] -> [String]
708+ formatBodies ex bds = concatMap formatBody (select bodyGroups)
709+ where
710+ bodyGroups :: [(Text, NonEmpty M.MediaType, ByteString)]
711+ bodyGroups =
712+ map (\grps -> let (t,_,b) = NE.head grps in (t, fmap (\(_,m,_) -> m) grps, b))
713+ . groupWith (\(t,_,b) -> (t,b))
714+ $ bds
715+
716+ select = case ex of
717+ AllContentTypes -> id
718+ FirstContentType -> map (\(t,ms,b) -> (t, NE.head ms :| [], b))
719+
720+ formatBody :: (Text, NonEmpty M.MediaType, ByteString) -> [String]
721+ formatBody (t, ms, b) =
722+ "- " <> title <> " (" <> mediaList ms <> "):" :
723+ contentStr (NE.head ms) b
724+ where
725+ mediaList = fold . NE.intersperse ", " . fmap (\m -> "`" ++ show m ++ "`")
726+
727+ title
728+ | T.null t = "Example"
729+ | otherwise = cs t
645730
646731 markdownForType mime_type =
647732 case (M.mainType mime_type, M.subType mime_type) of
648733 ("text", "html") -> "html"
649734 ("application", "xml") -> "xml"
735+ ("text", "xml") -> "xml"
650736 ("application", "json") -> "javascript"
651737 ("application", "javascript") -> "javascript"
652738 ("text", "css") -> "css"
653739 (_, _) -> ""
654740
741+
655742 contentStr mime_type body =
656743 "" :
657− "```" <> markdownForType mime_type :
744+ " ```" <> markdownForType mime_type :
658745 cs body :
659− "```" :
746+ " ```" :
660747 "" :
661748 []
662749
@@ -674,7 +761,7 @@ markdown api = unlines $
674761 [] -> ["- No response body\n"]
675762 [("", t, r)] -> "- Response body as below." : contentStr t r
676763 xs ->
677− concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx <> " (`" <> cs (show t) <> "`)") : contentStr t r) xs
764+ formatBodies _responseExamples xs
678765
679766-- * Instances
680767