1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
{-# LANGUAGE OverloadedStrings #-}
module Text.Markdown.Types where
import Data.Text (Text)
import qualified Data.Text as T
import Data.Default (Default (def))
import Data.Set (Set, empty)
import Data.Map (Map, singleton)
import Data.Monoid (mappend)
import Text.Blaze.Html (Html)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
-- | A settings type providing various configuration options.
--
-- See <http://www.yesodweb.com/book/settings-types> for more information on
-- settings types. In general, you can use @def@.
data MarkdownSettings = MarkdownSettings
{ msXssProtect :: Bool
-- ^ Whether to automatically apply XSS protection to embedded HTML. Default: @True@.
, msStandaloneHtml :: Set Text
-- ^ HTML snippets which stand on their own. We do not require a blank line following these pieces of HTML.
--
-- Default: empty set.
--
-- Since: 0.1.2
, msFencedHandlers :: Map Text (Text -> FencedHandler)
-- ^ Handlers for the special \"fenced\" format. This is most commonly
-- used for fenced code, e.g.:
--
-- > ```haskell
-- > main = putStrLn "Hello"
-- > ```
--
-- This is an extension of Markdown, but a fairly commonly used one.
--
-- This setting allows you to create new kinds of fencing. Fencing goes
-- into two categories: parsed and raw. Code fencing would be in the raw
-- category, where the contents are not treated as Markdown. Parsed will
-- treat the contents as Markdown and allow you to perform some kind of
-- modifcation to it.
--
-- For example, to create a new @\@\@\@@ fencing which wraps up the
-- contents in an @article@ tag, you could use:
--
-- > def { msFencedHandlers = htmlFencedHandler "@@@" (const "<article>") (const "</article")
-- > `Map.union` msFencedHandlers def
-- > }
--
-- Default: code fencing for @```@ and @~~~@.
--
-- Since: 0.1.2
, msBlockCodeRenderer :: Maybe Text -> (Text,Html) -> Html
-- ^ A rendering function through which code blocks are passed.
--
-- The arguments are the block's language, if any, and the tuple
-- @(unrendered content, rendered content)@. For example, if you wanted to pass
-- code blocks in your markdown text through a highlighter like @highlighting-kate@,
-- you might do something like:
--
-- >>> :set -XOverloadedStrings
-- >>> let renderer lang (src,_) = formatHtmlBlock defaultFormatOpts $ highlightAs (maybe "text" unpack lang) $ unpack src
-- >>> let md = markdown def { msBlockCodeRenderer = renderer } "``` haskell\nmain = putStrLn \"Hello world!\"\n```"
-- >>> putStrLn $ renderHtml md
-- <pre class="sourceCode"><code class="sourceCode">main <span class="fu">=</span> <span class="fu">putStrLn</span> <span class="st">"Hello world!"</span></code></pre>
--
-- Since: 0.1.2.1
, msLinkNewTab :: Bool
-- ^ If @True@, all generated links have the attribute target=_blank set,
-- causing them to be opened in a new tab or window.
--
-- Default: @False@
--
-- Since 0.1.4
, msBlankBeforeBlockquote :: Bool
-- ^ If @True@, a blank line is required before the start of a blockquote. Standard
-- markdown syntax does not require a blank line before a blockquote, but it is all
-- too easy for a > to end up at the beginning of a line by accident.
--
-- Default: @True@
--
-- Since 0.1.5
, msBlockFilter :: [Block [Inline]] -> [Block [Inline]]
-- ^ A function to filter and/or modify parsed blocks before they are
-- written to Html
--
-- Default: @id@
--
-- Since 0.1.7
, msAddHeadingId :: Bool
-- ^ If @True@, an @id@ attribute is added to the heading tag with the value equal to
-- the text with only valid CSS identifier characters.
--
-- > ## Executive Summary
--
-- > <h2 id="executive-summary">Executive Summary</h2>
--
-- Default: @False@
--
-- Since 0.1.13
, msNoFollowExternal :: Bool
}
-- | See 'msFencedHandlers.
--
-- Since 0.1.2
data FencedHandler = FHRaw (Text -> [Block Text])
-- ^ Wrap up the given raw content.
| FHParsed ([Block Text] -> [Block Text])
-- ^ Wrap up the given parsed content.
-- | @since 0.1.15
defaultMarkdownSettings :: MarkdownSettings
defaultMarkdownSettings = MarkdownSettings
{ msXssProtect = True
, msStandaloneHtml = empty
, msFencedHandlers = codeFencedHandler "```" `mappend` codeFencedHandler "~~~"
, msBlockCodeRenderer =
\lang (_,rendered) -> case lang of
Just l -> H.pre $ H.code H.! HA.class_ (H.toValue l) $ rendered
Nothing -> H.pre $ H.code $ rendered
, msLinkNewTab = False
, msBlankBeforeBlockquote = True
, msBlockFilter = id
, msAddHeadingId = False
, msNoFollowExternal = False
}
instance Default MarkdownSettings where
def = defaultMarkdownSettings
-- | Helper for creating a 'FHRaw'.
--
-- Since 0.1.2
codeFencedHandler :: Text -- ^ Delimiter
-> Map Text (Text -> FencedHandler)
codeFencedHandler key = singleton key $ \lang -> FHRaw $
return . BlockCode (if T.null lang then Nothing else Just lang)
-- | Helper for creating a 'FHParsed'.
--
-- Note that the start and end parameters take a @Text@ parameter; this is the
-- text following the delimiter. For example, with the markdown:
--
-- > @@@ foo
--
-- @foo@ would be passed to start and end.
--
-- Since 0.1.2
htmlFencedHandler :: Text -- ^ Delimiter
-> (Text -> Text) -- ^ start HTML
-> (Text -> Text) -- ^ end HTML
-> Map Text (Text -> FencedHandler)
htmlFencedHandler key start end = singleton key $ \lang -> FHParsed $ \blocks ->
BlockHtml (start lang)
: blocks
++ [BlockHtml $ end lang]
data ListType = Ordered | Unordered
deriving (Show, Eq)
data Block inline
= BlockPara inline
| BlockList ListType (Either inline [Block inline])
| BlockCode (Maybe Text) Text
| BlockQuote [Block inline]
| BlockHtml Text
| BlockRule
| BlockHeading Int inline
| BlockReference Text Text
| BlockPlainText inline
deriving (Show, Eq)
instance Functor Block where
fmap f (BlockPara i) = BlockPara (f i)
fmap f (BlockList lt (Left i)) = BlockList lt $ Left $ f i
fmap f (BlockList lt (Right bs)) = BlockList lt $ Right $ map (fmap f) bs
fmap _ (BlockCode a b) = BlockCode a b
fmap f (BlockQuote bs) = BlockQuote $ map (fmap f) bs
fmap _ (BlockHtml t) = BlockHtml t
fmap _ BlockRule = BlockRule
fmap f (BlockHeading level i) = BlockHeading level (f i)
fmap _ (BlockReference x y) = BlockReference x y
fmap f (BlockPlainText x) = BlockPlainText (f x)
data Inline = InlineText Text
| InlineItalic [Inline]
| InlineBold [Inline]
| InlineCode Text
| InlineHtml Text
| InlineLink Text (Maybe Text) [Inline] -- ^ URL, title, content
| InlineImage Text (Maybe Text) Text -- ^ URL, title, content
| InlineFootnoteRef Integer -- ^ The footnote reference in the body
| InlineFootnote Integer
deriving (Show, Eq)
|
