src/Idris/Docstrings.hs · Idris-dev

1{-|

2Module : Idris.Docstrings

3Description : Wrapper around Markdown library.

4Copyright :

5License : BSD3

6Maintainer : The Idris Community.

7-}

8

9{-# LANGUAGE DeriveFunctor, DeriveGeneric, ScopedTypeVariables #-}

10{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

11module Idris.Docstrings (

12 Docstring(..), Block(..), Inline(..), parseDocstring, renderDocstring

13 , emptyDocstring, nullDocstring, noDocs, overview, containsText

14 , renderHtml, annotCode, DocTerm(..), renderDocTerm, checkDocstring

15 ) where

16

17import qualified Cheapskate as C

18import qualified Cheapskate.Types as CT

19import Cheapskate.Html (renderDoc)

20

21import Util.Pretty

22

23import Idris.Core.TT (OutputAnnotation(..), TextFormatting(..), Name, Term, Err)

24

25import Prelude hiding ((<$>))

26

27import qualified Data.Text as T

28import qualified Data.Foldable as F

29import Data.Foldable (Foldable)

30import Data.Traversable (Traversable)

31import qualified Data.Sequence as S

32

33import GHC.Generics (Generic)

34

35import Text.Blaze.Html (Html)

36

37-- | The various kinds of code samples that can be embedded in docs

38data DocTerm = Unchecked

39 | Checked Term

40 | Example Term

41 | Failing Err

42 deriving (Show, Generic)

43

44-- | Render a term in the documentation

45renderDocTerm :: (Term -> Doc OutputAnnotation) -> (Term -> Term) -> DocTerm -> String -> Doc OutputAnnotation

46renderDocTerm pp norm Unchecked src = text src

47renderDocTerm pp norm (Checked tm) src = pp tm

48renderDocTerm pp norm (Example tm) src = align $

49 text ">" <+> align (pp tm) <$>

50 pp (norm tm)

51renderDocTerm pp norm (Failing err) src = annotate (AnnErr err) $ text src

52

53-- | Representation of Idris's inline documentation. The type paramter

54-- represents the type of terms that are associated with code blocks.

55data Docstring a = DocString CT.Options (Blocks a)

56 deriving (Show, Functor, Foldable, Traversable, Generic)

57

58type Blocks a = S.Seq (Block a)

59

60-- | Block-level elements.

61data Block a = Para (Inlines a)

62 | Header Int (Inlines a)

63 | Blockquote (Blocks a)

64 | List Bool CT.ListType [Blocks a]

65 | CodeBlock CT.CodeAttr T.Text a

66 | HtmlBlock T.Text

67 | HRule

68 deriving (Show, Functor, Foldable, Traversable, Generic)

69

70data Inline a = Str T.Text

71 | Space

72 | SoftBreak

73 | LineBreak

74 | Emph (Inlines a)

75 | Strong (Inlines a)

76 | Code T.Text a

77 | Link (Inlines a) T.Text T.Text

78 | Image (Inlines a) T.Text T.Text

79 | Entity T.Text

80 | RawHtml T.Text

81 deriving (Show, Functor, Foldable, Traversable, Generic)

82

83type Inlines a = S.Seq (Inline a)

84

85

86-- | Run some kind of processing step over code in a Docstring. The code

87-- processor gets the language and annotations as parameters, along with the

88-- source and the original annotation.

89checkDocstring :: forall a b. (String -> [String] -> String -> a -> b) -> Docstring a -> Docstring b

90checkDocstring f (DocString opts blocks) = DocString opts (fmap (checkBlock f) blocks)

91 where checkBlock :: (String -> [String] -> String -> a -> b) -> Block a -> Block b

92 checkBlock f (Para inlines) = Para (fmap (checkInline f) inlines)

93 checkBlock f (Header i inlines) = Header i (fmap (checkInline f) inlines)

94 checkBlock f (Blockquote bs) = Blockquote (fmap (checkBlock f) bs)

95 checkBlock f (List b t blocks) = List b t (fmap (fmap (checkBlock f)) blocks)

96 checkBlock f (CodeBlock attrs src tm) = CodeBlock attrs src

97 (f (T.unpack $ CT.codeLang attrs)

98 (words . T.unpack $ CT.codeInfo attrs)

99 (T.unpack src)

100 tm)

101 checkBlock f (HtmlBlock src) = HtmlBlock src

102 checkBlock f HRule = HRule

103

104 checkInline :: (String -> [String] -> String -> a -> b) -> Inline a -> Inline b

105 checkInline f (Str txt) = Str txt

106 checkInline f Space = Space

107 checkInline f SoftBreak = SoftBreak

108 checkInline f LineBreak = LineBreak

109 checkInline f (Emph is) = Emph (fmap (checkInline f) is)

110 checkInline f (Strong is) = Strong (fmap (checkInline f) is)

111 checkInline f (Code src x) = Code src (f "" [] (T.unpack src) x)

112 checkInline f (Link is url title) = Link (fmap (checkInline f) is) url title

113 checkInline f (Image is url title) = Image (fmap (checkInline f) is) url title

114 checkInline f (Entity txt) = Entity txt

115 checkInline f (RawHtml src) = RawHtml src

116

117-- | Construct a docstring from a Text that contains Markdown-formatted docs

118parseDocstring :: T.Text -> Docstring ()

119parseDocstring = toDocstring . C.markdown options

120 where toDocstring :: CT.Doc -> Docstring ()

121 toDocstring (CT.Doc opts blocks) = DocString opts (fmap toBlock blocks)

122

123 toBlock :: CT.Block -> Block ()

124 toBlock (CT.Para inlines) = Para (fmap toInline inlines)

125 toBlock (CT.Header i inlines) = Header i (fmap toInline inlines)

126 toBlock (CT.Blockquote blocks) = Blockquote (fmap toBlock blocks)

127 toBlock (CT.List b t blocks) = List b t (fmap (fmap toBlock) blocks)

128 toBlock (CT.CodeBlock attrs text) = CodeBlock attrs text ()

129 toBlock (CT.HtmlBlock src) = HtmlBlock src

130 toBlock CT.HRule = HRule

131

132 toInline :: CT.Inline -> Inline ()

133 toInline (CT.Str t) = Str t

134 toInline CT.Space = Space

135 toInline CT.SoftBreak = SoftBreak

136 toInline CT.LineBreak = LineBreak

137 toInline (CT.Emph is) = Emph (fmap toInline is)

138 toInline (CT.Strong is) = Strong (fmap toInline is)

139 toInline (CT.Code src) = Code src ()

140 toInline (CT.Link is url title) = Link (fmap toInline is) url title

141 toInline (CT.Image is url title) = Image (fmap toInline is) url title

142 toInline (CT.Entity txt) = Entity txt

143 toInline (CT.RawHtml src) = RawHtml src

144

145

146options = CT.Options { CT.sanitize = True

147 , CT.allowRawHtml = False

148 , CT.preserveHardBreaks = True

149 , CT.debug = False

150 }

151

152-- | Convert a docstring to be shown by the pretty-printer

153renderDocstring :: (a -> String -> Doc OutputAnnotation) -> Docstring a -> Doc OutputAnnotation

154renderDocstring pp (DocString _ blocks) = renderBlocks pp blocks

155

156-- | Construct a docstring consisting of the first block-level element of the

157-- argument docstring, for use in summaries.

158overview :: Docstring a -> Docstring a

159overview (DocString opts blocks) = DocString opts (S.take 1 blocks)

160

161renderBlocks :: (a -> String -> Doc OutputAnnotation)

162 -> Blocks a -> Doc OutputAnnotation

163renderBlocks pp blocks | S.length blocks > 1 = F.foldr1 (\b1 b2 -> b1 <> line <> line <> b2) $

164 fmap (renderBlock pp) blocks

165 | S.length blocks == 1 = renderBlock pp (S.index blocks 0)

166 | otherwise = empty

167

168renderBlock :: (a -> String -> Doc OutputAnnotation)

169 -> Block a -> Doc OutputAnnotation

170renderBlock pp (Para inlines) = renderInlines pp inlines

171renderBlock pp (Header lvl inlines) = renderInlines pp inlines <+> parens (text (show lvl))

172renderBlock pp (Blockquote blocks) = indent 8 $ renderBlocks pp blocks

173renderBlock pp (List b ty blockss) = renderList pp b ty blockss

174renderBlock pp (CodeBlock attr src tm) = indent 4 $ pp tm (T.unpack src)

175renderBlock pp (HtmlBlock txt) = text "<html block>" -- TODO

176renderBlock pp HRule = text "----------------------"

177

178renderList :: (a -> String -> Doc OutputAnnotation)

179 -> Bool -> CT.ListType -> [Blocks a] -> Doc OutputAnnotation

180renderList pp b (CT.Bullet c) blockss = vsep $ map (hang 4 . (char c <+>) . renderBlocks pp) blockss

181renderList pp b (CT.Numbered nw i) blockss =

182 vsep $

183 zipWith3 (\n p txt -> hang 4 $ text (show n) <> p <+> txt)

184 [i..] (repeat punc) (map (renderBlocks pp) blockss)

185 where punc = case nw of

186 CT.PeriodFollowing -> char '.'

187 CT.ParenFollowing -> char '('

188

189renderInlines :: (a -> String -> Doc OutputAnnotation) -> Inlines a -> Doc OutputAnnotation

190renderInlines pp = F.foldr (<>) empty . fmap (renderInline pp)

191

192renderInline :: (a -> String -> Doc OutputAnnotation) -> Inline a -> Doc OutputAnnotation

193renderInline pp (Str s) = text $ T.unpack s

194renderInline pp Space = softline

195renderInline pp SoftBreak = softline

196renderInline pp LineBreak = line

197renderInline pp (Emph txt) = annotate (AnnTextFmt ItalicText) $ renderInlines pp txt

198renderInline pp (Strong txt) = annotate (AnnTextFmt BoldText) $ renderInlines pp txt

199renderInline pp (Code txt tm) = pp tm $ T.unpack txt

200renderInline pp (Link body url title) = annotate (AnnLink (T.unpack url)) (renderInlines pp body)

201renderInline pp (Image body url title) = text "<image>" -- TODO

202renderInline pp (Entity a) = text $ "<entity " ++ T.unpack a ++ ">" -- TODO

203renderInline pp (RawHtml txt) = text "<html content>" --TODO

204

205-- | The empty docstring

206emptyDocstring :: Docstring a

207emptyDocstring = DocString options S.empty

208

209-- | Check whether a docstring is emtpy

210nullDocstring :: Docstring a -> Bool

211nullDocstring (DocString _ blocks) = S.null blocks

212

213-- | Empty documentation for a definition

214noDocs :: (Docstring a, [(Name, Docstring a)])

215noDocs = (emptyDocstring, [])

216

217-- | Does a string occur in the docstring?

218containsText :: T.Text -> Docstring a -> Bool

219containsText str (DocString _ blocks) = F.any (blockContains (T.toLower str)) blocks

220 -- blockContains and inlineContains should always be called with a lower-case search string

221 where blockContains :: T.Text -> Block a -> Bool

222 blockContains str (Para inlines) = F.any (inlineContains str) inlines

223 blockContains str (Header lvl inlines) = F.any (inlineContains str) inlines

224 blockContains str (Blockquote blocks) = F.any (blockContains str) blocks

225 blockContains str (List b ty blockss) = F.any (F.any (blockContains str)) blockss

226 blockContains str (CodeBlock attr src _) = T.isInfixOf str (T.toLower src)

227 blockContains str (HtmlBlock txt) = False -- TODO

228 blockContains str HRule = False

229

230 inlineContains :: T.Text -> Inline a -> Bool

231 inlineContains str (Str s) = T.isInfixOf str (T.toLower s)

232 inlineContains str Space = False

233 inlineContains str SoftBreak = False

234 inlineContains str LineBreak = False

235 inlineContains str (Emph txt) = F.any (inlineContains str) txt

236 inlineContains str (Strong txt) = F.any (inlineContains str) txt

237 inlineContains str (Code txt _) = T.isInfixOf str (T.toLower txt)

238 inlineContains str (Link body url title) = F.any (inlineContains str) body

239 inlineContains str (Image body url title) = False

240 inlineContains str (Entity a) = False

241 inlineContains str (RawHtml txt) = T.isInfixOf str (T.toLower txt)

242

243

244renderHtml :: Docstring DocTerm -> Html

245renderHtml = renderDoc . fromDocstring

246 where

247 fromDocstring :: Docstring DocTerm -> CT.Doc

248 fromDocstring (DocString opts blocks) = CT.Doc opts (fmap fromBlock blocks)

249

250 fromBlock :: Block DocTerm -> CT.Block

251 fromBlock (Para inlines) = CT.Para (fmap fromInline inlines)

252 fromBlock (Header i inlines) = CT.Header i (fmap fromInline inlines)

253 fromBlock (Blockquote blocks) = CT.Blockquote (fmap fromBlock blocks)

254 fromBlock (List b t blocks) = CT.List b t (fmap (fmap fromBlock) blocks)

255 fromBlock (CodeBlock attrs text _) = CT.CodeBlock attrs text

256 fromBlock (HtmlBlock src) = CT.HtmlBlock src

257 fromBlock HRule = CT.HRule

258

259 fromInline :: Inline DocTerm -> CT.Inline

260 fromInline (Str t) = CT.Str t

261 fromInline Space = CT.Space

262 fromInline SoftBreak = CT.SoftBreak

263 fromInline LineBreak = CT.LineBreak

264 fromInline (Emph is) = CT.Emph (fmap fromInline is)

265 fromInline (Strong is) = CT.Strong (fmap fromInline is)

266 fromInline (Code src _) = CT.Code src

267 fromInline (Link is url title) = CT.Link (fmap fromInline is) url title

268 fromInline (Image is url title) = CT.Image (fmap fromInline is) url title

269 fromInline (Entity txt) = CT.Entity txt

270 fromInline (RawHtml src) = CT.RawHtml src

271

272

273-- | Annotate the code samples in a docstring

274annotCode :: forall a b. (String -> b) -- ^ How to annotate code samples

275 -> Docstring a

276 -> Docstring b

277annotCode annot (DocString opts blocks)

278 = DocString opts $ fmap annotCodeBlock blocks

279 where

280 annotCodeBlock :: Block a -> Block b

281 annotCodeBlock (Para inlines) = Para (fmap annotCodeInline inlines)

282 annotCodeBlock (Header i inlines) = Header i (fmap annotCodeInline inlines)

283 annotCodeBlock (Blockquote blocks) = Blockquote (fmap annotCodeBlock blocks)

284 annotCodeBlock (List b t blocks) = List b t (fmap (fmap annotCodeBlock) blocks)

285 annotCodeBlock (CodeBlock attrs src _) = CodeBlock attrs src (annot (T.unpack src))

286 annotCodeBlock (HtmlBlock src) = HtmlBlock src

287 annotCodeBlock HRule = HRule

288

289 annotCodeInline :: Inline a -> Inline b

290 annotCodeInline (Str t) = Str t

291 annotCodeInline Space = Space

292 annotCodeInline SoftBreak = SoftBreak

293 annotCodeInline LineBreak = LineBreak

294 annotCodeInline (Emph is) = Emph (fmap annotCodeInline is)

295 annotCodeInline (Strong is) = Strong (fmap annotCodeInline is)

296 annotCodeInline (Code src _) = Code src (annot (T.unpack src))

297 annotCodeInline (Link is url title) = Link (fmap annotCodeInline is) url title

298 annotCodeInline (Image is url title) = Image (fmap annotCodeInline is) url title

299 annotCodeInline (Entity txt) = Entity txt

300 annotCodeInline (RawHtml src) = RawHtml src