From 0713cb65bc6fcea0c950d1afcdfdce412a8b56d4 Mon Sep 17 00:00:00 2001
From: Alexander Krotov <ilabdsf@gmail.com>
Date: Sat, 13 Jul 2019 20:54:26 +0300
Subject: Muse: add RTL support

Closes #5551
---
 src/Text/Pandoc/Readers/Muse.hs | 12 ++++++++++++
 src/Text/Pandoc/Writers/Muse.hs | 14 +++++++++-----
 test/Tests/Readers/Muse.hs      |  3 +++
 test/Tests/Writers/Muse.hs      |  7 +++++++
 4 files changed, 31 insertions(+), 5 deletions(-)

diff --git a/src/Text/Pandoc/Readers/Muse.hs b/src/Text/Pandoc/Readers/Muse.hs
index 568287929..ca7c94245 100644
--- a/src/Text/Pandoc/Readers/Muse.hs
+++ b/src/Text/Pandoc/Readers/Muse.hs
@@ -746,6 +746,8 @@ inline' = whitespace
       <|> strikeoutTag
       <|> verbatimTag
       <|> classTag
+      <|> inlineRtl
+      <|> inlineLtr
       <|> nbsp
       <|> linkOrImage
       <|> code
@@ -863,6 +865,16 @@ classTag = do
   classes <- maybe [] words . lookup "name" <$> openTag "class"
   fmap (B.spanWith ("", classes, [])) . mconcat <$> manyTill inline (closeTag "class")
 
+-- | Parse @\<\<\<RTL>>>@ text.
+inlineRtl :: PandocMonad m => MuseParser m (F Inlines)
+inlineRtl = try $
+  fmap (B.spanWith ("", [], [("dir", "rtl")])) . mconcat <$ string "<<<" <*> manyTill inline (string ">>>")
+
+-- | Parse @\<\<\<LTR>>>@ text.
+inlineLtr :: PandocMonad m => MuseParser m (F Inlines)
+inlineLtr = try $
+  fmap (B.spanWith ("", [], [("dir", "ltr")])) . mconcat <$ string ">>>" <*> manyTill inline (string "<<<")
+
 -- | Parse "~~" as nonbreaking space.
 nbsp :: PandocMonad m => MuseParser m (F Inlines)
 nbsp = try $ pure (B.str "\160") <$ string "~~"
diff --git a/src/Text/Pandoc/Writers/Muse.hs b/src/Text/Pandoc/Writers/Muse.hs
index c03fd0c1a..ec03d6292 100644
--- a/src/Text/Pandoc/Writers/Muse.hs
+++ b/src/Text/Pandoc/Writers/Muse.hs
@@ -377,6 +377,7 @@ shouldEscapeString s = do
            "::" `isInfixOf` s ||
            "~~" `isInfixOf` s ||
            "[[" `isInfixOf` s ||
+           ">>>" `isInfixOf` s ||
            ("]" `isInfixOf` s && insideLink) ||
            containsNotes '[' ']' s ||
            containsNotes '{' '}' s
@@ -412,7 +413,7 @@ 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
-removeKeyValues (Span (i, cls, _) xs) = Span (i, cls, []) xs
+-- Do not remove attributes, such as "dir", from Span
 removeKeyValues x                     = x
 
 normalizeInlineList :: [Inline] -> [Inline]
@@ -682,14 +683,17 @@ inlineToMuse (Note contents) = do
   n <- gets stNoteNum
   let ref = show $ n + length notes
   return $ "[" <> text ref <> "]"
-inlineToMuse (Span (anchor,names,_) inlines) = do
+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 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
-                               then "<class>"
-                               else "<class name=\"" <> text (head names) <> "\">") <> contents <> "</class>")
+                         else (if null names then (if hasDir then contents' else "<class>" <> contents' <> "</class>")
+                               else "<class name=\"" <> text (head names) <> "\">" <> contents' <> "</class>"))
diff --git a/test/Tests/Readers/Muse.hs b/test/Tests/Readers/Muse.hs
index 426ba935d..87495eba1 100644
--- a/test/Tests/Readers/Muse.hs
+++ b/test/Tests/Readers/Muse.hs
@@ -236,6 +236,9 @@ tests =
       , "Class tag" =: "<class name=\"foo\">bar</class>" =?> para (spanWith ("", ["foo"], []) "bar")
       , "Class tag without name" =: "<class>foobar</class>" =?> para (spanWith ("", [], []) "foobar")
 
+      , "RTL" =: "<<<foo bar>>>" =?> para (spanWith ("", [], [("dir", "rtl")]) "foo bar")
+      , "LTR" =: ">>>foo bar<<<" =?> para (spanWith ("", [], [("dir", "ltr")]) "foo bar")
+
       -- <em> tag should match with the last </em> tag, not verbatim one
       , "Nested \"</em>\" inside em tag" =: "<em>foo<verbatim></em></verbatim>bar</em>" =?> para (emph "foo</em>bar")
 
diff --git a/test/Tests/Writers/Muse.hs b/test/Tests/Writers/Muse.hs
index 7a07f39b7..ee61d18e0 100644
--- a/test/Tests/Writers/Muse.hs
+++ b/test/Tests/Writers/Muse.hs
@@ -620,6 +620,13 @@ tests = [ testGroup "block elements"
           , "adjacent spans" =: spanWith ("", ["syllable"], []) (str "wa") <>
                                 spanWith ("", ["syllable"], []) (str "ter")
                              =?> "<class name=\"syllable\">wa</class><class name=\"syllable\">ter</class>"
+          , testGroup "RTL"
+            [ "RTL span" =: spanWith ("",[],[("dir", "rtl")]) (text "foo bar") =?> "<<<foo bar>>>"
+            , "LTR span" =: spanWith ("",[],[("dir", "ltr")]) (text "foo bar") =?> ">>>foo bar<<<"
+            , "RTL span with a class" =: spanWith ("",["foobar"],[("dir", "rtl")]) (text "foo bar") =?> "<class name=\"foobar\"><<<foo bar>>></class>"
+            , "LTR span with a class" =: spanWith ("",["foobar"],[("dir", "ltr")]) (text "foo bar") =?> "<class name=\"foobar\">>>>foo bar<<<</class>"
+            , "Escape <<< and >>>" =: plain (text "<<< foo bar >>>") =?> "<verbatim><<<</verbatim> foo bar <verbatim>>>></verbatim>"
+            ]
           , testGroup "combined"
             [ "emph word before" =:
                 para ("foo" <> emph "bar") =?>
-- 
cgit v1.2.3