git.iko.soy/Idris-dev
on a5a63fc help sign in
Idris-dev/src/Idris/Docstrings.hs
244 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) -> Docstring (Maybe a) -> Doc OutputAnnotation
98renderDocstring pp (DocString _ blocks) = renderBlocks pp 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)
105renderBlocks :: (a -> Doc OutputAnnotation) -> Blocks (Maybe a) -> Doc OutputAnnotation
106renderBlocks pp blocks | S.length blocks > 1 = F.foldr1 (\b1 b2 -> b1 <> line <> line <> b2) $
107 fmap (renderBlock pp) blocks
108 | S.length blocks == 1 = renderBlock pp (S.index blocks 0)
109 | otherwise = empty
111renderBlock :: (a -> Doc OutputAnnotation) -> Block (Maybe a) -> Doc OutputAnnotation
112renderBlock pp (Para inlines) = renderInlines pp inlines
113renderBlock pp (Header lvl inlines) = renderInlines pp inlines <+> parens (text (show lvl))
114renderBlock pp (Blockquote blocks) = indent 8 $ renderBlocks pp blocks
115renderBlock pp (List b ty blockss) = renderList pp b ty blockss
116renderBlock pp (CodeBlock attr src Nothing) = indent 8 $ text (T.unpack src)
117renderBlock pp (CodeBlock attr src (Just tm)) = indent 8 $ pp tm
118renderBlock pp (HtmlBlock txt) = text "<html block>" -- TODO
119renderBlock pp HRule = text "----------------------"
121renderList :: (a -> Doc OutputAnnotation) -> Bool -> CT.ListType -> [Blocks (Maybe a)] -> Doc OutputAnnotation
122renderList pp b (CT.Bullet c) blockss = vsep $ map (hang 4 . (char c <+>) . renderBlocks pp) blockss
123renderList pp b (CT.Numbered nw i) blockss =
124 vsep $
125 zipWith3 (\n p txt -> hang 4 $ text (show n) <> p <+> txt)
126 [i..] (repeat punc) (map (renderBlocks pp) blockss)
127 where punc = case nw of
128 CT.PeriodFollowing -> char '.'
129 CT.ParenFollowing -> char '('
131renderInlines :: (a -> Doc OutputAnnotation) -> Inlines (Maybe a) -> Doc OutputAnnotation
132renderInlines pp = F.foldr (<>) empty . fmap (renderInline pp)
134renderInline :: (a -> Doc OutputAnnotation) -> Inline (Maybe a) -> Doc OutputAnnotation
135renderInline pp (Str s) = text $ T.unpack s
136renderInline pp Space = softline
137renderInline pp SoftBreak = softline
138renderInline pp LineBreak = line
139renderInline pp (Emph txt) = annotate (AnnTextFmt ItalicText) $ renderInlines pp txt
140renderInline pp (Strong txt) = annotate (AnnTextFmt BoldText) $ renderInlines pp txt
141renderInline pp (Code txt Nothing) = text $ T.unpack txt
142renderInline pp (Code txt (Just tm)) = pp tm
143renderInline pp (Link body url title) = annotate (AnnTextFmt UnderlineText) (renderInlines pp body) <+>
144 parens (text $ T.unpack url)
145renderInline pp (Image body url title) = text "<image>" -- TODO
146renderInline pp (Entity a) = text $ "<entity " ++ T.unpack a ++ ">" -- TODO
147renderInline pp (RawHtml txt) = text "<html content>" --TODO
149-- | The empty docstring
150emptyDocstring :: Docstring a
151emptyDocstring = DocString options S.empty
153-- | Check whether a docstring is emtpy
154nullDocstring :: Docstring a -> Bool
155nullDocstring (DocString _ blocks) = S.null blocks
157-- | Empty documentation for a definition
158noDocs :: (Docstring a, [(Name, Docstring a)])
159noDocs = (emptyDocstring, [])
161-- | Does a string occur in the docstring?
162containsText :: T.Text -> Docstring a -> Bool
163containsText str (DocString _ blocks) = F.any (blockContains (T.toLower str)) blocks
164 -- blockContains and inlineContains should always be called with a lower-case search string
165 where blockContains :: T.Text -> Block a -> Bool
166 blockContains str (Para inlines) = F.any (inlineContains str) inlines
167 blockContains str (Header lvl inlines) = F.any (inlineContains str) inlines
168 blockContains str (Blockquote blocks) = F.any (blockContains str) blocks
169 blockContains str (List b ty blockss) = F.any (F.any (blockContains str)) blockss
170 blockContains str (CodeBlock attr src _) = T.isInfixOf str (T.toLower src)
171 blockContains str (HtmlBlock txt) = False -- TODO
172 blockContains str HRule = False
174 inlineContains :: T.Text -> Inline a -> Bool
175 inlineContains str (Str s) = T.isInfixOf str (T.toLower s)
176 inlineContains str Space = False
177 inlineContains str SoftBreak = False
178 inlineContains str LineBreak = False
179 inlineContains str (Emph txt) = F.any (inlineContains str) txt
180 inlineContains str (Strong txt) = F.any (inlineContains str) txt
181 inlineContains str (Code txt _) = T.isInfixOf str (T.toLower txt)
182 inlineContains str (Link body url title) = F.any (inlineContains str) body
183 inlineContains str (Image body url title) = False
184 inlineContains str (Entity a) = False
185 inlineContains str (RawHtml txt) = T.isInfixOf str (T.toLower txt)
188renderHtml :: Docstring (Maybe Term) -> Html
189renderHtml = renderDoc . fromDocstring
190 where
191 fromDocstring :: Docstring (Maybe Term) -> CT.Doc
192 fromDocstring (DocString opts blocks) = CT.Doc opts (fmap fromBlock blocks)
194 fromBlock :: Block (Maybe Term) -> CT.Block
195 fromBlock (Para inlines) = CT.Para (fmap fromInline inlines)
196 fromBlock (Header i inlines) = CT.Header i (fmap fromInline inlines)
197 fromBlock (Blockquote blocks) = CT.Blockquote (fmap fromBlock blocks)
198 fromBlock (List b t blocks) = CT.List b t (fmap (fmap fromBlock) blocks)
199 fromBlock (CodeBlock attrs text _) = CT.CodeBlock attrs text
200 fromBlock (HtmlBlock src) = CT.HtmlBlock src
201 fromBlock HRule = CT.HRule
203 fromInline :: Inline (Maybe Term) -> CT.Inline
204 fromInline (Str t) = CT.Str t
205 fromInline Space = CT.Space
206 fromInline SoftBreak = CT.SoftBreak
207 fromInline LineBreak = CT.LineBreak
208 fromInline (Emph is) = CT.Emph (fmap fromInline is)
209 fromInline (Strong is) = CT.Strong (fmap fromInline is)
210 fromInline (Code src _) = CT.Code src
211 fromInline (Link is url title) = CT.Link (fmap fromInline is) url title
212 fromInline (Image is url title) = CT.Image (fmap fromInline is) url title
213 fromInline (Entity txt) = CT.Entity txt
214 fromInline (RawHtml src) = CT.RawHtml src
217-- | Annotate the code samples in a docstring
218annotCode :: forall a b. (String -> b) -- ^ How to annotate code samples
219 -> Docstring a
220 -> Docstring b
221annotCode annot (DocString opts blocks)
222 = DocString opts $ fmap annotCodeBlock blocks
223 where
224 annotCodeBlock :: Block a -> Block b
225 annotCodeBlock (Para inlines) = Para (fmap annotCodeInline inlines)
226 annotCodeBlock (Header i inlines) = Header i (fmap annotCodeInline inlines)
227 annotCodeBlock (Blockquote blocks) = Blockquote (fmap annotCodeBlock blocks)
228 annotCodeBlock (List b t blocks) = List b t (fmap (fmap annotCodeBlock) blocks)
229 annotCodeBlock (CodeBlock attrs src _) = CodeBlock attrs src (annot (T.unpack src))
230 annotCodeBlock (HtmlBlock src) = HtmlBlock src
231 annotCodeBlock HRule = HRule
233 annotCodeInline :: Inline a -> Inline b
234 annotCodeInline (Str t) = Str t
235 annotCodeInline Space = Space
236 annotCodeInline SoftBreak = SoftBreak
237 annotCodeInline LineBreak = LineBreak
238 annotCodeInline (Emph is) = Emph (fmap annotCodeInline is)
239 annotCodeInline (Strong is) = Strong (fmap annotCodeInline is)
240 annotCodeInline (Code src _) = Code src (annot (T.unpack src))
241 annotCodeInline (Link is url title) = Link (fmap annotCodeInline is) url title
242 annotCodeInline (Image is url title) = Image (fmap annotCodeInline is) url title
243 annotCodeInline (Entity txt) = Entity txt
244 annotCodeInline (RawHtml src) = RawHtml src