Merge pull request #289 from mitchellwrosen/master

Add 'pretty' to servant-docs

servant-docs/servant-docs.cabal

@@ -29,8 +29,11 @@ library
   exposed-modules:
       Servant.Docs
     , Servant.Docs.Internal
+    , Servant.Docs.Internal.Pretty
   build-depends:
       base >=4.7 && <5
+    , aeson
+    , aeson-pretty
     , bytestring
     , bytestring-conversion
     , case-insensitive

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
@@ -54,3 +54,4 @@ module Servant.Docs
   ) where
 
 import Servant.Docs.Internal
+import Servant.Docs.Internal.Pretty

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