{-# LANGUAGE CPP #-}
module Servant.Docs.Simple.Render
( ApiDocs (..)
, Details (..)
, Renderable (..)
, Parameter
, Route
, Json (..)
, Markdown (..)
, Pretty (..)
, PlainText (..)
) where
import Data.Aeson (ToJSON (..), Value (..), (.=), object)
import Data.List (intersperse)
import Data.Text (Text, pack)
#if MIN_VERSION_prettyprinter(1,7,0)
import Prettyprinter (Doc, annotate, defaultLayoutOptions, indent, layoutPretty, line, pretty, vcat,
vsep)
import Prettyprinter.Render.Util.StackMachine (renderSimplyDecorated)
#else
import Data.Text.Prettyprint.Doc (Doc, annotate, defaultLayoutOptions, indent, layoutPretty, line,
pretty, vcat, vsep)
import Data.Text.Prettyprint.Doc.Render.Util.StackMachine (renderSimplyDecorated)
#endif
newtype ApiDocs = ApiDocs [(Route, Details)] deriving stock (ApiDocs -> ApiDocs -> Bool
(ApiDocs -> ApiDocs -> Bool)
-> (ApiDocs -> ApiDocs -> Bool) -> Eq ApiDocs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApiDocs -> ApiDocs -> Bool
$c/= :: ApiDocs -> ApiDocs -> Bool
== :: ApiDocs -> ApiDocs -> Bool
$c== :: ApiDocs -> ApiDocs -> Bool
Eq, Int -> ApiDocs -> ShowS
[ApiDocs] -> ShowS
ApiDocs -> String
(Int -> ApiDocs -> ShowS)
-> (ApiDocs -> String) -> ([ApiDocs] -> ShowS) -> Show ApiDocs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiDocs] -> ShowS
$cshowList :: [ApiDocs] -> ShowS
show :: ApiDocs -> String
$cshow :: ApiDocs -> String
showsPrec :: Int -> ApiDocs -> ShowS
$cshowsPrec :: Int -> ApiDocs -> ShowS
Show)
type Route = Text
data Details = Details [(Parameter, Details)]
| Detail Text
deriving stock (Details -> Details -> Bool
(Details -> Details -> Bool)
-> (Details -> Details -> Bool) -> Eq Details
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Details -> Details -> Bool
$c/= :: Details -> Details -> Bool
== :: Details -> Details -> Bool
$c== :: Details -> Details -> Bool
Eq, Int -> Details -> ShowS
[Details] -> ShowS
Details -> String
(Int -> Details -> ShowS)
-> (Details -> String) -> ([Details] -> ShowS) -> Show Details
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Details] -> ShowS
$cshowList :: [Details] -> ShowS
show :: Details -> String
$cshow :: Details -> String
showsPrec :: Int -> Details -> ShowS
$cshowsPrec :: Int -> Details -> ShowS
Show)
type Parameter = Text
class Renderable a where
render :: ApiDocs -> a
newtype Json = Json { Json -> Value
getJson :: Value } deriving stock (Json -> Json -> Bool
(Json -> Json -> Bool) -> (Json -> Json -> Bool) -> Eq Json
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Json -> Json -> Bool
$c/= :: Json -> Json -> Bool
== :: Json -> Json -> Bool
$c== :: Json -> Json -> Bool
Eq, Int -> Json -> ShowS
[Json] -> ShowS
Json -> String
(Int -> Json -> ShowS)
-> (Json -> String) -> ([Json] -> ShowS) -> Show Json
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Json] -> ShowS
$cshowList :: [Json] -> ShowS
show :: Json -> String
$cshow :: Json -> String
showsPrec :: Int -> Json -> ShowS
$cshowsPrec :: Int -> Json -> ShowS
Show)
instance Renderable Json where
render :: ApiDocs -> Json
render = Value -> Json
Json (Value -> Json) -> (ApiDocs -> Value) -> ApiDocs -> Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApiDocs -> Value
forall a. ToJSON a => a -> Value
toJSON
instance ToJSON ApiDocs where
toJSON :: ApiDocs -> Value
toJSON (ApiDocs [(Route, Details)]
endpoints) =
[Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ ((Route, Details) -> Pair) -> [(Route, Details)] -> [Pair]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Route
route, Details
details) -> Route
route Route -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Route -> v -> kv
.= Details -> Value
forall a. ToJSON a => a -> Value
toJSON Details
details) [(Route, Details)]
endpoints
instance ToJSON Details where
toJSON :: Details -> Value
toJSON (Detail Route
t) = Route -> Value
String Route
t
toJSON (Details [(Route, Details)]
ds) = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ ((Route, Details) -> Pair) -> [(Route, Details)] -> [Pair]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Route
param, Details
details) -> Route
param Route -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Route -> v -> kv
.= Details -> Value
forall a. ToJSON a => a -> Value
toJSON Details
details) [(Route, Details)]
ds
newtype Pretty = Pretty { Pretty -> Doc Ann
getPretty :: Doc Ann }
data Ann = AnnRoute | AnnParam | AnnDetail
instance Renderable Pretty where
render :: ApiDocs -> Pretty
render = Doc Ann -> Pretty
Pretty (Doc Ann -> Pretty) -> (ApiDocs -> Doc Ann) -> ApiDocs -> Pretty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApiDocs -> Doc Ann
prettyPrint
prettyPrint :: ApiDocs -> Doc Ann
prettyPrint :: ApiDocs -> Doc Ann
prettyPrint (ApiDocs [(Route, Details)]
endpoints) = [Doc Ann] -> Doc Ann
forall ann. [Doc ann] -> Doc ann
vsep
([Doc Ann] -> Doc Ann) -> [Doc Ann] -> Doc Ann
forall a b. (a -> b) -> a -> b
$ Doc Ann -> [Doc Ann] -> [Doc Ann]
forall a. a -> [a] -> [a]
intersperse Doc Ann
forall ann. Doc ann
line
([Doc Ann] -> [Doc Ann]) -> [Doc Ann] -> [Doc Ann]
forall a b. (a -> b) -> a -> b
$ (Route, Details) -> Doc Ann
documentRoute
((Route, Details) -> Doc Ann) -> [(Route, Details)] -> [Doc Ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Route, Details)]
endpoints
documentRoute :: (Route, Details)
-> Doc Ann
documentRoute :: (Route, Details) -> Doc Ann
documentRoute (Route
r, Details
d) = Doc Ann
routeDoc Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> Doc Ann
":" Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> Doc Ann
detailsDoc
where routeDoc :: Doc Ann
routeDoc = Ann -> Doc Ann -> Doc Ann
forall ann. ann -> Doc ann -> Doc ann
annotate Ann
AnnRoute (Doc Ann -> Doc Ann) -> Doc Ann -> Doc Ann
forall a b. (a -> b) -> a -> b
$ Route -> Doc Ann
forall a ann. Pretty a => a -> Doc ann
pretty Route
r
detailsDoc :: Doc Ann
detailsDoc = Int -> Details -> Doc Ann
documentDetails Int
0 Details
d
documentDetails :: Int
-> Details
-> Doc Ann
documentDetails :: Int -> Details -> Doc Ann
documentDetails Int
i Details
d = case Details
d of
Detail Route
d' -> Doc Ann
" " Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> Ann -> Doc Ann -> Doc Ann
forall ann. ann -> Doc ann -> Doc ann
annotate Ann
AnnDetail (Route -> Doc Ann
forall a ann. Pretty a => a -> Doc ann
pretty Route
d')
Details [(Route, Details)]
ds -> (Doc Ann
forall ann. Doc ann
line Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<>)
(Doc Ann -> Doc Ann) -> Doc Ann -> Doc Ann
forall a b. (a -> b) -> a -> b
$ Int -> Doc Ann -> Doc Ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
i
(Doc Ann -> Doc Ann) -> Doc Ann -> Doc Ann
forall a b. (a -> b) -> a -> b
$ [Doc Ann] -> Doc Ann
forall ann. [Doc ann] -> Doc ann
vcat
([Doc Ann] -> Doc Ann) -> [Doc Ann] -> Doc Ann
forall a b. (a -> b) -> a -> b
$ (Route, Details) -> Doc Ann
documentParameters ((Route, Details) -> Doc Ann) -> [(Route, Details)] -> [Doc Ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Route, Details)]
ds
where documentParameters :: (Route, Details) -> Doc Ann
documentParameters (Route
param, Details
details) = Ann -> Doc Ann -> Doc Ann
forall ann. ann -> Doc ann -> Doc ann
annotate Ann
AnnParam (Route -> Doc Ann
forall a ann. Pretty a => a -> Doc ann
pretty Route
param)
Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> Doc Ann
":"
Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> Int -> Details -> Doc Ann
documentDetails (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) Details
details
newtype PlainText = PlainText { PlainText -> Route
getPlainText :: Text } deriving stock (PlainText -> PlainText -> Bool
(PlainText -> PlainText -> Bool)
-> (PlainText -> PlainText -> Bool) -> Eq PlainText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PlainText -> PlainText -> Bool
$c/= :: PlainText -> PlainText -> Bool
== :: PlainText -> PlainText -> Bool
$c== :: PlainText -> PlainText -> Bool
Eq, Int -> PlainText -> ShowS
[PlainText] -> ShowS
PlainText -> String
(Int -> PlainText -> ShowS)
-> (PlainText -> String)
-> ([PlainText] -> ShowS)
-> Show PlainText
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlainText] -> ShowS
$cshowList :: [PlainText] -> ShowS
show :: PlainText -> String
$cshow :: PlainText -> String
showsPrec :: Int -> PlainText -> ShowS
$cshowsPrec :: Int -> PlainText -> ShowS
Show)
instance Renderable PlainText where
render :: ApiDocs -> PlainText
render = Route -> PlainText
PlainText (Route -> PlainText) -> (ApiDocs -> Route) -> ApiDocs -> PlainText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Route
pack (String -> Route) -> (ApiDocs -> String) -> ApiDocs -> Route
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Ann -> String
forall a. Show a => a -> String
show (Doc Ann -> String) -> (ApiDocs -> Doc Ann) -> ApiDocs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty -> Doc Ann
getPretty (Pretty -> Doc Ann) -> (ApiDocs -> Pretty) -> ApiDocs -> Doc Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApiDocs -> Pretty
forall a. Renderable a => ApiDocs -> a
render
newtype Markdown = Markdown { Markdown -> Route
getMarkdown :: Text } deriving stock (Markdown -> Markdown -> Bool
(Markdown -> Markdown -> Bool)
-> (Markdown -> Markdown -> Bool) -> Eq Markdown
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Markdown -> Markdown -> Bool
$c/= :: Markdown -> Markdown -> Bool
== :: Markdown -> Markdown -> Bool
$c== :: Markdown -> Markdown -> Bool
Eq, Int -> Markdown -> ShowS
[Markdown] -> ShowS
Markdown -> String
(Int -> Markdown -> ShowS)
-> (Markdown -> String) -> ([Markdown] -> ShowS) -> Show Markdown
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Markdown] -> ShowS
$cshowList :: [Markdown] -> ShowS
show :: Markdown -> String
$cshow :: Markdown -> String
showsPrec :: Int -> Markdown -> ShowS
$cshowsPrec :: Int -> Markdown -> ShowS
Show)
instance Renderable Markdown where
render :: ApiDocs -> Markdown
render ApiDocs
docs = Route -> Markdown
Markdown Route
m
where m :: Route
m = (Route -> Route)
-> (Ann -> Route) -> (Ann -> Route) -> SimpleDocStream Ann -> Route
forall out ann.
Monoid out =>
(Route -> out)
-> (ann -> out) -> (ann -> out) -> SimpleDocStream ann -> out
renderSimplyDecorated Route -> Route
forall a. a -> a
id Ann -> Route
annOpen Ann -> Route
annClose SimpleDocStream Ann
docStream
annOpen :: Ann -> Route
annOpen = \case
Ann
AnnRoute -> Route
"### "
Ann
AnnParam -> Route
"- **"
Ann
AnnDetail -> Route
"`"
annClose :: Ann -> Route
annClose = \case
Ann
AnnRoute -> Route
""
Ann
AnnParam -> Route
"**"
Ann
AnnDetail -> Route
"`"
docStream :: SimpleDocStream Ann
docStream = LayoutOptions -> Doc Ann -> SimpleDocStream Ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions Doc Ann
docs'
docs' :: Doc Ann
docs' = Pretty -> Doc Ann
getPretty (Pretty -> Doc Ann) -> Pretty -> Doc Ann
forall a b. (a -> b) -> a -> b
$ ApiDocs -> Pretty
forall a. Renderable a => ApiDocs -> a
render ApiDocs
docs