git.iko.soy/Idris-dev
on fdb46c7 help sign in
Idris-dev/src/Idris/Docstrings.hs
80 lines 3.1 kB history raw
1-- | Wrapper around Markdown library
2module Idris.Docstrings (
3 Docstring, parseDocstring, renderDocstring, emptyDocstring, nullDocstring, noDocs
4 ) where
6import qualified Cheapskate as C
7import qualified Cheapskate.Types as CT
9import Util.Pretty
11import Idris.Core.TT (OutputAnnotation, Name)
13import qualified Data.Text as T
14import qualified Data.Foldable as F
15import qualified Data.Sequence as S
17type Docstring = CT.Doc
19parseDocstring :: T.Text -> CT.Doc
20parseDocstring = C.markdown options
23options = CT.Options { CT.sanitize = True
24 , CT.allowRawHtml = False
25 , CT.preserveHardBreaks = True
26 , CT.debug = False
27 }
29renderDocstring :: Docstring -> Doc OutputAnnotation
30renderDocstring (CT.Doc _ blocks) = renderBlocks blocks
32renderBlocks :: CT.Blocks -> Doc OutputAnnotation
33renderBlocks blocks | S.length blocks > 1 = F.foldr1 (\b1 b2 -> b1 <> line <> line <> b2) $
34 fmap renderBlock blocks
35 | S.length blocks == 1 = renderBlock (S.index blocks 0)
36 | otherwise = empty
38renderBlock :: CT.Block -> Doc OutputAnnotation
39renderBlock (CT.Para inlines) = renderInlines inlines
40renderBlock (CT.Header lvl inlines) = renderInlines inlines <+> parens (text (show lvl))
41renderBlock (CT.Blockquote blocks) = indent 8 $ renderBlocks blocks
42renderBlock (CT.List b ty blockss) = renderList b ty blockss
43renderBlock (CT.CodeBlock attr src) = indent 8 $ text (T.unpack src)
44renderBlock (CT.HtmlBlock txt) = text "<html block>" -- TODO
45renderBlock CT.HRule = text "----------------------"
47renderList :: Bool -> CT.ListType -> [CT.Blocks] -> Doc OutputAnnotation
48renderList b (CT.Bullet c) blockss = vsep $ map (hang 4 . (char c <+>) . renderBlocks) blockss
49renderList b (CT.Numbered nw i) blockss =
50 vsep $
51 zipWith3 (\n p txt -> hang 4 $ text (show n) <> p <+> txt)
52 [i..] (repeat punc) (map renderBlocks blockss)
53 where punc = case nw of
54 CT.PeriodFollowing -> char '.'
55 CT.ParenFollowing -> char '('
57renderInlines :: CT.Inlines -> Doc OutputAnnotation
58renderInlines = F.foldr (<>) empty . fmap renderInline
60renderInline :: CT.Inline -> Doc OutputAnnotation
61renderInline (CT.Str s) = text $ T.unpack s
62renderInline CT.Space = space
63renderInline CT.SoftBreak = softline
64renderInline CT.LineBreak = line
65renderInline (CT.Emph txt) = renderInlines txt -- TODO
66renderInline (CT.Strong txt) = renderInlines txt -- TODO
67renderInline (CT.Code txt) = text $ T.unpack txt
68renderInline (CT.Link body url title) = renderInlines body <+> parens (text $ T.unpack url)
69renderInline (CT.Image body url title) = text "<image>" -- TODO
70renderInline (CT.Entity a) = text $ "<entity " ++ T.unpack a ++ ">" -- TODO
71renderInline (CT.RawHtml txt) = text "<html content>" --TODO
73emptyDocstring :: Docstring
74emptyDocstring = CT.Doc options S.empty
76nullDocstring :: Docstring -> Bool
77nullDocstring (CT.Doc _ blocks) = S.null blocks
79noDocs :: (Docstring, [(Name, Docstring)])
80noDocs = (emptyDocstring, [])