path: root/src/Text/Pandoc/Writers/RST.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}
{- |
   Module      : Text.Pandoc.Writers.RST
   Copyright   : Copyright (C) 2006-2024 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <[email protected]>
   Stability   : alpha
   Portability : portable

Conversion of 'Pandoc' documents to reStructuredText.

reStructuredText:  <http://docutils.sourceforge.net/rst.html>
-}
module Text.Pandoc.Writers.RST ( writeRST, flatten ) where
import Control.Monad.State.Strict ( StateT, gets, modify, evalStateT )
import Control.Monad (zipWithM, liftM)
import Data.Char (isSpace, generalCategory, isAscii, isAlphaNum,
                  GeneralCategory(
                        ClosePunctuation, OpenPunctuation, InitialQuote,
                         FinalQuote, DashPunctuation, OtherPunctuation))
import Data.List (transpose, intersperse, foldl')
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Text (Text)
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Class.PandocMonad (PandocMonad, report)
import Text.Pandoc.Definition
import Text.Pandoc.ImageSize
import Text.Pandoc.Logging
import Text.Pandoc.Options
import Text.DocLayout
import Text.Pandoc.Shared
import Text.Pandoc.URI
import Text.Pandoc.Templates (renderTemplate)
import Text.Pandoc.Writers.Shared
import Text.Pandoc.Walk
import Safe (lastMay, headMay)

type Refs = [([Inline], Target)]

data WriterState =
  WriterState { stNotes       :: [[Block]]
              , stLinks       :: Refs
              , stImages      :: [([Inline], (Attr, Text, Text, Maybe Text))]
              , stHasMath     :: Bool
              , stHasRawTeX   :: Bool
              , stOptions     :: WriterOptions
              , stTopLevel    :: Bool
              , stImageId     :: Int
              }

type RST = StateT WriterState

-- | Convert Pandoc to RST.
writeRST :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeRST opts document = do
  let st = WriterState { stNotes = [], stLinks = [],
                         stImages = [], stHasMath = False,
                         stHasRawTeX = False, stOptions = opts,
                         stTopLevel = True, stImageId = 1 }
  evalStateT (pandocToRST document) st

-- | Return RST representation of document.
pandocToRST :: PandocMonad m => Pandoc -> RST m Text
pandocToRST (Pandoc meta blocks) = do
  opts <- gets stOptions
  let colwidth = if writerWrapText opts == WrapAuto
                    then Just $ writerColumns opts
                    else Nothing
  let subtit = lookupMetaInlines "subtitle" meta
  title <- titleToRST (docTitle meta) subtit
  metadata <- metaToContext opts
                blockListToRST
                (fmap chomp . inlineListToRST)
                meta
  body <- blockListToRST' True $ case writerTemplate opts of
                                      Just _  -> normalizeHeadings 1 blocks
                                      Nothing -> blocks
  notes <- gets (reverse . stNotes) >>= notesToRST
  -- note that the notes may contain refs, so we do them first
  refs <- gets (reverse . stLinks) >>= refsToRST
  pics <- gets (reverse . stImages) >>= pictRefsToRST
  hasMath <- gets stHasMath
  rawTeX <- gets stHasRawTeX
  let main = vsep [body, notes, refs, pics]
  let context = defField "body" main
              $ defField "toc" (writerTableOfContents opts)
              $ defField "toc-depth" (tshow $ writerTOCDepth opts)
              $ defField "number-sections" (writerNumberSections opts)
              $ defField "math" hasMath
              $ defField "titleblock" (render Nothing title :: Text)
              $ defField "math" hasMath
              $ defField "rawtex" rawTeX metadata
  return $ render colwidth $
    case writerTemplate opts of
       Nothing  -> main
       Just tpl -> renderTemplate tpl context
  where
    normalizeHeadings lev (Header l a i:bs) =
      Header lev a i:normalizeHeadings (lev+1) cont ++ normalizeHeadings lev bs'
      where (cont,bs') = break (headerLtEq l) bs
            headerLtEq level (Header l' _ _) = l' <= level
            headerLtEq _ _                   = False
    normalizeHeadings lev (b:bs) = b:normalizeHeadings lev bs
    normalizeHeadings _   []     = []

-- | Return RST representation of reference key table.
refsToRST :: PandocMonad m => Refs -> RST m (Doc Text)
refsToRST refs =
   vcat <$> mapM keyToRST refs

-- | Return RST representation of a reference key.
keyToRST :: PandocMonad m => ([Inline], (Text, Text)) -> RST m (Doc Text)
keyToRST (label, (src, _)) = do
  label' <- inlineListToRST label
  let label'' = if (==':') `T.any` (render Nothing label' :: Text)
                   then char '`' <> label' <> char '`'
                   else label'
  return $ nowrap $ ".. _" <> label'' <> ": " <> literal src

-- | Return RST representation of notes.
notesToRST :: PandocMonad m => [[Block]] -> RST m (Doc Text)
notesToRST notes =
   vsep <$> zipWithM noteToRST [1..] notes

-- | Return RST representation of a note.
noteToRST :: PandocMonad m => Int -> [Block] -> RST m (Doc Text)
noteToRST num note = do
  contents <- blockListToRST note
  let marker = ".. [" <> text (show num) <> "]"
  return $ nowrap $ marker $$ nest 3 contents

-- | Return RST representation of picture reference table.
pictRefsToRST :: PandocMonad m
              => [([Inline], (Attr, Text, Text, Maybe Text))]
              -> RST m (Doc Text)
pictRefsToRST refs =
   vcat <$> mapM pictToRST refs

-- | Return RST representation of a picture substitution reference.
pictToRST :: PandocMonad m
          => ([Inline], (Attr, Text, Text, Maybe Text))
          -> RST m (Doc Text)
pictToRST (label, (attr, src, _, mbtarget)) = do
  label' <- inlineListToRST label
  dims   <- imageDimsToRST attr
  let (_, cls, _) = attr
      classes = case cls of
                   []               -> empty
                   ["align-top"]    -> ":align: top"
                   ["align-middle"] -> ":align: middle"
                   ["align-bottom"] -> ":align: bottom"
                   ["align-center"] -> empty
                   ["align-right"]  -> empty
                   ["align-left"]   -> empty
                   _                -> ":class: " <> literal (T.unwords cls)
  return $ nowrap
         $ ".. |" <> label' <> "| image:: " <> literal src $$ hang 3 empty (classes $$ dims)
         $$ case mbtarget of
                 Nothing -> empty
                 Just t  -> "   :target: " <> literal t

-- | Escape special characters for RST.
escapeText :: WriterOptions -> Text -> Text
escapeText opts t =
  if T.any isSpecial t
     then T.pack . escapeString' True . T.unpack $ t
     else t -- optimization
 where
  isSmart = isEnabled Ext_smart opts
  isSpecial c = c == '\\' || c == '_' || c == '`' || c == '*' || c == '|'
                || (isSmart && (c == '-' || c == '.' || c == '"' || c == '\''))
  canFollowInlineMarkup c = c == '-' || c == '.' || c == ',' || c == ':'
                    || c == ';' || c == '!' || c == '?' || c == '\''
                    || c == '"' || c == ')' || c == ']' || c == '}'
                    || c == '>' || isSpace c
                    || (not (isAscii c) &&
                        generalCategory c `elem`
                        [OpenPunctuation, InitialQuote, FinalQuote,
                         DashPunctuation, OtherPunctuation])
  canPrecedeInlineMarkup c = c == '-' || c == ':' || c == '/' || c == '\''
                     || c == '"' || c == '<' || c == '(' || c == '['
                     || c == '{' || isSpace c
                     || (not (isAscii c) &&
                          generalCategory c `elem`
                          [ClosePunctuation, InitialQuote, FinalQuote,
                          DashPunctuation, OtherPunctuation])
  escapeString' canStart cs =
    case cs of
      [] -> []
      d:ds
        | d == '\\'
        -> '\\' : d : escapeString' False ds
      '\'':ds
        | isSmart
        -> '\\' : '\'' : escapeString' True ds
      '"':ds
        | isSmart
        -> '\\' : '"' : escapeString' True ds
      '-':'-':ds
        | isSmart
        -> '\\' : '-' : escapeString' False ('-':ds)
      '.':'.':'.':ds
        | isSmart
        -> '\\' : '.' : escapeString' False ('.':'.':ds)
      [e]
        | e == '*' || e == '_' || e == '|' || e == '`'
        -> ['\\',e]
      d:ds
        | canPrecedeInlineMarkup d
        -> d : escapeString' True ds
      e:d:ds
        | e == '*' || e == '_' || e == '|' || e == '`'
        , (not canStart && canFollowInlineMarkup d)
          || (canStart && not (isSpace d))
        -> '\\' : e : escapeString' False (d:ds)
      '_':d:ds
        | not (isAlphaNum d)
        -> '\\' : '_' : escapeString' False (d:ds)
      d:ds -> d : escapeString' False ds

titleToRST :: PandocMonad m => [Inline] -> [Inline] -> RST m (Doc Text)
titleToRST [] _ = return empty
titleToRST tit subtit = do
  title <- inlineListToRST tit
  subtitle <- inlineListToRST subtit
  return $ bordered title '=' $$ bordered subtitle '-'

bordered :: Doc Text -> Char -> Doc Text
bordered contents c =
  if len > 0
     then border $$ contents $$ border
     else empty
   where len = offset contents
         border = literal (T.replicate len $ T.singleton c)

-- | Convert Pandoc block element to RST.
blockToRST :: PandocMonad m
           => Block         -- ^ Block element
           -> RST m (Doc Text)
blockToRST (Div ("",["title"],[]) _) = return empty
  -- this is generated by the rst reader and can safely be
  -- omitted when we're generating rst
blockToRST (Div (ident,classes,_kvs) bs) = do
  contents <- blockListToRST bs
  let admonitions = ["attention","caution","danger","error","hint",
                     "important","note","tip","warning","admonition"]
  let admonition = case classes of
                        (cl:_)
                          | cl `elem` admonitions
                          -> blankline <> ".. " <> literal cl <> "::"
                        cls -> blankline <> ".. container::" <> space <>
                                   literal (T.unwords (filter (/= "container") cls))
  -- if contents start with block quote, we need to insert
  -- an empty comment to fix the indentation point (#10236)
  let contents' = case bs of
                    BlockQuote{}:_-> ".." $+$ contents
                    _ -> contents
  return $ blankline $$
           admonition $$
           (if T.null ident
               then blankline
               else "   :name: " <> literal ident $$ blankline) $$
           nest 3 contents' $$
           blankline
blockToRST (Plain inlines) = inlineListToRST inlines
blockToRST (Para inlines)
  | LineBreak `elem` inlines =
      linesToLineBlock $ splitBy (==LineBreak) inlines
  | otherwise = do
      contents <- inlineListToRST inlines
      return $ contents <> blankline
blockToRST (LineBlock lns) =
  linesToLineBlock lns
blockToRST (RawBlock f@(Format f') str)
  | f == "rst" = return $ literal str
  | f == "tex" = blockToRST (RawBlock (Format "latex") str)
  | otherwise  = return $ blankline <> ".. raw:: " <>
                    literal (T.toLower f') $+$
                    nest 3 (literal str) $$ blankline
blockToRST HorizontalRule =
  return $ blankline $$ "--------------" $$ blankline
blockToRST (Header level (name,classes,_) inlines) = do
  contents <- inlineListToRST inlines
  -- we calculate the id that would be used by auto_identifiers
  -- so we know whether to print an explicit identifier
  opts <- gets stOptions
  let autoId = uniqueIdent (writerExtensions opts) inlines mempty
  isTopLevel <- gets stTopLevel
  if isTopLevel
    then do
          let headerChar = if level > 5 then ' ' else "=-~^'" !! (level - 1)
          let border = literal $ T.replicate (offset contents) $ T.singleton headerChar
          let anchor | T.null name || name == autoId = empty
                     | otherwise = ".. _" <>
                                   (if T.any (==':') name ||
                                        T.take 1 name == "_"
                                       then "`" <> literal name <> "`"
                                       else literal name) <>
                                   ":" $$ blankline
          return $ nowrap $ anchor $$ contents $$ border $$ blankline
    else do
          let rub     = "rubric:: " <> contents
          let name' | T.null name    = empty
                    | otherwise      = ":name: " <> literal name
          let cls   | null classes   = empty
                    | otherwise      = ":class: " <> literal (T.unwords classes)
          return $ nowrap $ hang 3 ".. " (rub $$ name' $$ cls) $$ blankline
blockToRST (CodeBlock (_,classes,kvs) str) = do
  opts <- gets stOptions
  let startnum = maybe "" (\x -> " " <> literal x) $ lookup "startFrom" kvs
  let numberlines = if "numberLines" `elem` classes
                       then "   :number-lines:" <> startnum
                       else empty
  if "haskell" `elem` classes && "literate" `elem` classes &&
                  isEnabled Ext_literate_haskell opts
     then return $ prefixed "> " (literal str) $$ blankline
     else return $
          (case [c | c <- classes,
                     c `notElem` ["sourceCode","literate","numberLines",
                                  "number-lines","example"]] of
             []       -> "::"
             (lang:_) -> (blankline <> ".. code:: " <> literal lang) $$ numberlines)
          $+$ nest 3 (literal str) $$ blankline
blockToRST (BlockQuote blocks) = do
  contents <- blockListToRST blocks
  return $ nest 3 contents <> blankline
blockToRST (Table _attrs blkCapt specs thead tbody tfoot) = do
  let (caption, aligns, widths, headers, rows) =
        toLegacyTable blkCapt specs thead tbody tfoot
  caption' <- inlineListToRST caption
  let blocksToDoc opts bs = do
         oldOpts <- gets stOptions
         modify $ \st -> st{ stOptions = opts }
         result <- blockListToRST bs
         modify $ \st -> st{ stOptions = oldOpts }
         return result
  opts <- gets stOptions
  let specs' = map (\(_,width) -> (AlignDefault, width)) specs
      renderGrid = gridTable opts blocksToDoc specs' thead tbody tfoot
      isSimple = all (== 0) widths && length widths > 1
      renderSimple = do
        tbl' <- simpleTable opts blocksToDoc thead tbody tfoot
        if offset tbl' > writerColumns opts
          then renderGrid
          else return tbl'
      isList = writerListTables opts
      renderList = tableToRSTList caption (map (const AlignDefault) aligns)
                    widths headers rows
      rendered
        | isList    = renderList
        | isSimple  = renderSimple
        | otherwise = renderGrid
  tbl <- rendered
  return $ blankline $$
           (if null caption || isList
               then tbl
               else (blankline <> ".. table:: " <> caption') $$ blankline $$ nest 3 tbl) $$
           blankline
blockToRST (BulletList items) = do
  contents <- mapM bulletListItemToRST items
  -- ensure that sublists have preceding blank line
  return $ blankline $$
           (if isTightList items then vcat else vsep) contents $$
           blankline
blockToRST (OrderedList (start, style', delim) items) = do
  let markers = if start == 1 && style' == DefaultStyle && delim == DefaultDelim
                   then replicate (length items) "#."
                   else take (length items) $ orderedListMarkers
                                              (start, style', delim)
  let maxMarkerLength = maybe 0 maximum $ NE.nonEmpty $ map T.length markers
  let markers' = map (\m -> let s = maxMarkerLength - T.length m
                            in  m <> T.replicate s " ") markers
  contents <- zipWithM orderedListItemToRST markers' items
  -- ensure that sublists have preceding blank line
  return $ blankline $$
           (if isTightList items then vcat else vsep) contents $$
           blankline
blockToRST (DefinitionList items) = do
  contents <- mapM definitionListItemToRST items
  -- ensure that sublists have preceding blank line
  return $ blankline $$ vcat contents $$ blankline

blockToRST (Figure (ident, classes, _kvs)
             (Caption _ longCapt) body) = do
  let figure attr txt (src, tit) = do
        description <- inlineListToRST txt
        capt <- blockListToRST longCapt
        dims <- imageDimsToRST attr
        let fig = "figure::" <+> literal src
            alt = if null txt
                     then if T.null tit
                              then empty
                              else ":alt:" <+> literal tit
                     else ":alt:" <+> description
            name = if T.null ident
                      then empty
                      else "name:" <+> literal ident
            (_,cls,_) = attr
            align = case cls of
                      []               -> empty
                      ["align-right"]  -> ":align: right"
                      ["align-left"]   -> ":align: left"
                      ["align-center"] -> ":align: center"
                      _ -> ":figclass: " <> literal (T.unwords cls)
        return $ hang 3 ".. " (fig $$ name $$ alt $$ align $$ dims $+$ capt)
              $$ blankline
  case body of
    [Para  [Image attr txt tgt]] -> figure attr txt tgt
    [Plain [Image attr txt tgt]] -> figure attr txt tgt
    _ -> do
      content <- blockListToRST body
      return $ blankline $$ (
        ".. container:: float" <> space <>
        literal (T.unwords (filter (/= "container") classes))) $$
        (if T.null ident
         then blankline
         else "   :name: " <> literal ident $$ blankline) $$
        nest 3 content $$
        blankline

-- | Convert bullet list item (list of blocks) to RST.
bulletListItemToRST :: PandocMonad m => [Block] -> RST m (Doc Text)
bulletListItemToRST items = do
  contents <- blockListToRST items
  -- if a list item starts with block quote, we need to insert
  -- an empty comment to fix the indentation point (#10236)
  let contents' = case items of
                    BlockQuote{}:_-> ".." $+$ contents
                    _ -> contents
  return $ hang 2 "- " contents' $$
      if null items || (endsWithPlain items && not (endsWithList items))
         then cr
         else blankline

-- | Convert ordered list item (a list of blocks) to RST.
orderedListItemToRST :: PandocMonad m
                     => Text   -- ^ marker for list item
                     -> [Block]  -- ^ list item (list of blocks)
                     -> RST m (Doc Text)
orderedListItemToRST marker items = do
  contents <- blockListToRST items
  let marker' = marker <> " "
  -- if a list item starts with block quote, we need to insert
  -- an empty comment to fix the indentation point (#10236)
  let contents' = case items of
                    BlockQuote{}:_-> ".." $+$ contents
                    _ -> contents
  return $ hang (T.length marker') (literal marker') contents' $$
      if null items || (endsWithPlain items && not (endsWithList items))
         then cr
         else blankline

endsWithList :: [Block] -> Bool
endsWithList bs = case lastMay bs of
                    Just (BulletList{}) -> True
                    Just (OrderedList{}) -> True
                    _ -> False

-- | Convert definition list item (label, list of blocks) to RST.
definitionListItemToRST :: PandocMonad m => ([Inline], [[Block]]) -> RST m (Doc Text)
definitionListItemToRST (label, defs) = do
  label' <- inlineListToRST label
  contents <- liftM vcat $ mapM blockListToRST defs
  -- if definition list starts with block quote, we need to insert
  -- an empty comment to fix the indentation point (#10236)
  let contents' = case defs of
                    (BlockQuote{}:_):_ -> ".." $+$ contents
                    _ -> contents
  return $ nowrap label' $$ nest 3 (nestle contents') $$
      if isTightList defs
         then cr
         else blankline

-- | Format a list of lines as line block.
linesToLineBlock :: PandocMonad m => [[Inline]] -> RST m (Doc Text)
linesToLineBlock inlineLines = do
  lns <- mapM inlineListToRST inlineLines
  return $
                      vcat (map (hang 2 (literal "| ")) lns) <> blankline

-- | Convert list of Pandoc block elements to RST.
blockListToRST' :: PandocMonad m
                => Bool
                -> [Block]       -- ^ List of block elements
                -> RST m (Doc Text)
blockListToRST' topLevel blocks = do
  -- insert comment between list and quoted blocks, see #4248 and #3675
  let fixBlocks (b1:b2@(BlockQuote _):bs)
        | toClose b1 = b1 : commentSep : b2 : fixBlocks bs
        where
          toClose Plain{}                  = False
          toClose Header{}                 = False
          toClose LineBlock{}              = False
          toClose HorizontalRule           = False
          toClose SimpleFigure{}           = True
          toClose Para{}                   = False
          toClose _                        = True
          commentSep  = RawBlock "rst" "..\n\n"
      fixBlocks (b:bs) = b : fixBlocks bs
      fixBlocks [] = []
  tl <- gets stTopLevel
  modify (\s->s{stTopLevel=topLevel})
  res <- vcat `fmap` mapM blockToRST (fixBlocks blocks)
  modify (\s->s{stTopLevel=tl})
  return res

blockListToRST :: PandocMonad m
               => [Block]       -- ^ List of block elements
               -> RST m (Doc Text)
blockListToRST = blockListToRST' False

{-

http://docutils.sourceforge.net/docs/ref/rst/restructuredtext.html#directives

According to the terminology used in the spec, a marker includes a
final whitespace and a block includes the directive arguments. Here
the variable names have slightly different meanings because we don't
want to finish the line with a space if there are no arguments, it
would produce rST that differs from what users expect in a way that's
not easy to detect

-}
toRSTDirective :: Doc Text -> Doc Text -> [(Doc Text, Doc Text)] -> Doc Text -> Doc Text
toRSTDirective typ args options content = marker <> spaceArgs <> cr <> block
  where marker = ".. " <> typ <> "::"
        block = nest 3 (fieldList $$
                        blankline $$
                        content $$
                        blankline)
        spaceArgs = if isEmpty args then "" else " " <> args
        -- a field list could end up being an empty doc thus being
        -- omitted by $$
        fieldList = foldl ($$) "" $ map joinField options
        -- a field body can contain multiple lines
        joinField (name, body) = ":" <> name <> ": " <> body

tableToRSTList :: PandocMonad m
             => [Inline]
             -> [Alignment]
             -> [Double]
             -> [[Block]]
             -> [[[Block]]]
             -> RST m (Doc Text)
tableToRSTList caption _ propWidths headers rows = do
  captionRST <- inlineListToRST caption
  opts       <- gets stOptions
  content    <- listTableContent toWrite
  pure $ toRSTDirective "list-table" captionRST (directiveOptions opts) content
  where directiveOptions opts = widths (writerColumns opts) propWidths <>
                                headerRows
        toWrite = if noHeaders then rows else headers:rows
        headerRows = [("header-rows", text $ show (1 :: Int)) | not noHeaders]
        widths tot pro = [("widths", showWidths tot pro) |
                          not (null propWidths || all (==0.0) propWidths)]
        noHeaders = all null headers
        -- >>> showWidths 70 [0.5, 0.5]
        -- "35 35"
        showWidths :: Int -> [Double] -> Doc Text
        showWidths tot = text . unwords . map (show . toColumns tot)
        -- toColumns converts a width expressed as a proportion of the
        -- total into a width expressed as a number of columns
        toColumns :: Int -> Double -> Int
        toColumns t p = round (p * fromIntegral t)
        listTableContent :: PandocMonad m => [[[Block]]] -> RST m (Doc Text)
        listTableContent = fmap vcat .
          mapM (fmap (hang 2 (text "* ") . vcat) . mapM bulletListItemToRST)

transformInlines :: [Inline] -> [Inline]
transformInlines =  insertBS .
                    filter hasContents .
                    removeSpaceAfterDisplayMath .
                    concatMap (transformNested . flatten)
  where -- empty inlines are not valid RST syntax
        hasContents :: Inline -> Bool
        hasContents (Str "")              = False
        hasContents (Emph [])             = False
        hasContents (Underline [])        = False
        hasContents (Strong [])           = False
        hasContents (Strikeout [])        = False
        hasContents (Superscript [])      = False
        hasContents (Subscript [])        = False
        hasContents (SmallCaps [])        = False
        hasContents (Quoted _ [])         = False
        hasContents (Cite _ [])           = False
        hasContents (Span _ [])           = False
        hasContents (Link _ [] ("", ""))  = False
        hasContents (Image _ [] ("", "")) = False
        hasContents _                     = True
        -- remove spaces after displaymath, as they screw up indentation:
        removeSpaceAfterDisplayMath (Math DisplayMath x : zs) =
              Math DisplayMath x : dropWhile (==Space) zs
        removeSpaceAfterDisplayMath (x:xs) = x : removeSpaceAfterDisplayMath xs
        removeSpaceAfterDisplayMath [] = []
        insertBS :: [Inline] -> [Inline] -- insert '\ ' where needed
        insertBS (x:y:z:zs)
          | isComplex y && surroundComplex x z =
              x : y : insertBS (z : zs)
        insertBS (x:y:zs)
          | isComplex x && not (okAfterComplex y) =
              x : RawInline "rst" "\\ " : insertBS (y : zs)
          | isComplex y && not (okBeforeComplex x) =
              x : RawInline "rst" "\\ " : insertBS (y : zs)
          | otherwise =
              x : insertBS (y : zs)
        insertBS (x:ys) = x : insertBS ys
        insertBS [] = []
        transformNested :: [Inline] -> [Inline]
        transformNested = concatMap exportLeadingTrailingSpace
        exportLeadingTrailingSpace :: Inline -> [Inline]
        exportLeadingTrailingSpace il
          | isComplex il =
             let contents = dropInlineParent il
                 headSpace = headMay contents == Just Space
                 lastSpace = lastMay contents == Just Space
              in (if headSpace then (Space:) else id) .
                 (if lastSpace then (++ [Space]) else id) $
                 [setInlineChildren il (stripLeadingTrailingSpace contents)]
          | otherwise = [il]

        surroundComplex :: Inline -> Inline -> Bool
        surroundComplex (Str s) (Str s')
          | Just (_, c)  <- T.unsnoc s
          , Just (c', _) <- T.uncons s'
          = case (c, c') of
              ('\'','\'') -> True
              ('"','"')   -> True
              ('<','>')   -> True
              ('[',']')   -> True
              ('{','}')   -> True
              _           -> False
        surroundComplex _ _ = False
        okAfterComplex :: Inline -> Bool
        okAfterComplex Space = True
        okAfterComplex SoftBreak = True
        okAfterComplex LineBreak = True
        okAfterComplex (Str (T.uncons -> Just (c,_)))
          = isSpace c || T.any (== c) "-.,:;!?\\/'\")]}>–—"
        okAfterComplex _ = False
        okBeforeComplex :: Inline -> Bool
        okBeforeComplex Space = True
        okBeforeComplex SoftBreak = True
        okBeforeComplex LineBreak = True
        okBeforeComplex (Str (T.unsnoc -> Just (_,c)))
          = isSpace c || T.any (== c) "-:/'\"<([{–—"
        okBeforeComplex _ = False
        isComplex :: Inline -> Bool
        isComplex (Emph _)        = True
        isComplex (Underline _)   = True
        isComplex (Strong _)      = True
        isComplex (SmallCaps _)   = True
        isComplex (Strikeout _)   = True
        isComplex (Superscript _) = True
        isComplex (Subscript _)   = True
        isComplex Link{}          = True
        isComplex Image{}         = True
        isComplex (Code _ _)      = True
        isComplex (Math _ _)      = True
        isComplex (Cite _ (x:_))  = isComplex x
        isComplex (Span _ (x:_))  = isComplex x
        isComplex _               = False

-- | Flattens nested inlines. Extracts nested inlines and goes through
-- them either collapsing them in the outer inline container or
-- pulling them out of it
flatten :: Inline -> [Inline]
flatten outer
  | null contents = [outer]
  | otherwise     = combineAll contents
  where contents = dropInlineParent outer
        combineAll = foldl' combine []

        combine :: [Inline] -> Inline -> [Inline]
        combine f i =
          case (outer, i) of
          -- quotes are not rendered using RST inlines, so we can keep
          -- them and they will be readable and parsable
          (Quoted _ _, _)          -> keep f i
          (_, Quoted _ _)          -> keep f i
          -- spans are not rendered using RST inlines, so we can keep them
          (Span (_,_,[]) _, _)   -> keep f i
          (_, Span (_,_,[]) _)   -> keep f i
          -- inlineToRST handles this case properly so it's safe to keep
          ( Link{}, Image{})       -> keep f i
          -- parent inlines would prevent links from being correctly
          -- parsed, in this case we prioritise the content over the
          -- style
          (_, Link{})              -> emerge f i
          -- always give priority to strong text over emphasis
          (Emph _, Strong _)       -> emerge f i
          -- drop all other nested styles
          (_, _)                   -> collapse f i

        emerge f i = f <> [i]
        keep f i = appendToLast f [i]
        collapse f i = appendToLast f $ dropInlineParent i

        appendToLast :: [Inline] -> [Inline] -> [Inline]
        appendToLast flattened toAppend =
          case NE.nonEmpty flattened of
            Nothing -> [setInlineChildren outer toAppend]
            Just xs ->
              if isOuter lastFlat
                 then NE.init xs <> [appendTo lastFlat toAppend]
                 else flattened <> [setInlineChildren outer toAppend]
               where
                lastFlat = NE.last xs
                appendTo o i = mapNested (<> i) o
                isOuter i = emptyParent i == emptyParent outer
                emptyParent i = setInlineChildren i []

mapNested :: ([Inline] -> [Inline]) -> Inline -> Inline
mapNested f i = setInlineChildren i (f (dropInlineParent i))

dropInlineParent :: Inline -> [Inline]
dropInlineParent (Link _ i _)    = i
dropInlineParent (Emph i)        = i
dropInlineParent (Underline i)   = i
dropInlineParent (Strong i)      = i
dropInlineParent (Strikeout i)   = i
dropInlineParent (Superscript i) = i
dropInlineParent (Subscript i)   = i
dropInlineParent (SmallCaps i)   = i
dropInlineParent (Cite _ i)      = i
dropInlineParent (Image _ i _)   = i
dropInlineParent (Span _ i)      = i
dropInlineParent (Quoted _ i)    = i
dropInlineParent i               = [i] -- not a parent, like Str or Space

setInlineChildren :: Inline -> [Inline] -> Inline
setInlineChildren (Link a _ t) i    = Link a i t
setInlineChildren (Emph _) i        = Emph i
setInlineChildren (Underline _) i   = Underline i
setInlineChildren (Strong _) i      = Strong i
setInlineChildren (Strikeout _) i   = Strikeout i
setInlineChildren (Superscript _) i = Superscript i
setInlineChildren (Subscript _) i   = Subscript i
setInlineChildren (SmallCaps _) i   = SmallCaps i
setInlineChildren (Quoted q _) i    = Quoted q i
setInlineChildren (Cite c _) i      = Cite c i
setInlineChildren (Image a _ t) i   = Image a i t
setInlineChildren (Span a _) i      = Span a i
setInlineChildren leaf _            = leaf

inlineListToRST :: PandocMonad m => [Inline] -> RST m (Doc Text)
inlineListToRST = writeInlines . walk transformInlines

-- | Convert list of Pandoc inline elements to RST.
writeInlines :: PandocMonad m => [Inline] -> RST m (Doc Text)
writeInlines lst =
   hcat <$> mapM inlineToRST lst

-- | Convert Pandoc inline element to RST.
inlineToRST :: PandocMonad m => Inline -> RST m (Doc Text)
inlineToRST (Span ("",["mark"],[]) ils) = do
  contents <- writeInlines ils
  return $ ":mark:`" <> contents <> "`"
inlineToRST (Span (_,_,kvs) ils) = do
  contents <- writeInlines ils
  return $
    case lookup "role" kvs of
          Just role -> ":" <> literal role <> ":`" <> contents <> "`"
          Nothing   -> contents
inlineToRST (Emph lst) = do
  contents <- writeInlines lst
  return $ "*" <> contents <> "*"
-- Underline is not supported, fall back to Emph
inlineToRST (Underline lst) =
  inlineToRST (Emph lst)
inlineToRST (Strong lst) = do
  contents <- writeInlines lst
  return $ "**" <> contents <> "**"
inlineToRST (Strikeout lst) = do
  contents <- writeInlines lst
  return $ "[STRIKEOUT:" <> contents <> "]"
inlineToRST (Superscript lst) = do
  contents <- writeInlines lst
  return $ ":sup:`" <> contents <> "`"
inlineToRST (Subscript lst) = do
  contents <- writeInlines lst
  return $ ":sub:`" <> contents <> "`"
inlineToRST (SmallCaps lst) = writeInlines lst
inlineToRST (Quoted SingleQuote lst) = do
  contents <- writeInlines lst
  opts <- gets stOptions
  if isEnabled Ext_smart opts
     then return $ "'" <> contents <> "'"
     else return $ "‘" <> contents <> "’"
inlineToRST (Quoted DoubleQuote lst) = do
  contents <- writeInlines lst
  opts <- gets stOptions
  if isEnabled Ext_smart opts
     then return $ "\"" <> contents <> "\""
     else return $ "“" <> contents <> "”"
inlineToRST (Cite _  lst) =
  writeInlines lst
inlineToRST (Code (_,["interpreted-text"],[("role",role)]) str) =
  return $ ":" <> literal role <> ":`" <> literal str <> "`"
inlineToRST (Code _ str) = do
  opts <- gets stOptions
  -- we trim the string because the delimiters must adjoin a
  -- non-space character; see #3496
  -- we use :literal: when the code contains backticks, since
  -- :literal: allows backslash-escapes; see #3974
  return $
    if T.any (== '`') str
       then ":literal:`" <> literal (escapeText opts (trim str)) <> "`"
       else "``" <> literal (trim str) <> "``"
inlineToRST (Str str) = do
  opts <- gets stOptions
  return $ literal $
    (if isEnabled Ext_smart opts
        then unsmartify opts
        else id) $ escapeText opts str
inlineToRST (Math t str) = do
  modify $ \st -> st{ stHasMath = True }
  return $ if t == InlineMath
              then ":math:`" <> literal str <> "`"
              else if T.any (== '\n') str
                   then blankline $$ ".. math::" $$
                        blankline $$ nest 3 (literal str) $$ blankline
                   else blankline $$ (".. math:: " <> literal str) $$ blankline
inlineToRST il@(RawInline f x)
  | f == "rst" = return $ literal x
  | f == "latex" || f == "tex" = do
      modify $ \st -> st{ stHasRawTeX = True }
      return $ ":raw-latex:`" <> literal x <> "`"
  | otherwise  = empty <$ report (InlineNotRendered il)
inlineToRST LineBreak = return cr -- there's no line break in RST (see Para)
inlineToRST Space = return space
inlineToRST SoftBreak = do
  wrapText <- gets $ writerWrapText . stOptions
  case wrapText of
        WrapPreserve -> return cr
        WrapAuto     -> return space
        WrapNone     -> return space
-- autolink
inlineToRST (Link _ [Str str] (src, _))
  | isURI src &&
    if "mailto:" `T.isPrefixOf` src
       then src == escapeURI ("mailto:" <> str)
       else src == escapeURI str = do
  let srcSuffix = fromMaybe src (T.stripPrefix "mailto:" src)
  return $ literal srcSuffix
inlineToRST (Link _ [Image attr alt (imgsrc,imgtit)] (src, _tit)) = do
  label <- registerImage attr alt (imgsrc,imgtit) (Just src)
  return $ "|" <> label <> "|"
inlineToRST (Link _ txt (src, tit)) = do
  useReferenceLinks <- gets $ writerReferenceLinks . stOptions
  linktext <- writeInlines $ B.toList . B.trimInlines . B.fromList $ txt
  if useReferenceLinks
    then do refs <- gets stLinks
            case lookup txt refs of
                 Just (src',tit') ->
                   if src == src' && tit == tit'
                      then return $ "`" <> linktext <> "`_"
                      else
                        return $ "`" <> linktext <> " <" <> literal src <> ">`__"
                 Nothing -> do
                   modify $ \st -> st { stLinks = (txt,(src,tit)):refs }
                   return $ "`" <> linktext <> "`_"
    else return $ "`" <> linktext <> " <" <> literal src <> ">`__"
inlineToRST (Image attr alternate (source, tit)) = do
  label <- registerImage attr alternate (source,tit) Nothing
  return $ "|" <> label <> "|"
inlineToRST (Note contents) = do
  -- add to notes in state
  notes <- gets stNotes
  modify $ \st -> st { stNotes = contents:notes }
  let ref = show $ length notes + 1
  return $ " [" <> text ref <> "]_"

registerImage :: PandocMonad m => Attr -> [Inline] -> Target -> Maybe Text -> RST m (Doc Text)
registerImage attr alt (src,tit) mbtarget = do
  pics <- gets stImages
  imgId <- gets stImageId
  let getImageName = do
        modify $ \st -> st{ stImageId = imgId + 1 }
        return [Str ("image" <> tshow imgId)]
  txt <- case lookup alt pics of
               Just (a,s,t,mbt) ->
                 if (a,s,t,mbt) == (attr,src,tit,mbtarget)
                    then return alt
                    else do
                        alt' <- getImageName
                        modify $ \st -> st { stImages =
                           (alt', (attr,src,tit, mbtarget)):stImages st }
                        return alt'
               Nothing -> do
                 alt' <- if null alt || alt == [Str ""]
                            then getImageName
                            else return alt
                 modify $ \st -> st { stImages =
                        (alt', (attr,src,tit, mbtarget)):stImages st }
                 return alt'
  inlineListToRST txt

imageDimsToRST :: PandocMonad m => Attr -> RST m (Doc Text)
imageDimsToRST attr = do
  let (ident, _, _) = attr
      name = if T.null ident
                then empty
                else ":name: " <> literal ident
      showDim dir = let cols d = ":" <> text (show dir) <> ": " <> text (show d)
                    in  case dimension dir attr of
                          Just (Percent a) ->
                            case dir of
                              Height -> empty
                              Width  -> cols (Percent a)
                          Just dim -> cols dim
                          Nothing  -> empty
  return $ cr <> name $$ showDim Width $$ showDim Height

simpleTable :: PandocMonad m
            => WriterOptions
            -> (WriterOptions -> [Block] -> m (Doc Text))
            -> TableHead
            -> [TableBody]
            -> TableFoot
            -> m (Doc Text)
simpleTable opts blocksToDoc (TableHead _ headers) tbody (TableFoot _ footers) = do
  headerDocs <- if all isEmptyRow headers
                   then return []
                   else fixEmpties <$> mapM rowToDoc headers
  rowDocs <- fixEmpties <$> mapM rowToDoc ((concatMap tableBodyToRows tbody) ++ footers)
  let numChars = maybe 0 maximum . NE.nonEmpty . map (offset . fst)
  let colWidths = map numChars $ transpose (headerDocs ++ rowDocs)
  let hline = nowrap $ hsep (map (\n -> literal (T.replicate n "=")) colWidths)
  let hdr = if all isEmptyRow headers
               then mempty
               else hline $$ mapToRow colWidths headerDocs
  let bdy = mapToRow colWidths rowDocs
  return $ hdr $$ hline $$ bdy $$ hline
  where
    isEmptyRow (Row _ cells) = all isEmptyCell cells

    isEmptyCell (Cell _ _ _ _ blocks) = null blocks

    -- can't have empty cells in first column:
    fixEmpties (d:ds) = fixEmpties' d : ds
    fixEmpties [] = []

    fixEmpties' ((d, colSpan):ds) = if isEmpty d
                                     then (literal "\\ ", colSpan) : ds
                                     else (d, colSpan) : ds
    fixEmpties' [] = []

    rowToDoc (Row _ cells) = concat <$> mapM cellToDocs cells

    cellToDocs (Cell _ _ _ colSpan blocks) = applyColSpan colSpan <$> (blocksToDoc opts) blocks

    tableBodyToRows (TableBody _ _ headerRows bodyRows) = headerRows ++ bodyRows

    applyColSpan col@(ColSpan colSpan) doc
      | colSpan > 1 =
          -- Fill up columns for the col spans by adding empty docs without a ColSpan.
          let emptyDoc = (literal "", Nothing)
          in  (doc, Just col) : replicate (colSpan - 1) emptyDoc
      | otherwise = [(doc, Just col)]

    mapToRow colWidths = vcat . concatMap (toRow colWidths)

    toRow colWidths rowDocsWithColSpans =
      let (rowDocs, colSpans) = unzip rowDocsWithColSpans
          row = intersperseDivider $ zipWith lblock colWidths rowDocs
          colSpanRow = intersperseDivider $ writeColSpans colSpans colWidths
      in  if any (maybe False (> 1)) colSpans
           then [row, colSpanRow]
           else [row] -- Don't write out col spans if they are all just 1.

    intersperseDivider = mconcat . intersperse (lblock 1 " ")

    -- Write col span dashes to match the length of the col widths.
    writeColSpans [] _ = []
    writeColSpans _ [] = []
    writeColSpans (Nothing : remainingColSpans) colWidths = writeColSpans remainingColSpans colWidths
    writeColSpans (Just (ColSpan colSpan) : remainingColSpans) colWidths =
      let (colWidths', remainingColWidths) = splitAt colSpan colWidths
      in  writeColSpanDashes colWidths' : writeColSpans remainingColSpans remainingColWidths

    writeColSpanDashes colWidths =
      let colWidthsLength = length colWidths
          colWidthsSum = sum colWidths
          dashLength = if colWidthsLength > 1
            -- Offset by 1 for the white spaces between columns so that the col
            -- span dashes align with the end of the columns correctly.
            then colWidthsSum + colWidthsLength - 1
            else colWidthsSum
      in  literal $ T.replicate dashLength "-"