src/Idris/Docstrings.hs · Idris-dev

1{-# LANGUAGE DeriveFunctor, ScopedTypeVariables #-}

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

3

4-- | Wrapper around Markdown library

5module Idris.Docstrings (

6 Docstring(..), Block(..), Inline(..), parseDocstring, renderDocstring, emptyDocstring, nullDocstring, noDocs,

7 overview, containsText, renderHtml, annotCode, DocTerm(..), renderDocTerm, checkDocstring

8 ) where

9

10import qualified Cheapskate as C

11import qualified Cheapskate.Types as CT

12import Cheapskate.Html (renderDoc)

13

14import Util.Pretty

15

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

17

18import Prelude hiding ((<$>))

19

20import qualified Data.Text as T

21import qualified Data.Foldable as F

22import Data.Foldable (Foldable)

23import Data.Traversable (Traversable)

24import qualified Data.Sequence as S

25

26import Control.DeepSeq (NFData(..))

27

28import Text.Blaze.Html (Html)

29

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

31data DocTerm = Unchecked

32 | Checked Term

33 | Example Term

34 | Failing Err

35 deriving Show

36

37-- | Render a term in the documentation

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

39renderDocTerm pp norm Unchecked src = text src

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

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

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

43 pp (norm tm)

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

45

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

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

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

49 deriving (Show, Functor, Foldable, Traversable)

50

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

52

53-- | Block-level elements.

54data Block a = Para (Inlines a)

55 | Header Int (Inlines a)

56 | Blockquote (Blocks a)

57 | List Bool CT.ListType [Blocks a]

58 | CodeBlock CT.CodeAttr T.Text a

59 | HtmlBlock T.Text

60 | HRule

61 deriving (Show, Functor, Foldable, Traversable)

62

63data Inline a = Str T.Text

64 | Space

65 | SoftBreak

66 | LineBreak

67 | Emph (Inlines a)

68 | Strong (Inlines a)

69 | Code T.Text a

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

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

72 | Entity T.Text

73 | RawHtml T.Text

74 deriving (Show, Functor, Foldable, Traversable)

75

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

77

78

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

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

81-- source and the original annotation.

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

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

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

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

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

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

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

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

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

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

92 (T.unpack src)

93 tm)

94 checkBlock f (HtmlBlock src) = HtmlBlock src

95 checkBlock f HRule = HRule

96

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

98 checkInline f (Str txt) = Str txt

99 checkInline f Space = Space

100 checkInline f SoftBreak = SoftBreak

101 checkInline f LineBreak = LineBreak

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

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

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

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

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

107 checkInline f (Entity txt) = Entity txt

108 checkInline f (RawHtml src) = RawHtml src

109

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

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

112parseDocstring = toDocstring . C.markdown options

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

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

115

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

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

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

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

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

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

122 toBlock (CT.HtmlBlock src) = HtmlBlock src

123 toBlock CT.HRule = HRule

124

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

126 toInline (CT.Str t) = Str t

127 toInline CT.Space = Space

128 toInline CT.SoftBreak = SoftBreak

129 toInline CT.LineBreak = LineBreak

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

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

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

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

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

135 toInline (CT.Entity txt) = Entity txt

136 toInline (CT.RawHtml src) = RawHtml src

137

138

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

140 , CT.allowRawHtml = False

141 , CT.preserveHardBreaks = True

142 , CT.debug = False

143 }

144

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

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

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

148

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

150-- argument docstring, for use in summaries.

151overview :: Docstring a -> Docstring a

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

153

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

155 -> Blocks a -> Doc OutputAnnotation

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

157 fmap (renderBlock pp) blocks

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

159 | otherwise = empty

160

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

162 -> Block a -> Doc OutputAnnotation

163renderBlock pp (Para inlines) = renderInlines pp inlines

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

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

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

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

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

169renderBlock pp HRule = text "----------------------"

170

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

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

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

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

175 vsep $

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

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

178 where punc = case nw of

179 CT.PeriodFollowing -> char '.'

180 CT.ParenFollowing -> char '('

181

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

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

184

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

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

187renderInline pp Space = softline

188renderInline pp SoftBreak = softline

189renderInline pp LineBreak = line

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

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

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

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

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

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

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

197

198-- | The empty docstring

199emptyDocstring :: Docstring a

200emptyDocstring = DocString options S.empty

201

202-- | Check whether a docstring is emtpy

203nullDocstring :: Docstring a -> Bool

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

205

206-- | Empty documentation for a definition

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

208noDocs = (emptyDocstring, [])

209

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

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

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

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

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

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

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

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

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

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

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

221 blockContains str HRule = False

222

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

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

225 inlineContains str Space = False

226 inlineContains str SoftBreak = False

227 inlineContains str LineBreak = False

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

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

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

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

232 inlineContains str (Image body url title) = False

233 inlineContains str (Entity a) = False

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

235

236

237renderHtml :: Docstring DocTerm -> Html

238renderHtml = renderDoc . fromDocstring

239 where

240 fromDocstring :: Docstring DocTerm -> CT.Doc

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

242

243 fromBlock :: Block DocTerm -> CT.Block

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

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

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

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

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

249 fromBlock (HtmlBlock src) = CT.HtmlBlock src

250 fromBlock HRule = CT.HRule

251

252 fromInline :: Inline DocTerm -> CT.Inline

253 fromInline (Str t) = CT.Str t

254 fromInline Space = CT.Space

255 fromInline SoftBreak = CT.SoftBreak

256 fromInline LineBreak = CT.LineBreak

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

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

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

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

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

262 fromInline (Entity txt) = CT.Entity txt

263 fromInline (RawHtml src) = CT.RawHtml src

264

265

266-- | Annotate the code samples in a docstring

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

268 -> Docstring a

269 -> Docstring b

270annotCode annot (DocString opts blocks)

271 = DocString opts $ fmap annotCodeBlock blocks

272 where

273 annotCodeBlock :: Block a -> Block b

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

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

276 annotCodeBlock (Blockquote blocks) = Blockquote (fmap annotCodeBlock blocks)

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

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

279 annotCodeBlock (HtmlBlock src) = HtmlBlock src

280 annotCodeBlock HRule = HRule

281

282 annotCodeInline :: Inline a -> Inline b

283 annotCodeInline (Str t) = Str t

284 annotCodeInline Space = Space

285 annotCodeInline SoftBreak = SoftBreak

286 annotCodeInline LineBreak = LineBreak

287 annotCodeInline (Emph is) = Emph (fmap annotCodeInline is)

288 annotCodeInline (Strong is) = Strong (fmap annotCodeInline is)

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

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

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

292 annotCodeInline (Entity txt) = Entity txt

293 annotCodeInline (RawHtml src) = RawHtml src