on 4162113 help sign in
Idris-dev/src/Idris/Docstrings.hs
298 lines 15 kB history raw
1{-|
2Module : Idris.Docstrings
3Description : Wrapper around Markdown library.
5License : BSD3
6Maintainer : The Idris Community.
7-}
9{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable,
10 ScopedTypeVariables #-}
11{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
12module Idris.Docstrings (
13 Docstring(..), Block(..), Inline(..), parseDocstring, renderDocstring
14 , emptyDocstring, nullDocstring, noDocs, overview, containsText
15 , renderHtml, annotCode, DocTerm(..), renderDocTerm, checkDocstring
16 ) where
18import Idris.Core.TT (Err, Name, OutputAnnotation(..), Term, TextFormatting(..))
20import Util.Pretty
22import Prelude hiding ((<$>))
24import qualified Cheapskate as C
25import Cheapskate.Html (renderDoc)
26import qualified Cheapskate.Types as CT
27import Data.Foldable (Foldable)
28import qualified Data.Foldable as F
29import qualified Data.Sequence as S
30import qualified Data.Text as T
31import Data.Traversable (Traversable)
32import GHC.Generics (Generic)
33import Text.Blaze.Html (Html)
35-- | The various kinds of code samples that can be embedded in docs
36data DocTerm = Unchecked
37 | Checked Term
38 | Example Term
39 | Failing Err
40 deriving (Show, Generic)
42-- | Render a term in the documentation
43renderDocTerm :: (Term -> Doc OutputAnnotation) -> (Term -> Term) -> DocTerm -> String -> Doc OutputAnnotation
44renderDocTerm pp norm Unchecked src = text src
45renderDocTerm pp norm (Checked tm) src = pp tm
46renderDocTerm pp norm (Example tm) src = align $
47 text ">" <+> align (pp tm) <$>
48 pp (norm tm)
49renderDocTerm pp norm (Failing err) src = annotate (AnnErr err) $ text src
51-- | Representation of Idris's inline documentation. The type paramter
52-- represents the type of terms that are associated with code blocks.
53data Docstring a = DocString CT.Options (Blocks a)
54 deriving (Show, Functor, Foldable, Traversable, Generic)
56type Blocks a = S.Seq (Block a)
58-- | Block-level elements.
59data Block a = Para (Inlines a)
60 | Header Int (Inlines a)
61 | Blockquote (Blocks a)
62 | List Bool CT.ListType [Blocks a]
63 | CodeBlock CT.CodeAttr T.Text a
64 | HtmlBlock T.Text
65 | HRule
66 deriving (Show, Functor, Foldable, Traversable, Generic)
68data Inline a = Str T.Text
69 | Space
70 | SoftBreak
71 | LineBreak
72 | Emph (Inlines a)
73 | Strong (Inlines a)
74 | Code T.Text a
75 | Link (Inlines a) T.Text T.Text
76 | Image (Inlines a) T.Text T.Text
77 | Entity T.Text
78 | RawHtml T.Text
79 deriving (Show, Functor, Foldable, Traversable, Generic)
81type Inlines a = S.Seq (Inline a)
84-- | Run some kind of processing step over code in a Docstring. The code
85-- processor gets the language and annotations as parameters, along with the
86-- source and the original annotation.
87checkDocstring :: forall a b. (String -> [String] -> String -> a -> b) -> Docstring a -> Docstring b
88checkDocstring f (DocString opts blocks) = DocString opts (fmap (checkBlock f) blocks)
89 where checkBlock :: (String -> [String] -> String -> a -> b) -> Block a -> Block b
90 checkBlock f (Para inlines) = Para (fmap (checkInline f) inlines)
91 checkBlock f (Header i inlines) = Header i (fmap (checkInline f) inlines)
92 checkBlock f (Blockquote bs) = Blockquote (fmap (checkBlock f) bs)
93 checkBlock f (List b t blocks) = List b t (fmap (fmap (checkBlock f)) blocks)
94 checkBlock f (CodeBlock attrs src tm) = CodeBlock attrs src
95 (f (T.unpack $ CT.codeLang attrs)
96 (words . T.unpack $ CT.codeInfo attrs)
97 (T.unpack src)
98 tm)
99 checkBlock f (HtmlBlock src) = HtmlBlock src
100 checkBlock f HRule = HRule
102 checkInline :: (String -> [String] -> String -> a -> b) -> Inline a -> Inline b
103 checkInline f (Str txt) = Str txt
104 checkInline f Space = Space
105 checkInline f SoftBreak = SoftBreak
106 checkInline f LineBreak = LineBreak
107 checkInline f (Emph is) = Emph (fmap (checkInline f) is)
108 checkInline f (Strong is) = Strong (fmap (checkInline f) is)
109 checkInline f (Code src x) = Code src (f "" [] (T.unpack src) x)
110 checkInline f (Link is url title) = Link (fmap (checkInline f) is) url title
111 checkInline f (Image is url title) = Image (fmap (checkInline f) is) url title
112 checkInline f (Entity txt) = Entity txt
113 checkInline f (RawHtml src) = RawHtml src
115-- | Construct a docstring from a Text that contains Markdown-formatted docs
116parseDocstring :: T.Text -> Docstring ()
117parseDocstring = toDocstring . C.markdown options
118 where toDocstring :: CT.Doc -> Docstring ()
119 toDocstring (CT.Doc opts blocks) = DocString opts (fmap toBlock blocks)
121 toBlock :: CT.Block -> Block ()
122 toBlock (CT.Para inlines) = Para (fmap toInline inlines)
123 toBlock (CT.Header i inlines) = Header i (fmap toInline inlines)
124 toBlock (CT.Blockquote blocks) = Blockquote (fmap toBlock blocks)
125 toBlock (CT.List b t blocks) = List b t (fmap (fmap toBlock) blocks)
126 toBlock (CT.CodeBlock attrs text) = CodeBlock attrs text ()
127 toBlock (CT.HtmlBlock src) = HtmlBlock src
128 toBlock CT.HRule = HRule
130 toInline :: CT.Inline -> Inline ()
131 toInline (CT.Str t) = Str t
132 toInline CT.Space = Space
133 toInline CT.SoftBreak = SoftBreak
134 toInline CT.LineBreak = LineBreak
135 toInline (CT.Emph is) = Emph (fmap toInline is)
136 toInline (CT.Strong is) = Strong (fmap toInline is)
137 toInline (CT.Code src) = Code src ()
138 toInline (CT.Link is url title) = Link (fmap toInline is) url title
139 toInline (CT.Image is url title) = Image (fmap toInline is) url title
140 toInline (CT.Entity txt) = Entity txt
141 toInline (CT.RawHtml src) = RawHtml src
144options = CT.Options { CT.sanitize = True
145 , CT.allowRawHtml = False
146 , CT.preserveHardBreaks = True
147 , CT.debug = False
148 }
150-- | Convert a docstring to be shown by the pretty-printer
151renderDocstring :: (a -> String -> Doc OutputAnnotation) -> Docstring a -> Doc OutputAnnotation
152renderDocstring pp (DocString _ blocks) = renderBlocks pp blocks
154-- | Construct a docstring consisting of the first block-level element of the
155-- argument docstring, for use in summaries.
156overview :: Docstring a -> Docstring a
157overview (DocString opts blocks) = DocString opts (S.take 1 blocks)
159renderBlocks :: (a -> String -> Doc OutputAnnotation)
160 -> Blocks a -> Doc OutputAnnotation
161renderBlocks pp blocks | S.length blocks > 1 = F.foldr1 (\b1 b2 -> b1 <> line <> line <> b2) $
162 fmap (renderBlock pp) blocks
163 | S.length blocks == 1 = renderBlock pp (S.index blocks 0)
164 | otherwise = empty
166renderBlock :: (a -> String -> Doc OutputAnnotation)
167 -> Block a -> Doc OutputAnnotation
168renderBlock pp (Para inlines) = renderInlines pp inlines
169renderBlock pp (Header lvl inlines) = renderInlines pp inlines <+> parens (text (show lvl))
170renderBlock pp (Blockquote blocks) = indent 8 $ renderBlocks pp blocks
171renderBlock pp (List b ty blockss) = renderList pp b ty blockss
172renderBlock pp (CodeBlock attr src tm) = indent 4 $ pp tm (T.unpack src)
173renderBlock pp (HtmlBlock txt) = text "<html block>" -- TODO
174renderBlock pp HRule = text "----------------------"
176renderList :: (a -> String -> Doc OutputAnnotation)
177 -> Bool -> CT.ListType -> [Blocks a] -> Doc OutputAnnotation
178renderList pp b (CT.Bullet c) blockss = vsep $ map (hang 4 . (char c <+>) . renderBlocks pp) blockss
179renderList pp b (CT.Numbered nw i) blockss =
180 vsep $
181 zipWith3 (\n p txt -> hang 4 $ text (show n) <> p <+> txt)
182 [i..] (repeat punc) (map (renderBlocks pp) blockss)
183 where punc = case nw of
184 CT.PeriodFollowing -> char '.'
185 CT.ParenFollowing -> char '('
187renderInlines :: (a -> String -> Doc OutputAnnotation) -> Inlines a -> Doc OutputAnnotation
188renderInlines pp = F.foldr (<>) empty . fmap (renderInline pp)
190renderInline :: (a -> String -> Doc OutputAnnotation) -> Inline a -> Doc OutputAnnotation
191renderInline pp (Str s) = text $ T.unpack s
192renderInline pp Space = softline
193renderInline pp SoftBreak = softline
194renderInline pp LineBreak = line
195renderInline pp (Emph txt) = annotate (AnnTextFmt ItalicText) $ renderInlines pp txt
196renderInline pp (Strong txt) = annotate (AnnTextFmt BoldText) $ renderInlines pp txt
197renderInline pp (Code txt tm) = pp tm $ T.unpack txt
198renderInline pp (Link body url title) = annotate (AnnLink (T.unpack url)) (renderInlines pp body)
199renderInline pp (Image body url title) = text "<image>" -- TODO
200renderInline pp (Entity a) = text $ "<entity " ++ T.unpack a ++ ">" -- TODO
201renderInline pp (RawHtml txt) = text "<html content>" --TODO
203-- | The empty docstring
204emptyDocstring :: Docstring a
205emptyDocstring = DocString options S.empty
207-- | Check whether a docstring is emtpy
208nullDocstring :: Docstring a -> Bool
209nullDocstring (DocString _ blocks) = S.null blocks
211-- | Empty documentation for a definition
212noDocs :: (Docstring a, [(Name, Docstring a)])
213noDocs = (emptyDocstring, [])
215-- | Does a string occur in the docstring?
216containsText :: T.Text -> Docstring a -> Bool
217containsText str (DocString _ blocks) = F.any (blockContains (T.toLower str)) blocks
218 -- blockContains and inlineContains should always be called with a lower-case search string
219 where blockContains :: T.Text -> Block a -> Bool
220 blockContains str (Para inlines) = F.any (inlineContains str) inlines
221 blockContains str (Header lvl inlines) = F.any (inlineContains str) inlines
222 blockContains str (Blockquote blocks) = F.any (blockContains str) blocks
223 blockContains str (List b ty blockss) = F.any (F.any (blockContains str)) blockss
224 blockContains str (CodeBlock attr src _) = T.isInfixOf str (T.toLower src)
225 blockContains str (HtmlBlock txt) = False -- TODO
226 blockContains str HRule = False
228 inlineContains :: T.Text -> Inline a -> Bool
229 inlineContains str (Str s) = T.isInfixOf str (T.toLower s)
230 inlineContains str Space = False
231 inlineContains str SoftBreak = False
232 inlineContains str LineBreak = False
233 inlineContains str (Emph txt) = F.any (inlineContains str) txt
234 inlineContains str (Strong txt) = F.any (inlineContains str) txt
235 inlineContains str (Code txt _) = T.isInfixOf str (T.toLower txt)
236 inlineContains str (Link body url title) = F.any (inlineContains str) body
237 inlineContains str (Image body url title) = False
238 inlineContains str (Entity a) = False
239 inlineContains str (RawHtml txt) = T.isInfixOf str (T.toLower txt)
242renderHtml :: Docstring DocTerm -> Html
243renderHtml = renderDoc . fromDocstring
244 where
245 fromDocstring :: Docstring DocTerm -> CT.Doc
246 fromDocstring (DocString opts blocks) = CT.Doc opts (fmap fromBlock blocks)
248 fromBlock :: Block DocTerm -> CT.Block
249 fromBlock (Para inlines) = CT.Para (fmap fromInline inlines)
250 fromBlock (Header i inlines) = CT.Header i (fmap fromInline inlines)
251 fromBlock (Blockquote blocks) = CT.Blockquote (fmap fromBlock blocks)
252 fromBlock (List b t blocks) = CT.List b t (fmap (fmap fromBlock) blocks)
253 fromBlock (CodeBlock attrs text _) = CT.CodeBlock attrs text
254 fromBlock (HtmlBlock src) = CT.HtmlBlock src
255 fromBlock HRule = CT.HRule
257 fromInline :: Inline DocTerm -> CT.Inline
258 fromInline (Str t) = CT.Str t
259 fromInline Space = CT.Space
260 fromInline SoftBreak = CT.SoftBreak
261 fromInline LineBreak = CT.LineBreak
262 fromInline (Emph is) = CT.Emph (fmap fromInline is)
263 fromInline (Strong is) = CT.Strong (fmap fromInline is)
264 fromInline (Code src _) = CT.Code src
265 fromInline (Link is url title) = CT.Link (fmap fromInline is) url title
266 fromInline (Image is url title) = CT.Image (fmap fromInline is) url title
267 fromInline (Entity txt) = CT.Entity txt
268 fromInline (RawHtml src) = CT.RawHtml src
271-- | Annotate the code samples in a docstring
272annotCode :: forall a b. (String -> b) -- ^ How to annotate code samples
273 -> Docstring a
274 -> Docstring b
275annotCode annot (DocString opts blocks)
276 = DocString opts $ fmap annotCodeBlock blocks
277 where
278 annotCodeBlock :: Block a -> Block b
279 annotCodeBlock (Para inlines) = Para (fmap annotCodeInline inlines)
280 annotCodeBlock (Header i inlines) = Header i (fmap annotCodeInline inlines)
281 annotCodeBlock (Blockquote blocks) = Blockquote (fmap annotCodeBlock blocks)
282 annotCodeBlock (List b t blocks) = List b t (fmap (fmap annotCodeBlock) blocks)
283 annotCodeBlock (CodeBlock attrs src _) = CodeBlock attrs src (annot (T.unpack src))
284 annotCodeBlock (HtmlBlock src) = HtmlBlock src
285 annotCodeBlock HRule = HRule
287 annotCodeInline :: Inline a -> Inline b
288 annotCodeInline (Str t) = Str t
289 annotCodeInline Space = Space
290 annotCodeInline SoftBreak = SoftBreak
291 annotCodeInline LineBreak = LineBreak
292 annotCodeInline (Emph is) = Emph (fmap annotCodeInline is)
293 annotCodeInline (Strong is) = Strong (fmap annotCodeInline is)
294 annotCodeInline (Code src _) = Code src (annot (T.unpack src))
295 annotCodeInline (Link is url title) = Link (fmap annotCodeInline is) url title
296 annotCodeInline (Image is url title) = Image (fmap annotCodeInline is) url title
297 annotCodeInline (Entity txt) = Entity txt
298 annotCodeInline (RawHtml src) = RawHtml src