Merge pull request #6527 from lierdakil/fix-6514

[Docx Reader] Only use bCs/iCs on runs with rtl or cs property

3 files changed, 59 insertions, 55 deletions

diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs
index ddec0bdf8..c9aa2f7c5 100644
--- a/src/Text/Pandoc/Readers/Docx.hs
+++ b/src/Text/Pandoc/Readers/Docx.hs
@@ -261,46 +261,43 @@ resolveDependentRunStyle rPr
   | otherwise = return rPr
 
 runStyleToTransform :: PandocMonad m => RunStyle -> DocxContext m (Inlines -> Inlines)
-runStyleToTransform rPr
-  | Just sn <- getStyleName <$> rParentStyle rPr
-  , sn `elem` spansToKeep = do
-      transform <- runStyleToTransform rPr{rParentStyle = Nothing}
-      return $ spanWith ("", [normalizeToClassName sn], []) . transform
-  | Just s <- rParentStyle rPr = do
-      ei <- extraInfo spanWith s
-      transform <- runStyleToTransform rPr{rParentStyle = Nothing}
-      return $ ei . transform
-  | Just True <- isItalic rPr = do
-      transform <- runStyleToTransform rPr{isItalic = Nothing}
-      return $ emph  . transform
-  | Just True <- isBold rPr = do
-      transform <- runStyleToTransform rPr{isBold = Nothing}
-      return $ strong . transform
-  | Just True <- isSmallCaps rPr = do
-      transform <- runStyleToTransform rPr{isSmallCaps = Nothing}
-      return $ smallcaps . transform
-  | Just True <- isStrike rPr = do
-      transform <- runStyleToTransform rPr{isStrike = Nothing}
-      return $ strikeout . transform
-  | Just True <- isRTL rPr = do
-      transform <- runStyleToTransform rPr{isRTL = Nothing}
-      return $ spanWith ("",[],[("dir","rtl")]) . transform
-  | Just False <- isRTL rPr = do
-      transform <- runStyleToTransform rPr{isRTL = Nothing}
-      inBidi <- asks docxInBidi
-      return $ if inBidi
-               then spanWith ("",[],[("dir","ltr")]) . transform
-               else transform
-  | Just SupScrpt <- rVertAlign rPr = do
-      transform <- runStyleToTransform rPr{rVertAlign = Nothing}
-      return $ superscript . transform
-  | Just SubScrpt <- rVertAlign rPr = do
-      transform <- runStyleToTransform rPr{rVertAlign = Nothing}
-      return $ subscript . transform
-  | Just "single" <- rUnderline rPr = do
-      transform <- runStyleToTransform rPr{rUnderline = Nothing}
-      return $ Pandoc.underline . transform
-  | otherwise = return id
+runStyleToTransform rPr' = do
+  opts <- asks docxOptions
+  inBidi <- asks docxInBidi
+  let styles = isEnabled Ext_styles opts
+      ctl = (Just True == isRTL rPr') || (Just True == isForceCTL rPr')
+      italic rPr | ctl = isItalicCTL rPr
+                 | otherwise = isItalic rPr
+      bold rPr | ctl = isBoldCTL rPr
+               | otherwise = isBold rPr
+      go rPr
+        | Just sn <- getStyleName <$> rParentStyle rPr
+        , sn `elem` spansToKeep =
+            spanWith ("", [normalizeToClassName sn], [])
+            . go rPr{rParentStyle = Nothing}
+        | styles, Just s <- rParentStyle rPr =
+             spanWith (extraAttr s) . go rPr{rParentStyle = Nothing}
+        | Just True <- italic rPr =
+            emph . go rPr{isItalic = Nothing, isItalicCTL = Nothing}
+        | Just True <- bold rPr =
+            strong . go rPr{isBold = Nothing, isBoldCTL = Nothing}
+        | Just True <- isSmallCaps rPr =
+            smallcaps . go rPr{isSmallCaps = Nothing}
+        | Just True <- isStrike rPr =
+            strikeout . go rPr{isStrike = Nothing}
+        | Just True <- isRTL rPr =
+            spanWith ("",[],[("dir","rtl")]) . go rPr{isRTL = Nothing}
+        | inBidi, Just False <- isRTL rPr =
+            spanWith ("",[],[("dir","ltr")]) . go rPr{isRTL = Nothing}
+        | Just SupScrpt <- rVertAlign rPr =
+            superscript . go rPr{rVertAlign = Nothing}
+        | Just SubScrpt <- rVertAlign rPr = do
+            subscript . go rPr{rVertAlign = Nothing}
+        | Just "single" <- rUnderline rPr = do
+            Pandoc.underline . go rPr{rUnderline = Nothing}
+        | otherwise = id
+  return $ go rPr'
+
 
 runToInlines :: PandocMonad m => Run -> DocxContext m Inlines
 runToInlines (Run rs runElems)
@@ -512,13 +509,8 @@ trimSps (Many ils) = Many $ Seq.dropWhileL isSp $Seq.dropWhileR isSp ils
         isSp LineBreak = True
         isSp _         = False
 
-extraInfo :: (Eq (StyleName a), PandocMonad m, HasStyleName a)
-          => (Attr -> i -> i) -> a -> DocxContext m (i -> i)
-extraInfo f s = do
-  opts <- asks docxOptions
-  return $ if isEnabled Ext_styles opts
-              then f ("", [], [("custom-style", fromStyleName $ getStyleName s)])
-              else id
+extraAttr :: (Eq (StyleName a), HasStyleName a) => a -> Attr
+extraAttr s = ("", [], [("custom-style", fromStyleName $ getStyleName s)])
 
 parStyleToTransform :: PandocMonad m => ParagraphStyle -> DocxContext m (Blocks -> Blocks)
 parStyleToTransform pPr = case pStyle pPr of
@@ -534,8 +526,11 @@ parStyleToTransform pPr = case pStyle pPr of
     | otherwise -> do
         let pPr' = pPr { pStyle = cs }
         transform <- parStyleToTransform pPr'
-        ei <- extraInfo divWith c
-        return $ ei . (if isBlockQuote c then blockQuote else id) . transform
+        styles <- asks (isEnabled Ext_styles . docxOptions)
+        return $
+          (if styles then divWith (extraAttr c) else id)
+          . (if isBlockQuote c then blockQuote else id)
+          . transform
   []
     | Just left <- indentation pPr >>= leftParIndent -> do
         let pPr' = pPr { indentation = Nothing }
diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs
index 199ca6d03..eab4f4e0d 100644
--- a/src/Text/Pandoc/Readers/Docx/Parse.hs
+++ b/src/Text/Pandoc/Readers/Docx/Parse.hs
@@ -259,10 +259,13 @@ newtype Cell = Cell [BodyPart]
 leftBiasedMergeRunStyle :: RunStyle -> RunStyle -> RunStyle
 leftBiasedMergeRunStyle a b = RunStyle
     { isBold = isBold a <|> isBold b
+    , isBoldCTL = isBoldCTL a <|> isBoldCTL b
     , isItalic = isItalic a <|> isItalic b
+    , isItalicCTL = isItalicCTL a <|> isItalicCTL b
     , isSmallCaps = isSmallCaps a <|> isSmallCaps b
     , isStrike = isStrike a <|> isStrike b
     , isRTL = isRTL a <|> isRTL b
+    , isForceCTL = isForceCTL a <|> isForceCTL b
     , rVertAlign = rVertAlign a <|> rVertAlign b
     , rUnderline = rUnderline a <|> rUnderline b
     , rParentStyle = rParentStyle a
diff --git a/src/Text/Pandoc/Readers/Docx/Parse/Styles.hs b/src/Text/Pandoc/Readers/Docx/Parse/Styles.hs
index bfbc65cb0..236167187 100644
--- a/src/Text/Pandoc/Readers/Docx/Parse/Styles.hs
+++ b/src/Text/Pandoc/Readers/Docx/Parse/Styles.hs
@@ -44,7 +44,6 @@ module Text.Pandoc.Readers.Docx.Parse.Styles (
   ) where
 import Codec.Archive.Zip
 import Control.Applicative ((<|>))
-import Control.Monad.Except
 import Data.Function (on)
 import Data.String (IsString(..))
 import qualified Data.Map as M
@@ -101,10 +100,13 @@ data CharStyle = CharStyle { cStyleId   :: CharStyleId
                            } deriving (Show)
 
 data RunStyle = RunStyle { isBold       :: Maybe Bool
+                         , isBoldCTL    :: Maybe Bool
                          , isItalic     :: Maybe Bool
+                         , isItalicCTL  :: Maybe Bool
                          , isSmallCaps  :: Maybe Bool
                          , isStrike     :: Maybe Bool
                          , isRTL        :: Maybe Bool
+                         , isForceCTL   :: Maybe Bool
                          , rVertAlign   :: Maybe VertAlign
                          , rUnderline   :: Maybe String
                          , rParentStyle :: Maybe CharStyle
@@ -121,10 +123,13 @@ data ParStyle = ParStyle { headingLev    :: Maybe (ParaStyleName, Int)
 
 defaultRunStyle :: RunStyle
 defaultRunStyle = RunStyle { isBold = Nothing
+                           , isBoldCTL = Nothing
                            , isItalic = Nothing
+                           , isItalicCTL = Nothing
                            , isSmallCaps = Nothing
                            , isStrike = Nothing
                            , isRTL = Nothing
+                           , isForceCTL = Nothing
                            , rVertAlign = Nothing
                            , rUnderline = Nothing
                            , rParentStyle = Nothing
@@ -240,20 +245,21 @@ elemToCharStyle :: NameSpaces
 elemToCharStyle ns element parentStyle
   = CharStyle <$> (CharStyleId <$> findAttrTextByName ns "w" "styleId" element)
               <*> getElementStyleName ns element
-              <*> (Just $ elemToRunStyle ns element parentStyle)
+              <*> Just (elemToRunStyle ns element parentStyle)
 
 elemToRunStyle :: NameSpaces -> Element -> Maybe CharStyle -> RunStyle
 elemToRunStyle ns element parentStyle
   | Just rPr <- findChildByName ns "w" "rPr" element =
     RunStyle
       {
-        isBold = checkOnOff ns rPr (elemName ns "w" "b") `mplus`
-                 checkOnOff ns rPr (elemName ns "w" "bCs")
-      , isItalic = checkOnOff ns rPr (elemName ns "w" "i") `mplus`
-                   checkOnOff ns rPr (elemName ns "w" "iCs")
+        isBold = checkOnOff ns rPr (elemName ns "w" "b")
+      , isBoldCTL = checkOnOff ns rPr (elemName ns "w" "bCs")
+      , isItalic = checkOnOff ns rPr (elemName ns "w" "i")
+      , isItalicCTL = checkOnOff ns rPr (elemName ns "w" "iCs")
       , isSmallCaps = checkOnOff ns rPr (elemName ns "w" "smallCaps")
       , isStrike = checkOnOff ns rPr (elemName ns "w" "strike")
       , isRTL = checkOnOff ns rPr (elemName ns "w" "rtl")
+      , isForceCTL = checkOnOff ns rPr (elemName ns "w" "cs")
       , rVertAlign =
            findChildByName ns "w" "vertAlign" rPr >>=
            findAttrByName ns "w" "val" >>=