git.iko.soy/typeable/pandoc
on master help sign in
Merge pull request #1366 from jkr/reducible3
ac67560John MacFarlane
pandoc.cabal+1
compare with master
unifiedsplit
@@ -327,6 +327,7 @@ Library
327 Text.Pandoc.SelfContained,
327 Text.Pandoc.SelfContained,
328 Text.Pandoc.Process
328 Text.Pandoc.Process
329 Other-Modules: Text.Pandoc.Readers.Docx.Lists,
329 Other-Modules: Text.Pandoc.Readers.Docx.Lists,
330+ Text.Pandoc.Readers.Docx.Reducible,
330 Text.Pandoc.Readers.Docx.Parse,
331 Text.Pandoc.Readers.Docx.Parse,
331 Text.Pandoc.Writers.Shared,
332 Text.Pandoc.Writers.Shared,
332 Text.Pandoc.Asciify,
333 Text.Pandoc.Asciify,
src/Text/Pandoc/Readers/Docx.hs+111−273
@@ -79,8 +79,10 @@ import Text.Pandoc.Builder (text, toList)
79import Text.Pandoc.Generic (bottomUp)
79import Text.Pandoc.Generic (bottomUp)
80import Text.Pandoc.MIME (getMimeType)
80import Text.Pandoc.MIME (getMimeType)
81import Text.Pandoc.UTF8 (toString)
81import Text.Pandoc.UTF8 (toString)
82+import Text.Pandoc.Walk
82import Text.Pandoc.Readers.Docx.Parse
83import Text.Pandoc.Readers.Docx.Parse
83import Text.Pandoc.Readers.Docx.Lists
84import Text.Pandoc.Readers.Docx.Lists
85+import Text.Pandoc.Readers.Docx.Reducible
84import Data.Maybe (mapMaybe, isJust, fromJust)
86import Data.Maybe (mapMaybe, isJust, fromJust)
85import Data.List (delete, isPrefixOf, (\\), intersect)
87import Data.List (delete, isPrefixOf, (\\), intersect)
86import qualified Data.ByteString as BS
88import qualified Data.ByteString as BS
@@ -96,28 +98,65 @@ readDocx opts bytes =
96 Just docx -> Pandoc nullMeta (docxToBlocks opts docx)
98 Just docx -> Pandoc nullMeta (docxToBlocks opts docx)
97 Nothing -> error $ "couldn't parse docx file"
99 Nothing -> error $ "couldn't parse docx file"
98
100
99−runStyleToSpanAttr :: RunStyle -> (String, [String], [(String, String)])
101+spansToKeep :: [String]
100−runStyleToSpanAttr rPr = ("",
102+spansToKeep = ["list-item", "Definition", "DefinitionTerm"] ++ codeSpans
103+
104+
105+-- This is empty, but we put it in for future-proofing.
106+divsToKeep :: [String]
107+divsToKeep = []
108+
109+runStyleToContainers :: RunStyle -> [Container Inline]
110+runStyleToContainers rPr =
101− mapMaybe id [
111+ let formatters = mapMaybe id
102− if isBold rPr then (Just "strong") else Nothing,
112+ [ if isBold rPr then (Just Strong) else Nothing
103− if isItalic rPr then (Just "emph") else Nothing,
113+ , if isItalic rPr then (Just Emph) else Nothing
104− if isSmallCaps rPr then (Just "smallcaps") else Nothing,
114+ , if isSmallCaps rPr then (Just SmallCaps) else Nothing
105− if isStrike rPr then (Just "strike") else Nothing,
115+ , if isStrike rPr then (Just Strikeout) else Nothing
106− if isSuperScript rPr then (Just "superscript") else Nothing,
116+ , if isSuperScript rPr then (Just Superscript) else Nothing
107− if isSubScript rPr then (Just "subscript") else Nothing,
117+ , if isSubScript rPr then (Just Subscript) else Nothing
108− rStyle rPr],
118+ , rStyle rPr >>=
119+ (\s -> if s `elem` spansToKeep then Just s else Nothing) >>=
120+ (\s -> Just $ Span ("", [s], []))
109− case underline rPr of
121+ , underline rPr >>= (\f -> Just $ Span ("", [], [("underline", f)]))
110− Just fmt -> [("underline", fmt)]
122+ ]
111− _ -> []
123+ in
112− )
124+ map Container formatters
113−
125+
114−parStyleToDivAttr :: ParagraphStyle -> (String, [String], [(String, String)])
126+
115−parStyleToDivAttr pPr = ("",
127+divAttrToContainers :: [String] -> [(String, String)] -> [Container Block]
128+divAttrToContainers [] [] = []
129+divAttrToContainers (c:cs) _ | isJust (isHeaderClass c) =
130+ let n = fromJust (isHeaderClass c)
131+ in
132+ [(Container $ \blks ->
133+ Header n ("", delete ("Heading" ++ show n) cs, []) (blksToInlines blks))]
134+divAttrToContainers (c:_) _ | c `elem` codeDivs =
135+ [Container $ \blks -> CodeBlock ("", [], []) (concatMap blkToCode blks)]
136+divAttrToContainers (c:cs) kvs | c `elem` listParagraphDivs =
137+ let kvs' = filter (\(k,_) -> k /= "indent") kvs
138+ in
139+ (Container $ Div ("", [c], [])) : (divAttrToContainers cs kvs')
140+divAttrToContainers (c:cs) kvs | c `elem` blockQuoteDivs =
141+ (Container BlockQuote) : (divAttrToContainers (cs \\ blockQuoteDivs) kvs)
142+divAttrToContainers (c:cs) kvs | c `elem` divsToKeep =
143+ (Container $ Div ("", [c], [])) : (divAttrToContainers cs kvs)
144+divAttrToContainers (_:cs) kvs = divAttrToContainers cs kvs
145+divAttrToContainers [] (kv:kvs) | fst kv == "indent" =
146+ (Container BlockQuote) : divAttrToContainers [] kvs
147+divAttrToContainers [] (_:kvs) =
148+ divAttrToContainers [] kvs
149+
150+
151+parStyleToContainers :: ParagraphStyle -> [Container Block]
152+parStyleToContainers pPr =
116− pStyle pPr,
153+ let classes = pStyle pPr
117− case indent pPr of
154+ kvs = case indent pPr of
118− Just n -> [("indent", (show n))]
155+ Just n -> [("indent", show n)]
119− Nothing -> []
156+ Nothing -> []
120− )
157+ in
158+ divAttrToContainers classes kvs
159+
121
160
122strToInlines :: String -> [Inline]
161strToInlines :: String -> [Inline]
123strToInlines = toList . text
162strToInlines = toList . text
@@ -144,103 +183,42 @@ runElemToString (Tab) = ['\t']
144runElemsToString :: [RunElem] -> String
183runElemsToString :: [RunElem] -> String
145runElemsToString = concatMap runElemToString
184runElemsToString = concatMap runElemToString
146
185
147−--- We use this instead of the more general
186+
148−--- Text.Pandoc.Shared.normalize for reasons of efficiency. For
187+inlineCodeContainer :: Container Inline -> Bool
149−--- whatever reason, `normalize` makes a run take almost twice as
188+inlineCodeContainer (Container f) = case f [] of
150−--- long. (It does more, but this does what we need)
189+ Span (_, classes, _) _ -> (not . null) (classes `intersect` codeSpans)
151−inlineNormalize :: [Inline] -> [Inline]
190+ _ -> False
152−inlineNormalize [] = []
191+inlineCodeContainer _ = False
153−inlineNormalize (Str "" : ils) = inlineNormalize ils
192+
154−inlineNormalize ((Str s) : (Str s') : l) =
193+-- blockCodeContainer :: Container Block -> Bool
155− inlineNormalize (Str (s++s') : l)
194+-- blockCodeContainer (Container f) = case f [] of
156−inlineNormalize ((Emph ils) : (Emph ils') : l) =
195+-- Div (ident, classes, kvs) _ -> (not . null) (classes `intersect` codeDivs)
157− inlineNormalize $ (Emph $ inlineNormalize (ils ++ ils')) : l
196+-- _ -> False
158−inlineNormalize ((Emph ils) : l) =
197+-- blockCodeContainer _ = False
159− Emph (inlineNormalize ils) : (inlineNormalize l)
160−inlineNormalize ((Strong ils) : (Strong ils') : l) =
161− inlineNormalize $ (Strong $ inlineNormalize (ils ++ ils')) : l
162−inlineNormalize ((Strong ils) : l) =
163− Strong (inlineNormalize ils) : (inlineNormalize l)
164−inlineNormalize ((Strikeout ils) : (Strikeout ils') : l) =
165− inlineNormalize $ (Strikeout $ inlineNormalize (ils ++ ils')) : l
166−inlineNormalize ((Strikeout ils) : l) =
167− Strikeout (inlineNormalize ils) : (inlineNormalize l)
168−inlineNormalize ((Superscript ils) : (Superscript ils') : l) =
169− inlineNormalize $ (Superscript $ inlineNormalize (ils ++ ils')) : l
170−inlineNormalize ((Superscript ils) : l) =
171− Superscript (inlineNormalize ils) : (inlineNormalize l)
172−inlineNormalize ((Subscript ils) : (Subscript ils') : l) =
173− inlineNormalize $ (Subscript $ inlineNormalize (ils ++ ils')) : l
174−inlineNormalize ((Subscript ils) : l) =
175− Subscript (inlineNormalize ils) : (inlineNormalize l)
176−inlineNormalize ((Space : Space : l)) =
177− inlineNormalize $ (Space : l)
178−inlineNormalize ((Quoted qt ils) : l) =
179− Quoted qt (inlineNormalize ils) : inlineNormalize l
180−inlineNormalize ((Cite cits ils) : l) =
181− let
182− f :: Citation -> Citation
183− f (Citation s pref suff mode num hash) =
184− Citation s (inlineNormalize pref) (inlineNormalize suff) mode num hash
185− in
186− Cite (map f cits) (inlineNormalize ils) : (inlineNormalize l)
187−inlineNormalize ((Link ils s) : l) =
188− Link (inlineNormalize ils) s : (inlineNormalize l)
189−inlineNormalize ((Image ils s) : l) =
190− Image (inlineNormalize ils) s : (inlineNormalize l)
191−inlineNormalize ((Note blks) : l) =
192− Note (map blockNormalize blks) : (inlineNormalize l)
193−inlineNormalize ((Span attr ils) : l) =
194− Span attr (inlineNormalize ils) : (inlineNormalize l)
195−inlineNormalize (il : l) = il : (inlineNormalize l)
196−
197−stripSpaces :: [Inline] -> [Inline]
198−stripSpaces ils =
199− reverse $ dropWhile (Space ==) $ reverse $ dropWhile (Space ==) ils
200−
201−blockNormalize :: Block -> Block
202−blockNormalize (Plain ils) = Plain $ stripSpaces $ inlineNormalize ils
203−blockNormalize (Para ils) = Para $ stripSpaces $ inlineNormalize ils
204−blockNormalize (Header n attr ils) =
205− Header n attr $ stripSpaces $ inlineNormalize ils
206−blockNormalize (Table ils align width hdr cells) =
207− Table (stripSpaces $ inlineNormalize ils) align width hdr cells
208−blockNormalize (DefinitionList pairs) =
209− DefinitionList $ map (\(ils, blklsts) -> (stripSpaces (inlineNormalize ils), (map (map blockNormalize) blklsts))) pairs
210−blockNormalize (BlockQuote blks) = BlockQuote (map blockNormalize blks)
211−blockNormalize (OrderedList attr blkslst) =
212− OrderedList attr $ map (\blks -> map blockNormalize blks) blkslst
213−blockNormalize (BulletList blkslst) =
214− BulletList $ map (\blks -> map blockNormalize blks) blkslst
215−blockNormalize (Div attr blks) = Div attr (map blockNormalize blks)
216−blockNormalize blk = blk
217
198
218runToInlines :: ReaderOptions -> Docx -> Run -> [Inline]
199runToInlines :: ReaderOptions -> Docx -> Run -> [Inline]
219runToInlines _ _ (Run rs runElems)
200runToInlines _ _ (Run rs runElems)
220− | isJust (rStyle rs) && (fromJust (rStyle rs)) `elem` codeSpans =
201+ | any inlineCodeContainer (runStyleToContainers rs) =
221− case runStyleToSpanAttr rs == ("", [], []) of
222− True -> [Str (runElemsToString runElems)]
223− False -> [Span (runStyleToSpanAttr rs) [Str (runElemsToString runElems)]]
202+ rebuild (runStyleToContainers rs) $ [Str $ runElemsToString runElems]
224− | otherwise = case runStyleToSpanAttr rs == ("", [], []) of
203+ | otherwise =
225− True -> concatMap runElemToInlines runElems
226− False -> [Span (runStyleToSpanAttr rs) (concatMap runElemToInlines runElems)]
204+ rebuild (runStyleToContainers rs) (concatMap runElemToInlines runElems)
227runToInlines opts docx@(Docx _ notes _ _ _ ) (Footnote fnId) =
205runToInlines opts docx@(Docx _ notes _ _ _ ) (Footnote fnId) =
228 case (getFootNote fnId notes) of
206 case (getFootNote fnId notes) of
229 Just bodyParts ->
207 Just bodyParts ->
230− [Note [Div ("", ["footnote"], []) (map (bodyPartToBlock opts docx) bodyParts)]]
208+ [Note (concatMap (bodyPartToBlocks opts docx) bodyParts)]
231 Nothing ->
209 Nothing ->
232− [Note [Div ("", ["footnote"], []) []]]
210+ [Note []]
233runToInlines opts docx@(Docx _ notes _ _ _) (Endnote fnId) =
211runToInlines opts docx@(Docx _ notes _ _ _) (Endnote fnId) =
234 case (getEndNote fnId notes) of
212 case (getEndNote fnId notes) of
235 Just bodyParts ->
213 Just bodyParts ->
236− [Note [Div ("", ["endnote"], []) (map (bodyPartToBlock opts docx) bodyParts)]]
214+ [Note (concatMap (bodyPartToBlocks opts docx) bodyParts)]
237 Nothing ->
215 Nothing ->
238− [Note [Div ("", ["endnote"], []) []]]
216+ [Note []]
239
217
240parPartToInlines :: ReaderOptions -> Docx -> ParPart -> [Inline]
218parPartToInlines :: ReaderOptions -> Docx -> ParPart -> [Inline]
241parPartToInlines opts docx (PlainRun r) = runToInlines opts docx r
219parPartToInlines opts docx (PlainRun r) = runToInlines opts docx r
242−parPartToInlines _ _ (BookMark _ anchor) =
220+parPartToInlines _ _ (BookMark _ anchor) | anchor `elem` dummyAnchors = []
243− [Span (anchor, ["anchor"], []) []]
221+parPartToInlines _ _ (BookMark _ anchor) = [Span (anchor, ["anchor"], []) []]
244parPartToInlines _ (Docx _ _ _ rels _) (Drawing relid) =
222parPartToInlines _ (Docx _ _ _ rels _) (Drawing relid) =
245 case lookupRelationship relid rels of
223 case lookupRelationship relid rels of
246 Just target -> [Image [] (combine "word" target, "")]
224 Just target -> [Image [] (combine "word" target, "")]
@@ -276,7 +254,6 @@ makeHeaderAnchors h@(Header n (_, classes, kvs) ils) =
276 _ -> h
254 _ -> h
277makeHeaderAnchors blk = blk
255makeHeaderAnchors blk = blk
278
256
279−
280parPartsToInlines :: ReaderOptions -> Docx -> [ParPart] -> [Inline]
257parPartsToInlines :: ReaderOptions -> Docx -> [ParPart] -> [Inline]
281parPartsToInlines opts docx parparts =
258parPartsToInlines opts docx parparts =
282 --
259 --
@@ -284,23 +261,32 @@ parPartsToInlines opts docx parparts =
284 -- not mandatory.
261 -- not mandatory.
285 --
262 --
286 (if False -- TODO depend on option
263 (if False -- TODO depend on option
287− then bottomUp (makeImagesSelfContained docx)
264+ then walk (makeImagesSelfContained docx)
288 else id) $
265 else id) $
289− bottomUp spanTrim $
266+ -- bottomUp spanTrim $
290− bottomUp spanCorrect $
267+ -- bottomUp spanCorrect $
291− bottomUp spanReduce $
268+ -- bottomUp spanReduce $
292− concatMap (parPartToInlines opts docx) parparts
269+ reduceList $ concatMap (parPartToInlines opts docx) parparts
293
270
294cellToBlocks :: ReaderOptions -> Docx -> Cell -> [Block]
271cellToBlocks :: ReaderOptions -> Docx -> Cell -> [Block]
295−cellToBlocks opts docx (Cell bps) = map (bodyPartToBlock opts docx) bps
272+cellToBlocks opts docx (Cell bps) = concatMap (bodyPartToBlocks opts docx) bps
296
273
297rowToBlocksList :: ReaderOptions -> Docx -> Row -> [[Block]]
274rowToBlocksList :: ReaderOptions -> Docx -> Row -> [[Block]]
298rowToBlocksList opts docx (Row cells) = map (cellToBlocks opts docx) cells
275rowToBlocksList opts docx (Row cells) = map (cellToBlocks opts docx) cells
299
276
300−bodyPartToBlock :: ReaderOptions -> Docx -> BodyPart -> Block
277+bodyPartToBlocks :: ReaderOptions -> Docx -> BodyPart -> [Block]
301−bodyPartToBlock opts docx (Paragraph pPr parparts) =
278+bodyPartToBlocks opts docx (Paragraph pPr parparts) =
302− Div (parStyleToDivAttr pPr) [Para (parPartsToInlines opts docx parparts)]
279+ case parPartsToInlines opts docx parparts of
280+ [] ->
281+ []
282+ _ ->
283+ let parContents = parPartsToInlines opts docx parparts
284+ trimmedContents = reverse $ dropWhile (Space ==) $ reverse $ dropWhile (Space ==) parContents
285+ in
286+ rebuild
287+ (parStyleToContainers pPr)
288+ [Para trimmedContents]
303−bodyPartToBlock opts docx@(Docx _ _ numbering _ _) (ListItem pPr numId lvl parparts) =
289+bodyPartToBlocks opts docx@(Docx _ _ numbering _ _) (ListItem pPr numId lvl parparts) =
304 let
290 let
305 kvs = case lookupLevel numId lvl numbering of
291 kvs = case lookupLevel numId lvl numbering of
306 Just (_, fmt, txt, Just start) -> [ ("level", lvl)
292 Just (_, fmt, txt, Just start) -> [ ("level", lvl)
@@ -317,12 +303,12 @@ bodyPartToBlock opts docx@(Docx _ _ numbering _ _) (ListItem pPr numId lvl parpa
317 ]
303 ]
318 Nothing -> []
304 Nothing -> []
319 in
305 in
320− Div
306+ [Div
321− ("", ["list-item"], kvs)
307+ ("", ["list-item"], kvs)
322− [bodyPartToBlock opts docx (Paragraph pPr parparts)]
308+ (bodyPartToBlocks opts docx (Paragraph pPr parparts))]
323−bodyPartToBlock _ _ (Tbl _ _ _ []) =
309+bodyPartToBlocks _ _ (Tbl _ _ _ []) =
324− Para []
310+ [Para []]
325−bodyPartToBlock opts docx (Tbl cap _ look (r:rs)) =
311+bodyPartToBlocks opts docx (Tbl cap _ look (r:rs)) =
326 let caption = strToInlines cap
312 let caption = strToInlines cap
327 (hdr, rows) = case firstRowFormatting look of
313 (hdr, rows) = case firstRowFormatting look of
328 True -> (Just r, rs)
314 True -> (Just r, rs)
@@ -344,7 +330,8 @@ bodyPartToBlock opts docx (Tbl cap _ look (r:rs)) =
344 alignments = take size (repeat AlignDefault)
330 alignments = take size (repeat AlignDefault)
345 widths = take size (repeat 0) :: [Double]
331 widths = take size (repeat 0) :: [Double]
346 in
332 in
347− Table caption alignments widths hdrCells cells
333+ [Table caption alignments widths hdrCells cells]
334+
348
335
349makeImagesSelfContained :: Docx -> Inline -> Inline
336makeImagesSelfContained :: Docx -> Inline -> Inline
350makeImagesSelfContained (Docx _ _ _ _ media) i@(Image alt (uri, title)) =
337makeImagesSelfContained (Docx _ _ _ _ media) i@(Image alt (uri, title)) =
@@ -360,127 +347,19 @@ makeImagesSelfContained _ inline = inline
360
347
361bodyToBlocks :: ReaderOptions -> Docx -> Body -> [Block]
348bodyToBlocks :: ReaderOptions -> Docx -> Body -> [Block]
362bodyToBlocks opts docx (Body bps) =
349bodyToBlocks opts docx (Body bps) =
363− bottomUp removeEmptyPars $
364− map blockNormalize $
365− bottomUp spanRemove $
366− bottomUp divRemove $
367 map (makeHeaderAnchors) $
350 map (makeHeaderAnchors) $
368− bottomUp divCorrect $
369− bottomUp divReduce $
370− bottomUp divCorrectPreReduce $
371 bottomUp blocksToDefinitions $
351 bottomUp blocksToDefinitions $
372 blocksToBullets $
352 blocksToBullets $
373− map (bodyPartToBlock opts docx) bps
353+ concatMap (bodyPartToBlocks opts docx) bps
374
354
375docxToBlocks :: ReaderOptions -> Docx -> [Block]
355docxToBlocks :: ReaderOptions -> Docx -> [Block]
376docxToBlocks opts d@(Docx (Document _ body) _ _ _ _) = bodyToBlocks opts d body
356docxToBlocks opts d@(Docx (Document _ body) _ _ _ _) = bodyToBlocks opts d body
377
357
378−spanReduce :: [Inline] -> [Inline]
379−spanReduce [] = []
380−spanReduce ((Span (id1, classes1, kvs1) ils1) : ils)
381− | (id1, classes1, kvs1) == ("", [], []) = ils1 ++ (spanReduce ils)
382−spanReduce (s1@(Span (id1, classes1, kvs1) ils1) :
383− s2@(Span (id2, classes2, kvs2) ils2) :
384− ils) =
385− let classes' = classes1 `intersect` classes2
386− kvs' = kvs1 `intersect` kvs2
387− classes1' = classes1 \\ classes'
388− kvs1' = kvs1 \\ kvs'
389− classes2' = classes2 \\ classes'
390− kvs2' = kvs2 \\ kvs'
391− in
392− case null classes' && null kvs' of
393− True -> s1 : (spanReduce (s2 : ils))
394− False -> let attr' = ("", classes', kvs')
395− attr1' = (id1, classes1', kvs1')
396− attr2' = (id2, classes2', kvs2')
397− in
398− spanReduce (Span attr' [(Span attr1' ils1), (Span attr2' ils2)] :
399− ils)
400−spanReduce (il:ils) = il : (spanReduce ils)
401
358
402ilToCode :: Inline -> String
359ilToCode :: Inline -> String
403ilToCode (Str s) = s
360ilToCode (Str s) = s
404ilToCode _ = ""
361ilToCode _ = ""
405
362
406−spanRemove' :: Inline -> [Inline]
407−spanRemove' s@(Span (ident, classes, _) [])
408− -- "_GoBack" is automatically inserted. We don't want to keep it.
409− | classes == ["anchor"] && not (ident `elem` dummyAnchors) = [s]
410−spanRemove' (Span (_, _, kvs) ils) =
411− case lookup "underline" kvs of
412− Just val -> [Span ("", [], [("underline", val)]) ils]
413− Nothing -> ils
414−spanRemove' il = [il]
415−
416−spanRemove :: [Inline] -> [Inline]
417−spanRemove = concatMap spanRemove'
418−
419−spanTrim' :: Inline -> [Inline]
420−spanTrim' il@(Span _ []) = [il]
421−spanTrim' il@(Span attr (il':[]))
422− | il' == Space = [Span attr [], Space]
423− | otherwise = [il]
424−spanTrim' (Span attr ils)
425− | head ils == Space && last ils == Space =
426− [Space, Span attr (init $ tail ils), Space]
427− | head ils == Space = [Space, Span attr (tail ils)]
428− | last ils == Space = [Span attr (init ils), Space]
429−spanTrim' il = [il]
430−
431−spanTrim :: [Inline] -> [Inline]
432−spanTrim = concatMap spanTrim'
433−
434−spanCorrect' :: Inline -> [Inline]
435−spanCorrect' (Span ("", [], []) ils) = ils
436−spanCorrect' (Span (ident, classes, kvs) ils)
437− | "emph" `elem` classes =
438− [Emph $ spanCorrect' $ Span (ident, (delete "emph" classes), kvs) ils]
439− | "strong" `elem` classes =
440− [Strong $ spanCorrect' $ Span (ident, (delete "strong" classes), kvs) ils]
441− | "smallcaps" `elem` classes =
442− [SmallCaps $ spanCorrect' $ Span (ident, (delete "smallcaps" classes), kvs) ils]
443− | "strike" `elem` classes =
444− [Strikeout $ spanCorrect' $ Span (ident, (delete "strike" classes), kvs) ils]
445− | "superscript" `elem` classes =
446− [Superscript $ spanCorrect' $ Span (ident, (delete "superscript" classes), kvs) ils]
447− | "subscript" `elem` classes =
448− [Subscript $ spanCorrect' $ Span (ident, (delete "subscript" classes), kvs) ils]
449− | (not . null) (codeSpans `intersect` classes) =
450− [Code (ident, (classes \\ codeSpans), kvs) (init $ unlines $ map ilToCode ils)]
451− | otherwise =
452− [Span (ident, classes, kvs) ils]
453−spanCorrect' il = [il]
454−
455−spanCorrect :: [Inline] -> [Inline]
456−spanCorrect = concatMap spanCorrect'
457−
458−removeEmptyPars :: [Block] -> [Block]
459−removeEmptyPars blks = filter (\b -> b /= (Para [])) blks
460−
461−divReduce :: [Block] -> [Block]
462−divReduce [] = []
463−divReduce ((Div (id1, classes1, kvs1) blks1) : blks)
464− | (id1, classes1, kvs1) == ("", [], []) = blks1 ++ (divReduce blks)
465−divReduce (d1@(Div (id1, classes1, kvs1) blks1) :
466− d2@(Div (id2, classes2, kvs2) blks2) :
467− blks) =
468− let classes' = classes1 `intersect` classes2
469− kvs' = kvs1 `intersect` kvs2
470− classes1' = classes1 \\ classes'
471− kvs1' = kvs1 \\ kvs'
472− classes2' = classes2 \\ classes'
473− kvs2' = kvs2 \\ kvs'
474− in
475− case null classes' && null kvs' of
476− True -> d1 : (divReduce (d2 : blks))
477− False -> let attr' = ("", classes', kvs')
478− attr1' = (id1, classes1', kvs1')
479− attr2' = (id2, classes2', kvs2')
480− in
481− divReduce (Div attr' [(Div attr1' blks1), (Div attr2' blks2)] :
482− blks)
483−divReduce (blk:blks) = blk : (divReduce blks)
484
363
485isHeaderClass :: String -> Maybe Int
364isHeaderClass :: String -> Maybe Int
486isHeaderClass s | "Heading" `isPrefixOf` s =
365isHeaderClass s | "Heading" `isPrefixOf` s =
@@ -490,27 +369,12 @@ isHeaderClass s | "Heading" `isPrefixOf` s =
490 _ -> Nothing
369 _ -> Nothing
491isHeaderClass _ = Nothing
370isHeaderClass _ = Nothing
492
371
493−findHeaderClass :: [String] -> Maybe Int
494−findHeaderClass ss = case mapMaybe id $ map isHeaderClass ss of
495− [] -> Nothing
496− n : _ -> Just n
497
372
498blksToInlines :: [Block] -> [Inline]
373blksToInlines :: [Block] -> [Inline]
499blksToInlines (Para ils : _) = ils
374blksToInlines (Para ils : _) = ils
500blksToInlines (Plain ils : _) = ils
375blksToInlines (Plain ils : _) = ils
501blksToInlines _ = []
376blksToInlines _ = []
502
377
503−divCorrectPreReduce' :: Block -> [Block]
504−divCorrectPreReduce' (Div (ident, classes, kvs) blks)
505− | isJust $ findHeaderClass classes =
506− let n = fromJust $ findHeaderClass classes
507− in
508− [Header n (ident, delete ("Heading" ++ (show n)) classes, kvs) (blksToInlines blks)]
509− | otherwise = [Div (ident, classes, kvs) blks]
510−divCorrectPreReduce' blk = [blk]
511−
512−divCorrectPreReduce :: [Block] -> [Block]
513−divCorrectPreReduce = concatMap divCorrectPreReduce'
514
378
515blkToCode :: Block -> String
379blkToCode :: Block -> String
516blkToCode (Para []) = ""
380blkToCode (Para []) = ""
@@ -520,29 +384,3 @@ blkToCode (Para ((Span (_, classes, _) ils'): ils))
520 (init $ unlines $ map ilToCode ils') ++ (blkToCode (Para ils))
384 (init $ unlines $ map ilToCode ils') ++ (blkToCode (Para ils))
521blkToCode _ = ""
385blkToCode _ = ""
522
386
523−divRemove' :: Block -> [Block]
524−divRemove' (Div (_, _, kvs) blks) =
525− case lookup "indent" kvs of
526− Just val -> [Div ("", [], [("indent", val)]) blks]
527− Nothing -> blks
528−divRemove' blk = [blk]
529−
530−divRemove :: [Block] -> [Block]
531−divRemove = concatMap divRemove'
532−
533−divCorrect' :: Block -> [Block]
534−divCorrect' b@(Div (ident, classes, kvs) blks)
535− | (not . null) (blockQuoteDivs `intersect` classes) =
536− [BlockQuote [Div (ident, classes \\ blockQuoteDivs, kvs) blks]]
537− | (not . null) (codeDivs `intersect` classes) =
538− [CodeBlock (ident, (classes \\ codeDivs), kvs) (init $ unlines $ map blkToCode blks)]
539− | otherwise =
540− case lookup "indent" kvs of
541− Just "0" -> [Div (ident, classes, filter (\kv -> fst kv /= "indent") kvs) blks]
542− Just _ ->
543− [BlockQuote [Div (ident, classes, filter (\kv -> fst kv /= "indent") kvs) blks]]
544− Nothing -> [b]
545−divCorrect' blk = [blk]
546−
547−divCorrect :: [Block] -> [Block]
548−divCorrect = concatMap divCorrect'
src/Text/Pandoc/Readers/Docx/Lists.hs+22−3
@@ -29,9 +29,12 @@ Functions for converting flat docx paragraphs into nested lists.
29-}
29-}
30
30
31module Text.Pandoc.Readers.Docx.Lists ( blocksToBullets
31module Text.Pandoc.Readers.Docx.Lists ( blocksToBullets
32− , blocksToDefinitions) where
32+ , blocksToDefinitions
33+ , listParagraphDivs
34+ ) where
33
35
34import Text.Pandoc.JSON
36import Text.Pandoc.JSON
37+import Text.Pandoc.Generic (bottomUp)
35import Text.Pandoc.Shared (trim)
38import Text.Pandoc.Shared (trim)
36import Control.Monad
39import Control.Monad
37import Data.List
40import Data.List
@@ -159,10 +162,9 @@ flatToBullets elems = flatToBullets' (-1) elems
159
162
160blocksToBullets :: [Block] -> [Block]
163blocksToBullets :: [Block] -> [Block]
161blocksToBullets blks =
164blocksToBullets blks =
162− -- bottomUp removeListItemDivs $
165+ bottomUp removeListDivs $
163 flatToBullets $ (handleListParagraphs blks)
166 flatToBullets $ (handleListParagraphs blks)
164
167
165−
166plainParaInlines :: Block -> [Inline]
168plainParaInlines :: Block -> [Inline]
167plainParaInlines (Plain ils) = ils
169plainParaInlines (Plain ils) = ils
168plainParaInlines (Para ils) = ils
170plainParaInlines (Para ils) = ils
@@ -199,6 +201,23 @@ blocksToDefinitions' [] acc (b:blks) =
199blocksToDefinitions' defAcc acc (b:blks) =
201blocksToDefinitions' defAcc acc (b:blks) =
200 blocksToDefinitions' [] (b : (DefinitionList (reverse defAcc)) : acc) blks
202 blocksToDefinitions' [] (b : (DefinitionList (reverse defAcc)) : acc) blks
201
203
204+removeListDivs' :: Block -> [Block]
205+removeListDivs' (Div (ident, classes, kvs) blks)
206+ | "list-item" `elem` classes =
207+ case delete "list-item" classes of
208+ [] -> blks
209+ classes' -> [Div (ident, classes', kvs) $ blks]
210+removeListDivs' (Div (ident, classes, kvs) blks)
211+ | not $ null $ listParagraphDivs `intersect` classes =
212+ case classes \\ listParagraphDivs of
213+ [] -> blks
214+ classes' -> [Div (ident, classes', kvs) blks]
215+removeListDivs' blk = [blk]
216+
217+removeListDivs :: [Block] -> [Block]
218+removeListDivs = concatMap removeListDivs'
219+
220+
202
221
203blocksToDefinitions :: [Block] -> [Block]
222blocksToDefinitions :: [Block] -> [Block]
204blocksToDefinitions = blocksToDefinitions' [] []
223blocksToDefinitions = blocksToDefinitions' [] []
src/Text/Pandoc/Readers/Docx/Reducible.hsnew file+150
@@ -0,0 +1,150 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Text.Pandoc.Readers.Docx.Reducible ((<++>),
4+ (<+++>),
5+ Reducible,
6+ Container(..),
7+ container,
8+ innards,
9+ reduceList,
10+ reduceListB,
11+ rebuild)
12+ where
13+
14+import Text.Pandoc.Builder
15+import Data.List ((\\), intersect)
16+
17+data Container a = Container ([a] -> a) | NullContainer
18+
19+instance (Eq a) => Eq (Container a) where
20+ (Container x) == (Container y) = ((x []) == (y []))
21+ NullContainer == NullContainer = True
22+ _ == _ = False
23+
24+instance (Show a) => Show (Container a) where
25+ show (Container x) = "Container {" ++
26+ (reverse $ drop 3 $ reverse $ show $ x []) ++
27+ "}"
28+ show (NullContainer) = "NullContainer"
29+
30+class Reducible a where
31+ (<++>) :: a -> a -> [a]
32+ container :: a -> Container a
33+ innards :: a -> [a]
34+ isSpace :: a -> Bool
35+
36+(<+++>) :: (Reducible a) => Many a -> Many a -> Many a
37+mr <+++> ms = fromList $ reduceList $ toList mr ++ toList ms
38+
39+reduceListB :: (Reducible a) => Many a -> Many a
40+reduceListB = fromList . reduceList . toList
41+
42+reduceList' :: (Reducible a) => [a] -> [a] -> [a]
43+reduceList' acc [] = acc
44+reduceList' [] (x:xs) = reduceList' [x] xs
45+reduceList' as (x:xs) = reduceList' (init as ++ (last as <++> x) ) xs
46+
47+reduceList :: (Reducible a) => [a] -> [a]
48+reduceList = reduceList' []
49+
50+combineReducibles :: (Reducible a, Eq a) => a -> a -> [a]
51+combineReducibles r s =
52+ let (conts, rs) = topLevelContainers r
53+ (conts', ss) = topLevelContainers s
54+ shared = conts `intersect` conts'
55+ remaining = conts \\ shared
56+ remaining' = conts' \\ shared
57+ in
58+ case null shared of
59+ True -> case (not . null) rs && isSpace (last rs) of
60+ True -> rebuild conts (init rs) ++ [last rs, s]
61+ False -> [r,s]
62+ False -> rebuild
63+ shared $
64+ reduceList $
65+ (rebuild remaining rs) ++ (rebuild remaining' ss)
66+
67+instance Reducible Inline where
68+ s1@(Span (id1, classes1, kvs1) ils1) <++> s2@(Span (id2, classes2, kvs2) ils2) =
69+ let classes' = classes1 `intersect` classes2
70+ kvs' = kvs1 `intersect` kvs2
71+ classes1' = classes1 \\ classes'
72+ kvs1' = kvs1 \\ kvs'
73+ classes2' = classes2 \\ classes'
74+ kvs2' = kvs2 \\ kvs'
75+ in
76+ case null classes' && null kvs' of
77+ True -> [s1,s2]
78+ False -> let attr' = ("", classes', kvs')
79+ attr1' = (id1, classes1', kvs1')
80+ attr2' = (id2, classes2', kvs2')
81+ s1' = case null classes1' && null kvs1' of
82+ True -> ils1
83+ False -> [Span attr1' ils1]
84+ s2' = case null classes2' && null kvs2' of
85+ True -> ils2
86+ False -> [Span attr2' ils2]
87+ in
88+ [Span attr' $ reduceList $ s1' ++ s2']
89+
90+ (Str x) <++> (Str y) = [Str (x++y)]
91+ il <++> il' = combineReducibles il il'
92+
93+ container (Emph _) = Container Emph
94+ container (Strong _) = Container Strong
95+ container (Strikeout _) = Container Strikeout
96+ container (Subscript _) = Container Subscript
97+ container (Superscript _) = Container Superscript
98+ container (Quoted qt _) = Container $ Quoted qt
99+ container (Cite cs _) = Container $ Cite cs
100+ container (Span attr _) = Container $ Span attr
101+ container _ = NullContainer
102+
103+ innards (Emph ils) = ils
104+ innards (Strong ils) = ils
105+ innards (Strikeout ils) = ils
106+ innards (Subscript ils) = ils
107+ innards (Superscript ils) = ils
108+ innards (Quoted _ ils) = ils
109+ innards (Cite _ ils) = ils
110+ innards (Span _ ils) = ils
111+ innards _ = []
112+
113+ isSpace Space = True
114+ isSpace _ = False
115+
116+instance Reducible Block where
117+ (Div (ident, classes, kvs) blks) <++> blk | "list-item" `elem` classes =
118+ [Div (ident, classes, kvs) (reduceList blks), blk]
119+
120+ blk <++> blk' = combineReducibles blk blk'
121+
122+ container (BlockQuote _) = Container BlockQuote
123+ container (Div attr _) = Container $ Div attr
124+ container _ = NullContainer
125+
126+ innards (BlockQuote bs) = bs
127+ innards (Div _ bs) = bs
128+ innards _ = []
129+
130+ isSpace _ = False
131+
132+
133+topLevelContainers' :: (Reducible a) => [a] -> ([Container a], [a])
134+topLevelContainers' (r : []) = case container r of
135+ NullContainer -> ([], [r])
136+ _ ->
137+ let (conts, inns) = topLevelContainers' (innards r)
138+ in
139+ ((container r) : conts, inns)
140+topLevelContainers' rs = ([], rs)
141+
142+topLevelContainers :: (Reducible a) => a -> ([Container a], [a])
143+topLevelContainers il = topLevelContainers' [il]
144+
145+rebuild :: [Container a] -> [a] -> [a]
146+rebuild [] xs = xs
147+rebuild ((Container f) : cs) xs = rebuild cs $ [f xs]
148+rebuild (NullContainer : cs) xs = rebuild cs $ xs
149+
150+
tests/Tests/Readers/Docx.hs+4
@@ -82,6 +82,10 @@ tests = [ testGroup "inlines"
82 "normalizing inlines deep inside blocks"
82 "normalizing inlines deep inside blocks"
83 "docx.deep_normalize.docx"
83 "docx.deep_normalize.docx"
84 "docx.deep_normalize.native"
84 "docx.deep_normalize.native"
85+ , testCompare
86+ "move trailing spaces outside of formatting"
87+ "docx.trailing_spaces_in_formatting.docx"
88+ "docx.trailing_spaces_in_formatting.native"
85 ]
89 ]
86 , testGroup "blocks"
90 , testGroup "blocks"
87 [ testCompare
91 [ testCompare
tests/docx.trailing_spaces_in_formatting.docxnew file

Binary file not shown.

tests/docx.trailing_spaces_in_formatting.nativenew file+1
@@ -0,0 +1 @@
1+[Para [Str "Turn",Space,Str "my",Space,Emph [Str "formatting"],Space,Str "off",Space,Str "after",Space,Str "the",Space,Str "spaces."]]