{-# LANGUAGE OverloadedStrings    #-}
{- |
   Module      : Text.Pandoc.Readers.Docx.Combine
   Copyright   : © 2014-2020 Jesse Rosenthal <jrosenthal@jhu.edu>,
                   2014-2023 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>
   Stability   : alpha
   Portability : portable

Flatten sequences of elements.
-}

{-
The purpose of this module is to combine the formatting of separate
runs, which have *non-nesting* formatting. Because the formatting
doesn't nest, you can't actually tell the nesting order until you
combine with the runs that follow.

For example, say you have a something like `<em><strong>foo</strong>
bar</em>`. Then in ooxml, you'll get these two runs:

~~~
<w:r>
 <w:rPr>
  <w:b />
  <w:i />
 </w:rPr>
 <w:t>Foo</w:t>
</w:r>
<w:r>
 <w:rPr>
  <w:i />
 </w:rPr>
 <w:t> Bar</w:t>
</w:r>
~~~

Note that this is an ideal situation. In practice, it will probably be
more---if, for example, the user turned italics
off and then on.

So, when you get the first run, which is marked as both bold and italic,
you have no idea whether it's `Strong [Emph [Str "Foo"]]` or `Emph
[Strong [Str "Foo"]]`.

We combine two runs, then, by taking off the formatting that modifies an
inline, seeing what is shared between them, and rebuilding an inline. We
fold this to combine the inlines.

-}

module Text.Pandoc.Readers.Docx.Combine ( smushInlines
                                        , smushBlocks
                                        )
       where

import Data.List
import Data.Bifunctor
import Data.Sequence ( ViewL (..), ViewR (..), viewl, viewr, spanr, spanl
                     , (><), (|>) )
import Text.Pandoc.Builder as B

data Modifier a = Modifier (a -> a)
                | AttrModifier (Attr -> a -> a) Attr

spaceOutInlinesL :: Inlines -> (Inlines, Inlines)
spaceOutInlinesL :: Inlines -> (Inlines, Inlines)
spaceOutInlinesL Inlines
ms = (Inlines
l, [Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
fs (Inlines
m' forall a. Semigroup a => a -> a -> a
<> Inlines
r))
  where (Inlines
l, ([Modifier Inlines]
fs, Inlines
m'), Inlines
r) = Inlines -> (Inlines, ([Modifier Inlines], Inlines), Inlines)
spaceOutInlines Inlines
ms

spaceOutInlinesR :: Inlines -> (Inlines, Inlines)
spaceOutInlinesR :: Inlines -> (Inlines, Inlines)
spaceOutInlinesR Inlines
ms = ([Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
fs (Inlines
l forall a. Semigroup a => a -> a -> a
<> Inlines
m'), Inlines
r)
  where (Inlines
l, ([Modifier Inlines]
fs, Inlines
m'), Inlines
r) = Inlines -> (Inlines, ([Modifier Inlines], Inlines), Inlines)
spaceOutInlines Inlines
ms

spaceOutInlines :: Inlines -> (Inlines, ([Modifier Inlines], Inlines), Inlines)
spaceOutInlines :: Inlines -> (Inlines, ([Modifier Inlines], Inlines), Inlines)
spaceOutInlines Inlines
ils =
  let ([Modifier Inlines]
fs, Inlines
ils') = Inlines -> ([Modifier Inlines], Inlines)
unstackInlines Inlines
ils
      (Seq Inline
left, (Seq Inline
right, Seq Inline
contents')) = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
spanr Inline -> Bool
isSpace) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
spanl Inline -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ forall a. Many a -> Seq a
unMany Inlines
ils'
      -- NOTE: spanr counterintuitively returns suffix as the FIRST tuple element
  in (forall a. Seq a -> Many a
Many Seq Inline
left, ([Modifier Inlines]
fs, forall a. Seq a -> Many a
Many Seq Inline
contents'), forall a. Seq a -> Many a
Many Seq Inline
right)

isSpace :: Inline -> Bool
isSpace :: Inline -> Bool
isSpace Inline
Space = Bool
True
isSpace Inline
SoftBreak = Bool
True
isSpace Inline
_ = Bool
False

stackInlines :: [Modifier Inlines] -> Inlines -> Inlines
stackInlines :: [Modifier Inlines] -> Inlines -> Inlines
stackInlines [] Inlines
ms = Inlines
ms
stackInlines (Modifier Inlines -> Inlines
f : [Modifier Inlines]
fs) Inlines
ms =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Inlines
ms
  then [Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
fs Inlines
ms
  else Inlines -> Inlines
f forall a b. (a -> b) -> a -> b
$ [Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
fs Inlines
ms
stackInlines (AttrModifier Attr -> Inlines -> Inlines
f Attr
attr : [Modifier Inlines]
fs) Inlines
ms = Attr -> Inlines -> Inlines
f Attr
attr forall a b. (a -> b) -> a -> b
$ [Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
fs Inlines
ms

unstackInlines :: Inlines -> ([Modifier Inlines], Inlines)
unstackInlines :: Inlines -> ([Modifier Inlines], Inlines)
unstackInlines Inlines
ms = case Inlines -> Maybe (Modifier Inlines, Inlines)
ilModifierAndInnards Inlines
ms of
  Maybe (Modifier Inlines, Inlines)
Nothing         -> ([], Inlines
ms)
  Just (Modifier Inlines
f, Inlines
inner) -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Modifier Inlines
f forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ Inlines -> ([Modifier Inlines], Inlines)
unstackInlines Inlines
inner

ilModifierAndInnards :: Inlines -> Maybe (Modifier Inlines, Inlines)
ilModifierAndInnards :: Inlines -> Maybe (Modifier Inlines, Inlines)
ilModifierAndInnards Inlines
ils = case forall a. Seq a -> ViewL a
viewl forall a b. (a -> b) -> a -> b
$ forall a. Many a -> Seq a
unMany Inlines
ils of
  Inline
x :< Seq Inline
xs | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq Inline
xs -> forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. [a] -> Many a
fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Inline
x of
    Emph [Inline]
lst          -> forall a. a -> Maybe a
Just (forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
emph, [Inline]
lst)
    Strong [Inline]
lst        -> forall a. a -> Maybe a
Just (forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
strong, [Inline]
lst)
    SmallCaps [Inline]
lst     -> forall a. a -> Maybe a
Just (forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
smallcaps, [Inline]
lst)
    Strikeout [Inline]
lst     -> forall a. a -> Maybe a
Just (forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
strikeout, [Inline]
lst)
    Underline [Inline]
lst     -> forall a. a -> Maybe a
Just (forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
underline, [Inline]
lst)
    Superscript [Inline]
lst   -> forall a. a -> Maybe a
Just (forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
superscript, [Inline]
lst)
    Subscript [Inline]
lst     -> forall a. a -> Maybe a
Just (forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
subscript, [Inline]
lst)
    Link Attr
attr [Inline]
lst (Text, Text)
tgt -> forall a. a -> Maybe a
Just (forall a. (a -> a) -> Modifier a
Modifier forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Attr -> Text -> Text -> Inlines -> Inlines
linkWith Attr
attr) (Text, Text)
tgt, [Inline]
lst)
    Span Attr
attr [Inline]
lst     -> forall a. a -> Maybe a
Just (forall a. (Attr -> a -> a) -> Attr -> Modifier a
AttrModifier Attr -> Inlines -> Inlines
spanWith Attr
attr, [Inline]
lst)
    Inline
_                 -> forall a. Maybe a
Nothing
  ViewL Inline
_ -> forall a. Maybe a
Nothing

inlinesL :: Inlines -> (Inlines, Inlines)
inlinesL :: Inlines -> (Inlines, Inlines)
inlinesL Inlines
ils = case forall a. Seq a -> ViewL a
viewl forall a b. (a -> b) -> a -> b
$ forall a. Many a -> Seq a
unMany Inlines
ils of
  (Inline
s :< Seq Inline
sq) -> (forall a. a -> Many a
B.singleton Inline
s, forall a. Seq a -> Many a
Many Seq Inline
sq)
  ViewL Inline
_         -> (forall a. Monoid a => a
mempty, Inlines
ils)

inlinesR :: Inlines -> (Inlines, Inlines)
inlinesR :: Inlines -> (Inlines, Inlines)
inlinesR Inlines
ils = case forall a. Seq a -> ViewR a
viewr forall a b. (a -> b) -> a -> b
$ forall a. Many a -> Seq a
unMany Inlines
ils of
  (Seq Inline
sq :> Inline
s) -> (forall a. Seq a -> Many a
Many Seq Inline
sq, forall a. a -> Many a
B.singleton Inline
s)
  ViewR Inline
_         -> (Inlines
ils, forall a. Monoid a => a
mempty)

combineInlines :: Inlines -> Inlines -> Inlines
combineInlines :: Inlines -> Inlines -> Inlines
combineInlines Inlines
x Inlines
y =
  let (Inlines
xs', Inlines
x') = Inlines -> (Inlines, Inlines)
inlinesR Inlines
x
      (Inlines
y', Inlines
ys') = Inlines -> (Inlines, Inlines)
inlinesL Inlines
y
  in
   Inlines
xs' forall a. Semigroup a => a -> a -> a
<> Inlines -> Inlines -> Inlines
combineSingletonInlines Inlines
x' Inlines
y' forall a. Semigroup a => a -> a -> a
<> Inlines
ys'

combineSingletonInlines :: Inlines -> Inlines -> Inlines
combineSingletonInlines :: Inlines -> Inlines -> Inlines
combineSingletonInlines Inlines
x Inlines
y =
  let ([Modifier Inlines]
xfs, Inlines
xs) = Inlines -> ([Modifier Inlines], Inlines)
unstackInlines Inlines
x
      ([Modifier Inlines]
yfs, Inlines
ys) = Inlines -> ([Modifier Inlines], Inlines)
unstackInlines Inlines
y
      shared :: [Modifier Inlines]
shared = [Modifier Inlines]
xfs forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Modifier Inlines]
yfs
      x_remaining :: [Modifier Inlines]
x_remaining = [Modifier Inlines]
xfs forall a. Eq a => [a] -> [a] -> [a]
\\ [Modifier Inlines]
shared
      y_remaining :: [Modifier Inlines]
y_remaining = [Modifier Inlines]
yfs forall a. Eq a => [a] -> [a] -> [a]
\\ [Modifier Inlines]
shared
      x_rem_attr :: [Modifier Inlines]
x_rem_attr = forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Modifier a -> Bool
isAttrModifier [Modifier Inlines]
x_remaining
      y_rem_attr :: [Modifier Inlines]
y_rem_attr = forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Modifier a -> Bool
isAttrModifier [Modifier Inlines]
y_remaining
  in
   case forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Modifier Inlines]
shared of
     Bool
True | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Inlines
xs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Inlines
ys ->
            [Modifier Inlines] -> Inlines -> Inlines
stackInlines ([Modifier Inlines]
x_rem_attr forall a. Semigroup a => a -> a -> a
<> [Modifier Inlines]
y_rem_attr) forall a. Monoid a => a
mempty
          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Inlines
xs ->
            let (Inlines
sp, Inlines
y') = Inlines -> (Inlines, Inlines)
spaceOutInlinesL Inlines
y in
            [Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
x_rem_attr forall a. Monoid a => a
mempty forall a. Semigroup a => a -> a -> a
<> Inlines
sp forall a. Semigroup a => a -> a -> a
<> Inlines
y'
          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Inlines
ys ->
            let (Inlines
x', Inlines
sp) = Inlines -> (Inlines, Inlines)
spaceOutInlinesR Inlines
x in
            Inlines
x' forall a. Semigroup a => a -> a -> a
<> Inlines
sp forall a. Semigroup a => a -> a -> a
<> [Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
y_rem_attr forall a. Monoid a => a
mempty
          | Bool
otherwise ->
              let (Inlines
x', Inlines
xsp) = Inlines -> (Inlines, Inlines)
spaceOutInlinesR Inlines
x
                  (Inlines
ysp, Inlines
y') = Inlines -> (Inlines, Inlines)
spaceOutInlinesL Inlines
y
              in
               Inlines
x' forall a. Semigroup a => a -> a -> a
<> Inlines
xsp forall a. Semigroup a => a -> a -> a
<> Inlines
ysp forall a. Semigroup a => a -> a -> a
<> Inlines
y'
     Bool
False -> [Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
shared forall a b. (a -> b) -> a -> b
$
              Inlines -> Inlines -> Inlines
combineInlines
              ([Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
x_remaining Inlines
xs)
              ([Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
y_remaining Inlines
ys)

combineBlocks :: Blocks -> Blocks -> Blocks
combineBlocks :: Blocks -> Blocks -> Blocks
combineBlocks Blocks
bs Blocks
cs
  | Seq Block
bs' :> BlockQuote [Block]
bs'' <- forall a. Seq a -> ViewR a
viewr (forall a. Many a -> Seq a
unMany Blocks
bs)
  , BlockQuote [Block]
cs'' :< Seq Block
cs' <- forall a. Seq a -> ViewL a
viewl (forall a. Many a -> Seq a
unMany Blocks
cs) =
      forall a. Seq a -> Many a
Many forall a b. (a -> b) -> a -> b
$ (Seq Block
bs' forall a. Seq a -> a -> Seq a
|> [Block] -> Block
BlockQuote ([Block]
bs'' forall a. Semigroup a => a -> a -> a
<> [Block]
cs'')) forall a. Seq a -> Seq a -> Seq a
>< Seq Block
cs'
  | Seq Block
bs' :> CodeBlock Attr
attr Text
codeStr <- forall a. Seq a -> ViewR a
viewr (forall a. Many a -> Seq a
unMany Blocks
bs)
  , CodeBlock Attr
attr' Text
codeStr' :< Seq Block
cs' <- forall a. Seq a -> ViewL a
viewl (forall a. Many a -> Seq a
unMany Blocks
cs)
  , Attr
attr forall a. Eq a => a -> a -> Bool
== Attr
attr' =
      forall a. Seq a -> Many a
Many forall a b. (a -> b) -> a -> b
$ (Seq Block
bs' forall a. Seq a -> a -> Seq a
|> Attr -> Text -> Block
CodeBlock Attr
attr (Text
codeStr forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
codeStr')) forall a. Seq a -> Seq a -> Seq a
>< Seq Block
cs'
combineBlocks Blocks
bs Blocks
cs = Blocks
bs forall a. Semigroup a => a -> a -> a
<> Blocks
cs

instance (Monoid a, Eq a) => Eq (Modifier a) where
  (Modifier a -> a
f) == :: Modifier a -> Modifier a -> Bool
== (Modifier a -> a
g) = a -> a
f forall a. Monoid a => a
mempty forall a. Eq a => a -> a -> Bool
== a -> a
g forall a. Monoid a => a
mempty
  (AttrModifier Attr -> a -> a
f Attr
attr) == (AttrModifier Attr -> a -> a
g Attr
attr') = Attr -> a -> a
f Attr
attr forall a. Monoid a => a
mempty forall a. Eq a => a -> a -> Bool
== Attr -> a -> a
g Attr
attr' forall a. Monoid a => a
mempty
  Modifier a
_ == Modifier a
_ = Bool
False

isAttrModifier :: Modifier a -> Bool
isAttrModifier :: forall a. Modifier a -> Bool
isAttrModifier (AttrModifier Attr -> a -> a
_ Attr
_) = Bool
True
isAttrModifier Modifier a
_                  = Bool
False

smushInlines :: [Inlines] -> Inlines
smushInlines :: [Inlines] -> Inlines
smushInlines [Inlines]
xs = Inlines -> Inlines -> Inlines
combineInlines Inlines
xs' forall a. Monoid a => a
mempty
  where xs' :: Inlines
xs' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Inlines -> Inlines -> Inlines
combineInlines forall a. Monoid a => a
mempty [Inlines]
xs

smushBlocks :: [Blocks] -> Blocks
smushBlocks :: [Blocks] -> Blocks
smushBlocks [Blocks]
xs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Blocks -> Blocks -> Blocks
combineBlocks forall a. Monoid a => a
mempty [Blocks]
xs