Merge remote-tracking branch 'servant-docs/prepare-merge' into merge

2015-04-20 11:24:11 +02:00 · 2015-04-20 11:24:11 +02:00 · 03862836c4
commit 03862836c4
parent 1eedad4073 88f1a3fc15
14 changed files with 1547 additions and 0 deletions
--- a/servant-docs/CHANGELOG.md
+++ b/servant-docs/CHANGELOG.md
@ -0,0 +1,15 @@
+0.4
+---
+* Allow for extra information to be added to the docs
+* Support content-type aware combinators of *servant-0.3*
+* Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15)
+* Remove ToJSON superclass from ToSample
+* Split out Internal module
+* `Canonicalize` API types before generating the docs for them
+
+0.3
+---
+
+* Add the ability to display multiple responses, with some accompanying `Text` to describe the context in which we get the corresponding JSON.
+* Expose the `headers` lens
+* Represent an endpoint's path as `[String]` (previously `String`), fixing a corner case where the leading `/` would be missing.
--- a/servant-docs/LICENSE
+++ b/servant-docs/LICENSE
@ -0,0 +1,30 @@
+Copyright (c) 2014, Zalora South East Asia Pte Ltd
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Zalora South East Asia Pte Ltd nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- a/servant-docs/README.md
+++ b/servant-docs/README.md
@ -0,0 +1,72 @@
+# servant-docs
+
+[![Build Status](https://secure.travis-ci.org/haskell-servant/servant-docs.svg)](http://travis-ci.org/haskell-servant/servant-docs)
+
+![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**.
+
+## Example
+
+See [here](https://github.com/haskell-servant/servant-docs/blob/master/example/greet.md) for the output of the following program.
+
+``` haskell
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Proxy
+import Data.Text
+import Servant
+
+-- our type for a Greeting message
+data Greet = Greet { _msg :: Text }
+  deriving (Generic, Show)
+
+-- we get our JSON serialization for free. This will be used by the default
+-- 'MimeRender' instance for 'JSON'.
+instance FromJSON Greet
+instance ToJSON Greet
+
+-- We can also implement 'MimeRender' explicitly for additional formats.
+instance MimeRender PlainText Greet where
+    toByteString Proxy (Greet s) = "<h1>" <> cs s <> "</h1>"
+
+-- we provide a sample value for the 'Greet' type
+instance ToSample Greet where
+  toSample = Just g
+
+    where g = Greet "Hello, haskeller!"
+
+instance ToParam (QueryParam "capital" Bool) where
+  toParam _ =
+    DocQueryParam "capital"
+                  ["true", "false"]
+                  "Get the greeting message in uppercase (true) or not (false). Default is false."
+
+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"
+
+-- 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
+
+testApi :: Proxy TestApi
+testApi = Proxy
+
+-- Generate the Documentation's ADT
+greetDocs :: API
+greetDocs = docs testApi
+
+main :: IO ()
+main = putStrLn $ markdown greetDocs
+```
--- a/servant-docs/Setup.hs
+++ b/servant-docs/Setup.hs
@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
--- a/servant-docs/default.nix
+++ b/servant-docs/default.nix
@ -0,0 +1,19 @@
+{ mkDerivation, aeson, base, bytestring, hashable, hspec
+, http-media, lens, servant, stdenv, string-conversions, text
+, unordered-containers
+}:
+mkDerivation {
+  pname = "servant-docs";
+  version = "0.3";
+  src = ./.;
+  isLibrary = true;
+  isExecutable = true;
+  buildDepends = [
+    aeson base bytestring hashable http-media lens servant
+    string-conversions text unordered-containers
+  ];
+  testDepends = [ aeson base hspec lens servant ];
+  homepage = "http://haskell-servant.github.io/";
+  description = "generate API docs for your servant webservice";
+  license = stdenv.lib.licenses.bsd3;
+}
--- a/servant-docs/docs.sh
+++ b/servant-docs/docs.sh
@ -0,0 +1,52 @@
+SERVANT_DIR=/tmp/servant-docs-gh-pages
+
+# Make a temporary clone
+
+rm -rf $SERVANT_DIR
+
+git clone . $SERVANT_DIR
+
+cd $SERVANT_DIR
+
+# Make sure to pull the latest
+
+git remote add haskell-servant git@github.com:haskell-servant/servant-docs.git
+
+git fetch haskell-servant
+
+git reset --hard haskell-servant/gh-pages
+
+# Clear everything away
+
+git rm -rf $SERVANT_DIR/*
+
+# Switch back and build the haddocks
+
+cd -
+
+cabal configure --builddir=$SERVANT_DIR
+
+cabal haddock --hoogle --hyperlink-source --html-location='https://hackage.haskell.org/package/$pkg-$version/docs' --builddir=$SERVANT_DIR
+
+commit_hash=$(git rev-parse HEAD)
+
+# Move the HTML docs to the root
+
+cd $SERVANT_DIR
+
+rm *
+rm -rf build
+mv doc/html/servant-docs/* .
+rm -r doc/
+
+# Add everything
+
+git add .
+
+git commit -m "Built from $commit_hash"
+
+# Push to update the pages
+
+git push haskell-servant HEAD:gh-pages
+
+rm -rf $SERVANT_DIR
--- a/servant-docs/example/greet.hs
+++ b/servant-docs/example/greet.hs
@ -0,0 +1,117 @@
+{-# 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 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
+
+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)) $
+             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
--- a/servant-docs/example/greet.md
+++ b/servant-docs/example/greet.md
@ -0,0 +1,124 @@
+#### On proper introductions.
+
+Hello there.
+
+As documentation is usually written for humans, it's often useful to introduce concepts with a few words.
+
+#### This title is below the last
+
+You'll also note that multiple intros are possible.
+
+## POST /greet
+
+#### Request:
+
+- Supported content types are:
+
+    - `application/json`
+
+- Example: `application/json`
+
+```javascript
+"Hello, haskeller!"
+```
+
+#### Response:
+
+- Status code 201
+
+- Supported content types are:
+
+    - `application/json`
+
+- If you use ?capital=true
+
+```javascript
+"HELLO, HASKELLER"
+```
+
+- If you use ?capital=false
+
+```javascript
+"Hello, haskeller"
+```
+
+## GET /hello;lang=<value>/:name
+
+#### Captures:
+
+- *name*: name of the person to greet
+
+#### Matrix Parameters:
+
+**hello**:
+
+- lang
+     - **Values**: *en, sv, fr*
+     - **Description**: Get the greeting message selected language. Default is en.
+
+
+
+#### GET Parameters:
+
+- capital
+     - **Values**: *true, false*
+     - **Description**: Get the greeting message in uppercase (true) or not (false).Default is false.
+
+
+#### Response:
+
+- Status code 200
+
+- Supported content types are:
+
+    - `application/json`
+    - `text/plain;charset=utf-8`
+
+- If you use ?capital=true
+
+```javascript
+"HELLO, HASKELLER"
+```
+
+- If you use ?capital=true
+
+```
+"HELLO, HASKELLER"
+```
+
+- If you use ?capital=false
+
+```javascript
+"Hello, haskeller"
+```
+
+- If you use ?capital=false
+
+```
+"Hello, haskeller"
+```
+
+## DELETE /greet/:greetid
+
+#### Title
+
+This is some text
+
+#### Second secton
+
+And some more
+
+#### Captures:
+
+- *greetid*: identifier of the greet msg to remove
+
+
+- This endpoint is sensitive to the value of the **unicorns** HTTP header.
+
+#### Response:
+
+- Status code 200
+
+- No response body
+
+
--- a/servant-docs/servant-docs.cabal
+++ b/servant-docs/servant-docs.cabal
@ -0,0 +1,71 @@
+name:                servant-docs
+version:             0.3
+synopsis:            generate API docs for your servant webservice
+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>.
+license:             BSD3
+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
+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-docs/issues
+extra-source-files:
+  CHANGELOG.md
+  README.md
+source-repository head
+  type: git
+  location: http://github.com/haskell-servant/servant-docs.git
+
+library
+  exposed-modules:
+      Servant.Docs
+    , Servant.Docs.Internal
+  build-depends:
+      base >=4.7 && <5
+    , bytestring
+    , hashable
+    , http-media >= 0.6
+    , lens
+    , servant >= 0.2.1
+    , string-conversions
+    , text
+    , unordered-containers
+  hs-source-dirs: src
+  default-language: Haskell2010
+  ghc-options: -Wall
+
+executable greet-docs
+  main-is: greet.hs
+  hs-source-dirs: example
+  ghc-options: -Wall
+  build-depends:
+      base
+    , aeson
+    , lens
+    , servant
+    , servant-docs
+    , string-conversions
+    , text
+  default-language: Haskell2010
+
+test-suite spec
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  hs-source-dirs: test
+  ghc-options: -Wall
+  build-depends:
+      base
+    , aeson
+    , hspec
+    , servant
+    , servant-docs
+    , string-conversions
+  default-language: Haskell2010
+
--- a/servant-docs/shell.nix
+++ b/servant-docs/shell.nix
@ -0,0 +1,9 @@
+with (import <nixpkgs> {}).pkgs;
+let modifiedHaskellPackages = haskellngPackages.override {
+      overrides = self: super: {
+        servant = self.callPackage ../servant {};
+        servant-server = self.callPackage ./servant-server {};
+        servant-docs = self.callPackage ./. {};
+      };
+    };
+in modifiedHaskellPackages.servant-docs.env
--- a/servant-docs/src/Servant/Docs.hs
+++ b/servant-docs/src/Servant/Docs.hs
@ -0,0 +1,168 @@
+-------------------------------------------------------------------------------
+-- | This module lets you get API docs for free. It lets you generate
+-- an 'API' from the type that represents your API using 'docs':
+--
+-- @docs :: 'HasDocs' api => 'Proxy' api -> 'API'@
+--
+-- Alternatively, if you wish to add one or more introductions to your
+-- documentation, use 'docsWithIntros':
+--
+-- @'docsWithIntros' :: 'HasDocs' api => [DocIntro] -> 'Proxy' api -> 'API'@
+--
+-- You can then call 'markdown' on the 'API' value:
+--
+-- @'markdown' :: 'API' -> String@
+--
+-- or define a custom pretty printer:
+--
+-- @yourPrettyDocs :: 'API' -> String -- or blaze-html's HTML, or ...@
+--
+-- 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 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
+-- >     toByteString 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 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
+-- >
+-- > 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)) $
+-- >              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
+module Servant.Docs
+  ( -- * 'HasDocs' class and key functions
+    HasDocs(..), docs, markdown
+    -- * Generating docs with extra information
+  , ExtraInfo(..), docsWith, docsWithIntros, extraInfo
+
+  , -- * Classes you need to implement for your types
+    ToSample(..)
+  , sampleByteString
+  , sampleByteStrings
+  , ToParam(..)
+  , ToCapture(..)
+
+  , -- * ADTs to represent an 'API'
+    Method(..)
+  , Endpoint, path, method, defEndpoint
+  , API, emptyAPI
+  , DocCapture(..), capSymbol, capDesc
+  , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
+  , DocNote(..), noteTitle, noteBody
+  , DocIntro(..)
+  , Response(..), respStatus, respTypes, respBody, defResponse
+  , Action, captures, headers, notes, params, rqtypes, rqbody, response, defAction
+  , single
+  ) where
+
+import Servant.Docs.Internal
--- a/servant-docs/src/Servant/Docs/Internal.hs
+++ b/servant-docs/src/Servant/Docs/Internal.hs
@ -0,0 +1,803 @@
+{-# LANGUAGE ConstraintKinds      #-}
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE PolyKinds            #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE TupleSections        #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Servant.Docs.Internal where
+
+import           Control.Applicative
+import           Control.Lens
+import           Data.ByteString.Lazy.Char8 (ByteString)
+import           Data.Hashable
+import           Data.HashMap.Strict        (HashMap)
+import           Data.List
+import           Data.Maybe
+import           Data.Monoid
+import           Data.Ord                   (comparing)
+import           Data.Proxy
+import           Data.String.Conversions
+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
+
+-- | 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)]
+  } 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 200 [] []
+
+-- | 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 (Canonicalize layout) => Proxy layout -> API
+docs p = docsFor (canonicalize 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 (Canonicalize layout)
+         => [DocIntro]
+         -> ExtraInfo layout
+         -> Proxy layout
+         -> API
+docsWith intros (ExtraInfo endpoints) p =
+    docs p & apiIntros <>~ intros
+           & apiEndpoints %~ HM.unionWith combineAction endpoints
+
+
+-- | Generate the docs for a given API that implements 'HasDocs' with with any
+-- number of introduction(s)
+docsWithIntros :: HasDocs (Canonicalize 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 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 where
+  {-# MINIMAL (toSample | toSamples) #-}
+  toSample :: Maybe a
+  toSample = snd <$> listToMaybe samples
+    where samples = toSamples :: [(Text, a)]
+
+  toSamples :: [(Text, a)]
+  toSamples = maybe [] (return . ("",)) s
+    where s = toSample :: Maybe a
+
+-- | Synthesise a sample value of a type, encoded in the specified media types.
+sampleByteString
+    :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
+    => Proxy ctypes
+    -> Proxy a
+    -> [(M.MediaType, ByteString)]
+sampleByteString ctypes@Proxy Proxy =
+    maybe [] (allMimeRender ctypes) (toSample :: Maybe a)
+
+-- | Synthesise a list of sample values of a particular type, encoded in the
+-- specified media types.
+sampleByteStrings
+    :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
+    => Proxy ctypes
+    -> Proxy a
+    -> [(Text, M.MediaType, ByteString)]
+sampleByteStrings ctypes@Proxy Proxy =
+    let samples = toSamples :: [(Text, 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)) :
+          "" :
+          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 HasDocs Delete where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where endpoint' = endpoint & method .~ DocDELETE
+
+          action' = action & response.respBody .~ []
+                           & response.respStatus .~ 204
+
+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, 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 (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 (ToSample a, IsNonEmpty cts, AllMimeRender cts a, 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 (ToSample a, IsNonEmpty cts, AllMimeRender cts a, 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 (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, IsNonEmpty cts, AllMimeRender cts a, 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
+
+{-
+
+-- | Serve your API's docs as markdown embedded in an html \<pre> tag.
+--
+-- > type MyApi = "users" :> Get [User]
+-- >         :<|> "docs   :> Raw
+-- >
+-- > apiProxy :: Proxy MyApi
+-- > apiProxy = Proxy
+-- >
+-- > server :: Server MyApi
+-- > server = listUsers
+-- >     :<|> serveDocumentation apiProxy
+serveDocumentation :: HasDocs api => Proxy api -> Server Raw
+serveDocumentation proxy _request respond =
+  respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy
+
+toHtml :: String -> String
+toHtml md =
+  "<html>" ++
+  "<body>" ++
+  "<pre>" ++
+  md ++
+  "</pre>" ++
+  "</body>" ++
+  "</html>"
+-}
--- a/servant-docs/test/Servant/DocsSpec.hs
+++ b/servant-docs/test/Servant/DocsSpec.hs
@ -0,0 +1,64 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
+module Servant.DocsSpec where
+
+import           Data.Aeson
+import           Data.Proxy
+import           Data.String.Conversions (cs)
+import           GHC.Generics
+import           Test.Hspec
+
+import           Servant.API
+import           Servant.Docs.Internal
+
+spec :: Spec
+spec = describe "Servant.Docs" $ do
+
+  describe "markdown" $ do
+    let md = markdown (docs (Proxy :: Proxy TestApi1))
+
+    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"
+      md `shouldContain` "Status code 201"
+
+    it "mentions methods" $ do
+      md `shouldContain` "POST"
+      md `shouldContain` "GET"
+
+    it "contains response samples" $ do
+      md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}"
+    it "contains request body samples" $ do
+      md `shouldContain` "17"
+-- * APIs
+
+data Datatype1 = Datatype1 { dt1field1 :: String
+                           , dt1field2 :: Int
+                           } deriving (Eq, Show, Generic)
+
+instance ToJSON Datatype1
+
+instance ToSample Datatype1 where
+  toSample = Just $ Datatype1 "field 1" 13
+
+instance ToSample String where
+  toSample = Just "a string"
+
+instance ToSample Int where
+  toSample = Just 17
+
+instance MimeRender PlainText Int where
+  mimeRender _ = cs . show
+
+
+type TestApi1 = Get '[JSON, PlainText] Int
+           :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1
+
--- a/servant-docs/test/Spec.hs
+++ b/servant-docs/test/Spec.hs
@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}