Merge pull request #6509 from lierdakil/docx-smush-inlines-refactor

[Docx Reader] Refactor/update Text.Pandoc.Readers.Docx.Combine.smushInlines

1 files changed, 39 insertions, 62 deletions

diff --git a/src/Text/Pandoc/Readers/Docx/Combine.hs b/src/Text/Pandoc/Readers/Docx/Combine.hs
index 54736cd0e..427a73dbe 100644
--- a/src/Text/Pandoc/Readers/Docx/Combine.hs
+++ b/src/Text/Pandoc/Readers/Docx/Combine.hs
@@ -1,10 +1,9 @@
-{-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE PatternGuards        #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {- |
    Module      : Text.Pandoc.Readers.Docx.Combine
    Copyright   : © 2014-2020 Jesse Rosenthal <jrosenthal@jhu.edu>,
-                   2014-2020 John MacFarlane <jgm@berkeley.edu>
+                   2014-2020 John MacFarlane <jgm@berkeley.edu>,
+                   2020 Nikolay Yakimov <root@livid.pp.ru>
    License     : GNU GPL, version 2 or above
 
    Maintainer  : Jesse Rosenthal <jrosenthal@jhu.edu>
@@ -59,79 +58,61 @@ module Text.Pandoc.Readers.Docx.Combine ( smushInlines
        where
 
 import Data.List
-import Data.Sequence (ViewL (..), ViewR (..), viewl, viewr, (><), (|>))
-import qualified Data.Sequence as Seq (null)
+import Data.Bifunctor
+import Data.Sequence ( ViewL (..), ViewR (..), viewl, viewr, spanr, spanl
+                     , (><), (|>) )
 import Text.Pandoc.Builder
 
 data Modifier a = Modifier (a -> a)
                 | AttrModifier (Attr -> a -> a) Attr
-                | NullModifier
 
 spaceOutInlinesL :: Inlines -> (Inlines, Inlines)
 spaceOutInlinesL ms = (l, stackInlines fs (m' <> r))
-  where (l, m, r) = spaceOutInlines ms
-        (fs, m')  = unstackInlines m
+  where (l, (fs, m'), r) = spaceOutInlines ms
 
 spaceOutInlinesR :: Inlines -> (Inlines, Inlines)
 spaceOutInlinesR ms = (stackInlines fs (l <> m'), r)
-  where (l, m, r) = spaceOutInlines ms
-        (fs, m')  = unstackInlines m
+  where (l, (fs, m'), r) = spaceOutInlines ms
 
-spaceOutInlines :: Inlines -> (Inlines, Inlines, Inlines)
+spaceOutInlines :: Inlines -> (Inlines, ([Modifier Inlines], Inlines), Inlines)
 spaceOutInlines ils =
   let (fs, ils') = unstackInlines ils
-      contents = unMany ils'
-      left  = case viewl contents of
-        (Space :< _) -> space
-        _            -> mempty
-      right = case viewr contents of
-        (_ :> Space) -> space
-        _            -> mempty in
-  (left, stackInlines fs $ trimInlines . Many $ contents, right)
+      (left, (right, contents')) = second (spanr isSpace) $ spanl isSpace $ unMany ils'
+      -- NOTE: spanr counterintuitively returns suffix as the FIRST tuple element
+  in (Many left, (fs, Many contents'), Many right)
+
+isSpace :: Inline -> Bool
+isSpace Space = True
+isSpace SoftBreak = True
+isSpace _ = False
 
 stackInlines :: [Modifier Inlines] -> Inlines -> Inlines
 stackInlines [] ms = ms
-stackInlines (NullModifier : fs) ms = stackInlines fs ms
 stackInlines (Modifier f : fs) ms =
-  if isEmpty ms
+  if null ms
   then stackInlines fs ms
   else f $ stackInlines fs ms
 stackInlines (AttrModifier f attr : fs) ms = f attr $ stackInlines fs ms
 
 unstackInlines :: Inlines -> ([Modifier Inlines], Inlines)
-unstackInlines ms = case ilModifier ms of
-  NullModifier -> ([], ms)
-  _            -> (f : fs, ms') where
-    f = ilModifier ms
-    (fs, ms') = unstackInlines $ ilInnards ms
-
-ilModifier :: Inlines -> Modifier Inlines
-ilModifier ils = case viewl (unMany ils) of
-  (x :< xs) | Seq.null xs -> case x of
-    (Emph _)          -> Modifier emph
-    (Strong _)        -> Modifier strong
-    (SmallCaps _)     -> Modifier smallcaps
-    (Strikeout _)     -> Modifier strikeout
-    (Superscript _)   -> Modifier superscript
-    (Subscript _)     -> Modifier subscript
-    (Link attr _ tgt) -> Modifier $ linkWith attr (fst tgt) (snd tgt)
-    (Span attr _)     -> AttrModifier spanWith attr
-    _                 -> NullModifier
-  _ -> NullModifier
-
-ilInnards :: Inlines -> Inlines
-ilInnards ils = case viewl (unMany ils) of
-  (x :< xs) | Seq.null xs -> case x of
-    (Emph lst)        -> fromList lst
-    (Strong lst)      -> fromList lst
-    (SmallCaps lst)   -> fromList lst
-    (Strikeout lst)   -> fromList lst
-    (Superscript lst) -> fromList lst
-    (Subscript lst)   -> fromList lst
-    (Link _ lst _)    -> fromList lst
-    (Span _ lst)      -> fromList lst
-    _                 -> ils
-  _          -> ils
+unstackInlines ms = case ilModifierAndInnards ms of
+  Nothing         -> ([], ms)
+  Just (f, inner) -> first (f :) $ unstackInlines inner
+
+ilModifierAndInnards :: Inlines -> Maybe (Modifier Inlines, Inlines)
+ilModifierAndInnards ils = case viewl $ unMany ils of
+  x :< xs | null xs -> second fromList <$> case x of
+    Emph lst          -> Just (Modifier emph, lst)
+    Strong lst        -> Just (Modifier strong, lst)
+    SmallCaps lst     -> Just (Modifier smallcaps, lst)
+    Strikeout lst     -> Just (Modifier strikeout, lst)
+    Underline lst     -> Just (Modifier underline, lst)
+    Superscript lst   -> Just (Modifier superscript, lst)
+    Subscript lst     -> Just (Modifier subscript, lst)
+    Link attr lst tgt -> Just (Modifier $ linkWith attr (fst tgt) (snd tgt), lst)
+    Span attr lst     -> Just (AttrModifier spanWith attr, lst)
+    _                 -> Nothing
+  _ -> Nothing
 
 inlinesL :: Inlines -> (Inlines, Inlines)
 inlinesL ils = case viewl $ unMany ils of
@@ -161,12 +142,12 @@ combineSingletonInlines x y =
       y_rem_attr = filter isAttrModifier y_remaining
   in
    case null shared of
-     True | isEmpty xs && isEmpty ys ->
-            stackInlines (x_rem_attr ++ y_rem_attr) mempty
-          | isEmpty xs ->
+     True | null xs && null ys ->
+            stackInlines (x_rem_attr <> y_rem_attr) mempty
+          | null xs ->
             let (sp, y') = spaceOutInlinesL y in
             stackInlines x_rem_attr mempty <> sp <> y'
-          | isEmpty ys ->
+          | null ys ->
             let (x', sp) = spaceOutInlinesR x in
             x' <> sp <> stackInlines y_rem_attr mempty
           | otherwise ->
@@ -193,12 +174,8 @@ combineBlocks bs cs = bs <> cs
 instance (Monoid a, Eq a) => Eq (Modifier a) where
   (Modifier f) == (Modifier g) = f mempty == g mempty
   (AttrModifier f attr) == (AttrModifier g attr') = f attr mempty == g attr' mempty
-  NullModifier == NullModifier = True
   _ == _ = False
 
-isEmpty :: (Monoid a, Eq a) => a -> Bool
-isEmpty x = x == mempty
-
 isAttrModifier :: Modifier a -> Bool
 isAttrModifier (AttrModifier _ _) = True
 isAttrModifier _                  = False