{-# 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 ms :: 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 (l :: Inlines
l, (fs :: [Modifier Inlines]
fs, m' :: Inlines
m'), r :: Inlines
r) = Inlines -> (Inlines, ([Modifier Inlines], Inlines), Inlines)
spaceOutInlines Inlines
ms
spaceOutInlinesR :: Inlines -> (Inlines, Inlines)
spaceOutInlinesR :: Inlines -> (Inlines, Inlines)
spaceOutInlinesR ms :: 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 (l :: Inlines
l, (fs :: [Modifier Inlines]
fs, m' :: Inlines
m'), r :: 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 ils :: Inlines
ils =
let (fs :: [Modifier Inlines]
fs, ils' :: Inlines
ils') = Inlines -> ([Modifier Inlines], Inlines)
unstackInlines Inlines
ils
(left :: Seq Inline
left, (right :: Seq Inline
right, contents' :: 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 Space = Bool
True
isSpace SoftBreak = Bool
True
isSpace _ = Bool
False
stackInlines :: [Modifier Inlines] -> Inlines -> Inlines
stackInlines :: [Modifier Inlines] -> Inlines -> Inlines
stackInlines [] ms :: Inlines
ms = Inlines
ms
stackInlines (Modifier f :: Inlines -> Inlines
f : fs :: [Modifier Inlines]
fs) ms :: 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 f :: Attr -> Inlines -> Inlines
f attr :: Attr
attr : fs :: [Modifier Inlines]
fs) ms :: 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 ms :: Inlines
ms = case Inlines -> Maybe (Modifier Inlines, Inlines)
ilModifierAndInnards Inlines
ms of
Nothing -> ([], Inlines
ms)
Just (f :: Modifier Inlines
f, inner :: 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 ils :: 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
x :: Inline
x :< xs :: 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 lst :: [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 lst :: [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 lst :: [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 lst :: [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 lst :: [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 lst :: [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 lst :: [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
attr lst :: [Inline]
lst tgt :: 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
attr lst :: [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)
_ -> Maybe (Modifier Inlines, [Inline])
forall a. Maybe a
Nothing
_ -> Maybe (Modifier Inlines, Inlines)
forall a. Maybe a
Nothing
inlinesL :: Inlines -> (Inlines, Inlines)
inlinesL :: Inlines -> (Inlines, Inlines)
inlinesL ils :: 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
(s :: Inline
s :< sq :: 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)
_ -> (Inlines
forall a. Monoid a => a
mempty, Inlines
ils)
inlinesR :: Inlines -> (Inlines, Inlines)
inlinesR :: Inlines -> (Inlines, Inlines)
inlinesR ils :: 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
(sq :: Seq Inline
sq :> s :: 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)
_ -> (Inlines
ils, Inlines
forall a. Monoid a => a
mempty)
combineInlines :: Inlines -> Inlines -> Inlines
combineInlines :: Inlines -> Inlines -> Inlines
combineInlines x :: Inlines
x y :: Inlines
y =
let (xs' :: Inlines
xs', x' :: Inlines
x') = Inlines -> (Inlines, Inlines)
inlinesR Inlines
x
(y' :: Inlines
y', ys' :: 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 x :: Inlines
x y :: Inlines
y =
let (xfs :: [Modifier Inlines]
xfs, xs :: Inlines
xs) = Inlines -> ([Modifier Inlines], Inlines)
unstackInlines Inlines
x
(yfs :: [Modifier Inlines]
yfs, ys :: 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
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 (sp :: Inlines
sp, y' :: 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 (x' :: Inlines
x', sp :: 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 (x' :: Inlines
x', xsp :: Inlines
xsp) = Inlines -> (Inlines, Inlines)
spaceOutInlinesR Inlines
x
(ysp :: Inlines
ysp, y' :: 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'
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 bs :: Blocks
bs cs :: Blocks
cs
| bs' :: Seq Block
bs' :> BlockQuote bs'' :: [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 cs'' :: [Block]
cs'' :< 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'
| bs' :: Seq Block
bs' :> CodeBlock attr :: Attr
attr codeStr :: 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
attr' codeStr' :: Text
codeStr' :< 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)
, 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
<> "\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 bs :: Blocks
bs cs :: 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 f :: a -> a
f) == :: Modifier a -> Modifier a -> Bool
== (Modifier g :: 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 f :: Attr -> a -> a
f attr :: Attr
attr) == (AttrModifier g :: Attr -> a -> a
g attr' :: 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
_ == _ = Bool
False
isAttrModifier :: Modifier a -> Bool
isAttrModifier :: Modifier a -> Bool
isAttrModifier (AttrModifier _ _) = Bool
True
isAttrModifier _ = Bool
False
smushInlines :: [Inlines] -> Inlines
smushInlines :: [Inlines] -> Inlines
smushInlines xs :: [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 xs :: [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