Move 'pretty' to its own module

This commit is contained in:
Mitchell Rosen 2015-12-10 12:27:15 -08:00
parent 702c2cec7d
commit f1a6a2a151
4 changed files with 53 additions and 34 deletions

View file

@ -29,6 +29,7 @@ library
exposed-modules: exposed-modules:
Servant.Docs Servant.Docs
, Servant.Docs.Internal , Servant.Docs.Internal
, Servant.Docs.Internal.Pretty
build-depends: build-depends:
base >=4.7 && <5 base >=4.7 && <5
, aeson , aeson

View file

@ -53,4 +53,5 @@ module Servant.Docs
, single , single
) where ) where
import Servant.Docs.Internal import Servant.Docs.Internal
import Servant.Docs.Internal.Pretty

View file

@ -26,8 +26,6 @@ import Control.Arrow (second)
import Control.Lens (makeLenses, over, traversed, (%~), import Control.Lens (makeLenses, over, traversed, (%~),
(&), (.~), (<>~), (^.), (|>)) (&), (.~), (<>~), (^.), (|>))
import qualified Control.Monad.Omega as Omega 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.Conversion (ToByteString, toByteString)
import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
@ -369,37 +367,6 @@ docsWith opts intros (ExtraInfo endpoints) p =
docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
docsWithIntros intros = docsWith defaultDocOptions intros mempty 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 -- | The class that abstracts away the impact of API combinators
-- on documentation generation. -- on documentation generation.
class HasDocs layout where class HasDocs layout where

View file

@ -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