{-# LANGUAGE OverloadedStrings #-}
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' Inlines -> Inlines -> Inlines
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 Inlines -> Inlines -> Inlines
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')) = (Seq Inline -> (Seq Inline, Seq Inline))
-> (Seq Inline, Seq Inline)
-> (Seq Inline, (Seq Inline, Seq Inline))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Inline -> Bool) -> Seq Inline -> (Seq Inline, Seq Inline)
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
spanr Inline -> Bool
isSpace) ((Seq Inline, Seq Inline)
-> (Seq Inline, (Seq Inline, Seq Inline)))
-> (Seq Inline, Seq Inline)
-> (Seq Inline, (Seq Inline, Seq Inline))
forall a b. (a -> b) -> a -> b
$ (Inline -> Bool) -> Seq Inline -> (Seq Inline, Seq Inline)
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
spanl Inline -> Bool
isSpace (Seq Inline -> (Seq Inline, Seq Inline))
-> Seq Inline -> (Seq Inline, Seq Inline)
forall a b. (a -> b) -> a -> b
$ Inlines -> Seq Inline
forall a. Many a -> Seq a
unMany Inlines
ils'
in (Seq Inline -> Inlines
forall a. Seq a -> Many a
Many Seq Inline
left, ([Modifier Inlines]
fs, Seq Inline -> Inlines
forall a. Seq a -> Many a
Many Seq Inline
contents'), Seq Inline -> Inlines
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 Inlines -> Bool
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 (Inlines -> Inlines) -> Inlines -> Inlines
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 (Inlines -> Inlines) -> Inlines -> Inlines
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) -> ([Modifier Inlines] -> [Modifier Inlines])
-> ([Modifier Inlines], Inlines) -> ([Modifier Inlines], Inlines)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Modifier Inlines
f Modifier Inlines -> [Modifier Inlines] -> [Modifier Inlines]
forall a. a -> [a] -> [a]
:) (([Modifier Inlines], Inlines) -> ([Modifier Inlines], Inlines))
-> ([Modifier Inlines], Inlines) -> ([Modifier Inlines], Inlines)
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 Seq Inline -> ViewL Inline
forall a. Seq a -> ViewL a
viewl (Seq Inline -> ViewL Inline) -> Seq Inline -> ViewL Inline
forall a b. (a -> b) -> a -> b
$ Inlines -> Seq Inline
forall a. Many a -> Seq a
unMany Inlines
ils of
Inline
x :< Seq Inline
xs | Seq Inline -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq Inline
xs -> ([Inline] -> Inlines)
-> (Modifier Inlines, [Inline]) -> (Modifier Inlines, Inlines)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [Inline] -> Inlines
forall a. [a] -> Many a
fromList ((Modifier Inlines, [Inline]) -> (Modifier Inlines, Inlines))
-> Maybe (Modifier Inlines, [Inline])
-> Maybe (Modifier Inlines, Inlines)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Inline
x of
Emph [Inline]
lst -> (Modifier Inlines, [Inline]) -> Maybe (Modifier Inlines, [Inline])
forall a. a -> Maybe a
Just ((Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
emph, [Inline]
lst)
Strong [Inline]
lst -> (Modifier Inlines, [Inline]) -> Maybe (Modifier Inlines, [Inline])
forall a. a -> Maybe a
Just ((Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
strong, [Inline]
lst)
SmallCaps [Inline]
lst -> (Modifier Inlines, [Inline]) -> Maybe (Modifier Inlines, [Inline])
forall a. a -> Maybe a
Just ((Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
smallcaps, [Inline]
lst)
Strikeout [Inline]
lst -> (Modifier Inlines, [Inline]) -> Maybe (Modifier Inlines, [Inline])
forall a. a -> Maybe a
Just ((Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
strikeout, [Inline]
lst)
Underline [Inline]
lst -> (Modifier Inlines, [Inline]) -> Maybe (Modifier Inlines, [Inline])
forall a. a -> Maybe a
Just ((Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
underline, [Inline]
lst)
Superscript [Inline]
lst -> (Modifier Inlines, [Inline]) -> Maybe (Modifier Inlines, [Inline])
forall a. a -> Maybe a
Just ((Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
superscript, [Inline]
lst)
Subscript [Inline]
lst -> (Modifier Inlines, [Inline]) -> Maybe (Modifier Inlines, [Inline])
forall a. a -> Maybe a
Just ((Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
subscript, [Inline]
lst)
Link Attr
attr [Inline]
lst Target
tgt -> (Modifier Inlines, [Inline]) -> Maybe (Modifier Inlines, [Inline])
forall a. a -> Maybe a
Just ((Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier ((Inlines -> Inlines) -> Modifier Inlines)
-> (Inlines -> Inlines) -> Modifier Inlines
forall a b. (a -> b) -> a -> b
$ (Text -> Text -> Inlines -> Inlines)
-> Target -> Inlines -> Inlines
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Attr -> Text -> Text -> Inlines -> Inlines
linkWith Attr
attr) Target
tgt, [Inline]
lst)
Span Attr
attr [Inline]
lst -> (Modifier Inlines, [Inline]) -> Maybe (Modifier Inlines, [Inline])
forall a. a -> Maybe a
Just ((Attr -> Inlines -> Inlines) -> Attr -> Modifier Inlines
forall a. (Attr -> a -> a) -> Attr -> Modifier a
AttrModifier Attr -> Inlines -> Inlines
spanWith Attr
attr, [Inline]
lst)
Inline
_ -> Maybe (Modifier Inlines, [Inline])
forall a. Maybe a
Nothing
ViewL Inline
_ -> Maybe (Modifier Inlines, Inlines)
forall a. Maybe a
Nothing
inlinesL :: Inlines -> (Inlines, Inlines)
inlinesL :: Inlines -> (Inlines, Inlines)
inlinesL Inlines
ils = case Seq Inline -> ViewL Inline
forall a. Seq a -> ViewL a
viewl (Seq Inline -> ViewL Inline) -> Seq Inline -> ViewL Inline
forall a b. (a -> b) -> a -> b
$ Inlines -> Seq Inline
forall a. Many a -> Seq a
unMany Inlines
ils of
(Inline
s :< Seq Inline
sq) -> (Inline -> Inlines
forall a. a -> Many a
B.singleton Inline
s, Seq Inline -> Inlines
forall a. Seq a -> Many a
Many Seq Inline
sq)
ViewL Inline
_ -> (Inlines
forall a. Monoid a => a
mempty, Inlines
ils)
inlinesR :: Inlines -> (Inlines, Inlines)
inlinesR :: Inlines -> (Inlines, Inlines)
inlinesR Inlines
ils = case Seq Inline -> ViewR Inline
forall a. Seq a -> ViewR a
viewr (Seq Inline -> ViewR Inline) -> Seq Inline -> ViewR Inline
forall a b. (a -> b) -> a -> b
$ Inlines -> Seq Inline
forall a. Many a -> Seq a
unMany Inlines
ils of
(Seq Inline
sq :> Inline
s) -> (Seq Inline -> Inlines
forall a. Seq a -> Many a
Many Seq Inline
sq, Inline -> Inlines
forall a. a -> Many a
B.singleton Inline
s)
ViewR Inline
_ -> (Inlines
ils, Inlines
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' Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines -> Inlines -> Inlines
combineSingletonInlines Inlines
x' Inlines
y' Inlines -> Inlines -> Inlines
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 [Modifier Inlines] -> [Modifier Inlines] -> [Modifier Inlines]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Modifier Inlines]
yfs
x_remaining :: [Modifier Inlines]
x_remaining = [Modifier Inlines]
xfs [Modifier Inlines] -> [Modifier Inlines] -> [Modifier Inlines]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Modifier Inlines]
shared
y_remaining :: [Modifier Inlines]
y_remaining = [Modifier Inlines]
yfs [Modifier Inlines] -> [Modifier Inlines] -> [Modifier Inlines]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Modifier Inlines]
shared
x_rem_attr :: [Modifier Inlines]
x_rem_attr = (Modifier Inlines -> Bool)
-> [Modifier Inlines] -> [Modifier Inlines]
forall a. (a -> Bool) -> [a] -> [a]
filter Modifier Inlines -> Bool
forall a. Modifier a -> Bool
isAttrModifier [Modifier Inlines]
x_remaining
y_rem_attr :: [Modifier Inlines]
y_rem_attr = (Modifier Inlines -> Bool)
-> [Modifier Inlines] -> [Modifier Inlines]
forall a. (a -> Bool) -> [a] -> [a]
filter Modifier Inlines -> Bool
forall a. Modifier a -> Bool
isAttrModifier [Modifier Inlines]
y_remaining
in
case [Modifier Inlines] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Modifier Inlines]
shared of
Bool
True | Inlines -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Inlines
xs Bool -> Bool -> Bool
&& Inlines -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Inlines
ys ->
[Modifier Inlines] -> Inlines -> Inlines
stackInlines ([Modifier Inlines]
x_rem_attr [Modifier Inlines] -> [Modifier Inlines] -> [Modifier Inlines]
forall a. Semigroup a => a -> a -> a
<> [Modifier Inlines]
y_rem_attr) Inlines
forall a. Monoid a => a
mempty
| Inlines -> Bool
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 Inlines
forall a. Monoid a => a
mempty Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
sp Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
y'
| Inlines -> Bool
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' Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
sp Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> [Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
y_rem_attr Inlines
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' Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
xsp Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
ysp Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
y'
Bool
False -> [Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
shared (Inlines -> Inlines) -> Inlines -> Inlines
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'' <- Seq Block -> ViewR Block
forall a. Seq a -> ViewR a
viewr (Blocks -> Seq Block
forall a. Many a -> Seq a
unMany Blocks
bs)
, BlockQuote [Block]
cs'' :< Seq Block
cs' <- Seq Block -> ViewL Block
forall a. Seq a -> ViewL a
viewl (Blocks -> Seq Block
forall a. Many a -> Seq a
unMany Blocks
cs) =
Seq Block -> Blocks
forall a. Seq a -> Many a
Many (Seq Block -> Blocks) -> Seq Block -> Blocks
forall a b. (a -> b) -> a -> b
$ (Seq Block
bs' Seq Block -> Block -> Seq Block
forall a. Seq a -> a -> Seq a
|> [Block] -> Block
BlockQuote ([Block]
bs'' [Block] -> [Block] -> [Block]
forall a. Semigroup a => a -> a -> a
<> [Block]
cs'')) Seq Block -> Seq Block -> Seq Block
forall a. Seq a -> Seq a -> Seq a
>< Seq Block
cs'
| Seq Block
bs' :> CodeBlock Attr
attr Text
codeStr <- Seq Block -> ViewR Block
forall a. Seq a -> ViewR a
viewr (Blocks -> Seq Block
forall a. Many a -> Seq a
unMany Blocks
bs)
, CodeBlock Attr
attr' Text
codeStr' :< Seq Block
cs' <- Seq Block -> ViewL Block
forall a. Seq a -> ViewL a
viewl (Blocks -> Seq Block
forall a. Many a -> Seq a
unMany Blocks
cs)
, Attr
attr Attr -> Attr -> Bool
forall a. Eq a => a -> a -> Bool
== Attr
attr' =
Seq Block -> Blocks
forall a. Seq a -> Many a
Many (Seq Block -> Blocks) -> Seq Block -> Blocks
forall a b. (a -> b) -> a -> b
$ (Seq Block
bs' Seq Block -> Block -> Seq Block
forall a. Seq a -> a -> Seq a
|> Attr -> Text -> Block
CodeBlock Attr
attr (Text
codeStr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
codeStr')) Seq Block -> Seq Block -> Seq Block
forall a. Seq a -> Seq a -> Seq a
>< Seq Block
cs'
combineBlocks Blocks
bs Blocks
cs = Blocks
bs Blocks -> Blocks -> Blocks
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 a
forall a. Monoid a => a
mempty a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a
g a
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 a
forall a. Monoid a => a
mempty a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Attr -> a -> a
g Attr
attr' a
forall a. Monoid a => a
mempty
Modifier a
_ == Modifier a
_ = Bool
False
isAttrModifier :: Modifier a -> Bool
isAttrModifier :: 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' Inlines
forall a. Monoid a => a
mempty
where xs' :: Inlines
xs' = (Inlines -> Inlines -> Inlines) -> Inlines -> [Inlines] -> Inlines
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Inlines -> Inlines -> Inlines
combineInlines Inlines
forall a. Monoid a => a
mempty [Inlines]
xs
smushBlocks :: [Blocks] -> Blocks
smushBlocks :: [Blocks] -> Blocks
smushBlocks [Blocks]
xs = (Blocks -> Blocks -> Blocks) -> Blocks -> [Blocks] -> Blocks
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Blocks -> Blocks -> Blocks
combineBlocks Blocks
forall a. Monoid a => a
mempty [Blocks]
xs