1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ViewPatterns      #-}
3{- |
4   Module      : Text.Pandoc.Writers.Muse
5   Copyright   : Copyright (C) 2017-2020 Alexander Krotov
6   License     : GNU GPL, version 2 or above
7
8   Maintainer  : Alexander Krotov <ilabdsf@gmail.com>
9   Stability   : stable
10   Portability : portable
11
12Conversion of 'Pandoc' documents to Muse.
13
14This module is mostly intended for <https://amusewiki.org/ Amusewiki> markup support,
15as described by <https://amusewiki.org/library/manual Text::Amuse markup manual>.
16Original <https://www.gnu.org/software/emacs-muse/ Emacs Muse> markup support
17is a secondary goal.
18
19Where Text::Amuse markup
20<https://metacpan.org/pod/Text::Amuse#DIFFERENCES-WITH-THE-ORIGINAL-EMACS-MUSE-MARKUP differs>
21from <https://www.gnu.org/software/emacs-muse/manual/ Emacs Muse markup>,
22Text::Amuse markup is supported.
23For example, native tables are always used instead of Org Mode tables.
24However, @\<literal style="html">@ tag is used for HTML raw blocks
25even though it is supported only in Emacs Muse.
26-}
27module Text.Pandoc.Writers.Muse (writeMuse) where
28import Control.Monad.Except (throwError)
29import Control.Monad.Reader
30import Control.Monad.State.Strict
31import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, isDigit, isSpace)
32import Data.Default
33import Data.List (intersperse, transpose)
34import Data.List.NonEmpty (nonEmpty, NonEmpty(..))
35import qualified Data.Set as Set
36import qualified Data.Text as T
37import Data.Text (Text)
38import System.FilePath (takeExtension)
39import Text.Pandoc.Class.PandocMonad (PandocMonad)
40import Text.Pandoc.Definition
41import Text.Pandoc.Error
42import Text.Pandoc.ImageSize
43import Text.Pandoc.Options
44import Text.DocLayout
45import Text.Pandoc.Shared
46import Text.Pandoc.Templates (renderTemplate)
47import Text.Pandoc.Writers.Math
48import Text.Pandoc.Writers.Shared
49
50type Notes = [[Block]]
51
52type Muse m = ReaderT WriterEnv (StateT WriterState m)
53
54data WriterEnv =
55  WriterEnv { envOptions               :: WriterOptions
56            , envTopLevel              :: Bool
57            , envInsideBlock           :: Bool
58            , envInlineStart           :: Bool -- ^ True if there is only whitespace since last newline
59            , envInsideLinkDescription :: Bool -- ^ Escape ] if True
60            , envAfterSpace            :: Bool -- ^ There is whitespace (not just newline) before
61            , envOneLine               :: Bool -- ^ True if newlines are not allowed
62            , envInsideAsterisks       :: Bool -- ^ True if outer element is emphasis with asterisks
63            , envNearAsterisks         :: Bool -- ^ Rendering inline near asterisks
64            }
65
66data WriterState =
67  WriterState { stNotes   :: Notes
68              , stNoteNum :: Int
69              , stIds     :: Set.Set Text
70              , stUseTags :: Bool -- ^ Use tags for emphasis, for example because previous character is a letter
71              }
72
73instance Default WriterState
74  where def = WriterState { stNotes = []
75                          , stNoteNum = 1
76                          , stIds = Set.empty
77                          , stUseTags = False
78                          }
79
80evalMuse :: PandocMonad m => Muse m a -> WriterEnv -> WriterState -> m a
81evalMuse document env = evalStateT $ runReaderT document env
82
83-- | Convert Pandoc to Muse.
84writeMuse :: PandocMonad m
85          => WriterOptions
86          -> Pandoc
87          -> m Text
88writeMuse opts document =
89  evalMuse (pandocToMuse document) env def
90  where env = WriterEnv { envOptions = opts
91                        , envTopLevel = True
92                        , envInsideBlock = False
93                        , envInlineStart = True
94                        , envInsideLinkDescription = False
95                        , envAfterSpace = False
96                        , envOneLine = False
97                        , envInsideAsterisks = False
98                        , envNearAsterisks = False
99                        }
100
101-- | Return Muse representation of document.
102pandocToMuse :: PandocMonad m
103             => Pandoc
104             -> Muse m Text
105pandocToMuse (Pandoc meta blocks) = do
106  opts <- asks envOptions
107  let colwidth = if writerWrapText opts == WrapAuto
108                    then Just $ writerColumns opts
109                    else Nothing
110  metadata <- metaToContext opts
111               blockListToMuse
112               (fmap chomp . inlineListToMuse)
113               meta
114  body <- blockListToMuse blocks
115  notes <- currentNotesToMuse
116  let main = body $+$ notes
117  let context = defField "body" main metadata
118  return $ render colwidth $
119    case writerTemplate opts of
120       Nothing  -> main
121       Just tpl -> renderTemplate tpl context
122
123-- | Helper function for flatBlockListToMuse
124-- | Render all blocks and insert blank lines between the first two
125catWithBlankLines :: PandocMonad m
126                  => [Block]       -- ^ List of block elements
127                  -> Int           -- ^ Number of blank lines
128                  -> Muse m (Doc Text)
129catWithBlankLines (b : bs) n = do
130  b' <- blockToMuseWithNotes b
131  bs' <- flatBlockListToMuse bs
132  return $ b' <> blanklines n <> bs'
133catWithBlankLines _ _ = error "Expected at least one block"
134
135-- | Convert list of Pandoc block elements to Muse
136-- | without setting envTopLevel.
137flatBlockListToMuse :: PandocMonad m
138                => [Block]       -- ^ List of block elements
139                -> Muse m (Doc Text)
140flatBlockListToMuse bs@(BulletList _ : BulletList _ : _) = catWithBlankLines bs 2
141flatBlockListToMuse bs@(OrderedList (_, style1, _) _ : OrderedList (_, style2, _) _ : _) =
142  catWithBlankLines bs (if style1' == style2' then 2 else 0)
143    where
144      style1' = normalizeStyle style1
145      style2' = normalizeStyle style2
146      normalizeStyle DefaultStyle = Decimal
147      normalizeStyle s            = s
148flatBlockListToMuse bs@(DefinitionList _ : DefinitionList _ : _) = catWithBlankLines bs 2
149flatBlockListToMuse bs@(_ : _) = catWithBlankLines bs 0
150flatBlockListToMuse [] = return mempty
151
152simpleTable :: PandocMonad m
153            => [Inline]
154            -> [[Block]]
155            -> [[[Block]]]
156            -> Muse m (Doc Text)
157simpleTable caption headers rows = do
158  topLevel <- asks envTopLevel
159  caption' <- inlineListToMuse caption
160  headers' <- mapM blockListToMuse headers
161  rows' <- mapM (mapM blockListToMuse) rows
162  let widthsInChars = maybe 0 maximum . nonEmpty . map offset <$>
163                       transpose (headers' : rows')
164  let hpipeBlocks sep blocks = hcat $ intersperse sep' blocks
165        where sep' = lblock (T.length sep) $ literal sep
166  let makeRow sep = hpipeBlocks sep . zipWith lblock widthsInChars
167  let head' = makeRow " || " headers'
168  rows'' <- mapM (\row -> makeRow rowSeparator <$> mapM blockListToMuse row) rows
169  let body = vcat rows''
170  return $ (if topLevel then nest 1 else id) ((if noHeaders then empty else head')
171                                             $$ body
172                                             $$ (if null caption then empty else "|+ " <> caption' <> " +|"))
173         $$ blankline
174  where noHeaders = all null headers
175        rowSeparator = if noHeaders then " | " else " |  "
176
177-- | Convert list of Pandoc block elements to Muse.
178blockListToMuse :: PandocMonad m
179                => [Block]       -- ^ List of block elements
180                -> Muse m (Doc Text)
181blockListToMuse =
182  local (\env -> env { envTopLevel = not (envInsideBlock env)
183                     , envInsideBlock = True
184                     }) . flatBlockListToMuse
185
186-- | Convert Pandoc block element to Muse.
187blockToMuse :: PandocMonad m
188            => Block         -- ^ Block element
189            -> Muse m (Doc Text)
190blockToMuse (Plain inlines) = inlineListToMuse' inlines
191blockToMuse (Para inlines) = do
192  contents <- inlineListToMuse' inlines
193  return $ contents <> blankline
194blockToMuse (LineBlock lns) = do
195  lns' <- local (\env -> env { envOneLine = True }) $ mapM inlineListToMuse lns
196  return $ nowrap $ vcat (map (literal "> " <>) lns') <> blankline
197blockToMuse (CodeBlock (_,_,_) str) =
198  return $ "<example>" $$ literal str $$ "</example>" $$ blankline
199blockToMuse (RawBlock (Format format) str) =
200  return $ blankline $$ "<literal style=\"" <> literal format <> "\">" $$
201           literal str $$ "</literal>" $$ blankline
202blockToMuse (BlockQuote blocks) = do
203  contents <- flatBlockListToMuse blocks
204  return $ blankline
205        <> "<quote>"
206        $$ nest 0 contents -- nest 0 to remove trailing blank lines
207        $$ "</quote>"
208        <> blankline
209blockToMuse (OrderedList (start, style, _) items) = do
210  let markers = take (length items) $ orderedListMarkers
211                                      (start, style, Period)
212  contents <- zipWithM orderedListItemToMuse markers items
213  topLevel <- asks envTopLevel
214  return $ (if topLevel then nest 1 else id) (vcat contents) $$ blankline
215  where orderedListItemToMuse :: PandocMonad m
216                              => Text     -- ^ marker for list item
217                              -> [Block]  -- ^ list item (list of blocks)
218                              -> Muse m (Doc Text)
219        orderedListItemToMuse marker item = hang (T.length marker + 1) (literal marker <> space)
220          <$> blockListToMuse item
221blockToMuse (BulletList items) = do
222  contents <- mapM bulletListItemToMuse items
223  topLevel <- asks envTopLevel
224  return $ (if topLevel then nest 1 else id) (vcat contents) $$ blankline
225  where bulletListItemToMuse :: PandocMonad m
226                             => [Block]
227                             -> Muse m (Doc Text)
228        bulletListItemToMuse item = do
229          modify $ \st -> st { stUseTags = False }
230          hang 2 "- " <$> blockListToMuse item
231blockToMuse (DefinitionList items) = do
232  contents <- mapM definitionListItemToMuse items
233  topLevel <- asks envTopLevel
234  return $ (if topLevel then nest 1 else id) (vcat contents) $$ blankline
235  where definitionListItemToMuse :: PandocMonad m
236                                 => ([Inline], [[Block]])
237                                 -> Muse m (Doc Text)
238        definitionListItemToMuse (label, defs) = do
239          modify $ \st -> st { stUseTags = False }
240          label' <- local (\env -> env { envOneLine = True, envAfterSpace = True }) $ inlineListToMuse' label
241          let ind = offset' label' -- using Text.DocLayout.offset results in round trip failures
242          hang ind (nowrap label') . vcat <$> mapM descriptionToMuse defs
243          where offset' d = maximum (0 :| map T.length
244                                         (T.lines $ render Nothing d))
245        descriptionToMuse :: PandocMonad m
246                          => [Block]
247                          -> Muse m (Doc Text)
248        descriptionToMuse desc = hang 4 " :: " <$> blockListToMuse desc
249blockToMuse (Header level (ident,_,_) inlines) = do
250  opts <- asks envOptions
251  topLevel <- asks envTopLevel
252  contents <- local (\env -> env { envOneLine = True }) $ inlineListToMuse' inlines
253  ids <- gets stIds
254  let autoId = uniqueIdent (writerExtensions opts) inlines ids
255  modify $ \st -> st{ stIds = Set.insert autoId ids }
256
257  let attr' = if T.null ident || (isEnabled Ext_auto_identifiers opts && ident == autoId)
258                 then empty
259                 else "#" <> literal ident <> cr
260  let header' = if topLevel then literal (T.replicate level "*") <> space else mempty
261  return $ blankline <> attr' $$ nowrap (header' <> contents) <> blankline
262-- https://www.gnu.org/software/emacs-muse/manual/muse.html#Horizontal-Rules-and-Anchors
263blockToMuse HorizontalRule = return $ blankline $$ "----" $$ blankline
264blockToMuse (Table _ blkCapt specs thead tbody tfoot) =
265  if isSimple && numcols > 1
266    then simpleTable caption headers rows
267    else do
268      opts <- asks envOptions
269      gridTable opts blocksToDoc True (map (const AlignDefault) aligns) widths headers rows
270  where
271    (caption, aligns, widths, headers, rows) = toLegacyTable blkCapt specs thead tbody tfoot
272    blocksToDoc opts blocks =
273      local (\env -> env { envOptions = opts }) $ blockListToMuse blocks
274    numcols = maximum
275              (length aligns :| length widths : map length (headers:rows))
276    isSimple = onlySimpleTableCells (headers : rows) && all (== 0) widths
277blockToMuse (Div _ bs) = flatBlockListToMuse bs
278blockToMuse Null = return empty
279
280-- | Return Muse representation of notes collected so far.
281currentNotesToMuse :: PandocMonad m
282                   => Muse m (Doc Text)
283currentNotesToMuse = do
284  notes <- reverse <$> gets stNotes
285  modify $ \st -> st { stNotes = mempty }
286  notesToMuse notes
287
288-- | Return Muse representation of notes.
289notesToMuse :: PandocMonad m
290            => Notes
291            -> Muse m (Doc Text)
292notesToMuse notes = do
293  n <- gets stNoteNum
294  modify $ \st -> st { stNoteNum = stNoteNum st + length notes }
295  vsep <$> zipWithM noteToMuse [n ..] notes
296
297-- | Return Muse representation of a note.
298noteToMuse :: PandocMonad m
299           => Int
300           -> [Block]
301           -> Muse m (Doc Text)
302noteToMuse num note = do
303  res <- hang (T.length marker) (literal marker) <$>
304    local (\env -> env { envInsideBlock = True
305                       , envInlineStart = True
306                       , envAfterSpace = True
307                       }) (blockListToMuse note)
308  return $ res <> blankline
309  where
310    marker = "[" <> tshow num <> "] "
311
312-- | Return Muse representation of block and accumulated notes.
313blockToMuseWithNotes :: PandocMonad m
314                     => Block
315                     -> Muse m (Doc Text)
316blockToMuseWithNotes blk = do
317  topLevel <- asks envTopLevel
318  opts <- asks envOptions
319  let hdrToMuse hdr@Header{} = do
320        b <- blockToMuse hdr
321        if topLevel && writerReferenceLocation opts == EndOfSection
322          then do
323            notes <- currentNotesToMuse
324            return $ notes $+$ b
325          else
326            return b
327      hdrToMuse b = blockToMuse b
328  b <- hdrToMuse blk
329  if topLevel && writerReferenceLocation opts == EndOfBlock
330    then do
331           notes <- currentNotesToMuse
332           return $ b $+$ notes <> blankline
333    else return b
334
335-- | Escape special characters for Muse.
336escapeText :: Text -> Text
337escapeText s =
338  "<verbatim>" <>
339  T.replace "</verbatim>" "<</verbatim><verbatim>/verbatim>" s <>
340  "</verbatim>"
341
342-- | Replace newlines with spaces
343replaceNewlines :: Text -> Text
344replaceNewlines = T.map $ \c ->
345  if c == '\n' then ' ' else c
346
347startsWithMarker :: (Char -> Bool) -> Text -> Bool
348startsWithMarker f t = case T.uncons $ T.dropWhile f' t of
349  Just ('.', xs) -> T.null xs || isSpace (T.head xs)
350  _              -> False
351  where
352    f' c = c == ' ' || f c
353
354containsNotes :: Char -> Char -> Text -> Bool
355containsNotes left right = p . T.unpack -- This ought to be a parser
356  where p (left':xs)
357          | left' == left = q xs || p xs
358          | otherwise = p xs
359        p ""       = False
360        q (x:xs)
361          | x `elem` ("123456789"::String) = r xs || p xs
362          | otherwise = p xs
363        q [] = False
364        r ('0':xs) = r xs || p xs
365        r xs       = s xs || q xs || p xs
366        s (right':xs)
367          | right' == right = True
368          | otherwise = p xs
369        s []      = False
370
371-- | Return True if string should be escaped with <verbatim> tags
372shouldEscapeText :: PandocMonad m
373                   => Text
374                   -> Muse m Bool
375shouldEscapeText s = do
376  insideLink <- asks envInsideLinkDescription
377  return $ T.null s ||
378           T.any (`elem` ("#*<=|" :: String)) s ||
379           "::" `T.isInfixOf` s ||
380           "~~" `T.isInfixOf` s ||
381           "[[" `T.isInfixOf` s ||
382           ">>>" `T.isInfixOf` s ||
383           ("]" `T.isInfixOf` s && insideLink) ||
384           containsNotes '[' ']' s ||
385           containsNotes '{' '}' s
386
387-- | Escape special characters for Muse if needed.
388conditionalEscapeText :: PandocMonad m
389                        => Text
390                        -> Muse m Text
391conditionalEscapeText s = do
392  shouldEscape <- shouldEscapeText s
393  return $ if shouldEscape
394             then escapeText s
395             else s
396
397-- Expand Math and Cite before normalizing inline list
398preprocessInlineList :: PandocMonad m
399                     => [Inline]
400                     -> m [Inline]
401preprocessInlineList (Math t str:xs) = (++) <$> texMathToInlines t str <*> preprocessInlineList xs
402-- Amusewiki does not support <cite> tag,
403-- and Emacs Muse citation support is limited
404-- (https://www.gnu.org/software/emacs-muse/manual/html_node/Citations.html#Citation)
405-- so just fallback to expanding inlines.
406preprocessInlineList (Cite _  lst:xs) = (lst ++) <$> preprocessInlineList xs
407preprocessInlineList (x:xs) = (x:) <$> preprocessInlineList xs
408preprocessInlineList [] = return []
409
410replaceSmallCaps :: Inline -> Inline
411replaceSmallCaps (SmallCaps lst) = Emph lst
412replaceSmallCaps x               = x
413
414removeKeyValues :: Inline -> Inline
415removeKeyValues (Code (i, cls, _) xs) = Code (i, cls, []) xs
416-- Do not remove attributes from Link
417-- Do not remove attributes, such as "width", from Image
418-- Do not remove attributes, such as "dir", from Span
419removeKeyValues x                     = x
420
421normalizeInlineList :: [Inline] -> [Inline]
422normalizeInlineList (Str "" : xs)
423  = normalizeInlineList xs
424normalizeInlineList (x : Str "" : xs)
425  = normalizeInlineList (x:xs)
426normalizeInlineList (Str x1 : Str x2 : xs)
427  = normalizeInlineList $ Str (x1 <> x2) : xs
428normalizeInlineList (Emph x1 : Emph x2 : ils)
429  = normalizeInlineList $ Emph (x1 <> x2) : ils
430normalizeInlineList (Strong x1 : Strong x2 : ils)
431  = normalizeInlineList $ Strong (x1 <> x2) : ils
432normalizeInlineList (Strikeout x1 : Strikeout x2 : ils)
433  = normalizeInlineList $ Strikeout (x1 <> x2) : ils
434normalizeInlineList (Superscript x1 : Superscript x2 : ils)
435  = normalizeInlineList $ Superscript (x1 <> x2) : ils
436normalizeInlineList (Subscript x1 : Subscript x2 : ils)
437  = normalizeInlineList $ Subscript (x1 <> x2) : ils
438normalizeInlineList (SmallCaps x1 : SmallCaps x2 : ils)
439  = normalizeInlineList $ SmallCaps (x1 <> x2) : ils
440normalizeInlineList (Code _ x1 : Code _ x2 : ils)
441  = normalizeInlineList $ Code nullAttr (x1 <> x2) : ils
442normalizeInlineList (RawInline f1 x1 : RawInline f2 x2 : ils) | f1 == f2
443  = normalizeInlineList $ RawInline f1 (x1 <> x2) : ils
444-- Do not join Span's during normalization
445normalizeInlineList (x:xs) = x : normalizeInlineList xs
446normalizeInlineList [] = []
447
448fixNotes :: [Inline] -> [Inline]
449fixNotes []                            = []
450fixNotes (Space : n@Note{} : rest)     = Str " " : n : fixNotes rest
451fixNotes (SoftBreak : n@Note{} : rest) = Str " " : n : fixNotes rest
452fixNotes (x:xs)                        = x : fixNotes xs
453
454startsWithSpace :: [Inline] -> Bool
455startsWithSpace (Space:_)     = True
456startsWithSpace (SoftBreak:_) = True
457startsWithSpace (Str s:_)     = stringStartsWithSpace s
458startsWithSpace _             = False
459
460endsWithSpace :: [Inline] -> Bool
461endsWithSpace [Space]     = True
462endsWithSpace [SoftBreak] = True
463endsWithSpace [Str s]     = stringEndsWithSpace s
464endsWithSpace (_:xs)      = endsWithSpace xs
465endsWithSpace []          = False
466
467urlEscapeBrackets :: Text -> Text
468urlEscapeBrackets = T.concatMap $ \c -> case c of
469  ']' -> "%5D"
470  _   -> T.singleton c
471
472isHorizontalRule :: Text -> Bool
473isHorizontalRule s = T.length s >= 4 && T.all (== '-') s
474
475stringStartsWithSpace :: Text -> Bool
476stringStartsWithSpace = maybe False (isSpace . fst) . T.uncons
477
478stringEndsWithSpace :: Text -> Bool
479stringEndsWithSpace = maybe False (isSpace . snd) . T.unsnoc
480
481fixOrEscape :: Bool -> Inline -> Bool
482fixOrEscape b (Str s) = fixOrEscapeStr b s
483  where
484    fixOrEscapeStr sp t = case T.uncons t of
485      Just ('-', xs)
486        | T.null xs -> sp
487        | otherwise -> (sp && isSpace (T.head xs)) || isHorizontalRule t
488      Just (';', xs)
489        | T.null xs -> not sp
490        | otherwise -> not sp && isSpace (T.head xs)
491      Just ('>', xs)
492        | T.null xs -> True
493        | otherwise -> isSpace (T.head xs)
494      _             -> (sp && (startsWithMarker isDigit s ||
495                               startsWithMarker isAsciiLower s ||
496                               startsWithMarker isAsciiUpper s))
497                       || stringStartsWithSpace s
498fixOrEscape _ Space = True
499fixOrEscape _ SoftBreak = True
500fixOrEscape _ _ = False
501
502inlineListStartsWithAlnum :: PandocMonad m
503                          => [Inline]
504                          -> Muse m Bool
505inlineListStartsWithAlnum (Str s:_) = do
506  esc <- shouldEscapeText s
507  return $ esc || isAlphaNum (T.head s)
508inlineListStartsWithAlnum _ = return False
509
510-- | Convert list of Pandoc inline elements to Muse
511renderInlineList :: PandocMonad m
512                 => [Inline]
513                 -> Muse m (Doc Text)
514renderInlineList [] = pure ""
515renderInlineList (x:xs) = do
516  start <- asks envInlineStart
517  afterSpace <- asks envAfterSpace
518  topLevel <- asks envTopLevel
519  insideAsterisks <- asks envInsideAsterisks
520  nearAsterisks <- asks envNearAsterisks
521  useTags <- gets stUseTags
522  alnumNext <- inlineListStartsWithAlnum xs
523  let newUseTags = useTags || alnumNext
524  modify $ \st -> st { stUseTags = newUseTags }
525
526  r <- local (\env -> env { envInlineStart = False
527                          , envInsideAsterisks = False
528                          , envNearAsterisks = nearAsterisks || (null xs && insideAsterisks)
529                          }) $ inlineToMuse x
530  opts <- asks envOptions
531  let isNewline = (x == SoftBreak && writerWrapText opts == WrapPreserve) || x == LineBreak
532  lst' <- local (\env -> env { envInlineStart = isNewline
533                             , envAfterSpace = x == Space || (not topLevel && isNewline)
534                             , envNearAsterisks = False
535                             }) $ renderInlineList xs
536  if start && fixOrEscape afterSpace x
537    then pure (literal "<verbatim></verbatim>" <> r <> lst')
538    else pure (r <> lst')
539
540-- | Normalize and convert list of Pandoc inline elements to Muse.
541inlineListToMuse :: PandocMonad m
542                 => [Inline]
543                 -> Muse m (Doc Text)
544inlineListToMuse lst = do
545  lst' <- normalizeInlineList . fixNotes <$> preprocessInlineList (map (removeKeyValues . replaceSmallCaps) lst)
546  insideAsterisks <- asks envInsideAsterisks
547  start <- asks envInlineStart
548  modify $ \st -> st { stUseTags = False } -- Previous character is likely a '>' or some other markup
549  if start && null lst'
550    then pure "<verbatim></verbatim>"
551    else local (\env -> env { envNearAsterisks = insideAsterisks }) $ renderInlineList lst'
552
553inlineListToMuse' :: PandocMonad m => [Inline] -> Muse m (Doc Text)
554inlineListToMuse' lst = do
555  topLevel <- asks envTopLevel
556  afterSpace <- asks envAfterSpace
557  local (\env -> env { envInlineStart = True
558                     , envAfterSpace = afterSpace || not topLevel
559                     }) $ inlineListToMuse lst
560
561emphasis :: PandocMonad m => Text -> Text -> [Inline] -> Muse m (Doc Text)
562emphasis b e lst = do
563  contents <- local (\env -> env { envInsideAsterisks = inAsterisks }) $ inlineListToMuse lst
564  modify $ \st -> st { stUseTags = useTags }
565  return $ literal b <> contents <> literal e
566  where inAsterisks = T.last b == '*' || T.head e == '*'
567        useTags = T.last e /= '>'
568
569-- | Convert Pandoc inline element to Muse.
570inlineToMuse :: PandocMonad m
571             => Inline
572             -> Muse m (Doc Text)
573inlineToMuse (Str str) = do
574  escapedStr <- conditionalEscapeText $ replaceNewlines str
575  let useTags = isAlphaNum $ T.last escapedStr -- escapedStr is never empty because empty strings are escaped
576  modify $ \st -> st { stUseTags = useTags }
577  return $ literal escapedStr
578inlineToMuse (Emph [Strong lst]) = do
579  useTags <- gets stUseTags
580  let lst' = normalizeInlineList lst
581  if useTags
582    then emphasis "<em>**" "**</em>" lst'
583    else if null lst' || startsWithSpace lst' || endsWithSpace lst'
584           then emphasis "*<strong>" "</strong>*" lst'
585           else emphasis "***" "***" lst'
586inlineToMuse (Emph lst) = do
587  useTags <- gets stUseTags
588  let lst' = normalizeInlineList lst
589  if useTags || null lst' || startsWithSpace lst' || endsWithSpace lst'
590    then emphasis "<em>" "</em>" lst'
591    else emphasis "*" "*" lst'
592inlineToMuse (Strong [Emph lst]) = do
593  useTags <- gets stUseTags
594  let lst' = normalizeInlineList lst
595  if useTags
596    then emphasis "<strong>*" "*</strong>" lst'
597    else if null lst' || startsWithSpace lst' || endsWithSpace lst'
598           then emphasis "**<em>" "</em>**" lst'
599           else emphasis "***" "***" lst'
600-- | Underline is only supported in Emacs Muse mode.
601inlineToMuse (Underline lst) = do
602  opts <- asks envOptions
603  contents <- inlineListToMuse lst
604  if isEnabled Ext_amuse opts
605     then return $ "_" <> contents <> "_"
606     else inlineToMuse (Emph lst)
607inlineToMuse (Strong lst) = do
608  useTags <- gets stUseTags
609  let lst' = normalizeInlineList lst
610  if useTags || null lst' || startsWithSpace lst' || endsWithSpace lst'
611    then emphasis "<strong>" "</strong>" lst'
612    else emphasis "**" "**" lst'
613inlineToMuse (Strikeout lst) = do
614  contents <- inlineListToMuse lst
615  modify $ \st -> st { stUseTags = False }
616  return $ "<del>" <> contents <> "</del>"
617inlineToMuse (Superscript lst) = do
618  contents <- inlineListToMuse lst
619  modify $ \st -> st { stUseTags = False }
620  return $ "<sup>" <> contents <> "</sup>"
621inlineToMuse (Subscript lst) = do
622  contents <- inlineListToMuse lst
623  modify $ \st -> st { stUseTags = False }
624  return $ "<sub>" <> contents <> "</sub>"
625inlineToMuse SmallCaps {} =
626  throwError $ PandocShouldNeverHappenError
627    "SmallCaps should be expanded before normalization"
628inlineToMuse (Quoted SingleQuote lst) = do
629  contents <- inlineListToMuse lst
630  modify $ \st -> st { stUseTags = False }
631  return $ "‘" <> contents <> "’"
632inlineToMuse (Quoted DoubleQuote lst) = do
633  contents <- inlineListToMuse lst
634  modify $ \st -> st { stUseTags = False }
635  return $ "“" <> contents <> "”"
636inlineToMuse Cite {} =
637  throwError $ PandocShouldNeverHappenError
638               "Citations should be expanded before normalization"
639inlineToMuse (Code _ str) = do
640  useTags <- gets stUseTags
641  modify $ \st -> st { stUseTags = False }
642  return $ if useTags || T.null str || T.any (== '=') str
643              || isSpace (T.head str) || isSpace (T.last str)
644             then "<code>" <> literal (T.replace "</code>" "<</code><code>/code>" str) <> "</code>"
645             else "=" <> literal str <> "="
646inlineToMuse Math{} =
647  throwError $ PandocShouldNeverHappenError
648    "Math should be expanded before normalization"
649inlineToMuse (RawInline (Format f) str) = do
650  modify $ \st -> st { stUseTags = False }
651  return $ "<literal style=\"" <> literal f <> "\">" <> literal str <> "</literal>"
652inlineToMuse LineBreak = do
653  oneline <- asks envOneLine
654  modify $ \st -> st { stUseTags = False }
655  return $ if oneline then "<br>" else "<br>" <> cr
656inlineToMuse Space = do
657  modify $ \st -> st { stUseTags = False }
658  return space
659inlineToMuse SoftBreak = do
660  oneline <- asks envOneLine
661  wrapText <- asks $ writerWrapText . envOptions
662  modify $ \st -> st { stUseTags = False }
663  return $ if not oneline && wrapText == WrapPreserve then cr else space
664inlineToMuse (Link _ txt (src, _)) =
665  case txt of
666        [Str x] | escapeURI x == src -> do
667             modify $ \st -> st { stUseTags = False }
668             return $ "[[" <> literal (escapeLink x) <> "]]"
669        _ -> do contents <- local (\env -> env { envInsideLinkDescription = True }) $ inlineListToMuse txt
670                modify $ \st -> st { stUseTags = False }
671                return $ "[[" <> literal (escapeLink src) <> "][" <> contents <> "]]"
672  where escapeLink lnk = if isImageUrl lnk then "URL:" <> urlEscapeBrackets lnk else urlEscapeBrackets lnk
673        -- Taken from muse-image-regexp defined in Emacs Muse file lisp/muse-regexps.el
674        imageExtensions = [".eps", ".gif", ".jpg", ".jpeg", ".pbm", ".png", ".tiff", ".xbm", ".xpm"]
675        isImageUrl = (`elem` imageExtensions) . takeExtension . T.unpack
676inlineToMuse (Image attr alt (source,T.stripPrefix "fig:" -> Just title)) =
677  inlineToMuse (Image attr alt (source,title))
678inlineToMuse (Image attr@(_, classes, _) inlines (source, title)) = do
679  opts <- asks envOptions
680  alt <- local (\env -> env { envInsideLinkDescription = True }) $ inlineListToMuse inlines
681  title' <- if T.null title
682            then if null inlines
683                 then return ""
684                 else return $ "[" <> alt <> "]"
685            else do s <- local (\env -> env { envInsideLinkDescription = True }) $ conditionalEscapeText title
686                    return $ "[" <> literal s <> "]"
687  let width = case dimension Width attr of
688                Just (Percent x) | isEnabled Ext_amuse opts -> " " <> tshow (round x :: Integer)
689                _ -> ""
690  let leftalign = if "align-left" `elem` classes
691                  then " l"
692                  else ""
693  let rightalign = if "align-right" `elem` classes
694                   then " r"
695                   else ""
696  modify $ \st -> st { stUseTags = False }
697  return $ "[[" <> literal (urlEscapeBrackets source <> width <> leftalign <> rightalign) <> "]" <> title' <> "]"
698inlineToMuse (Note contents) = do
699  -- add to notes in state
700  notes <- gets stNotes
701  modify $ \st -> st { stNotes = contents:notes
702                     , stUseTags = False
703                     }
704  n <- gets stNoteNum
705  let ref = tshow $ n + length notes
706  return $ "[" <> literal ref <> "]"
707inlineToMuse (Span (anchor,names,kvs) inlines) = do
708  contents <- inlineListToMuse inlines
709  let (contents', hasDir) = case lookup "dir" kvs of
710                              Just "rtl" -> ("<<<" <> contents <> ">>>", True)
711                              Just "ltr" -> (">>>" <> contents <> "<<<", True)
712                              _ -> (contents, False)
713  let anchorDoc = if T.null anchor
714                     then mempty
715                     else literal ("#" <> anchor) <> space
716  modify $ \st -> st { stUseTags = False }
717  return $ anchorDoc <> (if null inlines && not (T.null anchor)
718                         then mempty
719                         else (if null names then (if hasDir then contents' else "<class>" <> contents' <> "</class>")
720                               else "<class name=\"" <> literal (head names) <> "\">" <> contents' <> "</class>"))
721