src/Idris/Docstrings.hs · Idris-dev

git.iko.soy/Idris-dev

on 7afa310 help sign in

Idris-dev/src/Idris/Docstrings.hs

252 lines 12 kB history raw

1{-# LANGUAGE DeriveFunctor, ScopedTypeVariables #-}

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

4-- | Wrapper around Markdown library

5module Idris.Docstrings (

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

7 overview, containsText, renderHtml, annotCode

8 ) where

10import qualified Cheapskate as C

11import qualified Cheapskate.Types as CT

12import Cheapskate.Html (renderDoc)

14import Util.Pretty

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

18import qualified Data.Text as T

19import qualified Data.Foldable as F

20import Data.Foldable (Foldable)

21import Data.Traversable (Traversable)

22import qualified Data.Sequence as S

24import Control.DeepSeq (NFData(..))

26import Text.Blaze.Html (Html)

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

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

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

31 deriving (Show, Functor, Foldable, Traversable)

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

35-- | Block-level elements.

36data Block a = Para (Inlines a)

37 | Header Int (Inlines a)

38 | Blockquote (Blocks a)

39 | List Bool CT.ListType [Blocks a]

40 | CodeBlock CT.CodeAttr T.Text a

41 | HtmlBlock T.Text

42 | HRule

43 deriving (Show, Functor, Foldable, Traversable)

45data Inline a = Str T.Text

46 | Space

47 | SoftBreak

48 | LineBreak

49 | Emph (Inlines a)

50 | Strong (Inlines a)

51 | Code T.Text a

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

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

54 | Entity T.Text

55 | RawHtml T.Text

56 deriving (Show, Functor, Foldable, Traversable)

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

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

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

63parseDocstring = toDocstring . C.markdown options

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

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

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

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

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

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

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

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

73 toBlock (CT.HtmlBlock src) = HtmlBlock src

74 toBlock CT.HRule = HRule

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

77 toInline (CT.Str t) = Str t

78 toInline CT.Space = Space

79 toInline CT.SoftBreak = SoftBreak

80 toInline CT.LineBreak = LineBreak

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

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

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

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

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

86 toInline (CT.Entity txt) = Entity txt

87 toInline (CT.RawHtml src) = RawHtml src

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

91 , CT.allowRawHtml = False

92 , CT.preserveHardBreaks = True

93 , CT.debug = False

94 }

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

97renderDocstring :: (a -> Doc OutputAnnotation) -> (a -> a) -> Docstring (Maybe a) -> Doc OutputAnnotation

98renderDocstring pp norm (DocString _ blocks) = renderBlocks pp norm blocks

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

101-- argument docstring, for use in summaries.

102overview :: Docstring a -> Docstring a

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

104

105renderBlocks :: (a -> Doc OutputAnnotation) -> (a -> a)

106 -> Blocks (Maybe a) -> Doc OutputAnnotation

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

108 fmap (renderBlock pp norm) blocks

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

110 | otherwise = empty

111

112renderBlock :: (a -> Doc OutputAnnotation) -> (a -> a)

113 -> Block (Maybe a) -> Doc OutputAnnotation

114renderBlock pp norm (Para inlines) = renderInlines pp inlines

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

116renderBlock pp norm (Blockquote blocks) = indent 8 $ renderBlocks pp norm blocks

117renderBlock pp norm (List b ty blockss) = renderList pp norm b ty blockss

118renderBlock pp norm (CodeBlock attr src Nothing) = indent 8 $ text (T.unpack src)

119renderBlock pp norm (CodeBlock attr src (Just tm))

120 | isExample attr = indent 4 $

121 text ">" <+> align (group (pp tm)) <$>

122 align (group (pp (norm tm)))

123 | otherwise = indent 4 $ pp tm

124 where isExample (CT.CodeAttr lang info) = T.pack "example" `elem` lang : T.words info

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

126renderBlock pp norm HRule = text "----------------------"

127

128renderList :: (a -> Doc OutputAnnotation) -> (a -> a)

129 -> Bool -> CT.ListType -> [Blocks (Maybe a)] -> Doc OutputAnnotation

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

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

132 vsep $

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

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

135 where punc = case nw of

136 CT.PeriodFollowing -> char '.'

137 CT.ParenFollowing -> char '('

138

139renderInlines :: (a -> Doc OutputAnnotation) -> Inlines (Maybe a) -> Doc OutputAnnotation

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

141

142renderInline :: (a -> Doc OutputAnnotation) -> Inline (Maybe a) -> Doc OutputAnnotation

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

144renderInline pp Space = softline

145renderInline pp SoftBreak = softline

146renderInline pp LineBreak = line

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

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

149renderInline pp (Code txt Nothing) = text $ T.unpack txt

150renderInline pp (Code txt (Just tm)) = pp tm

151renderInline pp (Link body url title) = annotate (AnnTextFmt UnderlineText) (renderInlines pp body) <+>

152 parens (text $ T.unpack url)

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

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

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

156

157-- | The empty docstring

158emptyDocstring :: Docstring a

159emptyDocstring = DocString options S.empty

160

161-- | Check whether a docstring is emtpy

162nullDocstring :: Docstring a -> Bool

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

164

165-- | Empty documentation for a definition

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

167noDocs = (emptyDocstring, [])

168

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

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

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

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

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

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

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

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

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

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

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

180 blockContains str HRule = False

181

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

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

184 inlineContains str Space = False

185 inlineContains str SoftBreak = False

186 inlineContains str LineBreak = False

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

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

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

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

191 inlineContains str (Image body url title) = False

192 inlineContains str (Entity a) = False

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

194

195

196renderHtml :: Docstring (Maybe Term) -> Html

197renderHtml = renderDoc . fromDocstring

198 where

199 fromDocstring :: Docstring (Maybe Term) -> CT.Doc

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

201

202 fromBlock :: Block (Maybe Term) -> CT.Block

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

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

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

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

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

208 fromBlock (HtmlBlock src) = CT.HtmlBlock src

209 fromBlock HRule = CT.HRule

210

211 fromInline :: Inline (Maybe Term) -> CT.Inline

212 fromInline (Str t) = CT.Str t

213 fromInline Space = CT.Space

214 fromInline SoftBreak = CT.SoftBreak

215 fromInline LineBreak = CT.LineBreak

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

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

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

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

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

221 fromInline (Entity txt) = CT.Entity txt

222 fromInline (RawHtml src) = CT.RawHtml src

223

224

225-- | Annotate the code samples in a docstring

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

227 -> Docstring a

228 -> Docstring b

229annotCode annot (DocString opts blocks)

230 = DocString opts $ fmap annotCodeBlock blocks

231 where

232 annotCodeBlock :: Block a -> Block b

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

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

235 annotCodeBlock (Blockquote blocks) = Blockquote (fmap annotCodeBlock blocks)

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

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

238 annotCodeBlock (HtmlBlock src) = HtmlBlock src

239 annotCodeBlock HRule = HRule

240

241 annotCodeInline :: Inline a -> Inline b

242 annotCodeInline (Str t) = Str t

243 annotCodeInline Space = Space

244 annotCodeInline SoftBreak = SoftBreak

245 annotCodeInline LineBreak = LineBreak

246 annotCodeInline (Emph is) = Emph (fmap annotCodeInline is)

247 annotCodeInline (Strong is) = Strong (fmap annotCodeInline is)

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

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

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

251 annotCodeInline (Entity txt) = Entity txt

252 annotCodeInline (RawHtml src) = RawHtml src