{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.Readers.Docx.Combine ( smushInlines
, smushBlocks
)
where
import Prelude
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 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, m :: Inlines
m, r :: Inlines
r) = Inlines -> (Inlines, Inlines, Inlines)
spaceOutInlines Inlines
ms
(fs :: [Modifier Inlines]
fs, m' :: Inlines
m') = Inlines -> ([Modifier Inlines], Inlines)
unstackInlines Inlines
m
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, m :: Inlines
m, r :: Inlines
r) = Inlines -> (Inlines, Inlines, Inlines)
spaceOutInlines Inlines
ms
(fs :: [Modifier Inlines]
fs, m' :: Inlines
m') = Inlines -> ([Modifier Inlines], Inlines)
unstackInlines Inlines
m
spaceOutInlines :: Inlines -> (Inlines, Inlines, Inlines)
spaceOutInlines :: Inlines -> (Inlines, Inlines, Inlines)
spaceOutInlines ils :: Inlines
ils =
let (fs :: [Modifier Inlines]
fs, ils' :: 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
(Space :< _) -> Inlines
space
_ -> 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
(_ :> Space) -> Inlines
space
_ -> 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 [] ms :: Inlines
ms = Inlines
ms
stackInlines (NullModifier : fs :: [Modifier Inlines]
fs) ms :: Inlines
ms = [Modifier Inlines] -> Inlines -> Inlines
stackInlines [Modifier Inlines]
fs Inlines
ms
stackInlines (Modifier f :: Inlines -> Inlines
f : fs :: [Modifier Inlines]
fs) ms :: 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 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 -> Modifier Inlines
ilModifier Inlines
ms of
NullModifier -> ([], Inlines
ms)
_ -> (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
(fs :: [Modifier Inlines]
fs, ms' :: 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 ils :: 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
(x :: Inline
x :< xs :: Seq Inline
xs) | Seq Inline -> Bool
forall a. Seq a -> Bool
Seq.null Seq Inline
xs -> case Inline
x of
(Emph _) -> (Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
emph
(Strong _) -> (Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
strong
(SmallCaps _) -> (Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
smallcaps
(Strikeout _) -> (Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
strikeout
(Superscript _) -> (Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
superscript
(Subscript _) -> (Inlines -> Inlines) -> Modifier Inlines
forall a. (a -> a) -> Modifier a
Modifier Inlines -> Inlines
subscript
(Link attr :: Attr
attr _ tgt :: 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
attr _) -> (Attr -> Inlines -> Inlines) -> Attr -> Modifier Inlines
forall a. (Attr -> a -> a) -> Attr -> Modifier a
AttrModifier Attr -> Inlines -> Inlines
spanWith Attr
attr
_ -> Modifier Inlines
forall a. Modifier a
NullModifier
_ -> Modifier Inlines
forall a. Modifier a
NullModifier
ilInnards :: Inlines -> Inlines
ilInnards :: Inlines -> Inlines
ilInnards ils :: 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
(x :: Inline
x :< xs :: Seq Inline
xs) | Seq Inline -> Bool
forall a. Seq a -> Bool
Seq.null Seq Inline
xs -> case Inline
x of
(Emph lst :: [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(Strong lst :: [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(SmallCaps lst :: [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(Strikeout lst :: [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(Superscript lst :: [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(Subscript lst :: [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(Link _ lst :: [Inline]
lst _) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
(Span _ lst :: [Inline]
lst) -> [Inline] -> Inlines
forall a. [a] -> Many a
fromList [Inline]
lst
_ -> Inlines
ils
_ -> Inlines
ils
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
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
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 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 (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 a. (Monoid a, Eq a) => a -> Bool
isEmpty 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
NullModifier == NullModifier = Bool
True
_ == _ = Bool
False
isEmpty :: (Monoid a, Eq a) => a -> Bool
isEmpty :: a -> Bool
isEmpty x :: 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 _ _) = 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