@@ -1,4 +1,5 @@
11{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
23{-# LANGUAGE ViewPatterns #-}
34{- |
45 Module : Text.Pandoc.Readers.CommonMark
@@ -16,209 +17,50 @@ CommonMark is a strongly specified variant of Markdown: http://commonmark.org.
1617module Text.Pandoc.Readers.CommonMark (readCommonMark)
1718where
1819
19−import CMarkGFM
20−import Control.Monad.State
21−import qualified Data.Set as Set
20+import Commonmark
21+import Commonmark.Extensions
22+import Commonmark.Pandoc
2223import Data.Text (Text)
23−import qualified Data.Text as T
2424import Text.Pandoc.Class.PandocMonad (PandocMonad)
2525import Text.Pandoc.Definition
26−import Text.Pandoc.Emoji (emojiToInline)
26+import Text.Pandoc.Builder as B
2727import Text.Pandoc.Options
28−import Text.Pandoc.Shared (uniqueIdent, taskListItemFromAscii)
29−import Text.Pandoc.Walk (walkM)
28+import Text.Pandoc.Error
29+import Control.Monad.Except
30+import Data.Functor.Identity (runIdentity)
3031
3132-- | Parse a CommonMark formatted string into a 'Pandoc' structure.
3233readCommonMark :: PandocMonad m => ReaderOptions -> Text -> m Pandoc
33−readCommonMark opts s = return $
34− (if isEnabled Ext_auto_identifiers opts
35− then addHeaderIdentifiers opts
36− else id) $
37− nodeToPandoc opts $ commonmarkToNode opts' exts s
38− where opts' = [ optSmart | isEnabled Ext_smart opts ]
39− exts = [ extStrikethrough | isEnabled Ext_strikeout opts ] ++
40− [ extTable | isEnabled Ext_pipe_tables opts ] ++
41− [ extAutolink | isEnabled Ext_autolink_bare_uris opts ]
34+readCommonMark opts s = do
35+ let res = runIdentity $
36+ commonmarkWith (foldr (<>) defaultSyntaxSpec exts) "input" s
37+ case res of
38+ Left err -> throwError $ PandocParsecError s err
39+ Right (Cm bls :: Cm () Blocks) -> return $ B.doc bls
40+ where
41+ exts = [ hardLineBreaksSpec | isEnabled Ext_hard_line_breaks opts ] ++
42+ [ smartPunctuationSpec | isEnabled Ext_smart opts ] ++
43+ [ strikethroughSpec | isEnabled Ext_strikeout opts ] ++
44+ [ superscriptSpec | isEnabled Ext_superscript opts ] ++
45+ [ subscriptSpec | isEnabled Ext_subscript opts ] ++
46+ [ mathSpec | isEnabled Ext_tex_math_dollars opts ] ++
47+ [ fancyListSpec | isEnabled Ext_fancy_lists opts ] ++
48+ [ fencedDivSpec | isEnabled Ext_fenced_divs opts ] ++
49+ [ bracketedSpanSpec | isEnabled Ext_bracketed_spans opts ] ++
50+ [ rawAttributeSpec | isEnabled Ext_raw_attribute opts ] ++
51+ [ attributesSpec | isEnabled Ext_attributes opts ] ++
52+ [ pipeTableSpec | isEnabled Ext_pipe_tables opts ] ++
53+ [ autolinkSpec | isEnabled Ext_autolink_bare_uris opts ] ++
54+ [ emojiSpec | isEnabled Ext_emoji opts ] ++
55+ [ autoIdentifiersSpec
56+ | isEnabled Ext_gfm_auto_identifiers opts
57+ , not (isEnabled Ext_ascii_identifiers opts) ] ++
58+ [ autoIdentifiersAsciiSpec
59+ | isEnabled Ext_gfm_auto_identifiers opts
60+ , isEnabled Ext_ascii_identifiers opts ] ++
61+ [ implicitHeadingReferencesSpec
62+ | isEnabled Ext_implicit_header_references opts ] ++
63+ [ footnoteSpec | isEnabled Ext_footnotes opts ] ++
64+ [ definitionListSpec | isEnabled Ext_definition_lists opts ] ++
65+ [ taskListSpec | isEnabled Ext_task_lists opts ]
4266
43−convertEmojis :: Text -> [Inline]
44−convertEmojis s@(T.uncons -> Just (':',xs)) =
45− case T.break (==':') xs of
46− (ys, T.uncons -> Just (':',zs)) ->
47− case emojiToInline ys of
48− Just em -> em : convertEmojis zs
49− Nothing -> Str (":" <> ys) : convertEmojis (":" <> zs)
50− _ -> [Str s]
51−convertEmojis s =
52− case T.break (==':') s of
53− ("","") -> []
54− (_,"") -> [Str s]
55− (xs,ys) -> Str xs : convertEmojis ys
56−
57−addHeaderIdentifiers :: ReaderOptions -> Pandoc -> Pandoc
58−addHeaderIdentifiers opts doc = evalState (walkM (addHeaderId opts) doc) mempty
59−
60−addHeaderId :: ReaderOptions -> Block -> State (Set.Set Text) Block
61−addHeaderId opts (Header lev (_,classes,kvs) ils) = do
62− ids <- get
63− let ident = uniqueIdent (readerExtensions opts) ils ids
64− modify (Set.insert ident)
65− return $ Header lev (ident,classes,kvs) ils
66−addHeaderId _ x = return x
67−
68−nodeToPandoc :: ReaderOptions -> Node -> Pandoc
69−nodeToPandoc opts (Node _ DOCUMENT nodes) =
70− Pandoc nullMeta $ foldr (addBlock opts) [] nodes
71−nodeToPandoc opts n = -- shouldn't happen
72− Pandoc nullMeta $ foldr (addBlock opts) [] [n]
73−
74−addBlocks :: ReaderOptions -> [Node] -> [Block]
75−addBlocks opts = foldr (addBlock opts) []
76−
77−addBlock :: ReaderOptions -> Node -> [Block] -> [Block]
78−addBlock opts (Node _ PARAGRAPH nodes) =
79− case addInlines opts nodes of
80− [Image attr alt (src,tit)]
81− | isEnabled Ext_implicit_figures opts
82− -- the "fig:" prefix indicates an implicit figure
83− -> (Para [Image attr alt (src, "fig:" <> tit)] :)
84− ils -> (Para ils :)
85−addBlock _ (Node _ THEMATIC_BREAK _) =
86− (HorizontalRule :)
87−addBlock opts (Node _ BLOCK_QUOTE nodes) =
88− (BlockQuote (addBlocks opts nodes) :)
89−addBlock opts (Node _ (HTML_BLOCK t) _)
90− | isEnabled Ext_raw_html opts = (RawBlock (Format "html") t :)
91− | otherwise = id
92−-- Note: the cmark parser will never generate CUSTOM_BLOCK,
93−-- so we don't need to handle it:
94−addBlock _ (Node _ (CUSTOM_BLOCK _onEnter _onExit) _nodes) =
95− id
96−addBlock _ (Node _ (CODE_BLOCK info t) _) =
97− (CodeBlock ("", take 1 (T.words info), []) t :)
98−addBlock opts (Node _ (HEADING lev) nodes) =
99− (Header lev ("",[],[]) (addInlines opts nodes) :)
100−addBlock opts (Node _ (LIST listAttrs) nodes) =
101− (constructor (map listItem nodes) :)
102− where constructor = case listType listAttrs of
103− BULLET_LIST -> BulletList
104− ORDERED_LIST -> OrderedList
105− (start, DefaultStyle, delim)
106− start = listStart listAttrs
107− listItem = taskListItemFromAscii exts . setTightness
108− . addBlocks opts . children
109− setTightness = if listTight listAttrs
110− then map paraToPlain
111− else id
112− paraToPlain (Para xs) = Plain xs
113− paraToPlain x = x
114− delim = case listDelim listAttrs of
115− PERIOD_DELIM -> Period
116− PAREN_DELIM -> OneParen
117− exts = readerExtensions opts
118−addBlock opts (Node _ (TABLE alignments) nodes) =
119− (Table
120− nullAttr
121− (Caption Nothing [])
122− (zip aligns widths)
123− (TableHead nullAttr headers)
124− [TableBody nullAttr 0 [] rows]
125− (TableFoot nullAttr []) :)
126− where aligns = map fromTableCellAlignment alignments
127− fromTableCellAlignment NoAlignment = AlignDefault
128− fromTableCellAlignment LeftAligned = AlignLeft
129− fromTableCellAlignment RightAligned = AlignRight
130− fromTableCellAlignment CenterAligned = AlignCenter
131− widths = replicate numcols ColWidthDefault
132− numcols = if null rows'
133− then 0
134− else maximum $ map rowLength rows'
135− rows' = map toRow $ filter isRow nodes
136− (headers, rows) = case rows' of
137− (h:rs) -> ([h], rs)
138− [] -> ([], [])
139− isRow (Node _ TABLE_ROW _) = True
140− isRow _ = False
141− isCell (Node _ TABLE_CELL _) = True
142− isCell _ = False
143− toRow (Node _ TABLE_ROW ns) = Row nullAttr $ map toCell $ filter isCell ns
144− toRow (Node _ t _) = error $ "toRow encountered non-row " ++ show t
145− toCell (Node _ TABLE_CELL []) = fromSimpleCell []
146− toCell (Node _ TABLE_CELL (n:ns))
147− | isBlockNode n = fromSimpleCell $ addBlocks opts (n:ns)
148− | otherwise = fromSimpleCell [Plain (addInlines opts (n:ns))]
149− toCell (Node _ t _) = error $ "toCell encountered non-cell " ++ show t
150− fromSimpleCell = Cell nullAttr AlignDefault 1 1
151− rowLength (Row _ body) = length body -- all cells are 1×1
152−addBlock _ (Node _ TABLE_ROW _) = id -- handled in TABLE
153−addBlock _ (Node _ TABLE_CELL _) = id -- handled in TABLE
154−addBlock _ _ = id
155−
156−isBlockNode :: Node -> Bool
157−isBlockNode (Node _ nodetype _) =
158− case nodetype of
159− DOCUMENT -> True
160− THEMATIC_BREAK -> True
161− PARAGRAPH -> True
162− BLOCK_QUOTE -> True
163− HTML_BLOCK _ -> True
164− CUSTOM_BLOCK _ _ -> True
165− CODE_BLOCK _ _ -> True
166− HEADING _ -> True
167− LIST _ -> True
168− ITEM -> True
169− TEXT _ -> False
170− SOFTBREAK -> False
171− LINEBREAK -> False
172− HTML_INLINE _ -> False
173− CUSTOM_INLINE _ _ -> False
174− CODE _ -> False
175− EMPH -> False
176− STRONG -> False
177− LINK _ _ -> False
178− IMAGE _ _ -> False
179− STRIKETHROUGH -> False
180− TABLE _ -> False
181− TABLE_ROW -> False
182− TABLE_CELL -> False
183−
184−children :: Node -> [Node]
185−children (Node _ _ ns) = ns
186−
187−addInlines :: ReaderOptions -> [Node] -> [Inline]
188−addInlines opts = foldr (addInline opts) []
189−
190−addInline :: ReaderOptions -> Node -> [Inline] -> [Inline]
191−addInline opts (Node _ (TEXT t) _) = (concatMap toinl clumps ++)
192− where clumps = T.groupBy samekind t
193− samekind ' ' ' ' = True
194− samekind ' ' _ = False
195− samekind _ ' ' = False
196− samekind _ _ = True
197− toinl (T.uncons -> Just (' ', _)) = [Space]
198− toinl xs = if isEnabled Ext_emoji opts
199− then convertEmojis xs
200− else [Str xs]
201−addInline _ (Node _ LINEBREAK _) = (LineBreak :)
202−addInline opts (Node _ SOFTBREAK _)
203− | isEnabled Ext_hard_line_breaks opts = (LineBreak :)
204− | otherwise = (SoftBreak :)
205−addInline opts (Node _ (HTML_INLINE t) _)
206− | isEnabled Ext_raw_html opts = (RawInline (Format "html") t :)
207− | otherwise = id
208−-- Note: the cmark parser will never generate CUSTOM_BLOCK,
209−-- so we don't need to handle it:
210−addInline _ (Node _ (CUSTOM_INLINE _onEnter _onExit) _nodes) =
211− id
212−addInline _ (Node _ (CODE t) _) =
213− (Code ("",[],[]) t :)
214−addInline opts (Node _ EMPH nodes) =
215− (Emph (addInlines opts nodes) :)
216−addInline opts (Node _ STRONG nodes) =
217− (Strong (addInlines opts nodes) :)
218−addInline opts (Node _ STRIKETHROUGH nodes) =
219− (Strikeout (addInlines opts nodes) :)
220−addInline opts (Node _ (LINK url title) nodes) =
221− (Link nullAttr (addInlines opts nodes) (url, title) :)
222−addInline opts (Node _ (IMAGE url title) nodes) =
223− (Image nullAttr (addInlines opts nodes) (url, title) :)
224−addInline _ _ = id