2 files changed, 154 insertions, 183 deletions
diff --git a/src/Text/Pandoc/Readers/Docx/Combine.hs b/src/Text/Pandoc/Readers/Docx/Combine.hs
new file mode 100644
index 000000000..39e0df825
--- /dev/null
+++ b/src/Text/Pandoc/Readers/Docx/Combine.hs
@@ -0,0 +1,154 @@
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances,
+    PatternGuards #-}
+
+module Text.Pandoc.Readers.Docx.Combine ( smushInlines
+                                        , smushBlocks
+                                        )
+       where
+
+import Text.Pandoc.Builder
+import Data.List
+import Data.Sequence (ViewR(..), ViewL(..), viewl, viewr, (><), (|>))
+import qualified Data.Sequence as Seq (null)
+
+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
+
+spaceOutInlinesR :: Inlines -> (Inlines, Inlines)
+spaceOutInlinesR ms = (stackInlines fs (l <> m'), r)
+  where (l, m, r) = spaceOutInlines ms
+        (fs, m')  = unstackInlines m
+
+spaceOutInlines :: Inlines -> (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)
+
+stackInlines :: [Modifier Inlines] -> Inlines -> Inlines
+stackInlines [] ms = ms
+stackInlines (NullModifier : fs) ms = stackInlines fs ms
+stackInlines ((Modifier f) : fs) ms =
+  if isEmpty 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
+
+inlinesL :: Inlines -> (Inlines, Inlines)
+inlinesL ils = case viewl $ unMany ils of
+  (s :< sq) -> (singleton s, Many sq)
+  _          -> (mempty, ils)
+
+inlinesR :: Inlines -> (Inlines, Inlines)
+inlinesR ils = case viewr $ unMany ils of
+  (sq :> s) -> (Many sq, singleton s)
+  _          -> (ils, mempty)
+
+combineInlines :: Inlines -> Inlines -> Inlines
+combineInlines x y =
+  let (xs', x') = inlinesR x
+      (y', ys') = inlinesL y
+  in
+   xs' <> (combineSingletonInlines x' y') <> ys'
+
+combineSingletonInlines :: Inlines -> Inlines -> Inlines
+combineSingletonInlines x y =
+  let (xfs, xs) = unstackInlines x
+      (yfs, ys) = unstackInlines y
+      shared = xfs `intersect` yfs
+      x_remaining = xfs \\ shared
+      y_remaining = yfs \\ shared
+      x_rem_attr = filter isAttrModifier x_remaining
+      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 ->
+            let (sp, y') = spaceOutInlinesL y in
+            (stackInlines x_rem_attr mempty) <> sp <> y'
+          | isEmpty ys ->
+            let (x', sp) = spaceOutInlinesR x in
+            x' <> sp <> (stackInlines y_rem_attr mempty)
+          | otherwise ->
+              let (x', xsp) = spaceOutInlinesR x
+                  (ysp, y') = spaceOutInlinesL y
+              in
+               x' <> xsp <> ysp <> y'
+     False -> stackInlines shared $
+              combineInlines
+              (stackInlines x_remaining xs)
+              (stackInlines y_remaining ys)
+
+combineBlocks :: Blocks -> Blocks -> Blocks
+combineBlocks bs cs
+  | bs' :> (BlockQuote bs'') <- viewr (unMany bs)
+  , (BlockQuote cs'') :< cs' <- viewl (unMany cs) =
+      Many $ (bs' |> (BlockQuote (bs'' <> cs''))) >< cs'
+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
+
+smushInlines :: [Inlines] -> Inlines
+smushInlines xs = foldl combineInlines mempty xs
+
+smushBlocks :: [Blocks] -> Blocks
+smushBlocks xs = foldl combineBlocks mempty xs
diff --git a/src/Text/Pandoc/Readers/Docx/Reducible.hs b/src/Text/Pandoc/Readers/Docx/Reducible.hs
deleted file mode 100644
index e6de2d474..000000000
--- a/src/Text/Pandoc/Readers/Docx/Reducible.hs
+++ /dev/null
@@ -1,183 +0,0 @@
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances,
-    PatternGuards #-}
-
-module Text.Pandoc.Readers.Docx.Reducible ( concatReduce
-                                          , (<+>)
-                                          )
-       where
-
-
-import Text.Pandoc.Builder
-import Data.List
-import Data.Sequence (ViewR(..), ViewL(..), viewl, viewr)
-import qualified Data.Sequence as Seq (null)
-
-data Modifier a = Modifier (a -> a)
-                | AttrModifier (Attr -> a -> a) Attr
-                | NullModifier
-
-class (Eq a) => Modifiable a where
-  modifier :: a -> Modifier a
-  innards :: a -> a
-  getL    :: a -> (a, a)
-  getR    :: a -> (a, a)
-  spaceOut :: a -> (a, a, a)
-
-spaceOutL :: (Monoid a, Modifiable a) => a -> (a, a)
-spaceOutL ms = (l, stack fs (m' <> r))
-  where (l, m, r) = spaceOut ms
-        (fs, m')  = unstack m
-
-spaceOutR :: (Monoid a, Modifiable a) => a -> (a, a)
-spaceOutR ms = (stack fs (l <> m'), r)
-  where (l, m, r) = spaceOut ms
-        (fs, m')  = unstack m
-
-instance (Monoid a, Show a) => Show (Modifier a) where
-  show (Modifier f) = show $ f mempty
-  show (AttrModifier f attr) = show $ f attr mempty
-  show (NullModifier) = "NullModifier"
-
-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
-
-instance Modifiable Inlines where
-  modifier 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
-
-  innards 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
-
-  getL ils = case viewl $ unMany ils of
-    (s :< sq) -> (singleton s, Many sq)
-    _          -> (mempty, ils)
-
-  getR ils = case viewr $ unMany ils of
-    (sq :> s) -> (Many sq, singleton s)
-    _          -> (ils, mempty)
-
-  spaceOut ils =
-    let (fs, ils') = unstack ils
-        contents = unMany ils'
-        left  = case viewl contents of
-          (Space :< _) -> space
-          _            -> mempty
-        right = case viewr contents of
-          (_ :> Space) -> space
-          _            -> mempty in
-    (left, (stack fs $ trimInlines .Many $ contents), right)
-
-instance Modifiable Blocks where
-  modifier blks = case viewl (unMany blks) of
-    (x :< xs) | Seq.null xs -> case x of
-      (BlockQuote _) -> Modifier blockQuote
-      -- (Div attr _)   -> AttrModifier divWith attr
-      _               -> NullModifier
-    _ -> NullModifier
-
-  innards blks = case viewl (unMany blks) of
-    (x :< xs) | Seq.null xs -> case x of
-      (BlockQuote lst) -> fromList lst
-      -- (Div attr lst)   -> fromList lst
-      _        -> blks
-    _          -> blks
-
-  spaceOut blks = (mempty, blks, mempty)
-
-  getL ils = case viewl $ unMany ils of
-    (s :< sq) -> (singleton s, Many sq)
-    _          -> (mempty, ils)
-
-  getR ils = case viewr $ unMany ils of
-    (sq :> s) -> (Many sq, singleton s)
-    _          -> (ils, mempty)
-
-
-unstack :: (Modifiable a) => a -> ([Modifier a], a)
-unstack ms = case modifier ms of
-  NullModifier -> ([], ms)
-  _            -> (f : fs, ms') where
-    f = modifier ms
-    (fs, ms') = unstack $ innards ms
-
-stack :: (Monoid a, Modifiable a) => [Modifier a] -> a -> a
-stack [] ms = ms
-stack (NullModifier : fs) ms = stack fs ms
-stack ((Modifier f) : fs) ms =
-  if isEmpty ms
-  then stack fs ms
-  else f $ stack fs ms
-stack ((AttrModifier f attr) : fs) ms = f attr $ stack fs ms
-
-isEmpty :: (Monoid a, Eq a) => a -> Bool
-isEmpty x = x == mempty
-
-
-combine :: (Monoid a, Modifiable a, Eq a) => a -> a -> a
-combine x y =
-  let (xs', x') = getR x
-      (y', ys') = getL y
-  in
-   xs' <> (combineSingleton x' y') <> ys'
-
-isAttrModifier :: Modifier a -> Bool
-isAttrModifier (AttrModifier _ _) = True
-isAttrModifier _                  = False
-
-combineSingleton :: (Monoid a, Modifiable a, Eq a) => a -> a -> a
-combineSingleton x y =
-  let (xfs, xs) = unstack x
-      (yfs, ys) = unstack y
-      shared = xfs `intersect` yfs
-      x_remaining = xfs \\ shared
-      y_remaining = yfs \\ shared
-      x_rem_attr = filter isAttrModifier x_remaining
-      y_rem_attr = filter isAttrModifier y_remaining
-  in
-   case null shared of
-     True | isEmpty xs && isEmpty ys ->
-            stack (x_rem_attr ++ y_rem_attr) mempty
-          | isEmpty xs ->
-            let (sp, y') = spaceOutL y in
-            (stack x_rem_attr mempty) <> sp <> y'
-          | isEmpty ys ->
-            let (x', sp) = spaceOutR x in
-            x' <> sp <> (stack y_rem_attr mempty)
-          | otherwise ->
-              let (x', xsp) = spaceOutR x
-                  (ysp, y') = spaceOutL y
-              in
-               x' <> xsp <> ysp <> y'
-     False -> stack shared $
-              combine
-              (stack x_remaining xs)
-              (stack y_remaining ys)
-
-(<+>) :: (Monoid a, Modifiable a, Eq a) => a -> a -> a
-x <+> y = combine x y
-
-concatReduce :: (Monoid a, Modifiable a) => [a] -> a
-concatReduce xs = foldl combine mempty xs