From c45f2701d200de40091986867eb4f657d3abb752 Mon Sep 17 00:00:00 2001 From: John MacFarlane Date: Tue, 15 Sep 2026 02:54:16 +0000 Subject: [PATCH] AsciiDoc reader: resolve footnotes, stem, and icons during conversion. Previously the reader made three separate passes over the parsed AsciiDoc AST (for footnotes, stem math types, and icons) before converting to the pandoc AST. Each generic mapInlines/mapBlocks traversal rebuilds the entire AST and costs about as much as the parse itself; worse, resolveStem nested mapInlines inside mapBlocks, re-traversing each block's inlines once per ancestor block. Instead, resolve all three during the toPandoc conversion, which already traverses everything once, threading footnote state and document attributes through a StateT layer. Table headers are now converted before body rows so that footnote resolution follows document order. This makes the reader about twice as fast on typical documents. Output is unchanged. Co-Authored-By: Claude --- src/Text/Pandoc/Readers/AsciiDoc.hs | 156 +++++++++++++++------------- 1 file changed, 84 insertions(+), 72 deletions(-) diff --git a/src/Text/Pandoc/Readers/AsciiDoc.hs b/src/Text/Pandoc/Readers/AsciiDoc.hs index 01346920d..894b9be00 100644 --- a/src/Text/Pandoc/Readers/AsciiDoc.hs +++ b/src/Text/Pandoc/Readers/AsciiDoc.hs @@ -53,9 +53,6 @@ readAsciiDoc _opts inp = do (\(sourcepos, t) -> A.parseDocument getIncludeFile raiseError (sourceName sourcepos) t) sources) - >>= resolveFootnotes - >>= resolveStem - >>= resolveIcons >>= toPandoc where getIncludeFile fp = UTF8.toText <$> readFileStrict fp @@ -63,64 +60,56 @@ readAsciiDoc _opts inp = do $ msg <> " at " <> show fp <> " char " <> show pos +-- Context used when converting the AsciiDoc AST: resolved footnote +-- contents, plus document attributes governing stem (math) and icon +-- interpretation. These are used to resolve footnote references, +-- math types, and icons during conversion; doing this in the course +-- of the conversion is much cheaper than making separate passes over +-- the AST with mapInlines/mapBlocks. +data ADContext = ADContext + { adFootnotes :: M.Map T.Text B.Inlines + , adMathType :: A.MathType + , adIconFont :: Bool + , adIconsDir :: T.Text + , adIconType :: T.Text + } + toPandoc :: PandocMonad m => A.Document -> m Pandoc -toPandoc doc = - Pandoc <$> doMeta (A.docMeta doc) - <*> (B.toList <$> doBlocks (A.docBlocks doc)) - -resolveFootnotes :: Monad m => A.Document -> m A.Document -resolveFootnotes doc = do - evalStateT (A.mapInlines go doc) (mempty :: M.Map T.Text [A.Inline]) +toPandoc doc = evalStateT + (Pandoc <$> doMeta (A.docMeta doc) + <*> (B.toList <$> doBlocks (A.docBlocks doc))) + ADContext + { adFootnotes = mempty + , adMathType = case M.lookup "stem" docattrs of + Just "asciimath" -> A.AsciiMath + _ -> A.LaTeXMath + , adIconFont = case M.lookup "icons" docattrs of + Just "font" -> True + _ -> False + , adIconsDir = fromMaybe "./images/icons" $ M.lookup "iconsdir" docattrs + , adIconType = fromMaybe "png" $ M.lookup "icontype" docattrs + } where - go (A.Inline attr (A.Footnote (Just (A.FootnoteId fnid)) ils)) = do - fnmap <- get - case M.lookup fnid fnmap of - Just ils' -> - pure $ A.Inline attr (A.Footnote (Just (A.FootnoteId fnid)) ils') - Nothing -> do - put $ M.insert fnid ils fnmap - pure $ A.Inline attr (A.Footnote (Just (A.FootnoteId fnid)) ils) - go x = pure x - -resolveStem :: Monad m => A.Document -> m A.Document -resolveStem doc = do - let defaultType = case M.lookup "stem" (A.docAttributes (A.docMeta doc)) of - Just "asciimath" -> A.AsciiMath - _ -> A.LaTeXMath - let doInlineStem (A.Inline attr (A.Math Nothing t)) = - pure $ A.Inline attr (A.Math (Just defaultType) t) - doInlineStem x = pure x - let doBlockStem (A.Block attr mbtit (A.MathBlock Nothing t)) = - pure $ A.Block attr mbtit (A.MathBlock (Just defaultType) t) - doBlockStem x = A.mapInlines doInlineStem x - A.mapBlocks doBlockStem doc + docattrs = A.docAttributes (A.docMeta doc) -- resolve icons as either characters in an icon font or images -resolveIcons :: Monad m => A.Document -> m A.Document -resolveIcons doc = A.mapInlines fromIcon doc +resolveIcon :: ADContext -> A.Inline -> A.Inline +resolveIcon ctx (A.Inline attr (A.Icon name)) = + if adIconFont ctx + then A.Inline (addClasses ["fa", "fa-" <> name] attr) (A.Span []) + else -- default is to use an image + A.Inline (addClasses ["icon"] attr) + (A.InlineImage + (A.Target + (adIconsDir ctx <> "/" <> name <> "." <> adIconType ctx)) + Nothing Nothing Nothing) where - docattrs = A.docAttributes (A.docMeta doc) - iconFont = case M.lookup "icons" docattrs of - Just "font" -> True - _ -> False - iconsdir = fromMaybe "./images/icons" $ M.lookup "iconsdir" docattrs - icontype = fromMaybe "png" $ M.lookup "icontype" docattrs addClasses cls (A.Attr ps kvs) = A.Attr ps $ case M.lookup "role" kvs of Just r -> M.insert "role" (T.unwords (r : cls)) kvs Nothing -> M.insert "role" (T.unwords cls) kvs - fromIcon (A.Inline attr (A.Icon name)) = - if iconFont - then pure $ - A.Inline (addClasses ["fa", "fa-" <> name] attr) (A.Span []) - else pure $ -- default is to use an image - A.Inline (addClasses ["icon"] attr) - (A.InlineImage - (A.Target - (iconsdir <> "/" <> name <> "." <> icontype)) - Nothing Nothing Nothing) - fromIcon x = pure x +resolveIcon _ x = x addAttribution :: Maybe A.Attribution -> B.Blocks -> B.Blocks addAttribution Nothing bs = bs @@ -132,7 +121,7 @@ addAttribution (Just (A.Attribution t)) bs = B.fromList $ where attrBlock = Para (B.toList $ B.text $ "\x2014 " <> t) -doMeta :: PandocMonad m => A.Meta -> m B.Meta +doMeta :: (PandocMonad m, MonadState ADContext m) => A.Meta -> m B.Meta doMeta meta = do tit' <- doInlines (A.docTitle meta) pure $ @@ -164,7 +153,7 @@ fromAuthor au = B.text (A.authorName au) <> " (" <> B.link ("mailto:" <> email) "" (B.str email) <> ")") (A.authorEmail au) -doBlocks :: PandocMonad m => [A.Block] -> m B.Blocks +doBlocks :: (PandocMonad m, MonadState ADContext m) => [A.Block] -> m B.Blocks doBlocks = fmap mconcat . mapM doBlock addBlockAttr :: A.Attr -> B.Blocks -> B.Blocks @@ -196,7 +185,7 @@ addBlockTitle tit' bs = B.singleton $ B.Div attr (B.Div ("",["title"],[]) [B.Para tit] : bs') _ -> B.divWith B.nullAttr (B.divWith ("",["title"],[]) (B.para tit') <> bs) -doBlock :: PandocMonad m => A.Block -> m B.Blocks +doBlock :: (PandocMonad m, MonadState ADContext m) => A.Block -> m B.Blocks doBlock (A.Block attr@(A.Attr ps kvs) mbtitle bt) = do mbtitle' <- case mbtitle of Nothing -> pure Nothing @@ -232,11 +221,12 @@ doBlock (A.Block attr@(A.Attr ps kvs) mbtitle bt) = do addAttribution mbattrib . B.blockQuote <$> doBlocks bs A.Verse mbattrib bs -> addAttribution mbattrib . B.blockQuote <$> doBlocks bs - -- TODO when texmath's asciimath parser works, convert: - A.MathBlock (Just A.AsciiMath) t -> pure $ B.para $ B.displayMath t - A.MathBlock (Just A.LaTeXMath) t -> pure $ B.para $ B.displayMath t - A.MathBlock Nothing _ -> - throwError $ PandocParseError "Encountered math type Nothing" + A.MathBlock mbMathType t -> do + mathType <- maybe (gets adMathType) pure mbMathType + case mathType of + -- TODO when texmath's asciimath parser works, convert: + A.AsciiMath -> pure $ B.para $ B.displayMath t + A.LaTeXMath -> pure $ B.para $ B.displayMath t A.List (A.BulletList _) items -> B.bulletList <$> mapM doItem items A.List A.CheckList items -> @@ -272,8 +262,10 @@ doBlock (A.Block attr@(A.Attr ps kvs) mbtitle bt) = do (B.RowSpan rowspan) (B.ColSpan colspan) . B.toList <$> doBlocks bs let fromRow (A.TableRow cs) = B.Row B.nullAttr <$> mapM fromCell cs - tbody <- B.TableBody B.nullAttr (B.RowHeadColumns 0) [] <$> mapM fromRow rows + -- note: conversion is stateful (footnotes), so we convert in + -- document order: header, body, footer thead <- B.TableHead B.nullAttr <$> maybe (pure []) (mapM fromRow) mbHeader + tbody <- B.TableBody B.nullAttr (B.RowHeadColumns 0) [] <$> mapM fromRow rows tfoot <- B.TableFoot B.nullAttr <$> maybe (pure []) (mapM fromRow) mbFooter let totalWidth = sum $ map (fromMaybe 1 . A.colWidth) specs let toColSpec spec = (maybe B.AlignDefault toAlign (A.colHorizAlign spec), @@ -317,7 +309,7 @@ doBlock (A.Block attr@(A.Attr ps kvs) mbtitle bt) = do Left _ -> pure $ B.rawBlock "html" t Right (Pandoc _ bs) -> pure $ B.fromList bs -doItem :: PandocMonad m => A.ListItem -> m B.Blocks +doItem :: (PandocMonad m, MonadState ADContext m) => A.ListItem -> m B.Blocks doItem (A.ListItem Nothing bs) = doBlocks bs doItem (A.ListItem (Just checkstate) bs) = do bs' <- doBlocks bs @@ -330,18 +322,24 @@ doItem (A.ListItem (Just checkstate) bs) = do (B.Plain ils : rest) -> B.Plain (check : B.Space : ils) : rest rest -> B.Para [check] : rest -doDefListItem :: PandocMonad m +doDefListItem :: (PandocMonad m, MonadState ADContext m) => ([A.Inline], [A.Block]) -> m (B.Inlines , [B.Blocks]) doDefListItem (lab, bs) = do lab' <- doInlines lab bs' <- doBlocks bs pure (lab', [bs']) -doInlines :: PandocMonad m => [A.Inline] -> m B.Inlines +doInlines :: (PandocMonad m, MonadState ADContext m) => [A.Inline] -> m B.Inlines doInlines = fmap mconcat . mapM doInline -doInline :: PandocMonad m => A.Inline -> m B.Inlines -doInline (A.Inline (A.Attr _ps kvs') it) = do +doInline :: (PandocMonad m, MonadState ADContext m) => A.Inline -> m B.Inlines +doInline il@(A.Inline _ A.Icon{}) = do + ctx <- get + doInline' (resolveIcon ctx il) +doInline il = doInline' il + +doInline' :: (PandocMonad m, MonadState ADContext m) => A.Inline -> m B.Inlines +doInline' (A.Inline (A.Attr _ps kvs') it) = do let kvs = M.mapKeys (\k -> if k == "role" then "class" else k) kvs' addPandocAttributes (M.toList kvs) <$> case it of @@ -356,12 +354,14 @@ doInline (A.Inline (A.Attr _ps kvs') it) = do A.Strikethrough ils -> B.strikeout <$> doInlines ils A.DoubleQuoted ils -> B.doubleQuoted <$> doInlines ils A.SingleQuoted ils -> B.singleQuoted <$> doInlines ils - -- TODO when texmath's asciimath parser works, convert: - A.Math (Just A.AsciiMath) t -> pure $ B.math t - A.Math (Just A.LaTeXMath) t -> pure $ B.math t - A.Math Nothing _ -> - throwError $ PandocParseError "Encountered math type Nothing" - A.Icon t -> pure $ B.spanWith ("",["icon"],[("name",t)]) + A.Math mbMathType t -> do + mathType <- maybe (gets adMathType) pure mbMathType + case mathType of + -- TODO when texmath's asciimath parser works, convert: + A.AsciiMath -> pure $ B.math t + A.LaTeXMath -> pure $ B.math t + A.Icon t -> -- can't happen (rewritten by resolveIcon in doInline) + pure $ B.spanWith ("",["icon"],[("name",t)]) (B.str ("[" <> t <> "]")) A.Button t -> pure $ B.spanWith ("",["button"],[]) (B.strong $ B.str ("[" <> t <> "]")) @@ -382,7 +382,19 @@ doInline (A.Inline (A.Attr _ps kvs') it) = do Just (A.Height n) -> [("height", T.pack $ show n <> "px")] Nothing -> [] pure $ B.imageWith ("",[], width ++ height) url "" alt - A.Footnote _ ils -> B.note . B.para <$> doInlines ils + A.Footnote (Just (A.FootnoteId fnid)) ils -> do + -- repeated references to the same id get the contents of the + -- first footnote with that id + contents <- doInlines ils + fnmap <- gets adFootnotes + contents' <- case M.lookup fnid fnmap of + Just stored -> pure stored + Nothing -> do + modify $ \ctx -> + ctx{ adFootnotes = M.insert fnid contents fnmap } + pure contents + pure $ B.note $ B.para contents' + A.Footnote Nothing ils -> B.note . B.para <$> doInlines ils A.InlineAnchor t _ -> pure $ B.spanWith (t, [], []) mempty A.BibliographyAnchor t _ -> pure $ B.spanWith (t, [], []) mempty A.CrossReference t Nothing ->