aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorAlexander Krotov <ilabdsf@gmail.com>2018-08-30 17:10:46 +0300
committerAlexander Krotov <ilabdsf@gmail.com>2018-09-02 03:29:27 +0300
commit6ea6011ca66c3127ff42cd5d0d39b3bd40e56e76 (patch)
treeab49bc0a8d0571323302fd10d86ccaa1ad9b1f84 /src
parent746c30971ebbf9c1b02a3d7b7c5d94e67f8ee9ed (diff)
downloadpandoc-6ea6011ca66c3127ff42cd5d0d39b3bd40e56e76.tar.gz
Muse writer: use lightweight markup when possible
Diffstat (limited to 'src')
-rw-r--r--src/Text/Pandoc/Writers/Muse.hs142
1 files changed, 123 insertions, 19 deletions
diff --git a/src/Text/Pandoc/Writers/Muse.hs b/src/Text/Pandoc/Writers/Muse.hs
index a21bf5fc0..b9f9381c3 100644
--- a/src/Text/Pandoc/Writers/Muse.hs
+++ b/src/Text/Pandoc/Writers/Muse.hs
@@ -46,7 +46,7 @@ module Text.Pandoc.Writers.Muse (writeMuse) where
import Prelude
import Control.Monad.Reader
import Control.Monad.State.Strict
-import Data.Char (isSpace, isDigit, isAsciiUpper, isAsciiLower)
+import Data.Char (isSpace, isAlphaNum, isDigit, isAsciiUpper, isAsciiLower)
import Data.Default
import Data.Text (Text)
import Data.List (intersperse, transpose, isInfixOf)
@@ -74,16 +74,20 @@ data WriterEnv =
, 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
, stIds :: Set.Set String
+ , stUseTags :: Bool -- ^ Use tags for emphasis, for example because previous character is a letter
}
instance Default WriterState
where def = WriterState { stNotes = []
, stIds = Set.empty
+ , stUseTags = False
}
evalMuse :: PandocMonad m => Muse m a -> WriterEnv -> WriterState -> m a
@@ -103,6 +107,8 @@ writeMuse opts document =
, envInsideLinkDescription = False
, envAfterSpace = False
, envOneLine = False
+ , envInsideAsterisks = False
+ , envNearAsterisks = False
}
-- | Return Muse representation of document.
@@ -212,6 +218,7 @@ blockToMuse (BulletList items) = do
=> [Block]
-> Muse m Doc
bulletListItemToMuse item = do
+ modify $ \st -> st { stUseTags = False }
contents <- blockListToMuse item
return $ hang 2 "- " contents
blockToMuse (DefinitionList items) = do
@@ -223,6 +230,7 @@ blockToMuse (DefinitionList items) = do
=> ([Inline], [[Block]])
-> Muse m Doc
definitionListItemToMuse (label, defs) = do
+ modify $ \st -> st { stUseTags = False }
label' <- local (\env -> env { envOneLine = True, envAfterSpace = True }) $ inlineListToMuse' label
contents <- vcat <$> mapM descriptionToMuse defs
let ind = offset label'
@@ -401,6 +409,17 @@ 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 _ = False
+
+endsWithSpace :: [Inline] -> Bool
+endsWithSpace [Space] = True
+endsWithSpace [SoftBreak] = True
+endsWithSpace (_:xs) = endsWithSpace xs
+endsWithSpace [] = False
+
urlEscapeBrackets :: String -> String
urlEscapeBrackets (']':xs) = '%':'5':'D':urlEscapeBrackets xs
urlEscapeBrackets (x:xs) = x:urlEscapeBrackets xs
@@ -409,9 +428,9 @@ urlEscapeBrackets [] = []
isHorizontalRule :: String -> Bool
isHorizontalRule s = length s >= 4 && all (== '-') s
-startsWithSpace :: String -> Bool
-startsWithSpace (x:_) = isSpace x
-startsWithSpace [] = False
+stringStartsWithSpace :: String -> Bool
+stringStartsWithSpace (x:_) = isSpace x
+stringStartsWithSpace [] = False
fixOrEscape :: Bool -> Inline -> Bool
fixOrEscape sp (Str "-") = sp
@@ -420,11 +439,19 @@ fixOrEscape _ (Str ">") = True
fixOrEscape sp (Str s) = (sp && (startsWithMarker isDigit s ||
startsWithMarker isAsciiLower s ||
startsWithMarker isAsciiUpper s))
- || isHorizontalRule s || startsWithSpace s
+ || isHorizontalRule s || stringStartsWithSpace s
fixOrEscape _ Space = True
fixOrEscape _ SoftBreak = True
fixOrEscape _ _ = False
+inlineListStartsWithAlnum :: PandocMonad m
+ => [Inline]
+ -> Muse m Bool
+inlineListStartsWithAlnum (Str s:_) = do
+ esc <- shouldEscapeString s
+ return $ esc || isAlphaNum (head s)
+inlineListStartsWithAlnum _ = return False
+
-- | Convert list of Pandoc inline elements to Muse
renderInlineList :: PandocMonad m
=> [Inline]
@@ -436,11 +463,22 @@ renderInlineList (x:xs) = do
start <- asks envInlineStart
afterSpace <- asks envAfterSpace
topLevel <- asks envTopLevel
- r <- local (\env -> env { envInlineStart = False }) $ inlineToMuse x
+ 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 (text "<verbatim></verbatim>" <> r <> lst')
@@ -452,7 +490,9 @@ inlineListToMuse :: PandocMonad m
-> Muse m Doc
inlineListToMuse lst = do
lst' <- (normalizeInlineList . fixNotes) <$> preprocessInlineList (map (removeKeyValues . replaceSmallCaps) lst)
- renderInlineList lst'
+ insideAsterisks <- asks envInsideAsterisks
+ modify $ \st -> st { stUseTags = False } -- Previous character is likely a '>' or some other markup
+ local (\env -> env { envNearAsterisks = insideAsterisks }) $ renderInlineList lst'
inlineListToMuse' :: PandocMonad m => [Inline] -> Muse m Doc
inlineListToMuse' lst = do
@@ -466,52 +506,112 @@ inlineListToMuse' lst = do
inlineToMuse :: PandocMonad m
=> Inline
-> Muse m Doc
-inlineToMuse (Str str) =
- text <$> conditionalEscapeString str
+inlineToMuse (Str str) = do
+ escapedStr <- conditionalEscapeString str
+ let useTags = isAlphaNum $ last escapedStr -- escapedStr is never empty because empty strings are escaped
+ modify $ \st -> st { stUseTags = useTags }
+ return $ text escapedStr
+inlineToMuse (Emph [Strong lst]) = do
+ useTags <- gets stUseTags
+ if useTags
+ then do contents <- local (\env -> env { envInsideAsterisks = True }) $ inlineListToMuse lst
+ modify $ \st -> st { stUseTags = False }
+ return $ "<em>**" <> contents <> "**</em>"
+ else if null lst || startsWithSpace lst || endsWithSpace lst
+ then do
+ contents <- local (\env -> env { envInsideAsterisks = False }) $ inlineListToMuse lst
+ modify $ \st -> st { stUseTags = True }
+ return $ "*<strong>" <> contents <> "</strong>*"
+ else do
+ contents <- local (\env -> env { envInsideAsterisks = True }) $ inlineListToMuse lst
+ modify $ \st -> st { stUseTags = True }
+ return $ "***" <> contents <> "***"
inlineToMuse (Emph lst) = do
- contents <- inlineListToMuse lst
- return $ "<em>" <> contents <> "</em>"
+ useTags <- gets stUseTags
+ if useTags || null lst || startsWithSpace lst || endsWithSpace lst
+ then do contents <- inlineListToMuse lst
+ return $ "<em>" <> contents <> "</em>"
+ else do contents <- local (\env -> env { envInsideAsterisks = True }) $ inlineListToMuse lst
+ modify $ \st -> st { stUseTags = True }
+ return $ "*" <> contents <> "*"
+inlineToMuse (Strong [Emph lst]) = do
+ useTags <- gets stUseTags
+ if useTags
+ then do contents <- local (\env -> env { envInsideAsterisks = True }) $ inlineListToMuse lst
+ modify $ \st -> st { stUseTags = False }
+ return $ "<strong>*" <> contents <> "*</strong>"
+ else if null lst || startsWithSpace lst || endsWithSpace lst
+ then do
+ contents <- local (\env -> env { envInsideAsterisks = False }) $ inlineListToMuse lst
+ modify $ \st -> st { stUseTags = True }
+ return $ "**<em>" <> contents <> "</em>**"
+ else do
+ contents <- local (\env -> env { envInsideAsterisks = True }) $ inlineListToMuse lst
+ modify $ \st -> st { stUseTags = True }
+ return $ "***" <> contents <> "***"
inlineToMuse (Strong lst) = do
- contents <- inlineListToMuse lst
- return $ "<strong>" <> contents <> "</strong>"
+ useTags <- gets stUseTags
+ if useTags || null lst || startsWithSpace lst || endsWithSpace lst
+ then do contents <- inlineListToMuse lst
+ modify $ \st -> st { stUseTags = False }
+ return $ "<strong>" <> contents <> "</strong>"
+ else do contents <- local (\env -> env { envInsideAsterisks = True }) $ inlineListToMuse lst
+ modify $ \st -> st { stUseTags = True }
+ return $ "**" <> contents <> "**"
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 {} =
fail "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 {} =
fail "Citations should be expanded before normalization"
-inlineToMuse (Code _ str) = return $
- "<code>" <> text (substitute "</code>" "<</code><code>/code>" str) <> "</code>"
+inlineToMuse (Code _ str) = do
+ useTags <- gets stUseTags
+ modify $ \st -> st { stUseTags = False }
+ return $ if useTags || null str || '=' `elem` str || isSpace (head str) || isSpace (last str)
+ then "<code>" <> text (substitute "</code>" "<</code><code>/code>" str) <> "</code>"
+ else "=" <> text str <> "="
inlineToMuse Math{} =
fail "Math should be expanded before normalization"
-inlineToMuse (RawInline (Format f) str) =
+inlineToMuse (RawInline (Format f) str) = do
+ modify $ \st -> st { stUseTags = False }
return $ "<literal style=\"" <> text f <> "\">" <> text str <> "</literal>"
inlineToMuse LineBreak = do
oneline <- asks envOneLine
+ modify $ \st -> st { stUseTags = False }
return $ if oneline then "<br>" else "<br>" <> cr
-inlineToMuse Space = return space
+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 ->
+ [Str x] | escapeURI x == src -> do
+ modify $ \st -> st { stUseTags = False }
return $ "[[" <> text (escapeLink x) <> "]]"
_ -> do contents <- local (\env -> env { envInsideLinkDescription = True }) $ inlineListToMuse txt
+ modify $ \st -> st { stUseTags = False }
return $ "[[" <> text (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
@@ -537,11 +637,14 @@ inlineToMuse (Image attr@(_, classes, _) inlines (source, title)) = do
let rightalign = if "align-right" `elem` classes
then " r"
else ""
+ modify $ \st -> st { stUseTags = False }
return $ "[[" <> text (urlEscapeBrackets source ++ width ++ leftalign ++ rightalign) <> "]" <> title' <> "]"
inlineToMuse (Note contents) = do
-- add to notes in state
notes <- gets stNotes
- modify $ \st -> st { stNotes = contents:notes }
+ modify $ \st -> st { stNotes = contents:notes
+ , stUseTags = False
+ }
let ref = show $ length notes + 1
return $ "[" <> text ref <> "]"
inlineToMuse (Span (anchor,names,_) inlines) = do
@@ -549,6 +652,7 @@ inlineToMuse (Span (anchor,names,_) inlines) = do
let anchorDoc = if null anchor
then mempty
else text ('#':anchor) <> space
+ modify $ \st -> st { stUseTags = False }
return $ anchorDoc <> (if null inlines && not (null anchor)
then mempty
else (if null names
generated by cgit v1.2.3 (git 2.39.1) at 2025-05-04 12:33:55 +0000