1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances,
PatternGuards #-}
module Text.Pandoc.Readers.Docx.Reducible ( concatReduce
, (<+>)
)
where
import Text.Pandoc.Builder
import Data.List
import Data.Sequence (ViewR(..), ViewL(..), viewl, viewr)
import qualified Data.Sequence as Seq (null)
data Modifier a = Modifier (a -> a)
| AttrModifier (Attr -> a -> a) Attr
| NullModifier
class (Eq a) => Modifiable a where
modifier :: a -> Modifier a
innards :: a -> a
getL :: a -> (a, a)
getR :: a -> (a, a)
spaceOut :: a -> (a, a, a)
spaceOutL :: (Monoid a, Modifiable a) => a -> (a, a)
spaceOutL ms = (l, stack fs (m' <> r))
where (l, m, r) = spaceOut ms
(fs, m') = unstack m
spaceOutR :: (Monoid a, Modifiable a) => a -> (a, a)
spaceOutR ms = (stack fs (l <> m'), r)
where (l, m, r) = spaceOut ms
(fs, m') = unstack m
instance (Monoid a, Show a) => Show (Modifier a) where
show (Modifier f) = show $ f mempty
show (AttrModifier f attr) = show $ f attr mempty
show (NullModifier) = "NullModifier"
instance (Monoid a, Eq a) => Eq (Modifier a) where
(Modifier f) == (Modifier g) = (f mempty == g mempty)
(AttrModifier f attr) == (AttrModifier g attr') = (f attr mempty == g attr' mempty)
(NullModifier) == (NullModifier) = True
_ == _ = False
instance Modifiable Inlines where
modifier ils = case viewl (unMany ils) of
(x :< xs) | Seq.null xs -> case x of
(Emph _) -> Modifier emph
(Strong _) -> Modifier strong
(SmallCaps _) -> Modifier smallcaps
(Strikeout _) -> Modifier strikeout
(Superscript _) -> Modifier superscript
(Subscript _) -> Modifier subscript
(Span attr _) -> AttrModifier spanWith attr
_ -> NullModifier
_ -> NullModifier
innards ils = case viewl (unMany ils) of
(x :< xs) | Seq.null xs -> case x of
(Emph lst) -> fromList lst
(Strong lst) -> fromList lst
(SmallCaps lst) -> fromList lst
(Strikeout lst) -> fromList lst
(Superscript lst) -> fromList lst
(Subscript lst) -> fromList lst
(Span _ lst) -> fromList lst
_ -> ils
_ -> ils
getL ils = case viewl $ unMany ils of
(s :< sq) -> (singleton s, Many sq)
_ -> (mempty, ils)
getR ils = case viewr $ unMany ils of
(sq :> s) -> (Many sq, singleton s)
_ -> (ils, mempty)
spaceOut ils =
let (fs, ils') = unstack ils
contents = unMany ils'
left = case viewl contents of
(Space :< _) -> space
_ -> mempty
right = case viewr contents of
(_ :> Space) -> space
_ -> mempty in
(left, (stack fs $ trimInlines .Many $ contents), right)
instance Modifiable Blocks where
modifier blks = case viewl (unMany blks) of
(x :< xs) | Seq.null xs -> case x of
(BlockQuote _) -> Modifier blockQuote
-- (Div attr _) -> AttrModifier divWith attr
_ -> NullModifier
_ -> NullModifier
innards blks = case viewl (unMany blks) of
(x :< xs) | Seq.null xs -> case x of
(BlockQuote lst) -> fromList lst
-- (Div attr lst) -> fromList lst
_ -> blks
_ -> blks
spaceOut blks = (mempty, blks, mempty)
getL ils = case viewl $ unMany ils of
(s :< sq) -> (singleton s, Many sq)
_ -> (mempty, ils)
getR ils = case viewr $ unMany ils of
(sq :> s) -> (Many sq, singleton s)
_ -> (ils, mempty)
unstack :: (Modifiable a) => a -> ([Modifier a], a)
unstack ms = case modifier ms of
NullModifier -> ([], ms)
_ -> (f : fs, ms') where
f = modifier ms
(fs, ms') = unstack $ innards ms
stack :: (Monoid a, Modifiable a) => [Modifier a] -> a -> a
stack [] ms = ms
stack (NullModifier : fs) ms = stack fs ms
stack ((Modifier f) : fs) ms =
if isEmpty ms
then stack fs ms
else f $ stack fs ms
stack ((AttrModifier f attr) : fs) ms = f attr $ stack fs ms
isEmpty :: (Monoid a, Eq a) => a -> Bool
isEmpty x = x == mempty
combine :: (Monoid a, Modifiable a, Eq a) => a -> a -> a
combine x y =
let (xs', x') = getR x
(y', ys') = getL y
in
xs' <> (combineSingleton x' y') <> ys'
isAttrModifier :: Modifier a -> Bool
isAttrModifier (AttrModifier _ _) = True
isAttrModifier _ = False
combineSingleton :: (Monoid a, Modifiable a, Eq a) => a -> a -> a
combineSingleton x y =
let (xfs, xs) = unstack x
(yfs, ys) = unstack y
shared = xfs `intersect` yfs
x_remaining = xfs \\ shared
y_remaining = yfs \\ shared
x_rem_attr = filter isAttrModifier x_remaining
y_rem_attr = filter isAttrModifier y_remaining
in
case null shared of
True | isEmpty xs && isEmpty ys ->
stack (x_rem_attr ++ y_rem_attr) mempty
| isEmpty xs ->
let (sp, y') = spaceOutL y in
(stack x_rem_attr mempty) <> sp <> y'
| isEmpty ys ->
let (x', sp) = spaceOutR x in
x' <> sp <> (stack y_rem_attr mempty)
| otherwise ->
let (x', xsp) = spaceOutR x
(ysp, y') = spaceOutL y
in
x' <> xsp <> ysp <> y'
False -> stack shared $
combine
(stack x_remaining xs)
(stack y_remaining ys)
(<+>) :: (Monoid a, Modifiable a, Eq a) => a -> a -> a
x <+> y = combine x y
concatReduce :: (Monoid a, Modifiable a) => [a] -> a
concatReduce xs = foldl combine mempty xs
|
