From 6ea6011ca66c3127ff42cd5d0d39b3bd40e56e76 Mon Sep 17 00:00:00 2001
From: Alexander Krotov <ilabdsf@gmail.com>
Date: Thu, 30 Aug 2018 17:10:46 +0300
Subject: Muse writer: use lightweight markup when possible

---
 src/Text/Pandoc/Writers/Muse.hs | 142 ++++++++++++++++++++++++++++++++++------
 1 file changed, 123 insertions(+), 19 deletions(-)

(limited to 'src/Text/Pandoc')

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
-- 
cgit v1.2.3