servant-docs 0.4.4.7 → 0.13.1

raw patch · 12 files changed

Files

• CHANGELOG.md +160/−2
• LICENSE +1/−1
• README.md +46/−13
• Setup.hs +1/−1
• example/greet.hs +18/−30
• golden/comprehensive.md +610/−0
• servant-docs.cabal +57/−27
• src/Servant/Docs.hs +17/−126
• src/Servant/Docs/Internal.hs +1195/−903
• src/Servant/Docs/Internal/Pretty.hs +71/−0
• test/Servant/DocsSpec.hs +220/−0
• test/Spec.hs +8/−1

@@ -1,6 +1,164 @@-0.4.3+[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md)+[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)++0.13.1+------++- Compatibility with newer dependencies and newer GHCs.++0.13+----++- WithResource combinator for Servant-managed resources. [#1630](https://github.com/haskell-servant/servant/pull/1630)++  For servant-docs, this meant the addition of `instance HasDocs api => HasDocs (WithResource res :> api)`++- Compatibility with GHC series 9.2, 9.4, 9.6++0.12+----++### Significant changes++- Generate sample cURL requests+  ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)).+  Breaking change: requires sample header values to be supplied with `headers`.++0.11.9+------++### Significant changes++- Use Capture Description if available (#1423).++### Other changes++- Support GHC-9.0.1.+- Bump `bytestring` and `lens` dependencies.++0.11.8+------++### Significant changes++- Support `Fragment` combinator.++0.11.7+------++### Significant changes++- Add instance for ToSample NonEmpty++### Other changes++- Bump "tested-with" ghc versions+- Fix servant-docs code sample in README++0.11.5+----+++- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)++  The `NoContent` API endpoints should now use `NoContentVerb` combinator.+  The API type changes are usually of the kind++  ```diff+  - :<|> PostNoContent '[JSON] NoContent+  + :<|> PostNoContent+  ```++  i.e. one doesn't need to specify the content-type anymore. There is no content.++- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)++  You can specify a lenient capture as++  ```haskell+  :<|> "capture-lenient"  :> Capture' '[Lenient] "foo" Int :> GET+  ```++  which will make the capture always succeed. Handlers will be of the+  type `Either String CapturedType`, where `Left err` represents+  the possible parse failure.++- *servant-docs* Merge documentation from duplicate routes [#1240](https://github.com/haskell-servant/servant/issues/1240) [#1241](https://github.com/haskell-servant/servant/pull/1241)++  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* Prevent race-conditions in testing [#1194](https://github.com/haskell-servant/servant/pull/1194)++0.11.4+------++- Drop dependency on `control-monad-omega` in favor of `Data.Universe.Helpers` from `universe-base`.++0.11.3+------++- Support `servant-0.15`+   - Instances for 'Stream' and 'StreamBody'++0.11.2+------++* Allow `servant-0.13`:+  - Doesn't have instances for streaming.+  - Servant.API.Modifiers extra information isn't used.++0.11.1+------++* Export `DocAuthentication` and related lenses.+* Make `defAction`'s documentation visible in Haddock documentation.+* Add a markdown header for the Headers an endpoint is sensitive to.+* Document the HTTP Method the parameters of an endpoint belong to+  (rather than assuming `GET` for all of them).+* Content type of sample response body is also displayed.+* Can now customise various aspects of how the document is produced+  using `markdownWith` and `RenderingOptions`:+    - How many content-types for each example are shown+    - Whether notes should be grouped together under their own header.++0.11+----++* changed the type of `rqbody`.++0.10+----++There are no changes. Released as a part of `servant` suite.++0.7.1 ------* docsWith will no longer eat your documentation (https://github.com/haskell-servant/servant/pull/124)++* Support GHC 8.0++0.7+---++* Use `throwError` instead of `throwE` in documentation++0.5+----++* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators+* Support maximum samples setting with new `DocOptions` type (used by `docsWithOptions` and `docsWith`)+* Remove redundant second parameter of ToSample+* Add Generic-based default implementation for `ToSample` class+* Add more `ToSamples` instances: `Bool`, `Ordering`, tuples (up to 7), `[]`, `Maybe`, `Either`, `Const`, `ZipList` and some monoids+* Move `toSample` out of `ToSample` class+* Add a few helper functions to define `toSamples`+* Remove matrix params.+* Added support for Basic authentication  0.4 ---

@@ -1,4 +1,4 @@-Copyright (c) 2014, Zalora South East Asia Pte Ltd+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors  All rights reserved. 

@@ -2,24 +2,56 @@  ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) -Generate API docs for your *servant* webservice. Feel free to also take a look at [servant-pandoc](https://github.com/mpickering/servant-pandoc) which uses this package to target a broad range of output formats using the excellent **pandoc**.+Generate API docs for your _servant_ webservice. Feel free to also take a look at [servant-pandoc](https://github.com/mpickering/servant-pandoc) which uses this package to target a broad range of output formats using the excellent **pandoc**.  ## Example -See [here](https://github.com/haskell-servant/servant/tree/master/servant-docs/blob/master/example/greet.md) for the output of the following program.+See [here](https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.md) for the output of the following program. -``` haskell+```haskell {-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} -import Data.Proxy-import Data.Text-import Servant+import Data.Aeson (FromJSON, ToJSON)+import Data.Proxy (Proxy (..))+import Data.String.Conversions (cs)+import Data.Text (Text)+import GHC.Generics (Generic)+import Servant.API+  ( (:<|>),+    (:>),+    Capture,+    Delete,+    Get,+    JSON,+    MimeRender,+    PlainText,+    Post,+    QueryParam,+    ReqBody,+    mimeRender,+  )+import Servant.Docs+  ( API,+    DocCapture (..),+    DocQueryParam (..),+    ParamKind (..),+    ToCapture,+    ToParam,+    ToSample,+    docs,+    markdown,+    singleSample,+    toCapture,+    toParam,+    toSamples,+  )  -- our type for a Greeting message data Greet = Greet { _msg :: Text }@@ -29,6 +61,7 @@ -- 'MimeRender' instance for 'JSON'. instance FromJSON Greet instance ToJSON Greet+instance ToSample ()  -- We can also implement 'MimeRender' explicitly for additional formats. instance MimeRender PlainText Greet where@@ -36,8 +69,7 @@  -- we provide a sample value for the 'Greet' type instance ToSample Greet where-  toSample = Just g-+  toSamples _ = singleSample g     where g = Greet "Hello, haskeller!"  instance ToParam (QueryParam "capital" Bool) where@@ -45,6 +77,7 @@     DocQueryParam "capital"                   ["true", "false"]                   "Get the greeting message in uppercase (true) or not (false). Default is false."+                  Normal  instance ToCapture (Capture "name" Text) where   toCapture _ = DocCapture "name" "name of the person to greet"@@ -55,8 +88,8 @@ -- API specification type TestApi =        "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet-  :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet-  :<|> "delete" :> Capture "greetid" Text :> Delete '[] ()+  :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet+  :<|> "delete" :> Capture "greetid" Text :> Delete '[JSON] ()  testApi :: Proxy TestApi testApi = Proxy

@@ -1,2 +1,2 @@-import Distribution.Simple+import           Distribution.Simple main = defaultMain

@@ -5,14 +5,14 @@ {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE TypeOperators         #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-import Control.Lens-import Data.Aeson-import Data.Proxy-import Data.String.Conversions-import Data.Text (Text)-import GHC.Generics-import Servant.API-import Servant.Docs+import           Control.Lens+import           Data.Aeson+import           Data.Proxy+import           Data.String.Conversions+import           Data.Text (Text)+import           GHC.Generics+import           Servant.API+import           Servant.Docs  -- * Example @@ -46,26 +46,14 @@                   \Default is false."                   Normal -instance ToParam (MatrixParam "lang" String) where-  toParam _ =-    DocQueryParam "lang"-                  ["en", "sv", "fr"]-                  "Get the greeting message selected language. Default is en."-                  Normal--instance ToSample () () where-  toSample _ = Just ()--instance ToSample Greet Greet where-  toSample _ = Just $ Greet "Hello, haskeller!"-+instance ToSample Greet where   toSamples _ =     [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")     , ("If you use ?capital=false", Greet "Hello, haskeller")     ] -instance ToSample Int Int where-  toSample _ = Just 1729+instance ToSample Int where+  toSamples _ = singleSample 1729  -- We define some introductory sections, these will appear at the top of the -- documentation.@@ -86,14 +74,14 @@ -- API specification type TestApi =        -- GET /hello/:name?capital={true, false}  returns a Greet as JSON or PlainText-       "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet+       "hello" :> Capture "name" Text :> Header "X-Num-Fairies" Int :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet         -- POST /greet with a Greet as JSON in the request body,        --             returns a Greet as JSON   :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet)         -- DELETE /greet/:greetid-  :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] ()+  :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent  testApi :: Proxy TestApi testApi = Proxy@@ -103,10 +91,10 @@ -- notes. extra :: ExtraInfo TestApi extra =-    extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] ())) $-             defAction & headers <>~ ["unicorns"]+    extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $+             defAction & headers <>~ [("X-Num-Unicorns", "1")]                        & notes   <>~ [ DocNote "Title" ["This is some text"]-                                     , DocNote "Second secton" ["And some more"]+                                     , DocNote "Second section" ["And some more"]                                      ]  -- Generate the data that lets us have API docs. This@@ -117,7 +105,7 @@ -- -- > docs testAPI :: API docsGreet :: API-docsGreet = docsWith [intro1, intro2] extra testApi+docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi  main :: IO ()-main = putStrLn $ markdown docsGreet+main = putStrLn $ markdownWith (defRenderingOptions { _renderCurlBasePath = Just "http://localhost:80" }) docsGreet

@@ -0,0 +1,610 @@+## GET /++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /alternative/left++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /alternative/right++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /capture/:bar++### Captures:++- *bar*: example description++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /capture-all/:foo++### Captures:++- *foo*: Capture all foo Int++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /capture-lenient/:foo++### Captures:++- *foo*: Capture foo Int++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /description++### foo+++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /flag++### GET Parameters:++- foo+     - **Description**: QueryFlag+     - This parameter is a **flag**. This means no value is expected to be associated to this parameter.+++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /foo++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /fragment++### Fragment:++- *foo*: Fragment Int++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /get-int++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json+17+```++## GET /header++### Headers:++- This endpoint is sensitive to the value of the **foo** HTTP header.++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /header-lenient++### Headers:++- This endpoint is sensitive to the value of the **bar** HTTP header.++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /http-version++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /is-secure++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /named-context++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /param++### GET Parameters:++- foo+     - **Values**: *1, 2, 3*+     - **Description**: QueryParams Int+++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /param-lenient++### GET Parameters:++- bar+     - **Values**: *1, 2, 3*+     - **Description**: QueryParams Int+++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /params++### GET Parameters:++- foo+     - **Values**: *1, 2, 3*+     - **Description**: QueryParams Int+     - This parameter is a **list**. All GET parameters with the name foo[] will forward their values in a list to the handler.+++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## POST /post-int++### Response:++- Status code 204+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json+17+```++## POST /post-no-content++### Response:++- Status code 204+- Headers: []++- No response body++## GET /raw++### Response:++- Status code 200+- Headers: []++- No response body++## GET /remote-host++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /req-body++### Request:++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json+17+```++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /req-body-lenient++### Request:++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json+17+```++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /res-headers++### Response:++- Status code 200+- Headers: [("foo","17")]++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /resource++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /streaming++### Request:++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- No response body++## GET /summary++### foo+++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```++## GET /vault++### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json;charset=utf-8`+    - `application/json`++- Example (`application/json;charset=utf-8`, `application/json`):++```json++```+

@@ -1,26 +1,31 @@+cabal-version:       2.2 name:                servant-docs-version:             0.4.4.7+version:             0.13.1+ synopsis:            generate API docs for your servant webservice+category:            Servant, Web description:   Library for generating API docs from a servant API definition.   .-  Runnable example <https://github.com/haskell-servant/servant-docs/blob/master/example/greet.hs here>.+  Runnable example <https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.hs here>.   .   <https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md CHANGELOG>-license:             BSD3++homepage:            http://docs.servant.dev/+bug-reports:         http://github.com/haskell-servant/servant/issues+license:             BSD-3-Clause license-file:        LICENSE-author:              Alp Mestanogullari, Sönke Hahn, Julian K. Arni-maintainer:          alpmestan@gmail.com-copyright:           2014-2015 Zalora South East Asia Pte Ltd-category:            Web+author:              Servant Contributors+maintainer:          haskell-servant-maintainers@googlegroups.com+copyright:           2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type:          Simple-cabal-version:       >=1.10-tested-with:         GHC >= 7.8-homepage:            http://haskell-servant.github.io/-Bug-reports:         http://github.com/haskell-servant/servant/issues+tested-with: GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.8, GHC ==9.4.8, GHC ==9.6.4, GHC ==9.8.2, GHC ==9.10.1+ extra-source-files:   CHANGELOG.md   README.md+  golden/comprehensive.md+ source-repository head   type: git   location: http://github.com/haskell-servant/servant.git@@ -29,22 +34,39 @@   exposed-modules:       Servant.Docs     , Servant.Docs.Internal+    , Servant.Docs.Internal.Pretty++  -- Bundled with GHC: Lower bound to not force re-installs+  -- text and mtl are bundled starting with GHC-8.4+  --+  -- note: mtl lower bound is so low because of GHC-7.8   build-depends:-      base >=4.7 && <5-    , bytestring-    , bytestring-conversion-    , case-insensitive-    , hashable-    , http-media >= 0.6-    , http-types >= 0.7-    , lens-    , servant == 0.4.*-    , string-conversions-    , text-    , unordered-containers+      base       >= 4.14     && < 4.21+    , bytestring >= 0.10.8.1 && < 0.13+    , text       >= 1.2.3.0  && < 2.2++  -- Servant dependencies+  build-depends:+      servant            >= 0.20.2 && <0.21++  -- Other dependencies: Lower bound around what is in the latest Stackage LTS.+  -- Here can be exceptions if we really need features from the newer versions.+  build-depends:+      aeson                >= 1.4.1.0  && < 3+    , aeson-pretty         >= 0.8.5    && < 0.9+    , base-compat          >= 0.10.5   && < 0.15+    , case-insensitive     >= 1.2.0.11 && < 1.3+    , hashable             >= 1.2.7.0  && < 1.6+    , http-media           >= 0.7.1.3  && < 0.9+    , http-types           >= 0.12.2   && < 0.13+    , lens                 >= 4.17     && < 5.4+    , string-conversions   >= 0.4.0.1  && < 0.5+    , universe-base        >= 1.1.1    && < 1.2+    , unordered-containers >= 0.2.9.0  && < 0.3+   hs-source-dirs: src   default-language: Haskell2010-  ghc-options: -Wall+  ghc-options: -Wall -Wno-redundant-constraints  executable greet-docs   main-is: greet.hs@@ -53,7 +75,6 @@   build-depends:       base     , aeson-    , bytestring-conversion     , lens     , servant     , servant-docs@@ -62,17 +83,26 @@   default-language: Haskell2010  test-suite spec+  default-language: Haskell2010   type: exitcode-stdio-1.0   main-is: Spec.hs+  other-modules: Servant.DocsSpec   hs-source-dirs: test   ghc-options: -Wall++  -- Dependencies inherited from the library. No need to specify bounds.   build-depends:       base+    , base-compat     , aeson-    , hspec     , lens     , servant     , servant-docs     , string-conversions-  default-language: Haskell2010 +  -- Additional dependencies+  build-depends:+      tasty         >= 1.1.0.4  && < 1.6,+      tasty-golden  >= 2.3.2    && < 2.4,+      tasty-hunit   >= 0.10.0.1 && < 0.11,+      transformers  >= 0.5.2.0  && < 0.7

@@ -20,150 +20,41 @@ -- The only thing you'll need to do will be to implement some classes -- for your captures, get parameters and request or response bodies. ----- Here is a complete example that you can run to see the markdown pretty--- printer in action:------ > {-# LANGUAGE DataKinds             #-}--- > {-# LANGUAGE DeriveGeneric         #-}--- > {-# LANGUAGE FlexibleInstances     #-}--- > {-# LANGUAGE MultiParamTypeClasses #-}--- > {-# LANGUAGE OverloadedStrings     #-}--- > {-# LANGUAGE TypeOperators         #-}--- > {-# OPTIONS_GHC -fno-warn-orphans #-}--- > import Control.Lens--- > import Data.Aeson--- > import Data.Proxy--- > import Data.String.Conversions--- > import Data.Text (Text)--- > import GHC.Generics--- > import Servant.API--- > import Servant.Docs--- >--- > -- * Example--- >--- > -- | A greet message data type--- > newtype Greet = Greet Text--- >   deriving (Generic, Show)--- >--- > -- | We can get JSON support automatically. This will be used to parse--- > -- and encode a Greeting as 'JSON'.--- > instance FromJSON Greet--- > instance ToJSON Greet--- >--- > -- | We can also implement 'MimeRender' for additional formats like 'PlainText'.--- > instance MimeRender PlainText Greet where--- >     mimeRender Proxy (Greet s) = "\"" <> cs s <> "\""--- >--- > -- We add some useful annotations to our captures,--- > -- query parameters and request body to make the docs--- > -- really helpful.--- > instance ToCapture (Capture "name" Text) where--- >   toCapture _ = DocCapture "name" "name of the person to greet"--- >--- > instance ToCapture (Capture "greetid" Text) where--- >   toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"--- >--- > instance ToParam (QueryParam "capital" Bool) where--- >   toParam _ =--- >     DocQueryParam "capital"--- >                   ["true", "false"]--- >                   "Get the greeting message in uppercase (true) or not (false).\--- >                   \Default is false."--- >                   Normal--- >--- > instance ToParam (MatrixParam "lang" String) where--- >   toParam _ =--- >     DocQueryParam "lang"--- >                   ["en", "sv", "fr"]--- >                   "Get the greeting message selected language. Default is en."--- >                   Normal--- >--- > instance ToSample Greet Greet where--- >   toSample _ = Just $ Greet "Hello, haskeller!"--- >--- >   toSamples _ =--- >     [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")--- >     , ("If you use ?capital=false", Greet "Hello, haskeller")--- >     ]--- >--- > -- We define some introductory sections, these will appear at the top of the--- > -- documentation.--- > ----- > -- We pass them in with 'docsWith', below. If you only want to add--- > -- introductions, you may use 'docsWithIntros'--- > intro1 :: DocIntro--- > intro1 = DocIntro "On proper introductions." -- The title--- >     [ "Hello there."--- >     , "As documentation is usually written for humans, it's often useful \--- >       \to introduce concepts with a few words." ] -- Elements are paragraphs--- >--- > intro2 :: DocIntro--- > intro2 = DocIntro "This title is below the last"--- >     [ "You'll also note that multiple intros are possible." ]--- >--- >--- > -- API specification--- > type TestApi =--- >        -- GET /hello/:name?capital={true, false}  returns a Greet as JSON or PlainText--- >        "hello" :> MatrixParam "lang" String :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet--- >--- >        -- POST /greet with a Greet as JSON in the request body,--- >        --             returns a Greet as JSON--- >   :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet--- >--- >        -- DELETE /greet/:greetid--- >   :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] ()--- >--- > testApi :: Proxy TestApi--- > testApi = Proxy--- >--- > -- Build some extra information for the DELETE /greet/:greetid endpoint. We--- > -- want to add documentation about a secret unicorn header and some extra--- > -- notes.--- > extra :: ExtraInfo TestApi--- > extra =--- >     extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] ())) $--- >              defAction & headers <>~ ["unicorns"]--- >                        & notes   <>~ [ DocNote "Title" ["This is some text"]--- >                                      , DocNote "Second secton" ["And some more"]--- >                                      ]--- >--- > -- Generate the data that lets us have API docs. This--- > -- is derived from the type as well as from--- > -- the 'ToCapture', 'ToParam' and 'ToSample' instances from above.--- > ----- > -- If you didn't want intros and extra information, you could just call:--- > ----- > -- > docs testAPI :: API--- > docsGreet :: API--- > docsGreet = docsWith [intro1, intro2] extra testApi--- >--- > main :: IO ()--- > main = putStrLn $ markdown docsGreet+-- See example/greet.hs for an example. module Servant.Docs   ( -- * 'HasDocs' class and key functions-    HasDocs(..), docs, markdown+    HasDocs(..), docs, pretty, markdown+    -- ** Customising generated documentation+  , markdownWith, RenderingOptions(..), defRenderingOptions+  , requestExamples, responseExamples, ShowContentTypes(..), notesHeading     -- * Generating docs with extra information-  , ExtraInfo(..), docsWith, docsWithIntros, extraInfo+  , docsWith, docsWithIntros, docsWithOptions+  , ExtraInfo(..), extraInfo+  , DocOptions(..) , defaultDocOptions, maxSamples    , -- * Classes you need to implement for your types     ToSample(..)+  , toSample+  , noSamples+  , singleSample+  , samples   , sampleByteString   , sampleByteStrings   , ToParam(..)   , ToCapture(..)    , -- * ADTs to represent an 'API'-    Method(..)-  , Endpoint, path, method, defEndpoint+    Endpoint, path, method, defEndpoint   , API, apiIntros, apiEndpoints, emptyAPI+  , DocAuthentication(..), authIntro, authDataRequired   , DocCapture(..), capSymbol, capDesc   , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind   , DocNote(..), noteTitle, noteBody   , DocIntro(..), introTitle, introBody   , Response(..), respStatus, respTypes, respBody, defResponse-  , Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction+  , Action, authInfo, captures, headers, notes, params, rqtypes, rqbody, response, defAction   , single   ) where -import Servant.Docs.Internal+import           Servant.Docs.Internal+import           Servant.Docs.Internal.Pretty

@@ -1,904 +1,1196 @@ {-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE DeriveGeneric          #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE PolyKinds              #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TemplateHaskell        #-}-{-# LANGUAGE TupleSections          #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-}-#if !MIN_VERSION_base(4,8,0)-{-# LANGUAGE OverlappingInstances   #-}-#endif-module Servant.Docs.Internal where--#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif-import           Control.Lens               (makeLenses, over, traversed, (%~),-                                             (&), (.~), (<>~), (^.), _1, _2,-                                             _last, (|>))-import           Data.ByteString.Conversion (ToByteString, toByteString)-import           Data.ByteString.Lazy.Char8 (ByteString)-import qualified Data.CaseInsensitive       as CI-import           Data.Hashable              (Hashable)-import           Data.HashMap.Strict        (HashMap)-import           Data.List-import           Data.Maybe-import           Data.Monoid-import           Data.Ord                   (comparing)-import           Data.Proxy                 (Proxy(Proxy))-import           Data.String.Conversions    (cs)-import           Data.Text                  (Text, pack, unpack)-import           GHC.Exts                   (Constraint)-import           GHC.Generics-import           GHC.TypeLits-import           Servant.API-import           Servant.API.ContentTypes-import           Servant.Utils.Links--import qualified Data.HashMap.Strict        as HM-import qualified Data.Text                  as T-import qualified Network.HTTP.Media         as M-import qualified Network.HTTP.Types         as HTTP---- | Supported HTTP request methods-data Method = DocDELETE -- ^ the DELETE method-            | DocGET    -- ^ the GET method-            | DocPOST   -- ^ the POST method-            | DocPUT    -- ^ the PUT method-  deriving (Eq, Ord, Generic)--instance Show Method where-  show DocGET = "GET"-  show DocPOST = "POST"-  show DocDELETE = "DELETE"-  show DocPUT = "PUT"--instance Hashable Method---- | An 'Endpoint' type that holds the 'path' and the 'method'.------ Gets used as the key in the 'API' hashmap. Modify 'defEndpoint'--- or any 'Endpoint' value you want using the 'path' and 'method'--- lenses to tweak.------ @--- λ> 'defEndpoint'--- GET /--- λ> 'defEndpoint' & 'path' '<>~' ["foo"]--- GET /foo--- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'--- POST /foo--- @-data Endpoint = Endpoint-  { _path   :: [String] -- type collected-  , _method :: Method   -- type collected-  } deriving (Eq, Ord, Generic)--instance Show Endpoint where-  show (Endpoint p m) =-    show m ++ " " ++ showPath p---- |--- Render a path as a '/'-delimited string----showPath :: [String] -> String-showPath [] = "/"-showPath ps = concatMap ('/' :) ps---- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET'------ Here's how you can modify it:------ @--- λ> 'defEndpoint'--- GET /--- λ> 'defEndpoint' & 'path' '<>~' ["foo"]--- GET /foo--- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'--- POST /foo--- @-defEndpoint :: Endpoint-defEndpoint = Endpoint [] DocGET--instance Hashable Endpoint---- | Our API documentation type, a product of top-level information and a good--- old hashmap from 'Endpoint' to 'Action'-data API = API-  { _apiIntros    :: [DocIntro]-  , _apiEndpoints :: HashMap Endpoint Action-  } deriving (Eq, Show)--instance Monoid API where-    API a1 b1 `mappend` API a2 b2 = API (a1 <> a2) (b1 <> b2)-    mempty = API mempty mempty---- | An empty 'API'-emptyAPI :: API-emptyAPI = mempty---- | A type to represent captures. Holds the name of the capture---   and a description.------ Write a 'ToCapture' instance for your captured types.-data DocCapture = DocCapture-  { _capSymbol :: String -- type supplied-  , _capDesc   :: String -- user supplied-  } deriving (Eq, Ord, Show)---- | A type to represent a /GET/ parameter from the Query String. Holds its name,---   the possible values (leave empty if there isn't a finite number of them),---   and a description of how it influences the output or behavior.------ Write a 'ToParam' instance for your GET parameter types-data DocQueryParam = DocQueryParam-  { _paramName   :: String   -- type supplied-  , _paramValues :: [String] -- user supplied-  , _paramDesc   :: String   -- user supplied-  , _paramKind   :: ParamKind-  } deriving (Eq, Ord, Show)---- | An introductory paragraph for your documentation. You can pass these to--- 'docsWithIntros'.-data DocIntro = DocIntro-  { _introTitle :: String   -- ^ Appears above the intro blob-  , _introBody  :: [String] -- ^ Each String is a paragraph.-  } deriving (Eq, Show)--instance Ord DocIntro where-    compare = comparing _introTitle---- | A type to represent extra notes that may be attached to an 'Action'.------ This is intended to be used when writing your own HasDocs instances to--- add extra sections to your endpoint's documentation.-data DocNote = DocNote-  { _noteTitle :: String-  , _noteBody  :: [String]-  } deriving (Eq, Ord, Show)---- | Type of extra information that a user may wish to "union" with their--- documentation.------ These are intended to be built using extraInfo.--- Multiple ExtraInfo may be combined with the monoid instance.-newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action)-instance Monoid (ExtraInfo a) where-    mempty = ExtraInfo mempty-    ExtraInfo a `mappend` ExtraInfo b =-        ExtraInfo $ HM.unionWith combineAction a b---- | Type of GET parameter:------ - Normal corresponds to @QueryParam@, i.e your usual GET parameter--- - List corresponds to @QueryParams@, i.e GET parameters with multiple values--- - Flag corresponds to @QueryFlag@, i.e a value-less GET parameter-data ParamKind = Normal | List | Flag-  deriving (Eq, Ord, Show)---- | A type to represent an HTTP response. Has an 'Int' status, a list of--- possible 'MediaType's, and a list of example 'ByteString' response bodies.--- Tweak 'defResponse' using the 'respStatus', 'respTypes' and 'respBody'--- lenses if you want.------ If you want to respond with a non-empty response body, you'll most likely--- want to write a 'ToSample' instance for the type that'll be represented--- as encoded data in the response.------ Can be tweaked with three lenses.------ > λ> defResponse--- > Response {_respStatus = 200, _respTypes = [], _respBody = []}--- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]--- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}-data Response = Response-  { _respStatus  :: Int-  , _respTypes   :: [M.MediaType]-  , _respBody    :: [(Text, M.MediaType, ByteString)]-  , _respHeaders :: [HTTP.Header]-  } deriving (Eq, Ord, Show)---- | Default response: status code 200, no response body.------ Can be tweaked with two lenses.------ > λ> defResponse--- > Response {_respStatus = 200, _respBody = Nothing}--- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"--- > Response {_respStatus = 204, _respBody = Just "[]"}-defResponse :: Response-defResponse = Response-  { _respStatus  = 200-  , _respTypes   = []-  , _respBody    = []-  , _respHeaders = []-  }---- | A datatype that represents everything that can happen--- at an endpoint, with its lenses:------ - List of captures ('captures')--- - List of GET parameters ('params')--- - What the request body should look like, if any is requested ('rqbody')--- - What the response should be if everything goes well ('response')------ You can tweak an 'Action' (like the default 'defAction') with these lenses--- to transform an action and add some information to it.-data Action = Action-  { _captures :: [DocCapture]                -- type collected + user supplied info-  , _headers  :: [Text]                      -- type collected-  , _params   :: [DocQueryParam]             -- type collected + user supplied info-  , _notes    :: [DocNote]                   -- user supplied-  , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info-  , _rqtypes  :: [M.MediaType]               -- type collected-  , _rqbody   :: [(M.MediaType, ByteString)] -- user supplied-  , _response :: Response                    -- user supplied-  } deriving (Eq, Ord, Show)---- | Combine two Actions, we can't make a monoid as merging Response breaks the--- 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 :: Action -> Action -> Action-Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =-        Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp---- Default 'Action'. Has no 'captures', no GET 'params', expects--- no request body ('rqbody') and the typical response is 'defResponse'.------ Tweakable with lenses.------ > λ> defAction--- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}--- > λ> defAction & response.respStatus .~ 201--- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}-defAction :: Action-defAction =-  Action []-         []-         []-         []-         []-         []-         []-         defResponse---- | Create an API that's comprised of a single endpoint.---   'API' is a 'Monoid', so combine multiple endpoints with---   'mappend' or '<>'.-single :: Endpoint -> Action -> API-single e a = API mempty (HM.singleton e a)---- gimme some lenses-makeLenses ''API-makeLenses ''Endpoint-makeLenses ''DocCapture-makeLenses ''DocQueryParam-makeLenses ''DocIntro-makeLenses ''DocNote-makeLenses ''Response-makeLenses ''Action---- | Generate the docs for a given API that implements 'HasDocs'. This is the--- default way to create documentation.-docs :: HasDocs layout => Proxy layout -> API-docs p = docsFor p (defEndpoint, defAction)---- | Closed type family, check if endpoint is exactly within API.---- We aren't sure what affects how an Endpoint is built up, so we require an--- exact match.-type family IsIn (endpoint :: *) (api :: *) :: Constraint where-    IsIn e (sa :<|> sb)                = Or (IsIn e sa) (IsIn e sb)-    IsIn (e :> sa) (e :> sb)           = IsIn sa sb-    IsIn e e                           = ()---- | Create an 'ExtraInfo' that is garunteed to be within the given API layout.------ The safety here is to ensure that you only add custom documentation to an--- endpoint that actually exists within your API.------ > extra :: ExtraInfo TestApi--- > extra =--- >     extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $--- >              defAction & headers <>~ ["unicorns"]--- >                        & notes   <>~ [ DocNote "Title" ["This is some text"]--- >                                      , DocNote "Second secton" ["And some more"]--- >                                      ]--extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)-          => Proxy endpoint -> Action -> ExtraInfo layout-extraInfo p action =-    let api = docsFor p (defEndpoint, defAction)-    -- Assume one endpoint, HasLink constraint means that we should only ever-    -- point at one endpoint.-    in ExtraInfo $ api ^. apiEndpoints & traversed .~ action---- | Generate documentation given some extra introductions (in the form of--- 'DocInfo') and some extra endpoint documentation (in the form of--- 'ExtraInfo'.------ The extra introductions will be prepended to the top of the documentation,--- before the specific endpoint documentation. The extra endpoint documentation--- will be "unioned" with the automatically generated endpoint documentation.------ You are expected to build up the ExtraInfo with the Monoid instance and--- 'extraInfo'.------ If you only want to add an introduction, use 'docsWithIntros'.-docsWith :: HasDocs layout => [DocIntro] -> ExtraInfo layout -> Proxy layout -> API-docsWith intros (ExtraInfo endpoints) p =-    docs p & apiIntros <>~ intros-           & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints----- | Generate the docs for a given API that implements 'HasDocs' with with any--- number of introduction(s)-docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API-docsWithIntros intros = docsWith intros mempty---- | The class that abstracts away the impact of API combinators---   on documentation generation.-class HasDocs layout where-  docsFor :: Proxy layout -> (Endpoint, Action) -> API---- | The class that lets us display a sample input or output in the supported--- content-types when generating documentation for endpoints that either:------ - expect a request body, or--- - return a non empty response body------ Example of an instance:------ > {-# LANGUAGE DeriveGeneric #-}--- > {-# LANGUAGE OverloadedStrings #-}--- >--- > import Data.Aeson--- > import Data.Text--- > import GHC.Generics--- >--- > data Greet = Greet { _msg :: Text }--- >   deriving (Generic, Show)--- >--- > instance FromJSON Greet--- > instance ToJSON Greet--- >--- > instance ToSample Greet Greet where--- >   toSample _ = Just g--- >--- >     where g = Greet "Hello, haskeller!"------ You can also instantiate this class using 'toSamples' instead of--- 'toSample': it lets you specify different responses along with--- some context (as 'Text') that explains when you're supposed to--- get the corresponding response.-class ToSample a b | a -> b where-  {-# MINIMAL (toSample | toSamples) #-}-  toSample :: Proxy a -> Maybe b-  toSample _ = snd <$> listToMaybe samples-    where samples = toSamples (Proxy :: Proxy a)--  toSamples :: Proxy a -> [(Text, b)]-  toSamples _ = maybe [] (return . ("",)) s-    where s = toSample (Proxy :: Proxy a)--instance ToSample a b => ToSample (Headers ls a) b where-  toSample _  = toSample (Proxy :: Proxy a)-  toSamples _ = toSamples (Proxy :: Proxy a)---class AllHeaderSamples ls where-    allHeaderToSample :: Proxy ls -> [HTTP.Header]--instance AllHeaderSamples '[] where-    allHeaderToSample _  = []--instance (ToByteString l, AllHeaderSamples ls, ToSample l l, KnownSymbol h)-    => AllHeaderSamples (Header h l ': ls) where-    allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) :-                          allHeaderToSample (Proxy :: Proxy ls)-      where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)-            mkHeader (Just x) = (headerName, cs $ toByteString x)-            mkHeader Nothing  = (headerName, "<no header sample provided>")---- | Synthesise a sample value of a type, encoded in the specified media types.-sampleByteString-    :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)-    => Proxy ctypes-    -> Proxy a-    -> [(M.MediaType, ByteString)]-sampleByteString ctypes@Proxy Proxy =-    maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a)---- | Synthesise a list of sample values of a particular type, encoded in the--- specified media types.-sampleByteStrings-    :: forall ctypes a b. (ToSample a b, IsNonEmpty ctypes, AllMimeRender ctypes b)-    => Proxy ctypes-    -> Proxy a-    -> [(Text, M.MediaType, ByteString)]-sampleByteStrings ctypes@Proxy Proxy =-    let samples = toSamples (Proxy :: Proxy a)-        enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s-    in concatMap enc samples---- | Generate a list of 'MediaType' values describing the content types--- accepted by an API component.-class SupportedTypes (list :: [*]) where-    supportedTypes :: Proxy list -> [M.MediaType]--instance SupportedTypes '[] where-    supportedTypes Proxy = []--instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest)-  where-    supportedTypes Proxy =-        contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest)---- | The class that helps us automatically get documentation---   for GET parameters.------ Example of an instance:------ > instance ToParam (QueryParam "capital" Bool) where--- >   toParam _ =--- >     DocQueryParam "capital"--- >                   ["true", "false"]--- >                   "Get the greeting message in uppercase (true) or not (false). Default is false."-class ToParam t where-  toParam :: Proxy t -> DocQueryParam---- | The class that helps us automatically get documentation---   for URL captures.------ Example of an instance:------ > instance ToCapture (Capture "name" Text) where--- >   toCapture _ = DocCapture "name" "name of the person to greet"-class ToCapture c where-  toCapture :: Proxy c -> DocCapture---- | Generate documentation in Markdown format for---   the given 'API'.-markdown :: API -> String-markdown api = unlines $-       introsStr (api ^. apiIntros)-    ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)--  where printEndpoint :: Endpoint -> Action -> [String]-        printEndpoint endpoint action =-          str :-          "" :-          notesStr (action ^. notes) ++-          capturesStr (action ^. captures) ++-          mxParamsStr (action ^. mxParams) ++-          headersStr (action ^. headers) ++-          paramsStr (action ^. params) ++-          rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++-          responseStr (action ^. response) ++-          []--          where str = "## " ++ show (endpoint^.method)-                    ++ " " ++ showPath (endpoint^.path)--        introsStr :: [DocIntro] -> [String]-        introsStr = concatMap introStr--        introStr :: DocIntro -> [String]-        introStr i =-            ("## " ++ i ^. introTitle) :-            "" :-            intersperse "" (i ^. introBody) ++-            "" :-            []--        notesStr :: [DocNote] -> [String]-        notesStr = concatMap noteStr--        noteStr :: DocNote -> [String]-        noteStr nt =-            ("#### " ++ nt ^. noteTitle) :-            "" :-            intersperse "" (nt ^. noteBody) ++-            "" :-            []--        capturesStr :: [DocCapture] -> [String]-        capturesStr [] = []-        capturesStr l =-          "#### Captures:" :-          "" :-          map captureStr l ++-          "" :-          []--        captureStr cap =-          "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)--        mxParamsStr :: [(String, [DocQueryParam])] -> [String]-        mxParamsStr [] = []-        mxParamsStr l =-          "#### Matrix Parameters:" :-          "" :-          map segmentStr l-        segmentStr :: (String, [DocQueryParam]) -> String-        segmentStr (segment, l) = unlines $-          ("**" ++ segment ++ "**:") :-          "" :-          map paramStr l ++-          "" :-          []--        headersStr :: [Text] -> [String]-        headersStr [] = []-        headersStr l = [""] ++ map headerStr l ++ [""]--          where headerStr hname = "- This endpoint is sensitive to the value of the **"-                               ++ unpack hname ++ "** HTTP header."--        paramsStr :: [DocQueryParam] -> [String]-        paramsStr [] = []-        paramsStr l =-          "#### GET Parameters:" :-          "" :-          map paramStr l ++-          "" :-          []--        paramStr param = unlines $-          ("- " ++ param ^. paramName) :-          (if (not (null values) || param ^. paramKind /= Flag)-            then ["     - **Values**: *" ++ intercalate ", " values ++ "*"]-            else []) ++-          ("     - **Description**: " ++ param ^. paramDesc) :-          (if (param ^. paramKind == List)-            then ["     - This parameter is a **list**. All GET parameters with the name "-                  ++ param ^. paramName ++ "[] will forward their values in a list to the handler."]-            else []) ++-          (if (param ^. paramKind == Flag)-            then ["     - This parameter is a **flag**. This means no value is expected to be associated to this parameter."]-            else []) ++-          []--          where values = param ^. paramValues--        rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String]-        rqbodyStr [] [] = []-        rqbodyStr types samples =-            ["#### Request:", ""]-            <> formatTypes types-            <> concatMap formatBody samples--        formatTypes [] = []-        formatTypes ts = ["- Supported content types are:", ""]-            <> map (\t -> "    - `" <> show t <> "`") ts-            <> [""]--        formatBody (m, b) =-          "- Example: `" <> cs (show m) <> "`" :-          contentStr m b--        markdownForType mime_type =-            case (M.mainType mime_type, M.subType mime_type) of-                ("text", "html") -> "html"-                ("application", "xml") -> "xml"-                ("application", "json") -> "javascript"-                ("application", "javascript") -> "javascript"-                ("text", "css") -> "css"-                (_, _) -> ""--        contentStr mime_type body =-          "" :-          "```" <> markdownForType mime_type :-          cs body :-          "```" :-          "" :-          []--        responseStr :: Response -> [String]-        responseStr resp =-          "#### Response:" :-          "" :-          ("- Status code " ++ show (resp ^. respStatus)) :-          ("- Headers: " ++ show (resp ^. respHeaders)) :-          "" :-          formatTypes (resp ^. respTypes) ++-          bodies--          where bodies = case resp ^. respBody of-                  []        -> ["- No response body\n"]-                  [("", t, r)] -> "- Response body as below." : contentStr t r-                  xs        ->-                    concatMap (\(ctx, t, r) -> ("- " <> T.unpack ctx) : contentStr t r) xs---- * Instances---- | The generated docs for @a ':<|>' b@ just appends the docs---   for @a@ with the docs for @b@.-instance (HasDocs layout1, HasDocs layout2)-      => HasDocs (layout1 :<|> layout2) where--  docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)--    where p1 :: Proxy layout1-          p1 = Proxy--          p2 :: Proxy layout2-          p2 = Proxy---- | @"books" :> 'Capture' "isbn" Text@ will appear as--- @/books/:isbn@ in the docs.-instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)-      => HasDocs (Capture sym a :> sublayout) where--  docsFor Proxy (endpoint, action) =-    docsFor sublayoutP (endpoint', action')--    where sublayoutP = Proxy :: Proxy sublayout-          captureP = Proxy :: Proxy (Capture sym a)--          action' = over captures (|> toCapture captureP) action-          endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint-          symP = Proxy :: Proxy sym---instance-#if MIN_VERSION_base(4,8,0)-         {-# OVERLAPPABLe #-}-#endif-        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)-    => HasDocs (Delete cts a) where-  docsFor Proxy (endpoint, action) =-    single endpoint' action'--    where endpoint' = endpoint & method .~ DocDELETE-          action' = action & response.respBody .~ sampleByteStrings t p-                           & response.respTypes .~ supportedTypes t-          t = Proxy :: Proxy cts-          p = Proxy :: Proxy a--instance-#if MIN_VERSION_base(4,8,0)-         {-# OVERLAPPING #-}-#endif-        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts-         , AllHeaderSamples ls , GetHeaders (HList ls) )-    => HasDocs (Delete cts (Headers ls a)) where-  docsFor Proxy (endpoint, action) =-    single endpoint' action'--    where hdrs = allHeaderToSample (Proxy :: Proxy ls)-          endpoint' = endpoint & method .~ DocDELETE-          action' = action & response.respBody .~ sampleByteStrings t p-                           & response.respTypes .~ supportedTypes t-                           & response.respHeaders .~ hdrs-          t = Proxy :: Proxy cts-          p = Proxy :: Proxy a--instance-#if MIN_VERSION_base(4,8,0)-         {-# OVERLAPPABLe #-}-#endif-        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)-    => HasDocs (Get cts a) where-  docsFor Proxy (endpoint, action) =-    single endpoint' action'--    where endpoint' = endpoint & method .~ DocGET-          action' = action & response.respBody .~ sampleByteStrings t p-                           & response.respTypes .~ supportedTypes t-          t = Proxy :: Proxy cts-          p = Proxy :: Proxy a--instance-#if MIN_VERSION_base(4,8,0)-         {-# OVERLAPPING #-}-#endif-        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts-         , AllHeaderSamples ls , GetHeaders (HList ls) )-    => HasDocs (Get cts (Headers ls a)) where-  docsFor Proxy (endpoint, action) =-    single endpoint' action'--    where hdrs = allHeaderToSample (Proxy :: Proxy ls)-          endpoint' = endpoint & method .~ DocGET-          action' = action & response.respBody .~ sampleByteStrings t p-                           & response.respTypes .~ supportedTypes t-                           & response.respHeaders .~ hdrs-          t = Proxy :: Proxy cts-          p = Proxy :: Proxy a--instance (KnownSymbol sym, HasDocs sublayout)-      => HasDocs (Header sym a :> sublayout) where-  docsFor Proxy (endpoint, action) =-    docsFor sublayoutP (endpoint, action')--    where sublayoutP = Proxy :: Proxy sublayout-          action' = over headers (|> headername) action-          headername = pack $ symbolVal (Proxy :: Proxy sym)--instance-#if MIN_VERSION_base(4,8,0)-         {-# OVERLAPPABLE #-}-#endif-        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)-    => HasDocs (Post cts a) where-  docsFor Proxy (endpoint, action) =-    single endpoint' action'--    where endpoint' = endpoint & method .~ DocPOST-          action' = action & response.respBody .~ sampleByteStrings t p-                           & response.respTypes .~ supportedTypes t-                           & response.respStatus .~ 201-          t = Proxy :: Proxy cts-          p = Proxy :: Proxy a--instance-#if MIN_VERSION_base(4,8,0)-         {-# OVERLAPPING #-}-#endif-         (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts-         , AllHeaderSamples ls , GetHeaders (HList ls) )-    => HasDocs (Post cts (Headers ls a)) where-  docsFor Proxy (endpoint, action) =-    single endpoint' action'--    where hdrs = allHeaderToSample (Proxy :: Proxy ls)-          endpoint' = endpoint & method .~ DocPOST-          action' = action & response.respBody .~ sampleByteStrings t p-                           & response.respTypes .~ supportedTypes t-                           & response.respStatus .~ 201-                           & response.respHeaders .~ hdrs-          t = Proxy :: Proxy cts-          p = Proxy :: Proxy a--instance-#if MIN_VERSION_base(4,8,0)-         {-# OVERLAPPABLE #-}-#endif-        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)-    => HasDocs (Put cts a) where-  docsFor Proxy (endpoint, action) =-    single endpoint' action'--    where endpoint' = endpoint & method .~ DocPUT-          action' = action & response.respBody .~ sampleByteStrings t p-                           & response.respTypes .~ supportedTypes t-                           & response.respStatus .~ 200-          t = Proxy :: Proxy cts-          p = Proxy :: Proxy a--instance-#if MIN_VERSION_base(4,8,0)-         {-# OVERLAPPING #-}-#endif-        (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts-         , AllHeaderSamples ls , GetHeaders (HList ls) )-    => HasDocs (Put cts (Headers ls a)) where-  docsFor Proxy (endpoint, action) =-    single endpoint' action'--    where hdrs = allHeaderToSample (Proxy :: Proxy ls)-          endpoint' = endpoint & method .~ DocPUT-          action' = action & response.respBody .~ sampleByteStrings t p-                           & response.respTypes .~ supportedTypes t-                           & response.respStatus .~ 200-                           & response.respHeaders .~ hdrs-          t = Proxy :: Proxy cts-          p = Proxy :: Proxy a--instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)-      => HasDocs (QueryParam sym a :> sublayout) where--  docsFor Proxy (endpoint, action) =-    docsFor sublayoutP (endpoint, action')--    where sublayoutP = Proxy :: Proxy sublayout-          paramP = Proxy :: Proxy (QueryParam sym a)-          action' = over params (|> toParam paramP) action--instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout)-      => HasDocs (QueryParams sym a :> sublayout) where--  docsFor Proxy (endpoint, action) =-    docsFor sublayoutP (endpoint, action')--    where sublayoutP = Proxy :: Proxy sublayout-          paramP = Proxy :: Proxy (QueryParams sym a)-          action' = over params (|> toParam paramP) action---instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout)-      => HasDocs (QueryFlag sym :> sublayout) where--  docsFor Proxy (endpoint, action) =-    docsFor sublayoutP (endpoint, action')--    where sublayoutP = Proxy :: Proxy sublayout-          paramP = Proxy :: Proxy (QueryFlag sym)-          action' = over params (|> toParam paramP) action---instance (KnownSymbol sym, ToParam (MatrixParam sym a), HasDocs sublayout)-      => HasDocs (MatrixParam sym a :> sublayout) where--  docsFor Proxy (endpoint, action) =-    docsFor sublayoutP (endpoint', action')--    where sublayoutP = Proxy :: Proxy sublayout-          paramP = Proxy :: Proxy (MatrixParam sym a)-          segment = endpoint ^. (path._last)-          segment' = action ^. (mxParams._last._1)-          endpoint' = over (path._last) (\p -> p ++ ";" ++ symbolVal symP ++ "=<value>") endpoint--          action' = if segment' /= segment-                    -- This is the first matrix parameter for this segment, insert a new entry into the mxParams list-                    then over mxParams (|> (segment, [toParam paramP])) action-                    -- We've already inserted a matrix parameter for this segment, append to the existing list-                    else action & mxParams._last._2 <>~ [toParam paramP]-          symP = Proxy :: Proxy sym---instance (KnownSymbol sym, {- ToParam (MatrixParams sym a), -} HasDocs sublayout)-      => HasDocs (MatrixParams sym a :> sublayout) where--  docsFor Proxy (endpoint, action) =-    docsFor sublayoutP (endpoint', action)--    where sublayoutP = Proxy :: Proxy sublayout-          endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP ++ "=<value>"]) endpoint-          symP = Proxy :: Proxy sym---instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout)-      => HasDocs (MatrixFlag sym :> sublayout) where--  docsFor Proxy (endpoint, action) =-    docsFor sublayoutP (endpoint', action)--    where sublayoutP = Proxy :: Proxy sublayout--          endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint-          symP = Proxy :: Proxy sym--instance HasDocs Raw where-  docsFor _proxy (endpoint, action) =-    single endpoint action---- TODO: We use 'AllMimeRender' here because we need to be able to show the--- example data. However, there's no reason to believe that the instances of--- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that--- both are even defined) for any particular type.-instance (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, HasDocs sublayout-         , SupportedTypes cts)-      => HasDocs (ReqBody cts a :> sublayout) where--  docsFor Proxy (endpoint, action) =-    docsFor sublayoutP (endpoint, action')--    where sublayoutP = Proxy :: Proxy sublayout-          action' = action & rqbody .~ sampleByteString t p-                           & rqtypes .~ supportedTypes t-          t = Proxy :: Proxy cts-          p = Proxy :: Proxy a--instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where--  docsFor Proxy (endpoint, action) =-    docsFor sublayoutP (endpoint', action)--    where sublayoutP = Proxy :: Proxy sublayout-          endpoint' = endpoint & path <>~ [symbolVal pa]-          pa = Proxy :: Proxy path-+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DefaultSignatures      #-}+{-# LANGUAGE DeriveGeneric          #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RecordWildCards        #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TemplateHaskell        #-}+{-# LANGUAGE TupleSections          #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++module Servant.Docs.Internal where++import           Prelude ()+import           Prelude.Compat++import           Control.Applicative+import           Control.Arrow+                 (second)+import           Control.Lens+                 (makeLenses, mapped, each, over, set, to, toListOf, traversed, view,+                 _1, (%~), (&), (.~), (<>~), (^.), (|>))+import qualified Data.ByteString.Char8      as BSC+import           Data.ByteString.Lazy.Char8+                 (ByteString)+import qualified Data.CaseInsensitive       as CI+import           Data.Foldable+                 (fold, toList)+import           Data.Hashable+                 (Hashable)+import           Data.HashMap.Strict+                 (HashMap)+import           Data.List.Compat+                 (intercalate, intersperse, sort)+import           Data.List.NonEmpty+                 (NonEmpty ((:|)), groupWith)+import qualified Data.List.NonEmpty         as NE+import           Data.Maybe+import           Data.Monoid+                 (All (..), Any (..), Dual (..), First (..), Last (..),+                 Product (..), Sum (..))+import           Data.Ord+                 (comparing)+import           Data.Proxy+                 (Proxy (Proxy))+import           Data.String.Conversions+                 (cs)+import           Data.Text+                 (Text, unpack)+import           GHC.Generics+                 (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,+                 (:*:)((:*:)), (:+:)(L1, R1))+import qualified GHC.Generics               as G+import           GHC.TypeLits+import           Servant.API+import           Servant.API.ContentTypes+import           Servant.API.TypeErrors+import           Servant.API.TypeLevel+import           Servant.API.Generic++import qualified Data.Universe.Helpers      as U++import qualified Data.HashMap.Strict        as HM+import qualified Data.Text                  as T+import qualified Network.HTTP.Media         as M+import qualified Network.HTTP.Types         as HTTP++-- | An 'Endpoint' type that holds the 'path' and the 'method'.+--+-- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint'+-- or any 'Endpoint' value you want using the 'path' and 'method'+-- lenses to tweak.+--+-- >>> defEndpoint+-- "GET" /+--+-- >>> defEndpoint & path <>~ ["foo"]+-- "GET" /foo+--+-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost+-- "POST" /foo+--+data Endpoint = Endpoint+  { _path   :: [String]      -- type collected+  , _method :: HTTP.Method   -- type collected+  } deriving (Eq, Ord, Generic)++instance Show Endpoint where+  show (Endpoint p m) =+    show m ++ " " ++ showPath p++-- |+-- Render a path as a '/'-delimited string+--+showPath :: [String] -> String+showPath [] = "/"+showPath ps = concatMap ('/' :) ps++-- | An 'Endpoint' whose path is `"/"` and whose method is @GET@+--+-- Here's how you can modify it:+--+-- >>> defEndpoint+-- "GET" /+--+-- >>> defEndpoint & path <>~ ["foo"]+-- "GET" /foo+--+-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost+-- "POST" /foo+--+defEndpoint :: Endpoint+defEndpoint = Endpoint [] HTTP.methodGet++instance Hashable Endpoint++-- | Our API documentation type, a product of top-level information and a good+-- old hashmap from 'Endpoint' to 'Action'+data API = API+  { _apiIntros    :: [DocIntro]+  , _apiEndpoints :: HashMap Endpoint Action+  } deriving (Eq, Show)++instance Semigroup API where+    (<>) = mappend++instance Monoid API where+    API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2)+                                        (HM.unionWith combineAction b1 b2)+    mempty = API mempty mempty++-- | An empty 'API'+emptyAPI :: API+emptyAPI = mempty++-- | A type to represent captures. Holds the name of the capture+--   and a description.+--+-- Write a 'ToCapture' instance for your captured types.+data DocCapture = DocCapture+  { _capSymbol :: String -- type supplied+  , _capDesc   :: String -- user supplied+  } deriving (Eq, Ord, Show)++-- | A type to represent a /GET/ (or other possible 'HTTP.Method')+--   parameter from the Query String. Holds its name, the possible+--   values (leave empty if there isn't a finite number of them), and+--   a description of how it influences the output or behavior.+--+-- Write a 'ToParam' instance for your GET parameter types+data DocQueryParam = DocQueryParam+  { _paramName   :: String   -- type supplied+  , _paramValues :: [String] -- user supplied+  , _paramDesc   :: String   -- user supplied+  , _paramKind   :: ParamKind+  } deriving (Eq, Ord, Show)++-- | A type to represent fragment. Holds the name of the fragment and its description.+--+-- Write a 'ToFragment' instance for your fragment types.+data DocFragment = DocFragment+  { _fragSymbol :: String -- type supplied+  , _fragDesc   :: String -- user supplied+  } deriving (Eq, Ord, Show)++-- | There should be at most one 'Fragment' per API endpoint.+-- So here we are keeping the first occurrence.+combineFragment :: Maybe DocFragment -> Maybe DocFragment -> Maybe DocFragment+Nothing `combineFragment` mdocFragment = mdocFragment+Just docFragment `combineFragment` _ = Just docFragment++-- | An introductory paragraph for your documentation. You can pass these to+-- 'docsWithIntros'.+data DocIntro = DocIntro+  { _introTitle :: String   -- ^ Appears above the intro blob+  , _introBody  :: [String] -- ^ Each String is a paragraph.+  } deriving (Eq, Show)++-- | A type to represent Authentication information about an endpoint.+data DocAuthentication = DocAuthentication+  { _authIntro        :: String+  , _authDataRequired :: String+  } deriving (Eq, Ord, Show)++instance Ord DocIntro where+    compare = comparing _introTitle++-- | A type to represent extra notes that may be attached to an 'Action'.+--+-- This is intended to be used when writing your own HasDocs instances to+-- add extra sections to your endpoint's documentation.+data DocNote = DocNote+  { _noteTitle :: String+  , _noteBody  :: [String]+  } deriving (Eq, Ord, Show)++-- | Type of extra information that a user may wish to "union" with their+-- documentation.+--+-- These are intended to be built using extraInfo.+-- Multiple ExtraInfo may be combined with the monoid instance.+newtype ExtraInfo api = ExtraInfo (HashMap Endpoint Action)+instance Semigroup (ExtraInfo a) where+    (<>) = mappend+instance Monoid (ExtraInfo a) where+    mempty = ExtraInfo mempty+    ExtraInfo a `mappend` ExtraInfo b =+        ExtraInfo $ HM.unionWith combineAction a b++-- | Documentation options.+data DocOptions = DocOptions+  { _maxSamples :: Int    -- ^ Maximum samples allowed.+  } deriving (Show)++-- | Default documentation options.+defaultDocOptions :: DocOptions+defaultDocOptions = DocOptions+  { _maxSamples = 5 }++-- | Type of GET (or other 'HTTP.Method') parameter:+--+-- - Normal corresponds to @QueryParam@, i.e your usual GET parameter+-- - List corresponds to @QueryParams@, i.e GET parameters with multiple values+-- - Flag corresponds to @QueryFlag@, i.e a value-less GET parameter+data ParamKind = Normal | List | Flag+  deriving (Eq, Ord, Show)++-- | A type to represent an HTTP response. Has an 'Int' status, a list of+-- possible 'MediaType's, and a list of example 'ByteString' response bodies.+-- Tweak 'defResponse' using the 'respStatus', 'respTypes' and 'respBody'+-- lenses if you want.+--+-- If you want to respond with a non-empty response body, you'll most likely+-- want to write a 'ToSample' instance for the type that'll be represented+-- as encoded data in the response.+--+-- Can be tweaked with four lenses.+--+-- >>> defResponse+-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}+--+-- >>> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "application/json", "{ \"status\": \"ok\" }")]+-- Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well",application/json,"{ \"status\": \"ok\" }")], _respHeaders = []}+--+data Response = Response+  { _respStatus  :: Int+  , _respTypes   :: [M.MediaType]+  , _respBody    :: [(Text, M.MediaType, ByteString)]+  , _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 four lenses.+--+-- >>> defResponse+-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}+--+-- >>> defResponse & respStatus .~ 204+-- Response {_respStatus = 204, _respTypes = [], _respBody = [], _respHeaders = []}+--+defResponse :: Response+defResponse = Response+  { _respStatus  = 200+  , _respTypes   = []+  , _respBody    = []+  , _respHeaders = []+  }++-- | A datatype that represents everything that can happen+-- at an endpoint, with its lenses:+--+-- - List of captures ('captures')+-- - List of GET (or other 'HTTP.Method') parameters ('params')+-- - What the request body should look like, if any is requested ('rqbody')+-- - What the response should be if everything goes well ('response')+--+-- You can tweak an 'Action' (like the default 'defAction') with these lenses+-- to transform an action and add some information to it.+data Action = Action+  { _authInfo :: [DocAuthentication]         -- user supplied info+  , _captures :: [DocCapture]                -- type collected + user supplied info+  , _headers  :: [HTTP.Header]               -- type collected+  , _params   :: [DocQueryParam]             -- type collected + user supplied info+  , _fragment :: Maybe DocFragment           -- type collected + user supplied info+  , _notes    :: [DocNote]                   -- user supplied+  , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info+  , _rqtypes  :: [M.MediaType]               -- type collected+  , _rqbody   :: [(Text, M.MediaType, ByteString)] -- user supplied+  , _response :: Response                    -- user supplied+  } deriving (Eq, Ord, Show)++-- | Combine two Actions, we can't make a monoid as merging Response breaks the+-- laws.+--+-- As such, we invent a non-commutative, left associative operation+-- 'combineAction' to mush two together taking the response from the very left.+combineAction :: Action -> Action -> Action+Action a c h p f n m ts body resp+  `combineAction` Action a' c' h' p' f' n' m' ts' body' resp' =+        Action (a <> a') (c <> c') (h <> h') (p <> p') (f `combineFragment` f') (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'.+--+-- Tweakable with lenses.+--+-- >>> defAction+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}+--+-- >>> defAction & response.respStatus .~ 201+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}+--+defAction :: Action+defAction =+  Action []+         []+         []+         []+         Nothing+         []+         []+         []+         []+         defResponse++-- | Create an API that's comprised of a single endpoint.+--   'API' is a 'Monoid', so combine multiple endpoints with+--   'mappend' or '<>'.+single :: Endpoint -> Action -> API+single e a = API mempty (HM.singleton e a)++-- | How many content-types for each example should be shown?+--+--   @since 0.11.1+data ShowContentTypes = AllContentTypes  -- ^ For each example, show each content type.+                      | FirstContentType -- ^ For each example, show only one content type.+  deriving (Eq, Ord, Show, Read, Bounded, Enum)++-- | Customise how an 'API' is converted into documentation.+--+--   @since 0.11.1+data RenderingOptions = RenderingOptions+  { _requestExamples    :: !ShowContentTypes+    -- ^ How many content types to display for request body examples?+  , _responseExamples   :: !ShowContentTypes+    -- ^ How many content types to display for response body examples?+  , _notesHeading       :: !(Maybe String)+    -- ^ Optionally group all 'notes' together under a common heading.+  , _renderCurlBasePath :: !(Maybe String)+    -- ^ Optionally render example curl requests under a common base path (e.g. `http://localhost:80`).+  } deriving (Show)++-- | Default API generation options.+--+--   All content types are shown for both 'requestExamples' and+--   'responseExamples'; 'notesHeading' is set to 'Nothing'+--   (i.e. un-grouped).+--+--   @since 0.11.1+defRenderingOptions :: RenderingOptions+defRenderingOptions = RenderingOptions+  { _requestExamples    = AllContentTypes+  , _responseExamples   = AllContentTypes+  , _notesHeading       = Nothing+  , _renderCurlBasePath = Nothing+  }++-- gimme some lenses+makeLenses ''DocAuthentication+makeLenses ''DocOptions+makeLenses ''API+makeLenses ''Endpoint+makeLenses ''DocCapture+makeLenses ''DocQueryParam+makeLenses ''DocFragment+makeLenses ''DocIntro+makeLenses ''DocNote+makeLenses ''Response+makeLenses ''Action+makeLenses ''RenderingOptions++-- | Generate the docs for a given API that implements 'HasDocs'. This is the+-- default way to create documentation.+--+-- > docs == docsWithOptions defaultDocOptions+--+docs :: HasDocs api => Proxy api -> API+docs p = docsWithOptions p defaultDocOptions++-- | Generate the docs for a given API that implements 'HasDocs'.+docsWithOptions :: HasDocs api => Proxy api -> DocOptions -> API+docsWithOptions p = docsFor p (defEndpoint, defAction)++-- | Create an 'ExtraInfo' that is guaranteed to be within the given API layout.+--+-- The safety here is to ensure that you only add custom documentation to an+-- endpoint that actually exists within your API.+--+-- > extra :: ExtraInfo TestApi+-- > extra =+-- >     extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $+-- >              defAction & headers <>~ [("X-Num-Unicorns", 1)]+-- >                        & notes   <>~ [ DocNote "Title" ["This is some text"]+-- >                                      , DocNote "Second section" ["And some more"]+-- >                                      ]++extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)+          => Proxy endpoint -> Action -> ExtraInfo api+extraInfo p action =+    let api = docsFor p (defEndpoint, defAction) defaultDocOptions+    -- Assume one endpoint, HasLink constraint means that we should only ever+    -- point at one endpoint.+    in ExtraInfo $ api ^. apiEndpoints & traversed .~ action++-- | Generate documentation given some extra introductions (in the form of+-- 'DocInfo') and some extra endpoint documentation (in the form of+-- 'ExtraInfo'.+--+-- The extra introductions will be prepended to the top of the documentation,+-- before the specific endpoint documentation. The extra endpoint documentation+-- will be "unioned" with the automatically generated endpoint documentation.+--+-- You are expected to build up the ExtraInfo with the Monoid instance and+-- 'extraInfo'.+--+-- If you only want to add an introduction, use 'docsWithIntros'.+docsWith :: HasDocs api => DocOptions -> [DocIntro] -> ExtraInfo api -> Proxy api -> API+docsWith opts intros (ExtraInfo endpoints) p =+    docsWithOptions p opts+      & apiIntros <>~ intros+      & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints+++-- | Generate the docs for a given API that implements 'HasDocs' with any+-- number of introduction(s)+docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API+docsWithIntros intros = docsWith defaultDocOptions intros mempty++-- | The class that abstracts away the impact of API combinators+--   on documentation generation.+class HasDocs api where+  docsFor :: Proxy api -> (Endpoint, Action) -> DocOptions -> API++-- | The class that lets us display a sample input or output in the supported+-- content-types when generating documentation for endpoints that either:+--+-- - expect a request body, or+-- - return a non empty response body+--+-- Example of an instance:+--+-- > {-# LANGUAGE DeriveGeneric #-}+-- > {-# LANGUAGE OverloadedStrings #-}+-- >+-- > import Data.Aeson+-- > import Data.Text+-- > import GHC.Generics+-- >+-- > data Greet = Greet { _msg :: Text }+-- >   deriving (Generic, Show)+-- >+-- > instance FromJSON Greet+-- > instance ToJSON Greet+-- >+-- > instance ToSample Greet where+-- >   toSamples _ = singleSample g+-- >+-- >     where g = Greet "Hello, haskeller!"+--+-- You can also instantiate this class using 'toSamples' instead of+-- 'toSample': it lets you specify different responses along with+-- some context (as 'Text') that explains when you're supposed to+-- get the corresponding response.+class ToSample a where+  toSamples :: Proxy a -> [(Text, a)]+  default toSamples :: (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]+  toSamples = defaultSamples++-- | Sample input or output (if there is at least one).+toSample :: forall a. ToSample a => Proxy a -> Maybe a+toSample _ = snd <$> listToMaybe (toSamples (Proxy :: Proxy a))++-- | No samples.+noSamples :: [(Text, a)]+noSamples = empty++-- | Single sample without description.+singleSample :: a -> [(Text, a)]+singleSample x = [("", x)]++-- | Samples without documentation.+samples :: [a] -> [(Text, a)]+samples = map ("",)++-- | Default sample Generic-based inputs/outputs.+defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]+defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a))++-- | @'ToSample'@ for Generics.+--+-- Note: we use combinators from "Universe.Data.Helpers" for more productive sample generation.+class GToSample t where+  gtoSamples :: proxy t -> [(Text, t x)]++instance GToSample U1 where+  gtoSamples _ = singleSample U1++instance GToSample V1 where+  gtoSamples _ = empty++instance (GToSample p, GToSample q) => GToSample (p :*: q) where+  gtoSamples _ = U.cartesianProduct render ps qs+    where+      ps = gtoSamples (Proxy :: Proxy p)+      qs = gtoSamples (Proxy :: Proxy q)+      render (ta, a) (tb, b)+        | T.null ta || T.null tb = (ta <> tb, a :*: b)+        | otherwise              = (ta <> ", " <> tb, a :*: b)++instance (GToSample p, GToSample q) => GToSample (p :+: q) where+  gtoSamples _ = lefts U.+++ rights+    where+      lefts  = second L1 <$> gtoSamples (Proxy :: Proxy p)+      rights = second R1 <$> gtoSamples (Proxy :: Proxy q)++instance ToSample a => GToSample (K1 i a) where+  gtoSamples _ = second K1 <$> toSamples (Proxy :: Proxy a)++instance (GToSample f) => GToSample (M1 i a f) where+  gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)+++class AllHeaderSamples ls where+    allHeaderToSample :: Proxy ls -> [HTTP.Header]++instance AllHeaderSamples '[] where+    allHeaderToSample _  = []++instance (ToHttpApiData l, AllHeaderSamples ls, ToSample l, KnownSymbol h)+    => AllHeaderSamples (Header h l ': ls) where+    allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) :+                          allHeaderToSample (Proxy :: Proxy ls)+      where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)+            mkHeader (Just x) = (headerName, cs $ toHeader x)+            mkHeader Nothing  = (headerName, "<no header sample provided>")++-- | Synthesise a sample value of a type, encoded in the specified media types.+sampleByteString+    :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)+    => Proxy (ct ': cts)+    -> Proxy a+    -> [(M.MediaType, ByteString)]+sampleByteString ctypes@Proxy Proxy =+    maybe [] (allMimeRender ctypes) $ toSample (Proxy :: Proxy a)++-- | Synthesise a list of sample values of a particular type, encoded in the+-- specified media types.+sampleByteStrings+    :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)+    => Proxy (ct ': cts)+    -> Proxy a+    -> [(Text, M.MediaType, ByteString)]+sampleByteStrings ctypes@Proxy Proxy =+    let samples' = toSamples (Proxy :: Proxy a)+        enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s+    in concatMap enc samples'++-- | The class that helps us automatically get documentation for GET+--   (or other 'HTTP.Method') parameters.+--+-- Example of an instance:+--+-- > instance ToParam (QueryParam' mods "capital" Bool) where+-- >   toParam _ =+-- >     DocQueryParam "capital"+-- >                   ["true", "false"]+-- >                   "Get the greeting message in uppercase (true) or not (false). Default is false."+class ToParam t where+  toParam :: Proxy t -> DocQueryParam++-- | The class that helps us automatically get documentation+--   for URL captures.+--+-- Example of an instance:+--+-- > instance ToCapture (Capture "name" Text) where+-- >   toCapture _ = DocCapture "name" "name of the person to greet"+class ToCapture c where+  toCapture :: Proxy c -> DocCapture++-- | The class that helps us get documentation for authenticated endpoints+class ToAuthInfo a where+      toAuthInfo :: Proxy a -> DocAuthentication++-- | The class that helps us get documentation for URL fragments.+--+-- Example of an instance:+--+-- > instance ToFragment (Fragment a) where+-- >   toFragment _ = DocFragment "fragment" "fragment description"+class ToFragment t where+  toFragment :: Proxy t -> DocFragment++-- | Generate documentation in Markdown format for+--   the given 'API'.+--+--   This is equivalent to @'markdownWith' 'defRenderingOptions'@.+markdown :: API -> String+markdown = markdownWith defRenderingOptions++-- | Generate documentation in Markdown format for+--   the given 'API' using the specified options.+--+--   These options allow you to customise aspects such as:+--+--   * Choose how many content-types for each request body example are+--     shown with 'requestExamples'.+--+--   * Choose how many content-types for each response body example+--     are shown with 'responseExamples'.+--+--   For example, to only show the first content-type of each example:+--+--   @+--   markdownWith ('defRenderingOptions'+--                   & 'requestExamples'  '.~' 'FirstContentType'+--                   & 'responseExamples' '.~' 'FirstContentType' )+--                myAPI+--   @+--+--   @since 0.11.1+markdownWith :: RenderingOptions -> API -> String+markdownWith RenderingOptions{..} api = unlines $+       introsStr (api ^. apiIntros)+    ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)++  where printEndpoint :: Endpoint -> Action -> [String]+        printEndpoint endpoint action =+          str :+          "" :+          notesStr (action ^. notes) +++          authStr (action ^. authInfo) +++          capturesStr (action ^. captures) +++          headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) +++          paramsStr meth (action ^. params) +++          fragmentStr (action ^. fragment) +++          rqbodyStr (action ^. rqtypes) (action ^. rqbody) +++          responseStr (action ^. response) +++          maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath +++          []++          where str = "## " ++ BSC.unpack meth+                    ++ " " ++ showPath (endpoint^.path)++                meth = endpoint ^. method++        introsStr :: [DocIntro] -> [String]+        introsStr = concatMap introStr++        introStr :: DocIntro -> [String]+        introStr i =+            ("## " ++ i ^. introTitle) :+            "" :+            intersperse "" (i ^. introBody) +++            "" :+            []++        notesStr :: [DocNote] -> [String]+        notesStr = addHeading+                   . concatMap noteStr+          where+            addHeading nts = maybe nts (\hd -> ("### " ++ hd) : "" : nts) _notesHeading++        noteStr :: DocNote -> [String]+        noteStr nt =+            (hdr ++ nt ^. noteTitle) :+            "" :+            intersperse "" (nt ^. noteBody) +++            "" :+            []+          where+            hdr | isJust _notesHeading = "#### "+                | otherwise            = "### "++        authStr :: [DocAuthentication] -> [String]+        authStr [] = []+        authStr auths =+          let authIntros = mapped %~ view authIntro $ auths+              clientInfos = mapped %~ view authDataRequired $ auths+          in "### Authentication":+              "":+              unlines authIntros :+              "":+              "Clients must supply the following data" :+              unlines clientInfos :+              "" :+              []++        capturesStr :: [DocCapture] -> [String]+        capturesStr [] = []+        capturesStr l =+          "### Captures:" :+          "" :+          map captureStr l +++          "" :+          []++        captureStr cap =+          "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)++        headersStr :: [Text] -> [String]+        headersStr [] = []+        headersStr l =+          "### Headers:" :+          "" :+          map headerStr l +++          "" :+          []++          where headerStr hname = "- This endpoint is sensitive to the value of the **"+                               ++ unpack hname ++ "** HTTP header."++        paramsStr :: HTTP.Method -> [DocQueryParam] -> [String]+        paramsStr _ [] = []+        paramsStr m l =+          ("### " ++ cs m ++ " Parameters:") :+          "" :+          map (paramStr m) l +++          "" :+          []++        paramStr m param = unlines $+          ("- " ++ param ^. paramName) :+          (if (not (null values) || param ^. paramKind /= Flag)+            then ["     - **Values**: *" ++ intercalate ", " values ++ "*"]+            else []) +++          ("     - **Description**: " ++ param ^. paramDesc) :+          (if (param ^. paramKind == List)+            then ["     - This parameter is a **list**. All " ++ cs m ++ " parameters with the name "+                  ++ param ^. paramName ++ "[] will forward their values in a list to the handler."]+            else []) +++          (if (param ^. paramKind == Flag)+            then ["     - This parameter is a **flag**. This means no value is expected to be associated to this parameter."]+            else []) +++          []++          where values = param ^. paramValues++        fragmentStr :: Maybe DocFragment -> [String]+        fragmentStr Nothing = []+        fragmentStr (Just frag) =+          [ "### Fragment:", ""+          , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc)+          , ""+          ]++        rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]+        rqbodyStr [] [] = []+        rqbodyStr types s =+            ["### Request:", ""]+            <> formatTypes types+            <> formatBodies _requestExamples s++        formatTypes [] = []+        formatTypes ts = ["- Supported content types are:", ""]+            <> map (\t -> "    - `" <> show t <> "`") ts+            <> [""]++        -- This assumes that when the bodies are created, identical+        -- labels and representations are located next to each other.+        formatBodies :: ShowContentTypes -> [(Text, M.MediaType, ByteString)] -> [String]+        formatBodies ex bds = concatMap formatBody (select bodyGroups)+          where+            bodyGroups :: [(Text, NonEmpty M.MediaType, ByteString)]+            bodyGroups =+              map (\grps -> let (t,_,b) = NE.head grps in (t, fmap (\(_,m,_) -> m) grps, b))+              . groupWith (\(t,_,b) -> (t,b))+              $ bds++            select = case ex of+                       AllContentTypes  -> id+                       FirstContentType -> map (\(t,ms,b) -> (t, NE.head ms :| [], b))++        formatBody :: (Text, NonEmpty M.MediaType, ByteString) -> [String]+        formatBody (t, ms, b) =+          "- " <> title <> " (" <> mediaList ms <> "):" :+          contentStr (NE.head ms) b+          where+            mediaList = fold . NE.intersperse ", " . fmap (\m -> "`" ++ show m ++ "`")++            title+              | T.null t  = "Example"+              | otherwise = cs t++        markdownForType mime_type =+            case (M.mainType mime_type, M.subType mime_type) of+                ("text", "html") -> "html"+                ("application", "xml") -> "xml"+                ("text", "xml") -> "xml"+                ("application", "json") -> "json"+                ("application", "javascript") -> "javascript"+                ("text", "css") -> "css"+                (_, _) -> ""++        contentStr mime_type body =+          "" :+          "```" <> markdownForType mime_type :+          cs body :+          "```" :+          "" :+          []++        responseStr :: Response -> [String]+        responseStr resp =+          "### Response:" :+          "" :+          ("- Status code " ++ show (resp ^. respStatus)) :+          ("- Headers: " ++ show (resp ^. respHeaders)) :+          "" :+          formatTypes (resp ^. respTypes) +++          bodies++          where bodies = case resp ^. respBody of+                  []        -> ["- No response body\n"]+                  [("", t, r)] -> "- Response body as below." : contentStr t r+                  xs        ->+                    formatBodies _responseExamples xs++        curlStr :: Endpoint -> [HTTP.Header] -> [(Text, M.MediaType, ByteString)] -> String -> [String]+        curlStr endpoint hdrs reqBodies basePath =+          [  "### Sample Request:"+          , ""+          , "```bash"+          , "curl -X" ++ BSC.unpack (endpoint ^. method) ++ " \\"+          ] <>+          maybe [] pure mbMediaTypeStr <>+          headersStrs <>+          maybe [] pure mbReqBodyStr <>+          [  "  " ++ basePath ++ showPath (endpoint ^. path)+          , "```"+          , ""+          ]++          where escapeQuotes :: String -> String+                escapeQuotes = concatMap $ \c -> case c of+                  '\"' -> "\\\""+                  _ -> [c]+                mbReqBody = listToMaybe reqBodies+                mbMediaTypeStr = mkMediaTypeStr <$> mbReqBody+                headersStrs = mkHeaderStr <$> hdrs+                mbReqBodyStr = mkReqBodyStr <$> mbReqBody+                mkMediaTypeStr (_, media_type, _) =+                  "  -H \"Content-Type: " ++ show media_type ++ "\" \\"+                mkHeaderStr (hdrName, hdrVal) =+                  "  -H \"" ++ escapeQuotes (cs (CI.original hdrName)) ++ ": " +++                  escapeQuotes (cs hdrVal) ++ "\" \\"+                mkReqBodyStr (_, _, body) = "  -d \"" ++ escapeQuotes (cs body) ++ "\" \\"++-- * Instances++-- | The generated docs for @a ':<|>' b@ just appends the docs+--   for @a@ with the docs for @b@.+instance {-# OVERLAPPABLE #-}+         (HasDocs a, HasDocs b)+      => HasDocs (a :<|> b) where++  docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)++    where p1 :: Proxy a+          p1 = Proxy++          p2 :: Proxy b+          p2 = Proxy++-- | The generated docs for @'EmptyAPI'@ are empty.+instance HasDocs EmptyAPI where+  docsFor Proxy _ _ = emptyAPI++-- | @"books" :> 'Capture' "isbn" Text@ will appear as+-- @/books/:isbn@ in the docs.+instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)+      => HasDocs (Capture' '[] sym a :> api) where++  docsFor Proxy (endpoint, action) =+    docsFor subApiP (endpoint', action')++    where subApiP = Proxy :: Proxy api+          captureP = Proxy :: Proxy (Capture sym a)++          action' = over captures (|> toCapture captureP) action+          endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint+          symP = Proxy :: Proxy sym++instance (KnownSymbol descr, KnownSymbol sym, HasDocs api)+      => HasDocs (Capture' (Description descr ': mods) sym a :> api) where++  docsFor Proxy (endpoint, action) =+    docsFor subApiP (endpoint', action')++    where subApiP = Proxy :: Proxy api++          docCapture = DocCapture (symbolVal symP) (symbolVal descrP)+          action' = over captures (|> docCapture) action+          endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint+          descrP = Proxy :: Proxy descr+          symP = Proxy :: Proxy sym++instance {-# OVERLAPPABLE #-} HasDocs (Capture' mods sym a :> api)+      => HasDocs (Capture' (mod ': mods) sym a :> api) where++  docsFor Proxy =+    docsFor apiP++    where apiP = Proxy :: Proxy (Capture' mods sym a :> api)+++-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as+-- @/books/:isbn@ in the docs.+instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)+      => HasDocs (CaptureAll sym a :> sublayout) where++  docsFor Proxy (endpoint, action) =+    docsFor sublayoutP (endpoint', action')++    where sublayoutP = Proxy :: Proxy sublayout+          captureP = Proxy :: Proxy (CaptureAll sym a)++          action' = over captures (|> toCapture captureP) action+          endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint+          symP = Proxy :: Proxy sym+++instance {-# OVERLAPPABLE #-}+        (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status+        , ReflectMethod method)+    => HasDocs (Verb method status (ct ': cts) a) where+  docsFor Proxy (endpoint, action) DocOptions{..} =+    single endpoint' action'++    where endpoint' = endpoint & method .~ method'+          action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)+                           & response.respTypes .~ allMime t+                           & response.respStatus .~ status+          t = Proxy :: Proxy (ct ': cts)+          method' = reflectMethod (Proxy :: Proxy method)+          status = fromInteger $ natVal (Proxy :: Proxy status)+          p = Proxy :: Proxy a++instance (ReflectMethod method) =>+         HasDocs (NoContentVerb method) where+  docsFor Proxy (endpoint, action) DocOptions{..} =+    single endpoint' action'++    where endpoint' = endpoint & method .~ method'+          action' = action & response.respStatus .~ 204+                           & response.respTypes .~ []+                           & response.respBody .~ []+                           & response.respHeaders .~ []+          method' = reflectMethod (Proxy :: Proxy method)++-- | TODO: mention the endpoint is streaming, its framing strategy+--+-- Also there are no samples.+--+-- TODO: AcceptFraming for content-type+instance {-# OVERLAPPABLE #-}+        (Accept ct, KnownNat status, ReflectMethod method)+    => HasDocs (Stream method status framing ct a) where+  docsFor Proxy (endpoint, action) DocOptions{..} =+    single endpoint' action'++    where endpoint' = endpoint & method .~ method'+          action' = action & response.respTypes .~ allMime t+                           & response.respStatus .~ status+          t = Proxy :: Proxy '[ct]+          method' = reflectMethod (Proxy :: Proxy method)+          status = fromInteger $ natVal (Proxy :: Proxy status)++instance {-# OVERLAPPING #-}+        (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status+        , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))+    => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where+  docsFor Proxy (endpoint, action) DocOptions{..} =+    single endpoint' action'++    where endpoint' = endpoint & method .~ method'+          action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)+                           & response.respTypes .~ allMime t+                           & response.respStatus .~ status+                           & response.respHeaders .~ hdrs+          t = Proxy :: Proxy (ct ': cts)+          hdrs = allHeaderToSample (Proxy :: Proxy ls)+          method' = reflectMethod (Proxy :: Proxy method)+          status = fromInteger $ natVal (Proxy :: Proxy status)+          p = Proxy :: Proxy a++instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)+      => HasDocs (Header' mods sym a :> api) where+  docsFor Proxy (endpoint, action) =+    docsFor subApiP (endpoint, action')++    where subApiP = Proxy :: Proxy api+          action' = over headers (|> (headerName, headerVal)) action+          headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy sym)+          headerVal = case toSample (Proxy :: Proxy a) of+            Just x -> cs $ toHeader x+            Nothing -> "<no header sample provided>"++instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)+      => HasDocs (QueryParam' mods sym a :> api) where++  docsFor Proxy (endpoint, action) =+    docsFor subApiP (endpoint, action')++    where subApiP = Proxy :: Proxy api+          paramP = Proxy :: Proxy (QueryParam' mods sym a)+          action' = over params (|> toParam paramP) action++instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api)+      => HasDocs (QueryParams sym a :> api) where++  docsFor Proxy (endpoint, action) =+    docsFor subApiP (endpoint, action')++    where subApiP = Proxy :: Proxy api+          paramP = Proxy :: Proxy (QueryParams sym a)+          action' = over params (|> toParam paramP) action+++instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)+      => HasDocs (QueryFlag sym :> api) where++  docsFor Proxy (endpoint, action) =+    docsFor subApiP (endpoint, action')++    where subApiP = Proxy :: Proxy api+          paramP = Proxy :: Proxy (QueryFlag sym)+          action' = over params (|> toParam paramP) action++instance (ToFragment (Fragment a), HasDocs api)+      => HasDocs (Fragment a :> api) where++  docsFor Proxy (endpoint, action) =+    docsFor subApiP (endpoint, action')++    where subApiP = Proxy :: Proxy api+          fragmentP = Proxy :: Proxy (Fragment a)+          action' = set fragment (Just (toFragment fragmentP)) action++instance HasDocs Raw where+  docsFor _proxy (endpoint, action) _ =+    single endpoint action+++instance (KnownSymbol desc, HasDocs api)+  => HasDocs (Description desc :> api) where++  docsFor Proxy (endpoint, action) =+    docsFor subApiP (endpoint, action')++    where subApiP = Proxy :: Proxy api+          action' = over notes (|> note) action+          note = DocNote (symbolVal (Proxy :: Proxy desc)) []++instance (KnownSymbol desc, HasDocs api)+  => HasDocs (Summary desc :> api) where++  docsFor Proxy (endpoint, action) =+    docsFor subApiP (endpoint, action')++    where subApiP = Proxy :: Proxy api+          action' = over notes (|> note) action+          note = DocNote (symbolVal (Proxy :: Proxy desc)) []++-- TODO: We use 'AllMimeRender' here because we need to be able to show the+-- example data. However, there's no reason to believe that the instances of+-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that+-- both are even defined) for any particular type.+instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)+      => HasDocs (ReqBody' mods (ct ': cts) a :> api) where+  docsFor Proxy (endpoint, action) opts@DocOptions{..} =+    docsFor subApiP (endpoint, action') opts++    where subApiP = Proxy :: Proxy api+          action' :: Action+          action' = action & rqbody .~ take _maxSamples (sampleByteStrings t p)+                           & rqtypes .~ allMime t+          t = Proxy :: Proxy (ct ': cts)+          p = Proxy :: Proxy a++-- | TODO: this instance is incomplete.+instance (HasDocs api, Accept ctype) => HasDocs (StreamBody' mods framing ctype a :> api) where+    docsFor Proxy (endpoint, action) opts =+        docsFor subApiP (endpoint, action') opts+      where+        subApiP = Proxy :: Proxy api++        action' :: Action+        action' = action & rqtypes .~ toList (contentTypes t)++        t = Proxy :: Proxy ctype++instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where++  docsFor Proxy (endpoint, action) =+    docsFor subApiP (endpoint', action)++    where subApiP = Proxy :: Proxy api+          endpoint' = endpoint & path <>~ [symbolVal pa]+          pa = Proxy :: Proxy path++instance HasDocs api => HasDocs (RemoteHost :> api) where+  docsFor Proxy ep =+    docsFor (Proxy :: Proxy api) ep++instance HasDocs api => HasDocs (IsSecure :> api) where+  docsFor Proxy ep =+    docsFor (Proxy :: Proxy api) ep++instance HasDocs api => HasDocs (HttpVersion :> api) where+  docsFor Proxy ep =+    docsFor (Proxy :: Proxy api) ep++instance HasDocs api => HasDocs (Vault :> api) where+  docsFor Proxy ep =+    docsFor (Proxy :: Proxy api) ep++instance HasDocs api => HasDocs (WithNamedContext name context api) where+  docsFor Proxy = docsFor (Proxy :: Proxy api)++instance HasDocs api => HasDocs (WithResource res :> api) where+  docsFor Proxy = docsFor (Proxy :: Proxy api)++instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where+  docsFor Proxy (endpoint, action) =+    docsFor (Proxy :: Proxy api) (endpoint, action')+      where+        authProxy = Proxy :: Proxy (BasicAuth realm usr)+        action' = over authInfo (|> toAuthInfo authProxy) action++instance+  ( HasDocs (ToServantApi api)+  , ErrorIfNoGeneric api+  ) => HasDocs (NamedRoutes api) where+  docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))++-- ToSample instances for simple types+instance ToSample NoContent+instance ToSample Bool+instance ToSample Ordering++-- polymorphic ToSample instances+instance (ToSample a, ToSample b) => ToSample (a, b)+instance (ToSample a, ToSample b, ToSample c) => ToSample (a, b, c)+instance (ToSample a, ToSample b, ToSample c, ToSample d) => ToSample (a, b, c, d)+instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e) => ToSample (a, b, c, d, e)+instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f) => ToSample (a, b, c, d, e, f)+instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f, ToSample g) => ToSample (a, b, c, d, e, f, g)++instance ToSample a => ToSample (Maybe a)+instance (ToSample a, ToSample b) => ToSample (Either a b)+instance ToSample a => ToSample [a]+instance ToSample a => ToSample (NonEmpty a)++-- ToSample instances for Control.Applicative types+instance ToSample a => ToSample (Const a b)+instance ToSample a => ToSample (ZipList a)++-- ToSample instances for Data.Monoid newtypes+instance ToSample All+instance ToSample Any+instance ToSample a => ToSample (Sum a)+instance ToSample a => ToSample (Product a)+instance ToSample a => ToSample (First a)+instance ToSample a => ToSample (Last a)+instance ToSample a => ToSample (Dual a)++-- $setup+-- >>> :set -XOverloadedStrings

@@ -0,0 +1,71 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++module Servant.Docs.Internal.Pretty where++import           Data.Aeson+                 (ToJSON (..))+import           Data.Aeson.Encode.Pretty+                 (encodePretty)+import           Data.Proxy+                 (Proxy (Proxy))+import           Network.HTTP.Media+                 ((//))+import           Servant.API+import           Servant.API.Verbs++-- | PrettyJSON content type.+data PrettyJSON++instance Accept PrettyJSON where+    contentType _ = "application" // "json"++instance ToJSON a => MimeRender PrettyJSON a where+    mimeRender _ = encodePretty++-- | Prettify generated JSON documentation.+--+-- @+-- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI))+-- @+pretty :: Proxy api -> Proxy (Pretty api)+pretty Proxy = Proxy++-- | Replace all JSON content types with PrettyJSON.+-- Kind-polymorphic so it can operate on kinds @*@ and @[*]@.+type family Pretty (api :: k) :: k where+    Pretty (x :<|> y)     = Pretty x :<|> Pretty y+    Pretty (x :> y)       = Pretty x :> Pretty y+    Pretty (Get cs r)     = Get     (Pretty cs) r+    Pretty (Post cs r)    = Post    (Pretty cs) r+    Pretty (Put cs r)     = Put     (Pretty cs) r+    Pretty (Delete cs r)  = Delete  (Pretty cs) r+    Pretty (Patch cs r)   = Patch   (Pretty cs) r+    Pretty (GetPartialContent cs r)      = GetPartialContent      (Pretty cs) r+    Pretty (PutResetContent cs r)        = PutResetContent        (Pretty cs) r+    Pretty (PatchResetContent cs r)      = PatchResetContent      (Pretty cs) r+    Pretty (DeleteResetContent cs r)     = DeleteResetContent     (Pretty cs) r+    Pretty (PostResetContent cs r)       = PostResetContent       (Pretty cs) r+    Pretty (GetResetContent cs r)        = GetResetContent        (Pretty cs) r+    Pretty (PutNonAuthoritative cs r)    = PutNonAuthoritative    (Pretty cs) r+    Pretty (PatchNonAuthoritative cs r)  = PatchNonAuthoritative  (Pretty cs) r+    Pretty (DeleteNonAuthoritative cs r) = DeleteNonAuthoritative (Pretty cs) r+    Pretty (PostNonAuthoritative cs r)   = PostNonAuthoritative   (Pretty cs) r+    Pretty (GetNonAuthoritative cs r)    = GetNonAuthoritative    (Pretty cs) r+    Pretty (PutAccepted cs r)            = PutAccepted            (Pretty cs) r+    Pretty (PatchAccepted cs r)          = PatchAccepted          (Pretty cs) r+    Pretty (DeleteAccepted cs r)         = DeleteAccepted         (Pretty cs) r+    Pretty (PostAccepted cs r)           = PostAccepted           (Pretty cs) r+    Pretty (GetAccepted cs r)            = GetAccepted            (Pretty cs) r+    Pretty (PutCreated cs r)             = PutCreated             (Pretty cs) r+    Pretty (PostCreated cs r)            = PostCreated            (Pretty cs) r+    Pretty (ReqBody cs r) = ReqBody (Pretty cs) r+    Pretty (JSON ': xs)   = PrettyJSON ': xs+    Pretty (x ': xs)      = x ': Pretty xs+    Pretty x              = x

@@ -0,0 +1,220 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# OPTIONS_GHC -fno-warn-orphans  #-}+{-# OPTIONS_GHC -freduction-depth=100 #-}++module Servant.DocsSpec where++import           Control.Lens+                 ((&), (<>~))+import           Control.Monad+                 (unless)+import           Control.Monad.Trans.Writer+                 (Writer, runWriter, tell)+import           Data.Aeson+import           Data.List+                 (isInfixOf)+import           Data.Proxy+import           Data.String.Conversions+                 (cs)+import           GHC.Generics+import           Prelude ()+import           Prelude.Compat+import           Test.Tasty+                 (TestName, TestTree, testGroup)+import           Test.Tasty.Golden+                 (goldenVsString)+import           Test.Tasty.HUnit+                 (Assertion, HasCallStack, assertFailure, testCase, (@?=))++import           Servant.API+import           Servant.Docs.Internal+import           Servant.Test.ComprehensiveAPI++-- * comprehensive api++-- This declaration simply checks that all instances are in place.+comprehensiveDocs :: API+comprehensiveDocs = docs comprehensiveAPI++instance ToParam (QueryParam' mods "foo" Int) where+  toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" Normal+instance ToParam (QueryParam' mods "bar" Int) where+  toParam _ = DocQueryParam "bar" ["1","2","3"] "QueryParams Int" Normal+instance ToParam (QueryParams "foo" Int) where+  toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" List+instance ToParam (QueryFlag "foo") where+  toParam _ = DocQueryParam "foo" [] "QueryFlag" Flag+instance ToCapture (Capture "foo" Int) where+  toCapture _ = DocCapture "foo" "Capture foo Int"+instance ToCapture (CaptureAll "foo" Int) where+  toCapture _ = DocCapture "foo" "Capture all foo Int"+instance ToFragment (Fragment Int) where+  toFragment _ = DocFragment "foo" "Fragment Int"++-- * specs++spec :: TestTree+spec = describe "Servant.Docs" $ do+  golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)++  describe "markdown" $ do+    let md1 = markdown (docs (Proxy :: Proxy TestApi1))+    tests1 md1+    let md2 = markdown (docs (Proxy :: Proxy TestApi2))+    tests2 md2++  describe "markdown with extra info" $ do+    let+      extra = extraInfo+              (Proxy :: Proxy (Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)))+              (defAction & notes <>~ [DocNote "Get an Integer" ["get an integer in Json or plain text"]])+              <>+              extraInfo+              (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))+              (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])+      md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))+    tests1 md+    it "contains the extra info provided" $ do+      md `shouldContain` "Get an Integer"+      md `shouldContain` "Post data"+      md `shouldContain` "get an integer in Json or plain text"+      md `shouldContain` "Posts some Json data"++  describe "tuple samples" $ do+    it "looks like expected" $ do+      (toSample  (Proxy :: Proxy (TT, UT)))     `shouldBe` Just (TT1,UT1)+      (toSample  (Proxy :: Proxy (TT, UT, UT))) `shouldBe` Just (TT1,UT1,UT1)+      (toSamples (Proxy :: Proxy (TT, UT)))     `shouldBe`+         [ ("eins, yks",(TT1,UT1)), ("eins, kaks",(TT1,UT2))+         , ("zwei, yks",(TT2,UT1)), ("zwei, kaks",(TT2,UT2))+         ]+      (toSamples (Proxy :: Proxy (TT, UT, UT))) `shouldBe`+         [ ("eins, yks, yks",(TT1,UT1,UT1))+         , ("eins, yks, kaks",(TT1,UT1,UT2))+         , ("zwei, yks, yks",(TT2,UT1,UT1))+         , ("eins, kaks, yks",(TT1,UT2,UT1))+         , ("zwei, yks, kaks",(TT2,UT1,UT2))+         , ("eins, kaks, kaks",(TT1,UT2,UT2))+         , ("zwei, kaks, yks",(TT2,UT2,UT1))+         , ("zwei, kaks, kaks",(TT2,UT2,UT2))+         ]+++ where+   tests1 md = do+    it "mentions supported content-types" $ do+      md `shouldContain` "application/json"+      md `shouldContain` "text/plain;charset=utf-8"++    it "mentions status codes" $ do+      md `shouldContain` "Status code 200"++    it "has methods as section headers" $ do+      md `shouldContain` "## POST"+      md `shouldContain` "## GET"++    it "mentions headers" $ do+      md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."++    it "contains response samples - dt1field1" $+      md `shouldContain` "\"dt1field1\":\"field 1\""+    it "contains response samples - dt1field2" $+      md `shouldContain` "\"dt1field2\":13"+    it "contains request body samples" $+      md `shouldContain` "17"++    it "does not generate any docs mentioning the 'empty-api' path" $+      md `shouldNotContain` "empty-api"++   tests2 md = do+    it "mentions the content-types from both copies of the route" $ do+      md `shouldContain` "application/json"+      md `shouldContain` "text/plain;charset=utf-8"+++-- * APIs++data Datatype1 = Datatype1 { dt1field1 :: String+                           , dt1field2 :: Int+                           } deriving (Eq, Show, Generic)++instance ToJSON Datatype1++instance ToSample Datatype1 where+  toSamples _ = singleSample $ Datatype1 "field 1" 13++instance ToSample Char where+  toSamples _ = samples ['a'..'z']++instance ToSample Int where+  toSamples _ = singleSample 17++instance MimeRender PlainText Int where+  mimeRender _ = cs . show++type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)+           :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1+           :<|> Header "X-Test" Int :> Put '[JSON] Int+           :<|> "empty-api" :> EmptyAPI++type TestApi2 = "duplicate-endpoint" :> Get '[JSON]      Datatype1+           :<|> "duplicate-endpoint" :> Get '[PlainText] Int+++data TT = TT1 | TT2 deriving (Show, Eq)+data UT = UT1 | UT2 deriving (Show, Eq)++instance ToSample TT where+  toSamples _ = [("eins", TT1), ("zwei", TT2)]++instance ToSample UT where+  toSamples _ = [("yks", UT1), ("kaks", UT2)]++-------------------------------------------------------------------------------+-- HSpec like DSL for tasty+-------------------------------------------------------------------------------++newtype TestTreeM a = TestTreeM (Writer [TestTree] a)+  deriving (Functor, Applicative, Monad)++runTestTreeM :: TestTreeM () -> [TestTree]+runTestTreeM (TestTreeM m) = snd (runWriter m)++class Describe r where+    describe :: TestName -> TestTreeM () -> r++instance a ~ () =>  Describe (TestTreeM a) where+    describe n t = TestTreeM $ tell [ describe n t ]++instance Describe TestTree where+    describe n t = testGroup n $ runTestTreeM t++it :: TestName -> Assertion -> TestTreeM ()+it n assertion = TestTreeM $ tell [ testCase n assertion ]++shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion+shouldBe = (@?=)++shouldContain :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> Assertion+shouldContain = compareWith (flip isInfixOf) "does not contain"++shouldNotContain :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> Assertion+shouldNotContain = compareWith (\x y -> not (isInfixOf y x)) "contains"++compareWith :: (Show a, Show b, HasCallStack) => (a -> b -> Bool) -> String -> a -> b -> Assertion+compareWith f msg x y = unless (f x y) $ assertFailure $+    show x ++ " " ++ msg ++ " " ++ show y++golden :: TestName -> FilePath -> String -> TestTreeM ()+golden n fp contents = TestTreeM $ tell+    [ goldenVsString n fp (return (cs contents)) ]

@@ -1,1 +1,8 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+module Main (main) where++import           Test.Tasty+                 (defaultMain)+import qualified Servant.DocsSpec++main :: IO ()+main = defaultMain Servant.DocsSpec.spec