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