From 702c2cec7d297e42f680697c61ecdfa01a0dff3a Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 9 Dec 2015 18:04:47 -0800 Subject: [PATCH 1/2] Add 'pretty' --- servant-docs/servant-docs.cabal | 2 ++ servant-docs/src/Servant/Docs.hs | 2 +- servant-docs/src/Servant/Docs/Internal.hs | 33 +++++++++++++++++++++++ 3 files changed, 36 insertions(+), 1 deletion(-) 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 From f1a6a2a151cd178f36569c3212e8fcf89591a59a Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 10 Dec 2015 12:27:15 -0800 Subject: [PATCH 2/2] Move 'pretty' to its own module --- servant-docs/servant-docs.cabal | 1 + servant-docs/src/Servant/Docs.hs | 3 +- servant-docs/src/Servant/Docs/Internal.hs | 33 ------------ .../src/Servant/Docs/Internal/Pretty.hs | 50 +++++++++++++++++++ 4 files changed, 53 insertions(+), 34 deletions(-) create mode 100644 servant-docs/src/Servant/Docs/Internal/Pretty.hs diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 7f1f0025..b88bc612 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -29,6 +29,7 @@ library exposed-modules: Servant.Docs , Servant.Docs.Internal + , Servant.Docs.Internal.Pretty build-depends: base >=4.7 && <5 , aeson diff --git a/servant-docs/src/Servant/Docs.hs b/servant-docs/src/Servant/Docs.hs index a14a4f34..193b4e60 100644 --- a/servant-docs/src/Servant/Docs.hs +++ b/servant-docs/src/Servant/Docs.hs @@ -53,4 +53,5 @@ module Servant.Docs , single ) where -import Servant.Docs.Internal +import Servant.Docs.Internal +import Servant.Docs.Internal.Pretty diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 4b79e9f2..33cb86a0 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -26,8 +26,6 @@ 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 @@ -369,37 +367,6 @@ 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 diff --git a/servant-docs/src/Servant/Docs/Internal/Pretty.hs b/servant-docs/src/Servant/Docs/Internal/Pretty.hs new file mode 100644 index 00000000..7de722be --- /dev/null +++ b/servant-docs/src/Servant/Docs/Internal/Pretty.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +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.ContentTypes +import Servant.Utils.Links + +-- | 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 layout -> Proxy (Pretty layout) +pretty Proxy = Proxy + +-- | 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