@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE ConstraintKinds #-}
32{-# LANGUAGE DataKinds #-}
43{-# LANGUAGE DefaultSignatures #-}
@@ -17,7 +16,6 @@
1716{-# LANGUAGE TypeOperators #-}
1817{-# LANGUAGE UndecidableInstances #-}
1918
20−#include "overlapping-compat.h"
2119module Servant.Docs.Internal where
2220
2321import Prelude ()
@@ -27,15 +25,14 @@ import Control.Applicative
2725import Control.Arrow
2826 (second)
2927import Control.Lens
30− (makeLenses, mapped, over, traversed, view, (%~), (&), (.~),
31− (<>~), (^.), (|>))
32−import qualified Control.Monad.Omega as Omega
28+ (makeLenses, mapped, each, over, set, to, toListOf, traversed, view,
29+ _1, (%~), (&), (.~), (<>~), (^.), (|>))
3330import qualified Data.ByteString.Char8 as BSC
3431import Data.ByteString.Lazy.Char8
3532 (ByteString)
3633import qualified Data.CaseInsensitive as CI
3734import Data.Foldable
38− (fold)
35+ (fold, toList)
3936import Data.Hashable
4037 (Hashable)
4138import Data.HashMap.Strict
@@ -53,17 +50,21 @@ import Data.Ord
5350 (comparing)
5451import Data.Proxy
5552 (Proxy (Proxy))
56−import Data.Semigroup
57− (Semigroup (..))
5853import Data.String.Conversions
5954 (cs)
6055import Data.Text
6156 (Text, unpack)
6257import GHC.Generics
58+ (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,
59+ (:*:)((:*:)), (:+:)(L1, R1))
60+import qualified GHC.Generics as G
6361import GHC.TypeLits
6462import Servant.API
6563import Servant.API.ContentTypes
6664import Servant.API.TypeLevel
65+import Servant.API.Generic
66+
67+import qualified Data.Universe.Helpers as U
6768
6869import qualified Data.HashMap.Strict as HM
6970import qualified Data.Text as T
@@ -76,14 +77,15 @@ import qualified Network.HTTP.Types as HTTP
7677-- or any 'Endpoint' value you want using the 'path' and 'method'
7778-- lenses to tweak.
7879--
79−-- @
80−-- λ> 'defEndpoint'
81−-- GET /
82−-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
83−-- GET /foo
84−-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
85−-- POST /foo
86−-- @
80+-- >>> defEndpoint
81+-- "GET" /
82+--
83+-- >>> defEndpoint & path <>~ ["foo"]
84+-- "GET" /foo
85+--
86+-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost
87+-- "POST" /foo
88+--
8789data Endpoint = Endpoint
8890 { _path :: [String] -- type collected
8991 , _method :: HTTP.Method -- type collected
@@ -104,14 +106,15 @@ showPath ps = concatMap ('/' :) ps
104106--
105107-- Here's how you can modify it:
106108--
107−-- @
108−-- λ> 'defEndpoint'
109−-- GET /
110−-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
111−-- GET /foo
112−-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
113−-- POST /foo
114−-- @
109+-- >>> defEndpoint
110+-- "GET" /
111+--
112+-- >>> defEndpoint & path <>~ ["foo"]
113+-- "GET" /foo
114+--
115+-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost
116+-- "POST" /foo
117+--
115118defEndpoint :: Endpoint
116119defEndpoint = Endpoint [] HTTP.methodGet
117120
@@ -128,7 +131,8 @@ instance Semigroup API where
128131 (<>) = mappend
129132
130133instance Monoid API where
131− API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2)
134+ API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2)
135+ (HM.unionWith combineAction b1 b2)
132136 mempty = API mempty mempty
133137
134138-- | An empty 'API'
@@ -157,6 +161,20 @@ data DocQueryParam = DocQueryParam
157161 , _paramKind :: ParamKind
158162 } deriving (Eq, Ord, Show)
159163
164+-- | A type to represent fragment. Holds the name of the fragment and its description.
165+--
166+-- Write a 'ToFragment' instance for your fragment types.
167+data DocFragment = DocFragment
168+ { _fragSymbol :: String -- type supplied
169+ , _fragDesc :: String -- user supplied
170+ } deriving (Eq, Ord, Show)
171+
172+-- | There should be at most one 'Fragment' per API endpoint.
173+-- So here we are keeping the first occurrence.
174+combineFragment :: Maybe DocFragment -> Maybe DocFragment -> Maybe DocFragment
175+Nothing `combineFragment` mdocFragment = mdocFragment
176+Just docFragment `combineFragment` _ = Just docFragment
177+
160178-- | An introductory paragraph for your documentation. You can pass these to
161179-- 'docsWithIntros'.
162180data DocIntro = DocIntro
@@ -222,12 +240,14 @@ data ParamKind = Normal | List | Flag
222240-- want to write a 'ToSample' instance for the type that'll be represented
223241-- as encoded data in the response.
224242--
225−-- Can be tweaked with three lenses.
243+-- Can be tweaked with four lenses.
244+--
245+-- >>> defResponse
246+-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}
247+--
248+-- >>> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "application/json", "{ \"status\": \"ok\" }")]
249+-- Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well",application/json,"{ \"status\": \"ok\" }")], _respHeaders = []}
226250--
227−-- > λ> defResponse
228−-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
229−-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
230−-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
231251data Response = Response
232252 { _respStatus :: Int
233253 , _respTypes :: [M.MediaType]
@@ -235,14 +255,25 @@ data Response = Response
235255 , _respHeaders :: [HTTP.Header]
236256 } deriving (Eq, Ord, Show)
237257
258+-- | Combine two Responses, we can't make a monoid because merging Status breaks
259+-- the laws.
260+--
261+-- As such, we invent a non-commutative, left associative operation
262+-- 'combineResponse' to mush two together taking the status from the very left.
263+combineResponse :: Response -> Response -> Response
264+Response s ts bs hs `combineResponse` Response _ ts' bs' hs'
265+ = Response s (ts <> ts') (bs <> bs') (hs <> hs')
266+
238267-- | Default response: status code 200, no response body.
239268--
240−-- Can be tweaked with two lenses.
269+-- Can be tweaked with four lenses.
270+--
271+-- >>> defResponse
272+-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}
273+--
274+-- >>> defResponse & respStatus .~ 204
275+-- Response {_respStatus = 204, _respTypes = [], _respBody = [], _respHeaders = []}
241276--
242−-- > λ> defResponse
243−-- > Response {_respStatus = 200, _respBody = Nothing}
244−-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
245−-- > Response {_respStatus = 204, _respBody = Just "[]"}
246277defResponse :: Response
247278defResponse = Response
248279 { _respStatus = 200
@@ -264,8 +295,9 @@ defResponse = Response
264295data Action = Action
265296 { _authInfo :: [DocAuthentication] -- user supplied info
266297 , _captures :: [DocCapture] -- type collected + user supplied info
267− , _headers :: [Text] -- type collected
298+ , _headers :: [HTTP.Header] -- type collected
268299 , _params :: [DocQueryParam] -- type collected + user supplied info
300+ , _fragment :: Maybe DocFragment -- type collected + user supplied info
269301 , _notes :: [DocNote] -- user supplied
270302 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
271303 , _rqtypes :: [M.MediaType] -- type collected
@@ -277,27 +309,30 @@ data Action = Action
277309-- laws.
278310--
279311-- As such, we invent a non-commutative, left associative operation
280−-- 'combineAction' to mush two together taking the response, body and content
281−-- types from the very left.
312+-- 'combineAction' to mush two together taking the response from the very left.
282313combineAction :: Action -> Action -> Action
283−Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
284− Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
314+Action a c h p f n m ts body resp
315+ `combineAction` Action a' c' h' p' f' n' m' ts' body' resp' =
316+ Action (a <> a') (c <> c') (h <> h') (p <> p') (f `combineFragment` f') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp')
285317
286318-- | Default 'Action'. Has no 'captures', no query 'params', expects
287319-- no request body ('rqbody') and the typical response is 'defResponse'.
288320--
289321-- Tweakable with lenses.
290322--
291−-- > λ> defAction
292−-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}
293−-- > λ> defAction & response.respStatus .~ 201
294−-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}
323+-- >>> defAction
324+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}
325+--
326+-- >>> defAction & response.respStatus .~ 201
327+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}
328+--
295329defAction :: Action
296330defAction =
297331 Action []
298332 []
299333 []
300334 []
335+ Nothing
301336 []
302337 []
303338 []
@@ -321,12 +356,14 @@ data ShowContentTypes = AllContentTypes -- ^ For each example, show each conten
321356--
322357-- @since 0.11.1
323358data RenderingOptions = RenderingOptions
324− { _requestExamples :: !ShowContentTypes
359+ { _requestExamples :: !ShowContentTypes
325360 -- ^ How many content types to display for request body examples?
326− , _responseExamples :: !ShowContentTypes
361+ , _responseExamples :: !ShowContentTypes
327362 -- ^ How many content types to display for response body examples?
328− , _notesHeading :: !(Maybe String)
363+ , _notesHeading :: !(Maybe String)
329364 -- ^ Optionally group all 'notes' together under a common heading.
365+ , _renderCurlBasePath :: !(Maybe String)
366+ -- ^ Optionally render example curl requests under a common base path (e.g. `http://localhost:80`).
330367 } deriving (Show)
331368
332369-- | Default API generation options.
@@ -338,9 +375,10 @@ data RenderingOptions = RenderingOptions
338375-- @since 0.11.1
339376defRenderingOptions :: RenderingOptions
340377defRenderingOptions = RenderingOptions
341− { _requestExamples = AllContentTypes
342− , _responseExamples = AllContentTypes
343− , _notesHeading = Nothing
378+ { _requestExamples = AllContentTypes
379+ , _responseExamples = AllContentTypes
380+ , _notesHeading = Nothing
381+ , _renderCurlBasePath = Nothing
344382 }
345383
346384-- gimme some lenses
@@ -350,6 +388,7 @@ makeLenses ''API
350388makeLenses ''Endpoint
351389makeLenses ''DocCapture
352390makeLenses ''DocQueryParam
391+makeLenses ''DocFragment
353392makeLenses ''DocIntro
354393makeLenses ''DocNote
355394makeLenses ''Response
@@ -359,7 +398,8 @@ makeLenses ''RenderingOptions
359398-- | Generate the docs for a given API that implements 'HasDocs'. This is the
360399-- default way to create documentation.
361400--
362−-- prop> docs == docsWithOptions defaultDocOptions
401+-- > docs == docsWithOptions defaultDocOptions
402+--
363403docs :: HasDocs api => Proxy api -> API
364404docs p = docsWithOptions p defaultDocOptions
365405
@@ -375,9 +415,9 @@ docsWithOptions p = docsFor p (defEndpoint, defAction)
375415-- > extra :: ExtraInfo TestApi
376416-- > extra =
377417-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
378−-- > defAction & headers <>~ ["unicorns"]
418+-- > defAction & headers <>~ [("X-Num-Unicorns", 1)]
379419-- > & notes <>~ [ DocNote "Title" ["This is some text"]
380−-- > , DocNote "Second secton" ["And some more"]
420+-- > , DocNote "Second section" ["And some more"]
381421-- > ]
382422
383423extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)
@@ -470,22 +510,22 @@ samples = map ("",)
470510
471511-- | Default sample Generic-based inputs/outputs.
472512defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
473−defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a))
513+defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a))
474514
475515-- | @'ToSample'@ for Generics.
476516--
477−-- The use of @'Omega'@ allows for more productive sample generation.
517+-- Note: we use combinators from "Universe.Data.Helpers" for more productive sample generation.
478518class GToSample t where
479− gtoSamples :: proxy t -> Omega.Omega (Text, t x)
519+ gtoSamples :: proxy t -> [(Text, t x)]
480520
481521instance GToSample U1 where
482− gtoSamples _ = Omega.each (singleSample U1)
522+ gtoSamples _ = singleSample U1
483523
484524instance GToSample V1 where
485525 gtoSamples _ = empty
486526
487527instance (GToSample p, GToSample q) => GToSample (p :*: q) where
488− gtoSamples _ = render <$> ps <*> qs
528+ gtoSamples _ = U.cartesianProduct render ps qs
489529 where
490530 ps = gtoSamples (Proxy :: Proxy p)
491531 qs = gtoSamples (Proxy :: Proxy q)
@@ -494,13 +534,13 @@ instance (GToSample p, GToSample q) => GToSample (p :*: q) where
494534 | otherwise = (ta <> ", " <> tb, a :*: b)
495535
496536instance (GToSample p, GToSample q) => GToSample (p :+: q) where
497− gtoSamples _ = lefts <|> rights
537+ gtoSamples _ = lefts U.+++ rights
498538 where
499539 lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)
500540 rights = second R1 <$> gtoSamples (Proxy :: Proxy q)
501541
502542instance ToSample a => GToSample (K1 i a) where
503− gtoSamples _ = second K1 <$> Omega.each (toSamples (Proxy :: Proxy a))
543+ gtoSamples _ = second K1 <$> toSamples (Proxy :: Proxy a)
504544
505545instance (GToSample f) => GToSample (M1 i a f) where
506546 gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)
@@ -568,6 +608,15 @@ class ToCapture c where
568608class ToAuthInfo a where
569609 toAuthInfo :: Proxy a -> DocAuthentication
570610
611+-- | The class that helps us get documentation for URL fragments.
612+--
613+-- Example of an instance:
614+--
615+-- > instance ToFragment (Fragment a) where
616+-- > toFragment _ = DocFragment "fragment" "fragment description"
617+class ToFragment t where
618+ toFragment :: Proxy t -> DocFragment
619+
571620-- | Generate documentation in Markdown format for
572621-- the given 'API'.
573622--
@@ -597,7 +646,7 @@ markdown = markdownWith defRenderingOptions
597646--
598647-- @since 0.11.1
599648markdownWith :: RenderingOptions -> API -> String
600−markdownWith RenderingOptions{..} api = unlines $
649+markdownWith RenderingOptions{..} api = unlines $
601650 introsStr (api ^. apiIntros)
602651 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
603652
@@ -608,10 +657,12 @@ markdownWith RenderingOptions{..} api = unlines $
608657 notesStr (action ^. notes) ++
609658 authStr (action ^. authInfo) ++
610659 capturesStr (action ^. captures) ++
611− headersStr (action ^. headers) ++
660+ headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) ++
612661 paramsStr meth (action ^. params) ++
662+ fragmentStr (action ^. fragment) ++
613663 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
614664 responseStr (action ^. response) ++
665+ maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath ++
615666 []
616667
617668 where str = "## " ++ BSC.unpack meth
@@ -711,6 +762,14 @@ markdownWith RenderingOptions{..} api = unlines $
711762
712763 where values = param ^. paramValues
713764
765+ fragmentStr :: Maybe DocFragment -> [String]
766+ fragmentStr Nothing = []
767+ fragmentStr (Just frag) =
768+ [ "### Fragment:", ""
769+ , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc)
770+ , ""
771+ ]
772+
714773 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]
715774 rqbodyStr [] [] = []
716775 rqbodyStr types s =
@@ -759,12 +818,11 @@ markdownWith RenderingOptions{..} api = unlines $
759818 ("text", "css") -> "css"
760819 (_, _) -> ""
761820
762−
763821 contentStr mime_type body =
764822 "" :
765− " ```" <> markdownForType mime_type :
823+ "```" <> markdownForType mime_type :
766824 cs body :
767− " ```" :
825+ "```" :
768826 "" :
769827 []
770828
@@ -784,11 +842,41 @@ markdownWith RenderingOptions{..} api = unlines $
784842 xs ->
785843 formatBodies _responseExamples xs
786844
845+ curlStr :: Endpoint -> [HTTP.Header] -> [(Text, M.MediaType, ByteString)] -> String -> [String]
846+ curlStr endpoint hdrs reqBodies basePath =
847+ [ "### Sample Request:"
848+ , ""
849+ , "```bash"
850+ , "curl -X" ++ BSC.unpack (endpoint ^. method) ++ " \\"
851+ ] <>
852+ maybe [] pure mbMediaTypeStr <>
853+ headersStrs <>
854+ maybe [] pure mbReqBodyStr <>
855+ [ " " ++ basePath ++ showPath (endpoint ^. path)
856+ , "```"
857+ , ""
858+ ]
859+
860+ where escapeQuotes :: String -> String
861+ escapeQuotes = concatMap $ \c -> case c of
862+ '\"' -> "\\\""
863+ _ -> [c]
864+ mbReqBody = listToMaybe reqBodies
865+ mbMediaTypeStr = mkMediaTypeStr <$> mbReqBody
866+ headersStrs = mkHeaderStr <$> hdrs
867+ mbReqBodyStr = mkReqBodyStr <$> mbReqBody
868+ mkMediaTypeStr (_, media_type, _) =
869+ " -H \"Content-Type: " ++ show media_type ++ "\" \\"
870+ mkHeaderStr (hdrName, hdrVal) =
871+ " -H \"" ++ escapeQuotes (cs (CI.original hdrName)) ++ ": " ++
872+ escapeQuotes (cs hdrVal) ++ "\" \\"
873+ mkReqBodyStr (_, _, body) = " -d \"" ++ escapeQuotes (cs body) ++ "\" \\"
874+
787875-- * Instances
788876
789877-- | The generated docs for @a ':<|>' b@ just appends the docs
790878-- for @a@ with the docs for @b@.
791−instance OVERLAPPABLE_
879+instance {-# OVERLAPPABLE #-}
792880 (HasDocs a, HasDocs b)
793881 => HasDocs (a :<|> b) where
794882
@@ -807,7 +895,7 @@ instance HasDocs EmptyAPI where
807895-- | @"books" :> 'Capture' "isbn" Text@ will appear as
808896-- @/books/:isbn@ in the docs.
809897instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
810− => HasDocs (Capture' mods sym a :> api) where
898+ => HasDocs (Capture' '[] sym a :> api) where
811899
812900 docsFor Proxy (endpoint, action) =
813901 docsFor subApiP (endpoint', action')
@@ -819,6 +907,28 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
819907 endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
820908 symP = Proxy :: Proxy sym
821909
910+instance (KnownSymbol descr, KnownSymbol sym, HasDocs api)
911+ => HasDocs (Capture' (Description descr ': mods) sym a :> api) where
912+
913+ docsFor Proxy (endpoint, action) =
914+ docsFor subApiP (endpoint', action')
915+
916+ where subApiP = Proxy :: Proxy api
917+
918+ docCapture = DocCapture (symbolVal symP) (symbolVal descrP)
919+ action' = over captures (|> docCapture) action
920+ endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
921+ descrP = Proxy :: Proxy descr
922+ symP = Proxy :: Proxy sym
923+
924+instance {-# OVERLAPPABLE #-} HasDocs (Capture' mods sym a :> api)
925+ => HasDocs (Capture' (mod ': mods) sym a :> api) where
926+
927+ docsFor Proxy =
928+ docsFor apiP
929+
930+ where apiP = Proxy :: Proxy (Capture' mods sym a :> api)
931+
822932
823933-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as
824934-- @/books/:isbn@ in the docs.
@@ -836,7 +946,7 @@ instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)
836946 symP = Proxy :: Proxy sym
837947
838948
839−instance OVERLAPPABLE_
949+instance {-# OVERLAPPABLE #-}
840950 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
841951 , ReflectMethod method)
842952 => HasDocs (Verb method status (ct ': cts) a) where
@@ -852,12 +962,25 @@ instance OVERLAPPABLE_
852962 status = fromInteger $ natVal (Proxy :: Proxy status)
853963 p = Proxy :: Proxy a
854964
965+instance (ReflectMethod method) =>
966+ HasDocs (NoContentVerb method) where
967+ docsFor Proxy (endpoint, action) DocOptions{..} =
968+ single endpoint' action'
969+
970+ where endpoint' = endpoint & method .~ method'
971+ action' = action & response.respStatus .~ 204
972+ & response.respTypes .~ []
973+ & response.respBody .~ []
974+ & response.respHeaders .~ []
975+ method' = reflectMethod (Proxy :: Proxy method)
976+
855977-- | TODO: mention the endpoint is streaming, its framing strategy
856978--
857979-- Also there are no samples.
858−instance OVERLAPPABLE_
859− (MimeRender ct a, KnownNat status
860− , ReflectMethod method)
980+--
981+-- TODO: AcceptFraming for content-type
982+instance {-# OVERLAPPABLE #-}
983+ (Accept ct, KnownNat status, ReflectMethod method)
861984 => HasDocs (Stream method status framing ct a) where
862985 docsFor Proxy (endpoint, action) DocOptions{..} =
863986 single endpoint' action'
@@ -868,9 +991,8 @@ instance OVERLAPPABLE_
868991 t = Proxy :: Proxy '[ct]
869992 method' = reflectMethod (Proxy :: Proxy method)
870993 status = fromInteger $ natVal (Proxy :: Proxy status)
871− p = Proxy :: Proxy a
872994
873−instance OVERLAPPING_
995+instance {-# OVERLAPPING #-}
874996 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
875997 , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))
876998 => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where
@@ -888,14 +1010,17 @@ instance OVERLAPPING_
8881010 status = fromInteger $ natVal (Proxy :: Proxy status)
8891011 p = Proxy :: Proxy a
8901012
891−instance (KnownSymbol sym, HasDocs api)
1013+instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)
8921014 => HasDocs (Header' mods sym a :> api) where
8931015 docsFor Proxy (endpoint, action) =
8941016 docsFor subApiP (endpoint, action')
8951017
8961018 where subApiP = Proxy :: Proxy api
897− action' = over headers (|> headername) action
898− headername = T.pack $ symbolVal (Proxy :: Proxy sym)
1019+ action' = over headers (|> (headerName, headerVal)) action
1020+ headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy sym)
1021+ headerVal = case toSample (Proxy :: Proxy a) of
1022+ Just x -> cs $ toHeader x
1023+ Nothing -> "<no header sample provided>"
8991024
9001025instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
9011026 => HasDocs (QueryParam' mods sym a :> api) where
@@ -928,6 +1053,15 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
9281053 paramP = Proxy :: Proxy (QueryFlag sym)
9291054 action' = over params (|> toParam paramP) action
9301055
1056+instance (ToFragment (Fragment a), HasDocs api)
1057+ => HasDocs (Fragment a :> api) where
1058+
1059+ docsFor Proxy (endpoint, action) =
1060+ docsFor subApiP (endpoint, action')
1061+
1062+ where subApiP = Proxy :: Proxy api
1063+ fragmentP = Proxy :: Proxy (Fragment a)
1064+ action' = set fragment (Just (toFragment fragmentP)) action
9311065
9321066instance HasDocs Raw where
9331067 docsFor _proxy (endpoint, action) _ =
@@ -960,7 +1094,6 @@ instance (KnownSymbol desc, HasDocs api)
9601094-- both are even defined) for any particular type.
9611095instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
9621096 => HasDocs (ReqBody' mods (ct ': cts) a :> api) where
963−
9641097 docsFor Proxy (endpoint, action) opts@DocOptions{..} =
9651098 docsFor subApiP (endpoint, action') opts
9661099
@@ -971,6 +1104,18 @@ instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
9711104 t = Proxy :: Proxy (ct ': cts)
9721105 p = Proxy :: Proxy a
9731106
1107+-- | TODO: this instance is incomplete.
1108+instance (HasDocs api, Accept ctype) => HasDocs (StreamBody' mods framing ctype a :> api) where
1109+ docsFor Proxy (endpoint, action) opts =
1110+ docsFor subApiP (endpoint, action') opts
1111+ where
1112+ subApiP = Proxy :: Proxy api
1113+
1114+ action' :: Action
1115+ action' = action & rqtypes .~ toList (contentTypes t)
1116+
1117+ t = Proxy :: Proxy ctype
1118+
9741119instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where
9751120
9761121 docsFor Proxy (endpoint, action) =
@@ -1006,6 +1151,9 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
10061151 authProxy = Proxy :: Proxy (BasicAuth realm usr)
10071152 action' = over authInfo (|> toAuthInfo authProxy) action
10081153
1154+instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
1155+ docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
1156+
10091157-- ToSample instances for simple types
10101158instance ToSample NoContent
10111159instance ToSample Bool
@@ -1022,6 +1170,7 @@ instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f
10221170instance ToSample a => ToSample (Maybe a)
10231171instance (ToSample a, ToSample b) => ToSample (Either a b)
10241172instance ToSample a => ToSample [a]
1173+instance ToSample a => ToSample (NonEmpty a)
10251174
10261175-- ToSample instances for Control.Applicative types
10271176instance ToSample a => ToSample (Const a b)
@@ -1035,3 +1184,6 @@ instance ToSample a => ToSample (Product a)
10351184instance ToSample a => ToSample (First a)
10361185instance ToSample a => ToSample (Last a)
10371186instance ToSample a => ToSample (Dual a)
1187+
1188+-- $setup
1189+-- >>> :set -XOverloadedStrings