diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index ee6f71bf..7f1f0025 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -31,6 +31,8 @@ library , Servant.Docs.Internal build-depends: base >=4.7 && <5 + , aeson + , aeson-pretty , bytestring , bytestring-conversion , case-insensitive diff --git a/servant-docs/src/Servant/Docs.hs b/servant-docs/src/Servant/Docs.hs index 2f081127..a14a4f34 100644 --- a/servant-docs/src/Servant/Docs.hs +++ b/servant-docs/src/Servant/Docs.hs @@ -23,7 +23,7 @@ -- See example/greet.hs for an example. module Servant.Docs ( -- * 'HasDocs' class and key functions - HasDocs(..), docs, markdown + HasDocs(..), docs, pretty, markdown -- * Generating docs with extra information , docsWith, docsWithIntros, docsWithOptions , ExtraInfo(..), extraInfo diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 33cb86a0..4b79e9f2 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -26,6 +26,8 @@ import Control.Arrow (second) import Control.Lens (makeLenses, over, traversed, (%~), (&), (.~), (<>~), (^.), (|>)) import qualified Control.Monad.Omega as Omega +import Data.Aeson (ToJSON(..)) +import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString.Conversion (ToByteString, toByteString) import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.CaseInsensitive as CI @@ -367,6 +369,37 @@ docsWith opts intros (ExtraInfo endpoints) p = docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API docsWithIntros intros = docsWith defaultDocOptions intros mempty +-- | Prettify generated JSON documentation. +-- +-- @ +-- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI)) +-- @ +pretty :: Proxy layout -> Proxy (Pretty layout) +pretty Proxy = Proxy + +data PrettyJSON + +instance Accept PrettyJSON where + contentType _ = "application" M.// "json" + +instance ToJSON a => MimeRender PrettyJSON a where + mimeRender _ = encodePretty + +-- | Replace all JSON content types with PrettyJSON. +-- Kind-polymorphic so it can operate on kinds * and [*]. +type family Pretty (layout :: 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 (ReqBody cs r) = ReqBody (Pretty cs) r + Pretty (JSON ': xs) = PrettyJSON ': xs + Pretty (x ': xs) = x ': Pretty xs + Pretty x = x + -- | The class that abstracts away the impact of API combinators -- on documentation generation. class HasDocs layout where