Muse.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}
{- |
   Module      : Text.Pandoc.Writers.Muse
   Copyright   : Copyright (C) 2017-2020 Alexander Krotov
   License     : GNU GPL, version 2 or above

   Maintainer  : Alexander Krotov <ilabdsf@gmail.com>
   Stability   : stable
   Portability : portable

Conversion of 'Pandoc' documents to Muse.

This module is mostly intended for <https://amusewiki.org/ Amusewiki> markup support,
as described by <https://amusewiki.org/library/manual Text::Amuse markup manual>.
Original <https://www.gnu.org/software/emacs-muse/ Emacs Muse> markup support
is a secondary goal.

Where Text::Amuse markup
<https://metacpan.org/pod/Text::Amuse#DIFFERENCES-WITH-THE-ORIGINAL-EMACS-MUSE-MARKUP differs>
from <https://www.gnu.org/software/emacs-muse/manual/ Emacs Muse markup>,
Text::Amuse markup is supported.
For example, native tables are always used instead of Org Mode tables.
However, @\<literal style="html">@ tag is used for HTML raw blocks
even though it is supported only in Emacs Muse.
-}
module Text.Pandoc.Writers.Muse (writeMuse) where
import Control.Monad (zipWithM)
import Control.Monad.Except (throwError)
import Control.Monad.Reader
    ( asks, MonadReader(local), ReaderT(runReaderT) )
import Control.Monad.State.Strict
    ( StateT, gets, modify, evalStateT )
import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, isDigit, isSpace)
import Data.Default
import Data.List (intersperse, transpose)
import Data.List.NonEmpty (nonEmpty, NonEmpty(..))
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text (Text)
import System.FilePath (takeExtension)
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Definition
import Text.Pandoc.Error
import Text.Pandoc.ImageSize
import Text.Pandoc.Options
import Text.DocLayout
import Text.Pandoc.Shared
import Text.Pandoc.URI
import Text.Pandoc.Writers.Math
import Text.Pandoc.Writers.Shared

type Notes = [[Block]]

type Muse m = ReaderT WriterEnv (StateT WriterState m)

data WriterEnv =
  WriterEnv { envOptions               :: WriterOptions
            , envTopLevel              :: Bool
            , envInsideBlock           :: Bool
            , envInlineStart           :: Bool -- ^ True if there is only whitespace since last newline
            , envInsideLinkDescription :: Bool -- ^ Escape ] if True
            , envAfterSpace            :: Bool -- ^ There is whitespace (not just newline) before
            , envOneLine               :: Bool -- ^ True if newlines are not allowed
            , envInsideAsterisks       :: Bool -- ^ True if outer element is emphasis with asterisks
            , envNearAsterisks         :: Bool -- ^ Rendering inline near asterisks
            }

data WriterState =
  WriterState { stNotes   :: Notes
              , stNoteNum :: Int
              , stIds     :: Set.Set Text
              , stUseTags :: Bool -- ^ Use tags for emphasis, for example because previous character is a letter
              }

instance Default WriterState
  where def = WriterState { stNotes = []
                          , stNoteNum = 1
                          , stIds = Set.empty
                          , stUseTags = False
                          }

evalMuse :: PandocMonad m => Muse m a -> WriterEnv -> WriterState -> m a
evalMuse document env = evalStateT $ runReaderT document env

-- | Convert Pandoc to Muse.
writeMuse :: PandocMonad m
          => WriterOptions
          -> Pandoc
          -> m Text
writeMuse opts document =
  evalMuse (pandocToMuse document) env def
  where env = WriterEnv { envOptions = opts
                        , envTopLevel = True
                        , envInsideBlock = False
                        , envInlineStart = True
                        , envInsideLinkDescription = False
                        , envAfterSpace = False
                        , envOneLine = False
                        , envInsideAsterisks = False
                        , envNearAsterisks = False
                        }

-- | Return Muse representation of document.
pandocToMuse :: PandocMonad m
             => Pandoc
             -> Muse m Text
pandocToMuse (Pandoc meta blocks) = do
  opts <- asks envOptions
  metadata <- metaToContext opts
               blockListToMuse
               (fmap chomp . inlineListToMuse)
               meta
  body <- blockListToMuse blocks
  notes <- currentNotesToMuse
  let main = body $+$ notes
  let context = defField "body" main metadata
  return $ renderWithTemplate opts context main

-- | Helper function for flatBlockListToMuse
-- | Render all blocks and insert blank lines between the first two
catWithBlankLines :: PandocMonad m
                  => [Block]       -- ^ List of block elements
                  -> Int           -- ^ Number of blank lines
                  -> Muse m (Doc Text)
catWithBlankLines (b : bs) n = do
  b' <- blockToMuseWithNotes b
  bs' <- flatBlockListToMuse bs
  return $ b' <> blanklines n <> bs'
catWithBlankLines _ _ = error "Expected at least one block"

-- | Convert list of Pandoc block elements to Muse
-- | without setting envTopLevel.
flatBlockListToMuse :: PandocMonad m
                => [Block]       -- ^ List of block elements
                -> Muse m (Doc Text)
flatBlockListToMuse bs@(BulletList _ : BulletList _ : _) = catWithBlankLines bs 2
flatBlockListToMuse bs@(OrderedList (_, style1, _) _ : OrderedList (_, style2, _) _ : _) =
  catWithBlankLines bs (if style1' == style2' then 2 else 0)
    where
      style1' = normalizeStyle style1
      style2' = normalizeStyle style2
      normalizeStyle DefaultStyle = Decimal
      normalizeStyle s            = s
flatBlockListToMuse bs@(DefinitionList _ : DefinitionList _ : _) = catWithBlankLines bs 2
flatBlockListToMuse bs@(_ : _) = catWithBlankLines bs 0
flatBlockListToMuse [] = return mempty

simpleTable :: PandocMonad m
            => [Inline]
            -> [[Block]]
            -> [[[Block]]]
            -> Muse m (Doc Text)
simpleTable caption headers rows = do
  topLevel <- asks envTopLevel
  caption' <- inlineListToMuse caption
  headers' <- mapM blockListToMuse headers
  rows' <- mapM (mapM blockListToMuse) rows
  let widthsInChars = maybe 0 maximum . nonEmpty . map offset <$>
                       transpose (headers' : rows')
  let hpipeBlocks sep blocks = hcat $ intersperse sep' blocks
        where sep' = lblock (T.length sep) $ literal sep
  let makeRow sep = hpipeBlocks sep . zipWith lblock widthsInChars
  let head' = makeRow " || " headers'
  rows'' <- mapM (\row -> makeRow rowSeparator <$> mapM blockListToMuse row) rows
  let body = vcat rows''
  return $ (if topLevel then nest 1 else id) ((if noHeaders then empty else head')
                                             $$ body
                                             $$ (if null caption then empty else "|+ " <> caption' <> " +|"))
         $$ blankline
  where noHeaders = all null headers
        rowSeparator = if noHeaders then " | " else " |  "

-- | Convert list of Pandoc block elements to Muse.
blockListToMuse :: PandocMonad m
                => [Block]       -- ^ List of block elements
                -> Muse m (Doc Text)
blockListToMuse =
  local (\env -> env { envTopLevel = not (envInsideBlock env)
                     , envInsideBlock = True
                     }) . flatBlockListToMuse

-- | Convert Pandoc block element to Muse.
blockToMuse :: PandocMonad m
            => Block         -- ^ Block element
            -> Muse m (Doc Text)
blockToMuse (Plain inlines) = inlineListToMuse' inlines
blockToMuse (Para inlines) = do
  contents <- inlineListToMuse' inlines
  return $ contents <> blankline
blockToMuse (LineBlock lns) = do
  lns' <- local (\env -> env { envOneLine = True }) $ mapM inlineListToMuse lns
  return $ nowrap $ vcat (map (literal "> " <>) lns') <> blankline
blockToMuse (CodeBlock (_,_,_) str) =
  return $ "<example>" $$ literal str $$ "</example>" $$ blankline
blockToMuse (RawBlock (Format format) str) =
  return $ blankline $$ "<literal style=\"" <> literal format <> "\">" $$
           literal str $$ "</literal>" $$ blankline
blockToMuse (BlockQuote blocks) = do
  contents <- flatBlockListToMuse blocks
  return $ blankline
        <> "<quote>"
        $$ nest 0 contents -- nest 0 to remove trailing blank lines
        $$ "</quote>"
        <> blankline
blockToMuse (OrderedList (start, style, _) items) = do
  let markers = take (length items) $ orderedListMarkers
                                      (start, style, Period)
  contents <- zipWithM orderedListItemToMuse markers items
  topLevel <- asks envTopLevel
  return $ (if topLevel then nest 1 else id) (vcat contents) $$ blankline
  where orderedListItemToMuse :: PandocMonad m
                              => Text     -- marker for list item
                              -> [Block]  -- list item (list of blocks)
                              -> Muse m (Doc Text)
        orderedListItemToMuse marker item = hang (T.length marker + 1) (literal marker <> space)
          <$> blockListToMuse item
blockToMuse (BulletList items) = do
  contents <- mapM bulletListItemToMuse items
  topLevel <- asks envTopLevel
  return $ (if topLevel then nest 1 else id) (vcat contents) $$ blankline
  where bulletListItemToMuse :: PandocMonad m
                             => [Block]
                             -> Muse m (Doc Text)
        bulletListItemToMuse item = do
          modify $ \st -> st { stUseTags = False }
          hang 2 "- " <$> blockListToMuse item
blockToMuse (DefinitionList items) = do
  contents <- mapM definitionListItemToMuse items
  topLevel <- asks envTopLevel
  return $ (if topLevel then nest 1 else id) (vcat contents) $$ blankline
  where definitionListItemToMuse :: PandocMonad m
                                 => ([Inline], [[Block]])
                                 -> Muse m (Doc Text)
        definitionListItemToMuse (label, defs) = do
          modify $ \st -> st { stUseTags = False }
          label' <- local (\env -> env { envOneLine = True, envAfterSpace = True }) $ inlineListToMuse' label
          let ind = offset' label' -- using Text.DocLayout.offset results in round trip failures
          hang ind (nowrap label') . vcat <$> mapM descriptionToMuse defs
          where offset' d = maximum (0 :| map T.length
                                         (T.lines $ render Nothing d))
        descriptionToMuse :: PandocMonad m
                          => [Block]
                          -> Muse m (Doc Text)
        descriptionToMuse desc = hang 4 " :: " <$> blockListToMuse desc
blockToMuse (Header level (ident,_,_) inlines) = do
  opts <- asks envOptions
  topLevel <- asks envTopLevel
  contents <- local (\env -> env { envOneLine = True }) $ inlineListToMuse' inlines
  ids <- gets stIds
  let autoId = uniqueIdent (writerExtensions opts) inlines ids
  modify $ \st -> st{ stIds = Set.insert autoId ids }

  let attr' = if T.null ident || (isEnabled Ext_auto_identifiers opts && ident == autoId)
                 then empty
                 else "#" <> literal ident <> cr
  let header' = if topLevel then literal (T.replicate level "*") <> space else mempty
  return $ blankline <> attr' $$ nowrap (header' <> contents) <> blankline
-- https://www.gnu.org/software/emacs-muse/manual/muse.html#Horizontal-Rules-and-Anchors
blockToMuse HorizontalRule = return $ blankline $$ "----" $$ blankline
blockToMuse (Table _ blkCapt specs thead@(TableHead hattr hrows) tbody tfoot) =
  if isSimple && numcols > 1
    then simpleTable caption headers rows
    else do
      opts <- asks envOptions
      let tbody' = case hrows of
                     [] -> tbody
                     _  -> TableBody nullAttr 0 [] hrows : tbody
      gridTable opts blocksToDoc specs (TableHead hattr []) tbody' tfoot
  where
    (caption, aligns, widths, headers, rows) = toLegacyTable blkCapt specs thead tbody tfoot
    blocksToDoc opts blocks =
      local (\env -> env { envOptions = opts }) $ blockListToMuse blocks
    numcols = maximum
              (length aligns :| length widths : map length (headers:rows))
    isSimple = onlySimpleTableCells (headers : rows) && all (== 0) widths
blockToMuse (Div _ bs) = flatBlockListToMuse bs
blockToMuse (Figure attr capt body) = do
  blockToMuse (figureDiv attr capt body)

-- | Return Muse representation of notes collected so far.
currentNotesToMuse :: PandocMonad m
                   => Muse m (Doc Text)
currentNotesToMuse = do
  notes <- reverse <$> gets stNotes
  modify $ \st -> st { stNotes = mempty }
  notesToMuse notes

-- | Return Muse representation of notes.
notesToMuse :: PandocMonad m
            => Notes
            -> Muse m (Doc Text)
notesToMuse notes = do
  n <- gets stNoteNum
  modify $ \st -> st { stNoteNum = stNoteNum st + length notes }
  vsep <$> zipWithM noteToMuse [n ..] notes

-- | Return Muse representation of a note.
noteToMuse :: PandocMonad m
           => Int
           -> [Block]
           -> Muse m (Doc Text)
noteToMuse num note = do
  res <- hang (T.length marker) (literal marker) <$>
    local (\env -> env { envInsideBlock = True
                       , envInlineStart = True
                       , envAfterSpace = True
                       }) (blockListToMuse note)
  return $ res <> blankline
  where
    marker = "[" <> tshow num <> "] "

-- | Return Muse representation of block and accumulated notes.
blockToMuseWithNotes :: PandocMonad m
                     => Block
                     -> Muse m (Doc Text)
blockToMuseWithNotes blk = do
  topLevel <- asks envTopLevel
  opts <- asks envOptions
  let hdrToMuse hdr@Header{} = do
        b <- blockToMuse hdr
        if topLevel && writerReferenceLocation opts == EndOfSection
          then do
            notes <- currentNotesToMuse
            return $ notes $+$ b
          else
            return b
      hdrToMuse b = blockToMuse b
  b <- hdrToMuse blk
  if topLevel && writerReferenceLocation opts == EndOfBlock
    then do
           notes <- currentNotesToMuse
           return $ b $+$ notes <> blankline
    else return b

-- | Escape special characters for Muse.
escapeText :: Text -> Text
escapeText s =
  "<verbatim>" <>
  T.replace "</verbatim>" "<</verbatim><verbatim>/verbatim>" s <>
  "</verbatim>"

-- | Replace newlines with spaces
replaceNewlines :: Text -> Text
replaceNewlines = T.map $ \c ->
  if c == '\n' then ' ' else c

startsWithMarker :: (Char -> Bool) -> Text -> Bool
startsWithMarker f t = case T.uncons $ T.dropWhile f' t of
  Just ('.', xs) -> T.null xs || isSpace (T.head xs)
  _              -> False
  where
    f' c = c == ' ' || f c

containsNotes :: Char -> Char -> Text -> Bool
containsNotes left right = p . T.unpack -- This ought to be a parser
  where p (left':xs)
          | left' == left = q xs || p xs
          | otherwise = p xs
        p ""       = False
        q (x:xs)
          | x `elem` ("123456789"::String) = r xs || p xs
          | otherwise = p xs
        q [] = False
        r ('0':xs) = r xs || p xs
        r xs       = s xs || q xs || p xs
        s (right':xs)
          | right' == right = True
          | otherwise = p xs
        s []      = False

-- | Return True if string should be escaped with <verbatim> tags
shouldEscapeText :: PandocMonad m
                   => Text
                   -> Muse m Bool
shouldEscapeText s = do
  insideLink <- asks envInsideLinkDescription
  return $ T.null s ||
           T.any (`elem` ("#*<=|" :: String)) s ||
           "::" `T.isInfixOf` s ||
           "~~" `T.isInfixOf` s ||
           "[[" `T.isInfixOf` s ||
           ">>>" `T.isInfixOf` s ||
           ("]" `T.isInfixOf` s && insideLink) ||
           containsNotes '[' ']' s ||
           containsNotes '{' '}' s

-- | Escape special characters for Muse if needed.
conditionalEscapeText :: PandocMonad m
                        => Text
                        -> Muse m Text
conditionalEscapeText s = do
  shouldEscape <- shouldEscapeText s
  return $ if shouldEscape
             then escapeText s
             else s

-- Expand Math and Cite before normalizing inline list
preprocessInlineList :: PandocMonad m
                     => [Inline]
                     -> m [Inline]
preprocessInlineList (Math t str:xs) = (++) <$> texMathToInlines t str <*> preprocessInlineList xs
-- Amusewiki does not support <cite> tag,
-- and Emacs Muse citation support is limited
-- (https://www.gnu.org/software/emacs-muse/manual/html_node/Citations.html#Citation)
-- so just fallback to expanding inlines.
preprocessInlineList (Cite _  lst:xs) = (lst ++) <$> preprocessInlineList xs
preprocessInlineList (x:xs) = (x:) <$> preprocessInlineList xs
preprocessInlineList [] = return []

replaceSmallCaps :: Inline -> Inline
replaceSmallCaps (SmallCaps lst) = Emph lst
replaceSmallCaps x               = x

removeKeyValues :: Inline -> Inline
removeKeyValues (Code (i, cls, _) xs) = Code (i, cls, []) xs
-- Do not remove attributes from Link
-- Do not remove attributes, such as "width", from Image
-- Do not remove attributes, such as "dir", from Span
removeKeyValues x                     = x

normalizeInlineList :: [Inline] -> [Inline]
normalizeInlineList (Str "" : xs)
  = normalizeInlineList xs
normalizeInlineList (x : Str "" : xs)
  = normalizeInlineList (x:xs)
normalizeInlineList (Str x1 : Str x2 : xs)
  = normalizeInlineList $ Str (x1 <> x2) : xs
normalizeInlineList (Emph x1 : Emph x2 : ils)
  = normalizeInlineList $ Emph (x1 <> x2) : ils
normalizeInlineList (Strong x1 : Strong x2 : ils)
  = normalizeInlineList $ Strong (x1 <> x2) : ils
normalizeInlineList (Strikeout x1 : Strikeout x2 : ils)
  = normalizeInlineList $ Strikeout (x1 <> x2) : ils
normalizeInlineList (Superscript x1 : Superscript x2 : ils)
  = normalizeInlineList $ Superscript (x1 <> x2) : ils
normalizeInlineList (Subscript x1 : Subscript x2 : ils)
  = normalizeInlineList $ Subscript (x1 <> x2) : ils
normalizeInlineList (SmallCaps x1 : SmallCaps x2 : ils)
  = normalizeInlineList $ SmallCaps (x1 <> x2) : ils
normalizeInlineList (Code _ x1 : Code _ x2 : ils)
  = normalizeInlineList $ Code nullAttr (x1 <> x2) : ils
normalizeInlineList (RawInline f1 x1 : RawInline f2 x2 : ils) | f1 == f2
  = normalizeInlineList $ RawInline f1 (x1 <> x2) : ils
-- Do not join Span's during normalization
normalizeInlineList (x:xs) = x : normalizeInlineList xs
normalizeInlineList [] = []

fixNotes :: [Inline] -> [Inline]
fixNotes []                            = []
fixNotes (Space : n@Note{} : rest)     = Str " " : n : fixNotes rest
fixNotes (SoftBreak : n@Note{} : rest) = Str " " : n : fixNotes rest
fixNotes (x:xs)                        = x : fixNotes xs

startsWithSpace :: [Inline] -> Bool
startsWithSpace (Space:_)     = True
startsWithSpace (SoftBreak:_) = True
startsWithSpace (Str s:_)     = stringStartsWithSpace s
startsWithSpace _             = False

endsWithSpace :: [Inline] -> Bool
endsWithSpace [Space]     = True
endsWithSpace [SoftBreak] = True
endsWithSpace [Str s]     = stringEndsWithSpace s
endsWithSpace (_:xs)      = endsWithSpace xs
endsWithSpace []          = False

urlEscapeBrackets :: Text -> Text
urlEscapeBrackets = T.concatMap $ \c -> case c of
  ']' -> "%5D"
  _   -> T.singleton c

isHorizontalRule :: Text -> Bool
isHorizontalRule s = T.length s >= 4 && T.all (== '-') s

stringStartsWithSpace :: Text -> Bool
stringStartsWithSpace = maybe False (isSpace . fst) . T.uncons

stringEndsWithSpace :: Text -> Bool
stringEndsWithSpace = maybe False (isSpace . snd) . T.unsnoc

fixOrEscape :: Bool -> Inline -> Bool
fixOrEscape b (Str s) = fixOrEscapeStr b s
  where
    fixOrEscapeStr sp t = case T.uncons t of
      Just ('-', xs)
        | T.null xs -> sp
        | otherwise -> (sp && isSpace (T.head xs)) || isHorizontalRule t
      Just (';', xs)
        | T.null xs -> not sp
        | otherwise -> not sp && isSpace (T.head xs)
      Just ('>', xs)
        | T.null xs -> True
        | otherwise -> isSpace (T.head xs)
      _             -> (sp && (startsWithMarker isDigit s ||
                               startsWithMarker isAsciiLower s ||
                               startsWithMarker isAsciiUpper s))
                       || stringStartsWithSpace s
fixOrEscape _ Space = True
fixOrEscape _ SoftBreak = True
fixOrEscape _ _ = False

inlineListStartsWithAlnum :: PandocMonad m
                          => [Inline]
                          -> Muse m Bool
inlineListStartsWithAlnum (Str s:_) = do
  esc <- shouldEscapeText s
  return $ esc || isAlphaNum (T.head s)
inlineListStartsWithAlnum _ = return False

-- | Convert list of Pandoc inline elements to Muse
renderInlineList :: PandocMonad m
                 => [Inline]
                 -> Muse m (Doc Text)
renderInlineList [] = pure ""
renderInlineList (x:xs) = do
  start <- asks envInlineStart
  afterSpace <- asks envAfterSpace
  topLevel <- asks envTopLevel
  insideAsterisks <- asks envInsideAsterisks
  nearAsterisks <- asks envNearAsterisks
  useTags <- gets stUseTags
  alnumNext <- inlineListStartsWithAlnum xs
  let newUseTags = useTags || alnumNext
  modify $ \st -> st { stUseTags = newUseTags }

  r <- local (\env -> env { envInlineStart = False
                          , envInsideAsterisks = False
                          , envNearAsterisks = nearAsterisks || (null xs && insideAsterisks)
                          }) $ inlineToMuse x
  opts <- asks envOptions
  let isNewline = (x == SoftBreak && writerWrapText opts == WrapPreserve) || x == LineBreak
  lst' <- local (\env -> env { envInlineStart = isNewline
                             , envAfterSpace = x == Space || (not topLevel && isNewline)
                             , envNearAsterisks = False
                             }) $ renderInlineList xs
  if start && fixOrEscape afterSpace x
    then pure (literal "<verbatim></verbatim>" <> r <> lst')
    else pure (r <> lst')

-- | Normalize and convert list of Pandoc inline elements to Muse.
inlineListToMuse :: PandocMonad m
                 => [Inline]
                 -> Muse m (Doc Text)
inlineListToMuse lst = do
  lst' <- normalizeInlineList . fixNotes <$> preprocessInlineList (map (removeKeyValues . replaceSmallCaps) lst)
  insideAsterisks <- asks envInsideAsterisks
  start <- asks envInlineStart
  modify $ \st -> st { stUseTags = False } -- Previous character is likely a '>' or some other markup
  if start && null lst'
    then pure "<verbatim></verbatim>"
    else local (\env -> env { envNearAsterisks = insideAsterisks }) $ renderInlineList lst'

inlineListToMuse' :: PandocMonad m => [Inline] -> Muse m (Doc Text)
inlineListToMuse' lst = do
  topLevel <- asks envTopLevel
  afterSpace <- asks envAfterSpace
  local (\env -> env { envInlineStart = True
                     , envAfterSpace = afterSpace || not topLevel
                     }) $ inlineListToMuse lst

emphasis :: PandocMonad m => Text -> Text -> [Inline] -> Muse m (Doc Text)
emphasis b e lst = do
  contents <- local (\env -> env { envInsideAsterisks = inAsterisks }) $ inlineListToMuse lst
  modify $ \st -> st { stUseTags = useTags }
  return $ literal b <> contents <> literal e
  where inAsterisks = T.last b == '*' || T.head e == '*'
        useTags = T.last e /= '>'

-- | Convert Pandoc inline element to Muse.
inlineToMuse :: PandocMonad m
             => Inline
             -> Muse m (Doc Text)
inlineToMuse (Str str) = do
  escapedStr <- conditionalEscapeText $ replaceNewlines str
  let useTags = isAlphaNum $ T.last escapedStr -- escapedStr is never empty because empty strings are escaped
  modify $ \st -> st { stUseTags = useTags }
  return $ literal escapedStr
inlineToMuse (Emph [Strong lst]) = do
  useTags <- gets stUseTags
  let lst' = normalizeInlineList lst
  if useTags
    then emphasis "<em>**" "**</em>" lst'
    else if null lst' || startsWithSpace lst' || endsWithSpace lst'
           then emphasis "*<strong>" "</strong>*" lst'
           else emphasis "***" "***" lst'
inlineToMuse (Emph lst) = do
  useTags <- gets stUseTags
  let lst' = normalizeInlineList lst
  if useTags || null lst' || startsWithSpace lst' || endsWithSpace lst'
    then emphasis "<em>" "</em>" lst'
    else emphasis "*" "*" lst'
inlineToMuse (Strong [Emph lst]) = do
  useTags <- gets stUseTags
  let lst' = normalizeInlineList lst
  if useTags
    then emphasis "<strong>*" "*</strong>" lst'
    else if null lst' || startsWithSpace lst' || endsWithSpace lst'
           then emphasis "**<em>" "</em>**" lst'
           else emphasis "***" "***" lst'
-- Underline is only supported in Emacs Muse mode.
inlineToMuse (Underline lst) = do
  opts <- asks envOptions
  contents <- inlineListToMuse lst
  if isEnabled Ext_amuse opts
     then return $ "_" <> contents <> "_"
     else inlineToMuse (Emph lst)
inlineToMuse (Strong lst) = do
  useTags <- gets stUseTags
  let lst' = normalizeInlineList lst
  if useTags || null lst' || startsWithSpace lst' || endsWithSpace lst'
    then emphasis "<strong>" "</strong>" lst'
    else emphasis "**" "**" lst'
inlineToMuse (Strikeout lst) = do
  contents <- inlineListToMuse lst
  modify $ \st -> st { stUseTags = False }
  return $ "<del>" <> contents <> "</del>"
inlineToMuse (Superscript lst) = do
  contents <- inlineListToMuse lst
  modify $ \st -> st { stUseTags = False }
  return $ "<sup>" <> contents <> "</sup>"
inlineToMuse (Subscript lst) = do
  contents <- inlineListToMuse lst
  modify $ \st -> st { stUseTags = False }
  return $ "<sub>" <> contents <> "</sub>"
inlineToMuse SmallCaps {} =
  throwError $ PandocShouldNeverHappenError
    "SmallCaps should be expanded before normalization"
inlineToMuse (Quoted SingleQuote lst) = do
  contents <- inlineListToMuse lst
  modify $ \st -> st { stUseTags = False }
  return $ "‘" <> contents <> "’"
inlineToMuse (Quoted DoubleQuote lst) = do
  contents <- inlineListToMuse lst
  modify $ \st -> st { stUseTags = False }
  return $ "“" <> contents <> "”"
inlineToMuse Cite {} =
  throwError $ PandocShouldNeverHappenError
               "Citations should be expanded before normalization"
inlineToMuse (Code _ str) = do
  useTags <- gets stUseTags
  modify $ \st -> st { stUseTags = False }
  return $ if useTags || T.null str || T.any (== '=') str
              || isSpace (T.head str) || isSpace (T.last str)
             then "<code>" <> literal (T.replace "</code>" "<</code><code>/code>" str) <> "</code>"
             else "=" <> literal str <> "="
inlineToMuse Math{} =
  throwError $ PandocShouldNeverHappenError
    "Math should be expanded before normalization"
inlineToMuse (RawInline (Format f) str) = do
  modify $ \st -> st { stUseTags = False }
  return $ "<literal style=\"" <> literal f <> "\">" <> literal str <> "</literal>"
inlineToMuse LineBreak = do
  oneline <- asks envOneLine
  modify $ \st -> st { stUseTags = False }
  return $ if oneline then "<br>" else "<br>" <> cr
inlineToMuse Space = do
  modify $ \st -> st { stUseTags = False }
  return space
inlineToMuse SoftBreak = do
  oneline <- asks envOneLine
  wrapText <- asks $ writerWrapText . envOptions
  modify $ \st -> st { stUseTags = False }
  return $ if not oneline && wrapText == WrapPreserve then cr else space
inlineToMuse (Link _ txt (src, _)) =
  case txt of
        [Str x] | escapeURI x == src -> do
             modify $ \st -> st { stUseTags = False }
             return $ "[[" <> literal (escapeLink x) <> "]]"
        _ -> do contents <- local (\env -> env { envInsideLinkDescription = True }) $ inlineListToMuse txt
                modify $ \st -> st { stUseTags = False }
                return $ "[[" <> literal (escapeLink src) <> "][" <> contents <> "]]"
  where escapeLink lnk = if isImageUrl lnk then "URL:" <> urlEscapeBrackets lnk else urlEscapeBrackets lnk
        -- Taken from muse-image-regexp defined in Emacs Muse file lisp/muse-regexps.el
        imageExtensions = [".eps", ".gif", ".jpg", ".jpeg", ".pbm", ".png", ".tiff", ".xbm", ".xpm"]
        isImageUrl = (`elem` imageExtensions) . takeExtension . T.unpack
inlineToMuse (Image attr alt (source,T.stripPrefix "fig:" -> Just title)) =
  inlineToMuse (Image attr alt (source,title))
inlineToMuse (Image attr@(_, classes, _) inlines (source, title)) = do
  opts <- asks envOptions
  alt <- local (\env -> env { envInsideLinkDescription = True }) $ inlineListToMuse inlines
  title' <- if T.null title
            then if null inlines
                 then return ""
                 else return $ "[" <> alt <> "]"
            else do s <- local (\env -> env { envInsideLinkDescription = True }) $ conditionalEscapeText title
                    return $ "[" <> literal s <> "]"
  let width = case dimension Width attr of
                Just (Percent x) | isEnabled Ext_amuse opts -> " " <> tshow (round x :: Integer)
                _ -> ""
  let leftalign = if "align-left" `elem` classes
                  then " l"
                  else ""
  let rightalign = if "align-right" `elem` classes
                   then " r"
                   else ""
  modify $ \st -> st { stUseTags = False }
  return $ "[[" <> literal (urlEscapeBrackets source <> width <> leftalign <> rightalign) <> "]" <> title' <> "]"
inlineToMuse (Note contents) = do
  -- add to notes in state
  notes <- gets stNotes
  modify $ \st -> st { stNotes = contents:notes
                     , stUseTags = False
                     }
  n <- gets stNoteNum
  let ref = tshow $ n + length notes
  return $ "[" <> literal ref <> "]"
inlineToMuse (Span (anchor,names,kvs) inlines) = do
  contents <- inlineListToMuse inlines
  let (contents', hasDir) = case lookup "dir" kvs of
                              Just "rtl" -> ("<<<" <> contents <> ">>>", True)
                              Just "ltr" -> (">>>" <> contents <> "<<<", True)
                              _ -> (contents, False)
  let anchorDoc = if T.null anchor
                     then mempty
                     else literal ("#" <> anchor) <> space
  modify $ \st -> st { stUseTags = False }
  return $ anchorDoc <>
   if null inlines && not (T.null anchor)
      then mempty
      else case names of
             [] | hasDir -> contents'
                | otherwise -> "<class>" <> contents' <> "</class>"
             (n:_) -> "<class name=\"" <> literal n <> "\">" <>
                         contents' <> "</class>"