aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Readers/Docx/Reducible.hs
blob: c93b401198a390e7d3f1ba15c994ec7c40e0fdc8 (plain)
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