first commit

src/ChaoDoc.hs

@@ -0,0 +1,607 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module ChaoDoc (chaoDocRead, chaoDocWrite, chaoDocPandocCompiler, chaoDocCompiler) where
+
+import Control.Monad.State
+import Data.Char (isAlphaNum, isSpace)
+import Data.Kind (Type)
+import Data.Either
+import Data.Functor
+import Data.List (intersect, stripPrefix)
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Text (Text, pack)
+import qualified Data.Text as T
+import Hakyll
+import Pangu (isCJK, pangu)
+import SideNoteHTML (usingSideNotesHTML)
+import System.IO.Unsafe
+import Text.Pandoc
+-- import Text.Pandoc.Builder
+import Text.Pandoc.Citeproc
+import Text.Pandoc.Walk (query, walk, walkM)
+
+-- setMeta key val (Pandoc (Meta ms) bs) = Pandoc (Meta $ M.insert key val ms) bs
+
+-- On mac, please do `export LANG=C` before using this thing
+chaoDocRead :: ReaderOptions
+chaoDocRead =
+  def
+    { readerExtensions =
+        enableExtension Ext_lists_without_preceding_blankline $
+        enableExtension Ext_wikilinks_title_after_pipe        $
+        enableExtension Ext_tex_math_double_backslash         $
+        enableExtension Ext_tex_math_single_backslash         $
+        enableExtension Ext_latex_macros                      $
+        enableExtension Ext_raw_tex                           $
+        disableExtension Ext_blank_before_header pandocExtensions
+    }
+
+chaoDocWrite :: WriterOptions
+chaoDocWrite =
+  def
+    { writerHTMLMathMethod = MathML,
+      -- writerHtml5          = True,
+      -- writerHighlightStyle = Just syntaxHighlightingStyle,
+      writerNumberSections = True,
+      writerTableOfContents = True,
+      writerTOCDepth = 2
+    }
+
+-- getInline :: Inline -> [Inline]
+-- getInline x = [x]
+
+pandocToInline :: Pandoc -> [Inline]
+pandocToInline (Pandoc _ blocks) = go (reverse blocks)
+  where
+    go (Plain inlines : _) = inlines
+    go (Para inlines : _) = inlines
+    go (_ : xs) = go xs
+    go [] = []
+
+incrementalBlock :: [Text]
+incrementalBlock =
+  [ "Theorem",
+    "Conjecture",
+    "Definition",
+    "Example",
+    "Lemma",
+    "Problem",
+    "Proposition",
+    "Corollary",
+    "Observation",
+    "Claim",
+    "定理",
+    "猜想",
+    "定义",
+    "例",
+    "引理",
+    "问题",
+    "命题",
+    "推论",
+    "观察"
+  ]
+
+otherBlock :: [Text]
+otherBlock = ["Proof", "Remark", "证明", "备注"]
+
+theoremClasses :: [Text]
+theoremClasses = incrementalBlock ++ otherBlock
+
+canonicalTheoremType :: Text -> Maybe Text
+canonicalTheoremType raw =
+  listToMaybe
+    [ cls
+      | cls <- theoremClasses,
+        T.toCaseFold cls == T.toCaseFold (T.strip raw)
+    ]
+
+-- create a filter for theorems
+getClass :: Attr -> [Text]
+getClass (_, c, _) = c
+
+addClass :: Attr -> Text -> Attr
+addClass (a, b, c) d = (a, d : b, c)
+
+addAttr :: Attr -> Text -> Text -> Attr
+addAttr (a, b, c) x y = (a, b, (x, y) : c)
+
+-- For each theorem, add a number, and also add add class theorem
+preprocessTheorems :: Block -> State Int Block
+preprocessTheorems (Div attr xs)
+  | isIncremental = do
+      curId <- get
+      put (curId + 1)
+      return $ Div (addAttr attr' "index" (pack $ show curId)) xs
+  | isOtherBlock = return $ Div attr' xs
+  | otherwise = return (Div attr xs)
+  where
+    isIncremental = getClass attr `intersect` incrementalBlock /= []
+    isOtherBlock = getClass attr `intersect` otherBlock /= []
+    theoremType = head (getClass attr `intersect` theoremClasses)
+    attr' = addAttr attr "type" theoremType
+preprocessTheorems x = return x
+
+theoremFilter :: Pandoc -> Pandoc
+theoremFilter doc =
+  walk makeTheorem $
+    autorefFilter $
+      evalState (walkM preprocessTheorems normalizedDoc) 1
+  where
+    normalizedDoc = obsidianTheoremFilter doc
+
+--    [idx, type, maybe index]
+theoremIndex :: Block -> [(Text, (Text, Maybe Text))]
+theoremIndex (Div attr _)
+  | isNothing t = []
+  | T.null idx = []
+  | otherwise = [(idx, (fromJust t, index))]
+  where
+    (idx, _, parm) = attr
+    t = lookup "type" parm
+    index = lookup "index" parm
+theoremIndex _ = []
+
+theoremLink :: [(Text, (Text, Maybe Text))] -> Text -> Maybe Inline
+theoremLink refs blockId = do
+  (theoremType, index) <- lookup blockId refs
+  let num = fromMaybe "" index
+      linkTitle
+        | T.null num = theoremType
+        | otherwise = theoremType <> " " <> num
+  return $ Link nullAttr [Str linkTitle] ("#" <> blockId, linkTitle)
+
+autoref :: [(Text, (Text, Maybe Text))] -> Inline -> Inline
+autoref x (Cite citations inlines)
+  | Just link <- theoremLink x citeid = link
+  | otherwise = Cite citations inlines
+  where
+    citeid = citationId $ head citations
+autoref x (Link attr inlines (target, title))
+  | Just blockId <- T.stripPrefix "#^" target,
+    Just link <- theoremLink x blockId =
+      link
+  | otherwise = Link attr inlines (target, title)
+autoref _ y = y
+
+autorefFilter :: Pandoc -> Pandoc
+autorefFilter x = walk (autoref links) x
+  where
+    links = query theoremIndex x
+
+-- processCitations works on AST. If you want to use citations in theorem name,
+-- then you need to convert citations there to AST as well and then use processCitations\
+-- Thus one need to apply the theorem filter first.
+-- autoref still does not work.
+mathMacros :: Text
+mathMacros = unsafePerformIO (pack <$> readFile "math-macros.md")
+{-# NOINLINE mathMacros #-}
+
+prependMacros :: Text -> Text -> Text
+prependMacros macros body = macros <> "\n\n" <> body
+
+prependMathMacros :: Text -> Text
+prependMathMacros = prependMacros mathMacros
+
+thmNamePandoc :: Text -> Pandoc
+thmNamePandoc x =
+  fromRight (Pandoc nullMeta []) . runPure $
+    readMarkdown chaoDocRead (prependMathMacros x)
+
+obsidianTheoremFilter :: Pandoc -> Pandoc
+obsidianTheoremFilter = attachStandaloneLabels . walk rewriteObsidianBlockQuote
+
+rewriteObsidianBlockQuote :: Block -> Block
+rewriteObsidianBlockQuote block@(BlockQuote quoteBlocks) = fromMaybe block do
+  (theoremType, title, bodyBlocks0) <- parseObsidianTheorem quoteBlocks
+  let (bodyBlocks, label) = stripTrailingLabel bodyBlocks0
+      attrs :: [(Text, Text)]
+      attrs = maybe [] (\x -> [("title", x)]) title
+  return $ Div (fromMaybe "" label, [theoremType], attrs) bodyBlocks
+rewriteObsidianBlockQuote block = block
+
+attachStandaloneLabels :: Pandoc -> Pandoc
+attachStandaloneLabels (Pandoc meta blocks) = Pandoc meta (attachLabels blocks)
+
+attachLabels :: [Block] -> [Block]
+attachLabels (Div attr xs : next : rest)
+  | isTheoremAttr attr,
+    T.null blockId =
+      case blockLabel next of
+        Just label -> Div (setAttrId attr label) xs : attachLabels rest
+        Nothing -> Div attr xs : attachLabels (next : rest)
+  where
+    (blockId, _, _) = attr
+attachLabels (x : xs) = x : attachLabels xs
+attachLabels [] = []
+
+isTheoremAttr :: Attr -> Bool
+isTheoremAttr attr = getClass attr `intersect` theoremClasses /= []
+
+setAttrId :: Attr -> Text -> Attr
+setAttrId (_, classes, attrs) blockId = (blockId, classes, attrs)
+
+parseObsidianTheorem :: [Block] -> Maybe (Text, Maybe Text, [Block])
+parseObsidianTheorem [] = Nothing
+parseObsidianTheorem (x : xs) = do
+  (theoremType, title, bodyStart) <- parseCalloutHeader x
+  return (theoremType, title, maybeToList bodyStart ++ xs)
+
+parseCalloutHeader :: Block -> Maybe (Text, Maybe Text, Maybe Block)
+parseCalloutHeader (Para inlines) = parseCalloutHeaderWith Para inlines
+parseCalloutHeader (Plain inlines) = parseCalloutHeaderWith Plain inlines
+parseCalloutHeader _ = Nothing
+
+parseCalloutHeaderWith :: ([Inline] -> Block) -> [Inline] -> Maybe (Text, Maybe Text, Maybe Block)
+parseCalloutHeaderWith mkBlock inlines = do
+  (theoremType, rest) <- parseCalloutPrefix inlines
+  let (titleInlines, bodyInlines) = splitAtFirstBreak rest
+      titleMarkdown = inlineMarkdown $ trimInlineSpaces titleInlines
+      bodyBlock = nonEmptyBlock mkBlock $ trimInlineSpaces bodyInlines
+      title =
+        if T.null titleMarkdown
+          then Nothing
+          else Just titleMarkdown
+  return (theoremType, title, bodyBlock)
+
+parseCalloutPrefix :: [Inline] -> Maybe (Text, [Inline])
+parseCalloutPrefix (Str marker : rest) = do
+  theoremType <- canonicalTheoremType =<< (T.stripPrefix "[!" marker >>= T.stripSuffix "]")
+  return (theoremType, dropLeadingInlineSpaces rest)
+parseCalloutPrefix _ = Nothing
+
+stripTrailingLabel :: [Block] -> ([Block], Maybe Text)
+stripTrailingLabel [] = ([], Nothing)
+stripTrailingLabel blocks = case unsnoc blocks of
+  Nothing -> (blocks, Nothing)
+  Just (prefix, lastBlock) -> case splitBlockLabel lastBlock of
+    Nothing -> (blocks, Nothing)
+    Just (cleaned, label) -> (prefix ++ maybeToList cleaned, Just label)
+
+blockLabel :: Block -> Maybe Text
+blockLabel block = case splitBlockLabel block of
+  Just (Nothing, label) -> Just label
+  _ -> Nothing
+
+splitBlockLabel :: Block -> Maybe (Maybe Block, Text)
+splitBlockLabel (Para inlines) = splitBlockLabelWith Para inlines
+splitBlockLabel (Plain inlines) = splitBlockLabelWith Plain inlines
+splitBlockLabel (BlockQuote blocks) = splitBlockLabelWithBlocks BlockQuote blocks
+splitBlockLabel (Div attr blocks) = splitBlockLabelWithBlocks (Div attr) blocks
+splitBlockLabel (BulletList items) = do
+  (items', label) <- splitBlockLabelItems items
+  return (nonEmptyListBlock BulletList items', label)
+splitBlockLabel (OrderedList attrs items) = do
+  (items', label) <- splitBlockLabelItems items
+  return (nonEmptyListBlock (OrderedList attrs) items', label)
+splitBlockLabel _ = Nothing
+
+splitBlockLabelWith :: ([Inline] -> Block) -> [Inline] -> Maybe (Maybe Block, Text)
+splitBlockLabelWith mkBlock inlines = do
+  (prefix, label) <- splitTrailingLabelLine inlines
+  return (nonEmptyBlock mkBlock prefix, label)
+
+splitBlockLabelWithBlocks :: ([Block] -> Block) -> [Block] -> Maybe (Maybe Block, Text)
+splitBlockLabelWithBlocks mkBlock blocks = do
+  let (blocks', label) = stripTrailingLabel blocks
+  label' <- label
+  return (nonEmptyBlocks mkBlock blocks', label')
+
+splitBlockLabelItems :: [[Block]] -> Maybe ([[Block]], Text)
+splitBlockLabelItems items = do
+  (prefixItems, lastItem) <- unsnoc items
+  let (lastItem', label) = stripTrailingLabel lastItem
+  label' <- label
+  return (prefixItems ++ maybeToList (nonEmptyListItem lastItem'), label')
+
+splitTrailingLabelLine :: [Inline] -> Maybe ([Inline], Text)
+splitTrailingLabelLine inlines = do
+  (prefixLines, lastLine) <- unsnoc (inlineLines inlines)
+  label <- labelFromInlines lastLine
+  return (joinInlineLines prefixLines, label)
+
+labelFromInlines :: [Inline] -> Maybe Text
+labelFromInlines [Str s] = labelFromText s
+labelFromInlines _ = Nothing
+
+labelFromText :: Text -> Maybe Text
+labelFromText s = do
+  label <- T.stripPrefix "^" (T.strip s)
+  if T.null label then Nothing else Just label
+
+inlineLines :: [Inline] -> [[Inline]]
+inlineLines = foldr step [[]]
+  where
+    step SoftBreak acc = [] : acc
+    step LineBreak acc = [] : acc
+    step x (line : rest) = (x : line) : rest
+    step _ [] = [[]]
+
+joinInlineLines :: [[Inline]] -> [Inline]
+joinInlineLines [] = []
+joinInlineLines (x : xs) = x ++ concatMap (SoftBreak :) xs
+
+inlineMarkdownWrite :: WriterOptions
+inlineMarkdownWrite =
+  def
+    { writerExtensions = readerExtensions chaoDocRead
+    }
+
+inlineMarkdown :: [Inline] -> Text
+inlineMarkdown inlines =
+  T.strip $
+    fromRight "" $
+      runPure $
+        writeMarkdown inlineMarkdownWrite (Pandoc nullMeta [Plain inlines])
+
+splitAtFirstBreak :: [Inline] -> ([Inline], [Inline])
+splitAtFirstBreak = go []
+  where
+    go acc [] = (reverse acc, [])
+    go acc (SoftBreak : xs) = (reverse acc, xs)
+    go acc (LineBreak : xs) = (reverse acc, xs)
+    go acc (x : xs) = go (x : acc) xs
+
+trimInlineSpaces :: [Inline] -> [Inline]
+trimInlineSpaces = dropTrailingInlineSpaces . dropLeadingInlineSpaces
+
+dropLeadingInlineSpaces :: [Inline] -> [Inline]
+dropLeadingInlineSpaces = dropWhile isInlineSpace
+
+dropTrailingInlineSpaces :: [Inline] -> [Inline]
+dropTrailingInlineSpaces = reverse . dropWhile isInlineSpace . reverse
+
+isInlineSpace :: Inline -> Bool
+isInlineSpace Space = True
+isInlineSpace _ = False
+
+nonEmptyBlock :: ([Inline] -> Block) -> [Inline] -> Maybe Block
+nonEmptyBlock mkBlock inlines
+  | (not . all isWhitespaceInline) inlines = Just (mkBlock inlines)
+  | otherwise = Nothing
+
+nonEmptyBlocks :: ([Block] -> Block) -> [Block] -> Maybe Block
+nonEmptyBlocks mkBlock blocks
+  | null blocks = Nothing
+  | otherwise = Just (mkBlock blocks)
+
+nonEmptyListBlock :: ([[Block]] -> Block) -> [[Block]] -> Maybe Block
+nonEmptyListBlock mkBlock items
+  | null items = Nothing
+  | otherwise = Just (mkBlock items)
+
+nonEmptyListItem :: [Block] -> Maybe [Block]
+nonEmptyListItem []
+  = Nothing
+nonEmptyListItem blocks = Just blocks
+
+isWhitespaceInline :: Inline -> Bool
+isWhitespaceInline Space = True
+isWhitespaceInline SoftBreak = True
+isWhitespaceInline LineBreak = True
+isWhitespaceInline _ = False
+
+unsnoc :: [a] -> Maybe ([a], a)
+unsnoc [] = Nothing
+unsnoc [x] = Just ([], x)
+unsnoc (x : xs) = do
+  (prefix, lastElem) <- unsnoc xs
+  return (x : prefix, lastElem)
+
+makeTheorem :: Block -> Block
+makeTheorem (Div attr xs)
+  | isNothing t = Div attr xs
+  | otherwise = Div (addClass attr "theorem-environment") (Plain [header] : xs)
+  where
+    (_, _, parm) = attr
+    t = lookup "type" parm
+    name = lookup "title" parm
+    index = lookup "index" parm
+    header = Span (addClass nullAttr "theorem-header") [typetext, indextext, nametext]
+    typetext = Span (addClass nullAttr "type") [Str $ fromJust t]
+    indextext =
+      if isNothing index
+        then Str ""
+        else Span (addClass nullAttr "index") [Str $ fromJust index]
+    nametext =
+      if isNothing name
+        then Str ""
+        else Span (addClass nullAttr "name") (pandocToInline $ thmNamePandoc $ fromJust name)
+makeTheorem x = x
+
+-- bib from https://github.com/chaoxu/chaoxu.github.io/tree/develop
+cslFile :: String
+cslFile = "bib_style.csl"
+
+bibFile :: String
+bibFile = "reference.bib"
+
+chaoDocPandocCompiler :: Compiler (Item Pandoc)
+chaoDocPandocCompiler = do
+  macros <- T.pack <$> loadBody "math-macros.md"
+  body <- getResourceBody
+  let bodyWithMacros =
+        fmap (T.unpack . prependMacros macros . T.pack) body
+  myReadPandocBiblio chaoDocRead (T.pack cslFile) (T.pack bibFile) myFilter bodyWithMacros
+
+chaoDocCompiler :: Compiler (Item String)
+chaoDocCompiler = chaoDocPandocCompiler <&> writePandocWith chaoDocWrite
+
+addMeta :: T.Text -> MetaValue -> Pandoc -> Pandoc
+addMeta name value (Pandoc meta a) =
+  let prevMap = unMeta meta
+      newMap = M.insert name value prevMap
+      newMeta = Meta newMap
+   in Pandoc newMeta a
+
+myReadPandocBiblio ::
+  ReaderOptions ->
+  T.Text -> -- csl file name
+  T.Text ->
+  (Pandoc -> Pandoc) -> -- apply a filter before citeproc
+  Item String ->
+  Compiler (Item Pandoc)
+myReadPandocBiblio ropt csl biblio pdfilter item = do
+  -- Parse CSL file, if given
+  -- style <- unsafeCompiler $ CSL.readCSLFile Nothing . toFilePath . itemIdentifier $ csl
+
+  -- We need to know the citation keys, add then *before* actually parsing the
+  -- actual page. If we don't do this, pandoc won't even consider them
+  -- citations!
+  -- let Biblio refs = itemBody biblio
+  pandoc <- itemBody <$> readPandocWith ropt item
+  let pandoc' =
+        fromRight pandoc $
+          unsafePerformIO $
+            runIO $
+              processCitations $
+                addMeta "bibliography" (MetaList [MetaString biblio]) $
+                  addMeta "csl" (MetaString csl) $
+                    addMeta "link-citations" (MetaBool True) $
+                      addMeta "reference-section-title" (MetaInlines [Str "References"]) $
+                        pdfilter pandoc -- here's the change
+                        -- let a x = itemSetBody (pandoc' x)
+  return $ fmap (const pandoc') item
+
+myFilter :: Pandoc -> Pandoc
+myFilter = usingSideNotesHTML chaoDocWrite . theoremFilter . panguFilter . displayMathFilter
+
+-- pangu filter
+lastChar :: Inline -> Maybe Char
+lastChar e = case e of
+  Str s -> if null (T.unpack s) then Nothing else Just (last (T.unpack s))
+  Emph is -> lastCharList is
+  Strong is -> lastCharList is
+  Strikeout is -> lastCharList is
+  Link _ is _ -> lastCharList is
+  Span _ is -> lastCharList is
+  Quoted _ is -> lastCharList is
+  _ -> Nothing
+  where
+    lastCharList [] = Nothing
+    lastCharList is = lastChar (last is)
+
+firstChar :: Inline -> Maybe Char
+firstChar e = case e of
+  Str s -> if null (T.unpack s) then Nothing else Just (head (T.unpack s))
+  Emph is -> firstCharList is
+  Strong is -> firstCharList is
+  Strikeout is -> firstCharList is
+  Link _ is _ -> firstCharList is
+  Span _ is -> firstCharList is
+  Quoted _ is -> firstCharList is
+  _ -> Nothing
+  where
+    firstCharList [] = Nothing
+    firstCharList is = firstChar (head is)
+
+panguInline :: Inline -> Inline
+panguInline e = case e of
+  Str s -> Str (pangu s)
+  Emph is -> Emph (panguInlines is)
+  Strong is -> Strong (panguInlines is)
+  Strikeout is -> Strikeout (panguInlines is)
+  Link at is tg -> Link at (panguInlines is) tg
+  Span at is -> Span at (panguInlines is)
+  Quoted qt is -> Quoted qt (panguInlines is)
+  _ -> e
+
+panguInlines :: [Inline] -> [Inline]
+panguInlines = foldr (addSpace . panguInline) []
+  where
+    addSpace x [] = [x]
+    addSpace x (y : ys)
+      | shouldSpace x y = x : Space : y : ys
+      | otherwise = x : y : ys
+    shouldSpace x y = case (lastChar x, firstChar y) of
+      (Just lc, Just fc) -> isCJK lc /= isCJK fc
+      _ -> False
+
+panguFilter :: Pandoc -> Pandoc
+panguFilter = walk transformBlocks
+  where
+    transformBlocks :: Block -> Block
+    transformBlocks (Para inlines) = Para (panguInlines inlines)
+    transformBlocks x = x
+
+type MathTag :: Type
+data MathTag = MathTag
+  { mathTagStarred :: Bool,
+    mathTagBody :: Text
+  }
+
+extractMathTag :: Text -> Maybe (Text, MathTag)
+extractMathTag source = do
+  (mathBody, starred, tagBody) <- findTrailingMathTag (T.unpack source)
+  return
+    ( T.stripEnd (T.pack mathBody),
+      MathTag starred (T.strip (T.pack tagBody))
+    )
+
+findTrailingMathTag :: String -> Maybe (String, Bool, String)
+findTrailingMathTag = go [] Nothing
+  where
+    go :: String -> Maybe (String, Bool, String) -> String -> Maybe (String, Bool, String)
+    go _ best [] = best
+    go prefix best rest@(c : cs) =
+      go (c : prefix) best' cs
+      where
+        best' = case parseMathTagPrefix rest of
+          Just (starred, tagBody, suffix)
+            | all isSpace suffix -> Just (reverse prefix, starred, tagBody)
+          _ -> best
+
+parseMathTagPrefix :: String -> Maybe (Bool, String, String)
+parseMathTagPrefix s
+  | Just rest <- stripPrefix "\\tag*{" s = do
+      (tagBody, suffix) <- parseBalancedBraces 1 [] rest
+      return (True, tagBody, suffix)
+  | Just rest <- stripPrefix "\\tag{" s = do
+      (tagBody, suffix) <- parseBalancedBraces 1 [] rest
+      return (False, tagBody, suffix)
+  | otherwise = Nothing
+
+parseBalancedBraces :: Int -> String -> String -> Maybe (String, String)
+parseBalancedBraces _ _ [] = Nothing
+parseBalancedBraces depth acc ('\\' : x : xs)
+  | x `elem` ['{', '}', '\\'] = parseBalancedBraces depth (x : '\\' : acc) xs
+parseBalancedBraces depth acc ('{' : xs) =
+  parseBalancedBraces (depth + 1) ('{' : acc) xs
+parseBalancedBraces depth acc ('}' : xs)
+  | depth == 1 = Just (reverse acc, xs)
+  | otherwise = parseBalancedBraces (depth - 1) ('}' : acc) xs
+parseBalancedBraces depth acc (x : xs) =
+  parseBalancedBraces depth (x : acc) xs
+
+isPlainMathTag :: Text -> Bool
+isPlainMathTag =
+  T.all \c ->
+    isAlphaNum c || c `elem` ("*-.:()[] " :: String)
+
+mathTagInlines :: MathTag -> [Inline]
+mathTagInlines tag
+  | mathTagStarred tag = tagBody
+  | otherwise = [Str "("] ++ tagBody ++ [Str ")"]
+  where
+    tagText = mathTagBody tag
+    tagBody
+      | isPlainMathTag tagText = [Str tagText]
+      | otherwise = [Math InlineMath tagText]
+
+-- display math wrapper for MathML
+displayMathFilter :: Pandoc -> Pandoc
+displayMathFilter = walk wrapDisplayMath
+  where
+    wrapDisplayMath (Math DisplayMath source)
+      | Just (mathBody, tag) <- extractMathTag source =
+          Span
+            ("", ["math-container", "math-container-tagged"], [])
+            [ Span ("", ["math-tag-spacer"], []) [],
+              Span ("", ["math-equation"], []) [Math DisplayMath mathBody],
+              Span ("", ["math-tag"], []) (mathTagInlines tag)
+            ]
+      | otherwise =
+          Span ("", ["math-container"], []) [Math DisplayMath source]
+    wrapDisplayMath x = x