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