{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.Readers.Docx.Combine ( smushInlines
, smushBlocks
)
where
import Data.List
import Data.Sequence (ViewL (..), ViewR (..), viewl, viewr, (><), (|>))
import qualified Data.Sequence as Seq (null)
import Text.Pandoc.Builder
data Modifier a = Modifier (a -> a)
| AttrModifier (Attr -> a -> a) Attr
| NullModifier
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, Inlines
m, Inlines
r) = Inlines -> (Inlines, Inlines, Inlines)
spaceOutInlines Inlines
ms
([Modifier Inlines]
fs, Inlines
m') = Inlines -> ([Modifier Inlines], Inlines)
unstackInlines Inlines
m
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, Inlines
m, Inlines
r) = Inlines -> (Inlines, Inlines, Inlines)
spaceOutInlines Inlines
ms
([Modifier Inlines]
fs, Inlines
m') = Inlines -> ([Modifier Inlines], Inlines)
unstackInlines Inlines
m
spaceOutInlines :: Inlines -> (Inlines, Inlines, Inlines)
spaceOutInlines :: Inlines -> (Inlines, Inlines, Inlines)
spaceOutInlines Inlines
ils =
let ([Modifier Inlines]
fs, Inlines
ils') = Inlines -> ([Modifier Inlines], Inlines)
unstackInlines Inlines
ils
contents :: Seq Inline
contents = Inlines -> Seq Inline
forall a. Many a -> Seq a
unMany Inlines
ils'
left :: Inlines
left = case Seq Inline -> ViewL Inline
forall a. Seq a -> ViewL a
viewl Seq Inline
contents of
(Inline
Space :< Seq Inline
_) -> Inlines
space
ViewL Inline
_ -> Inlines
forall a. Monoid a => a
mempty
right :: Inlines
right = case Seq Inline -> ViewR Inline
forall a. Seq a -> ViewR a
viewr Seq Inline
contents of
(Seq Inline
_ :> Inline
Space) -> Inlines
space
ViewR Inline
_ -> Inlines
forall a. Monoid a => a
mempty in
(Inlines
left, [Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
fs (Inlines -> Inlines) -> Inlines -> Inlines
forall a b. (a -> b) -> a -> b
$ Inlines -> Inlines
trimInlines (Inlines -> Inlines)
-> (Seq Inline -> Inlines) -> Seq Inline -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Inline -> Inlines
forall a. Seq a -> Many a
Many (Seq Inline -> Inlines) -> Seq Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Seq Inline
contents, Inlines
right)
stackInlines :: [Modifier Inlines] -> Inlines -> Inlines
stackInlines :: [Modifier Inlines] -> Inlines -> Inlines
stackInlines [] Inlines
ms = Inlines
ms
stackInlines (Modifier Inlines
NullModifier : [Modifier Inlines]
fs) Inlines
ms = [Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
fs Inlines
ms
stackInlines (Modifier Inlines -> Inlines
f : [Modifier Inlines]
fs) Inlines
ms =
if Inlines -> Bool
forall a. (Monoid a, Eq a) => a -> Bool
isEmpty 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 -> Modifier Inlines
ilModifier Inlines
ms of
Modifier Inlines
NullModifier -> ([], Inlines
ms)
Modifier Inlines
_ -> (Modifier Inlines
f Modifier Inlines -> [Modifier Inlines] -> [Modifier Inlines]
forall a. a -> [a] -> [a]
: [Modifier Inlines]
fs, Inlines
ms') where
f :: Modifier Inlines
f = Inlines -> Modifier Inlines
ilModifier Inlines
ms
([Modifier Inlines]
fs, Inlines
ms') = Inlines -> ([Modifier Inlines], Inlines)
unstackInlines (Inlines -> ([Modifier Inlines], Inlines))
-> Inlines -> ([Modifier Inlines], Inlines)
forall a b. (a -> b) -> a -> b
$ Inlines -> Inlines
ilInnards Inlines
ms
ilModifier :: Inlines -> Modifier Inlines
ilModifier :: Inlines -> Modifier Inlines
ilModifier Inlines
ils = case Seq Inline -> ViewL Inline
forall a. Seq a -> ViewL a
viewl (Inlines -> Seq Inline
forall a. Many a -> Seq a
unMany Inlines
ils) of
(Inline
x :< Seq Inline
xs) | Seq Inline -> Bool
forall a. Seq a -> Bool
Seq.null Seq Inline
xs -> case Inline
x of
(Emph [Inline]
_) -> (Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
emph
(Strong [Inline]
_) -> (Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
strong
(SmallCaps [Inline]
_) -> (Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
smallcaps
(Strikeout [Inline]
_) -> (Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
strikeout
(Superscript [Inline]
_) -> (Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
superscript
(Subscript [Inline]
_) -> (Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
subscript
(Link Attr
attr [Inline]
_ Target
tgt) -> (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
$ Attr -> Text -> Text -> Inlines -> Inlines
linkWith Attr
attr (Target -> Text
forall a b. (a, b) -> a
fst Target
tgt) (Target -> Text
forall a b. (a, b) -> b
snd Target
tgt)
(Span Attr
attr [Inline]
_) -> (Attr -> Inlines -> Inlines) -> Attr -> Modifier Inlines
forall a. (Attr -> a -> a) -> Attr -> Modifier a
AttrModifier Attr -> Inlines -> Inlines
spanWith Attr
attr
Inline
_ -> Modifier Inlines
forall a. Modifier a
NullModifier
ViewL Inline
_ -> Modifier Inlines
forall a. Modifier a
NullModifier
ilInnards :: Inlines -> Inlines
ilInnards :: Inlines -> Inlines
ilInnards Inlines
ils = case Seq Inline -> ViewL Inline
forall a. Seq a -> ViewL a
viewl (Inlines -> Seq Inline
forall a. Many a -> Seq a
unMany Inlines
ils) of
(Inline
x :< Seq Inline
xs) | Seq Inline -> Bool
forall a. Seq a -> Bool
Seq.null Seq Inline
xs -> case Inline
x of
(Emph [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(Strong [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(SmallCaps [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(Strikeout [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(Superscript [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(Subscript [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(Link Attr
_ [Inline]
lst Target
_) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(Span Attr
_ [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
Inline
_ -> Inlines
ils
ViewL Inline
_ -> Inlines
ils
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
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
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 a. (Monoid a, Eq a) => a -> Bool
isEmpty Inlines
xs Bool -> Bool -> Bool
&& Inlines -> Bool
forall a. (Monoid a, Eq a) => a -> Bool
isEmpty Inlines
ys ->
[Modifier Inlines] -> Inlines -> Inlines
stackInlines ([Modifier Inlines]
x_rem_attr [Modifier Inlines] -> [Modifier Inlines] -> [Modifier Inlines]
forall a. [a] -> [a] -> [a]
++ [Modifier Inlines]
y_rem_attr) Inlines
forall a. Monoid a => a
mempty
| Inlines -> Bool
forall a. (Monoid a, Eq a) => a -> Bool
isEmpty 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 a. (Monoid a, Eq a) => a -> Bool
isEmpty 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
NullModifier == Modifier a
NullModifier = Bool
True
Modifier a
_ == Modifier a
_ = Bool
False
isEmpty :: (Monoid a, Eq a) => a -> Bool
isEmpty :: a -> Bool
isEmpty a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Monoid a => a
mempty
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