@@ -1,3 +1,5 @@
1+{-# LANGUAGE PatternGuards #-}
2+
13{-
24Copyright (C) 2014 Jesse Rosenthal <jrosenthal@jhu.edu>
35
@@ -82,12 +84,16 @@ import Text.Pandoc.Walk
8284import Text.Pandoc.Readers.Docx.Parse
8385import Text.Pandoc.Readers.Docx.Lists
8486import Text.Pandoc.Readers.Docx.Reducible
85−import Data.Maybe (mapMaybe, isJust, fromJust)
87+import Text.Pandoc.Shared
88+import Data.Maybe (mapMaybe)
8689import Data.List (delete, isPrefixOf, (\\))
8790import qualified Data.ByteString as BS
8891import qualified Data.ByteString.Lazy as B
8992import Data.ByteString.Base64 (encode)
9093import System.FilePath (combine)
94+import qualified Data.Map as M
95+import Control.Monad.Reader
96+import Control.Monad.State
9197
9298readDocx :: ReaderOptions
9399 -> B.ByteString
@@ -97,11 +103,24 @@ readDocx opts bytes =
97103 Just docx -> Pandoc nullMeta (docxToBlocks opts docx)
98104 Nothing -> error $ "couldn't parse docx file"
99105
100−spansToKeep :: [String]
101−spansToKeep = []
102106
107+data DState = DState { docxAnchorMap :: M.Map String String }
108+
109+data DEnv = DEnv { docxOptions :: ReaderOptions
110+ , docxDocument :: Docx}
111+
112+type DocxContext = ReaderT DEnv (State DState)
113+
114+evalDocxContext :: DocxContext a -> DEnv -> DState -> a
115+evalDocxContext ctx env st = evalState (runReaderT ctx env) st
116+
117+concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
118+concatMapM f xs = liftM concat (mapM f xs)
103119
104120-- This is empty, but we put it in for future-proofing.
121+spansToKeep :: [String]
122+spansToKeep = []
123+
105124divsToKeep :: [String]
106125divsToKeep = ["list-item", "Definition", "DefinitionTerm"]
107126
@@ -132,11 +151,9 @@ runStyleToContainers rPr =
132151
133152
134153divAttrToContainers :: [String] -> [(String, String)] -> [Container Block]
135−divAttrToContainers (c:cs) _ | isJust (isHeaderClass c) =
136− let n = fromJust (isHeaderClass c)
137− in
138− [(Container $ \blks ->
139− Header n ("", delete ("Heading" ++ show n) cs, []) (blksToInlines blks))]
154+divAttrToContainers (c:cs) _ | Just n <- isHeaderClass c =
155+ [Container $ \_ ->
156+ Header n ("", delete ("Heading" ++ show n) cs, []) []]
140157divAttrToContainers (c:cs) kvs | c `elem` divsToKeep =
141158 (Container $ Div ("", [c], [])) : (divAttrToContainers cs kvs)
142159divAttrToContainers (c:cs) kvs | c `elem` codeDivs =
@@ -150,10 +167,10 @@ divAttrToContainers (c:cs) kvs | c `elem` listParagraphDivs =
150167divAttrToContainers (c:cs) kvs | c `elem` blockQuoteDivs =
151168 (Container BlockQuote) : (divAttrToContainers (cs \\ blockQuoteDivs) kvs)
152169divAttrToContainers (_:cs) kvs = divAttrToContainers cs kvs
153−divAttrToContainers [] kvs | isJust (lookup "indent" kvs) =
170+divAttrToContainers [] kvs | Just numString <- lookup "indent" kvs =
154171 let kvs' = filter (\(k,_) -> k /= "indent") kvs
155172 in
156− case fromJust (lookup "indent" kvs) of
173+ case numString of
157174 "0" -> divAttrToContainers [] kvs'
158175 ('-' : _) -> divAttrToContainers [] kvs'
159176 _ -> (Container BlockQuote) : divAttrToContainers [] kvs'
@@ -213,57 +230,84 @@ inlineCodeContainer (Container f) = case f [] of
213230inlineCodeContainer _ = False
214231
215232
216−runToInlines :: ReaderOptions -> Docx -> Run -> [Inline]
217−runToInlines _ _ (Run rs runElems)
233+runToInlines :: Run -> DocxContext [Inline]
234+runToInlines (Run rs runElems)
218235 | any inlineCodeContainer (runStyleToContainers rs) =
236+ return $
219237 rebuild (runStyleToContainers rs) $ [Str $ runElemsToString runElems]
220238 | otherwise =
239+ return $
221240 rebuild (runStyleToContainers rs) (concatMap runElemToInlines runElems)
222−runToInlines opts docx@(Docx _ notes _ _ _ ) (Footnote fnId) =
241+runToInlines (Footnote fnId) = do
242+ (Docx _ notes _ _ _ ) <- asks docxDocument
223243 case (getFootNote fnId notes) of
224− Just bodyParts ->
225− [Note (concatMap (bodyPartToBlocks opts docx) bodyParts)]
226− Nothing ->
227− [Note []]
228−runToInlines opts docx@(Docx _ notes _ _ _) (Endnote fnId) =
244+ Just bodyParts -> do
245+ blks <- concatMapM bodyPartToBlocks bodyParts
246+ return $ [Note blks]
247+ Nothing -> return [Note []]
248+runToInlines (Endnote fnId) = do
249+ (Docx _ notes _ _ _ ) <- asks docxDocument
229250 case (getEndNote fnId notes) of
230− Just bodyParts ->
231− [Note (concatMap (bodyPartToBlocks opts docx) bodyParts)]
232− Nothing ->
233− [Note []]
234−
235−parPartToInlines :: ReaderOptions -> Docx -> ParPart -> [Inline]
236−parPartToInlines opts docx (PlainRun r) = runToInlines opts docx r
237−parPartToInlines opts docx (Insertion _ author date runs) =
251+ Just bodyParts -> do
252+ blks <- concatMapM bodyPartToBlocks bodyParts
253+ return $ [Note blks]
254+ Nothing -> return [Note []]
255+
256+parPartToInlines :: ParPart -> DocxContext [Inline]
257+parPartToInlines (PlainRun r) = runToInlines r
258+parPartToInlines (Insertion _ author date runs) = do
259+ opts <- asks docxOptions
238260 case readerTrackChanges opts of
239− AcceptChanges -> concatMap (runToInlines opts docx) runs
240− RejectChanges -> []
241− AllChanges ->
242− [Span
243− ("", ["insertion"], [("author", author), ("date", date)])
244− (concatMap (runToInlines opts docx) runs)]
245−parPartToInlines opts docx (Deletion _ author date runs) =
261+ AcceptChanges -> concatMapM runToInlines runs >>= return
262+ RejectChanges -> return []
263+ AllChanges -> do
264+ ils <- (concatMapM runToInlines runs)
265+ return [Span
266+ ("", ["insertion"], [("author", author), ("date", date)])
267+ ils]
268+parPartToInlines (Deletion _ author date runs) = do
269+ opts <- asks docxOptions
246270 case readerTrackChanges opts of
247− AcceptChanges -> []
248− RejectChanges -> concatMap (runToInlines opts docx) runs
249− AllChanges ->
250− [Span
251− ("", ["deletion"], [("author", author), ("date", date)])
252− (concatMap (runToInlines opts docx) runs)]
253−parPartToInlines _ _ (BookMark _ anchor) | anchor `elem` dummyAnchors = []
254−parPartToInlines _ _ (BookMark _ anchor) = [Span (anchor, ["anchor"], []) []]
255−parPartToInlines _ (Docx _ _ _ rels _) (Drawing relid) =
256− case lookupRelationship relid rels of
271+ AcceptChanges -> return []
272+ RejectChanges -> concatMapM runToInlines runs >>= return
273+ AllChanges -> do
274+ ils <- concatMapM runToInlines runs
275+ return [Span
276+ ("", ["deletion"], [("author", author), ("date", date)])
277+ ils]
278+parPartToInlines (BookMark _ anchor) | anchor `elem` dummyAnchors = return []
279+parPartToInlines (BookMark _ anchor) =
280+ -- We record these, so we can make sure not to overwrite
281+ -- user-defined anchor links with header auto ids.
282+ do
283+ -- Get the anchor map.
284+ anchorMap <- gets docxAnchorMap
285+ -- Check to see if the id is already in there. Rewrite if
286+ -- necessary. This will have the possible effect of rewriting
287+ -- user-defined anchor links. However, since these are not defined
288+ -- in pandoc, it seems like a necessary evil to avoid an extra
289+ -- pass.
290+ let newAnchor = case anchor `elem` (M.elems anchorMap) of
291+ True -> uniqueIdent [Str anchor] (M.elems anchorMap)
292+ False -> anchor
293+ put DState{ docxAnchorMap = M.insert anchor newAnchor anchorMap}
294+ return [Span (anchor, ["anchor"], []) []]
295+parPartToInlines (Drawing relid) = do
296+ (Docx _ _ _ rels _) <- asks docxDocument
297+ return $ case lookupRelationship relid rels of
257298 Just target -> [Image [] (combine "word" target, "")]
258299 Nothing -> [Image [] ("", "")]
259−parPartToInlines opts docx (InternalHyperLink anchor runs) =
260− [Link (concatMap (runToInlines opts docx) runs) ('#' : anchor, "")]
261−parPartToInlines opts docx@(Docx _ _ _ rels _) (ExternalHyperLink relid runs) =
262− case lookupRelationship relid rels of
300+parPartToInlines (InternalHyperLink anchor runs) = do
301+ ils <- concatMapM runToInlines runs
302+ return [Link ils ('#' : anchor, "")]
303+parPartToInlines (ExternalHyperLink relid runs) = do
304+ (Docx _ _ _ rels _) <- asks docxDocument
305+ rs <- concatMapM runToInlines runs
306+ return $ case lookupRelationship relid rels of
263307 Just target ->
264− [Link (concatMap (runToInlines opts docx) runs) (target, "")]
308+ [Link rs (target, "")]
265309 Nothing ->
266− [Link (concatMap (runToInlines opts docx) runs) ("", "")]
310+ [Link rs ("", "")]
267311
268312isAnchorSpan :: Inline -> Bool
269313isAnchorSpan (Span (ident, classes, kvs) ils) =
@@ -276,64 +320,68 @@ isAnchorSpan _ = False
276320dummyAnchors :: [String]
277321dummyAnchors = ["_GoBack"]
278322
279−makeHeaderAnchors :: Block -> Block
280−makeHeaderAnchors h@(Header n (_, classes, kvs) ils) =
281− case filter isAnchorSpan ils of
282− [] -> h
283− (x@(Span (ident, _, _) _) : xs) ->
284− case ident `elem` dummyAnchors of
285− True -> h
286− False -> Header n (ident, classes, kvs) (ils \\ (x:xs))
287− _ -> h
288−makeHeaderAnchors blk = blk
289−
290−parPartsToInlines :: ReaderOptions -> Docx -> [ParPart] -> [Inline]
291−parPartsToInlines opts docx parparts =
292− --
293− -- We're going to skip data-uri's for now. It should be an option,
294− -- not mandatory.
295− --
296− (if False -- TODO depend on option
297− then walk (makeImagesSelfContained docx)
298− else id) $
299− -- bottomUp spanTrim $
300− -- bottomUp spanCorrect $
301− -- bottomUp spanReduce $
302− reduceList $ concatMap (parPartToInlines opts docx) parparts
303−
304−cellToBlocks :: ReaderOptions -> Docx -> Cell -> [Block]
305−cellToBlocks opts docx (Cell bps) = concatMap (bodyPartToBlocks opts docx) bps
306−
307−rowToBlocksList :: ReaderOptions -> Docx -> Row -> [[Block]]
308−rowToBlocksList opts docx (Row cells) = map (cellToBlocks opts docx) cells
309−
310−blockCodeContainer :: Container Block -> Bool
311−blockCodeContainer (Container f) = case f [] of
312− CodeBlock _ _ -> True
313− _ -> False
314−blockCodeContainer _ = False
315−
316−bodyPartToBlocks :: ReaderOptions -> Docx -> BodyPart -> [Block]
317−bodyPartToBlocks _ _ (Paragraph pPr parparts)
318− | any blockCodeContainer (parStyleToContainers pPr) =
323+makeHeaderAnchor :: Block -> DocxContext Block
324+makeHeaderAnchor (Header n (_, classes, kvs) ils)
325+ | (x : xs) <- filter isAnchorSpan ils
326+ , (Span (ident, _, _) _) <- x
327+ , notElem ident dummyAnchors =
328+ do
329+ hdrIDMap <- gets docxAnchorMap
330+ let newIdent = uniqueIdent ils (M.elems hdrIDMap)
331+ put DState{docxAnchorMap = M.insert ident newIdent hdrIDMap}
332+ return $ Header n (newIdent, classes, kvs) (ils \\ (x:xs))
333+makeHeaderAnchor blk = return blk
334+
335+
336+parPartsToInlines :: [ParPart] -> DocxContext [Inline]
337+parPartsToInlines parparts = do
338+ ils <- concatMapM parPartToInlines parparts >>=
339+ -- TODO: Option for self-containted images
340+ (if False then (walkM makeImagesSelfContained) else return)
341+ return $ reduceList $ ils
342+
343+cellToBlocks :: Cell -> DocxContext [Block]
344+cellToBlocks (Cell bps) = concatMapM bodyPartToBlocks bps
345+
346+rowToBlocksList :: Row -> DocxContext [[Block]]
347+rowToBlocksList (Row cells) = mapM cellToBlocks cells
348+
349+isBlockCodeContainer :: Container Block -> Bool
350+isBlockCodeContainer (Container f) | CodeBlock _ _ <- f [] = True
351+isBlockCodeContainer _ = False
352+
353+isHeaderContainer :: Container Block -> Bool
354+isHeaderContainer (Container f) | Header _ _ _ <- f [] = True
355+isHeaderContainer _ = False
356+
357+bodyPartToBlocks :: BodyPart -> DocxContext [Block]
358+bodyPartToBlocks (Paragraph pPr parparts)
359+ | any isBlockCodeContainer (parStyleToContainers pPr) =
319360 let
320− otherConts = filter (not . blockCodeContainer) (parStyleToContainers pPr)
361+ otherConts = filter (not . isBlockCodeContainer) (parStyleToContainers pPr)
321362 in
363+ return $
322364 rebuild
323365 otherConts
324366 [CodeBlock ("", [], []) (concatMap parPartToString parparts)]
325−bodyPartToBlocks opts docx (Paragraph pPr parparts) =
326− case parPartsToInlines opts docx parparts of
327− [] ->
328− []
329− _ ->
330− let parContents = parPartsToInlines opts docx parparts
331− trimmedContents = reverse $ dropWhile (Space ==) $ reverse $ dropWhile (Space ==) parContents
332− in
367+bodyPartToBlocks (Paragraph pPr parparts)
368+ | any isHeaderContainer (parStyleToContainers pPr) = do
369+ ils <- parPartsToInlines parparts >>= (return . normalizeSpaces)
370+ let (Container hdrFun) = head $ filter isHeaderContainer (parStyleToContainers pPr)
371+ Header n attr _ = hdrFun []
372+ hdr <- makeHeaderAnchor $ Header n attr ils
373+ return [hdr]
374+bodyPartToBlocks (Paragraph pPr parparts) = do
375+ ils <- parPartsToInlines parparts >>= (return . normalizeSpaces)
376+ case ils of
377+ [] -> return []
378+ _ -> do
379+ return $
333380 rebuild
334381 (parStyleToContainers pPr)
335− [Para trimmedContents]
336−bodyPartToBlocks opts docx@(Docx _ _ numbering _ _) (ListItem pPr numId lvl parparts) =
382+ [Para ils]
383+bodyPartToBlocks (ListItem pPr numId lvl parparts) = do
384+ (Docx _ _ numbering _ _) <- asks docxDocument
337385 let
338386 kvs = case lookupLevel numId lvl numbering of
339387 Just (_, fmt, txt, Just start) -> [ ("level", lvl)
@@ -349,23 +397,22 @@ bodyPartToBlocks opts docx@(Docx _ _ numbering _ _) (ListItem pPr numId lvl parp
349397 , ("text", txt)
350398 ]
351399 Nothing -> []
352− in
353− [Div
354− ("", ["list-item"], kvs)
355− (bodyPartToBlocks opts docx (Paragraph pPr parparts))]
356−bodyPartToBlocks _ _ (Tbl _ _ _ []) =
357− [Para []]
358−bodyPartToBlocks opts docx (Tbl cap _ look (r:rs)) =
400+ blks <- bodyPartToBlocks (Paragraph pPr parparts)
401+ return $ [Div ("", ["list-item"], kvs) blks]
402+bodyPartToBlocks (Tbl _ _ _ []) =
403+ return [Para []]
404+bodyPartToBlocks (Tbl cap _ look (r:rs)) = do
359405 let caption = strToInlines cap
360406 (hdr, rows) = case firstRowFormatting look of
361407 True -> (Just r, rs)
362408 False -> (Nothing, r:rs)
363− hdrCells = case hdr of
364− Just r' -> rowToBlocksList opts docx r'
365− Nothing -> []
366− cells = map (rowToBlocksList opts docx) rows
409+ hdrCells <- case hdr of
410+ Just r' -> rowToBlocksList r'
411+ Nothing -> return []
412+
413+ cells <- mapM rowToBlocksList rows
367414
368− size = case null hdrCells of
415+ let size = case null hdrCells of
369416 True -> length $ head cells
370417 False -> length $ hdrCells
371418 --
@@ -374,41 +421,56 @@ bodyPartToBlocks opts docx (Tbl cap _ look (r:rs)) =
374421 -- moment. Width information is in the TblGrid field of the Tbl,
375422 -- so should be possible. Alignment might be more difficult,
376423 -- since there doesn't seem to be a column entity in docx.
377− alignments = take size (repeat AlignDefault)
378− widths = take size (repeat 0) :: [Double]
379− in
380− [Table caption alignments widths hdrCells cells]
381−
382−
383−makeImagesSelfContained :: Docx -> Inline -> Inline
384−makeImagesSelfContained (Docx _ _ _ _ media) i@(Image alt (uri, title)) =
385− case lookup uri media of
386− Just bs -> case getMimeType uri of
387− Just mime -> let data_uri =
388− "data:" ++ mime ++ ";base64," ++ toString (encode $ BS.concat $ B.toChunks bs)
389− in
390− Image alt (data_uri, title)
391− Nothing -> i
424+ alignments = replicate size AlignDefault
425+ widths = replicate size 0 :: [Double]
426+
427+ return [Table caption alignments widths hdrCells cells]
428+
429+-- replace targets with generated anchors.
430+rewriteLink :: Inline -> DocxContext Inline
431+rewriteLink l@(Link ils ('#':target, title)) = do
432+ anchorMap <- gets docxAnchorMap
433+ return $ case M.lookup target anchorMap of
434+ Just newTarget -> (Link ils ('#':newTarget, title))
435+ Nothing -> l
436+rewriteLink il = return il
437+
438+makeImagesSelfContained :: Inline -> DocxContext Inline
439+makeImagesSelfContained i@(Image alt (uri, title)) = do
440+ (Docx _ _ _ _ media) <- asks docxDocument
441+ return $ case lookup uri media of
442+ Just bs ->
443+ case getMimeType uri of
444+ Just mime ->
445+ let data_uri = "data:" ++ mime ++ ";base64," ++
446+ toString (encode $ BS.concat $ B.toChunks bs)
447+ in
448+ Image alt (data_uri, title)
449+ Nothing -> i
392450 Nothing -> i
393−makeImagesSelfContained _ inline = inline
451+makeImagesSelfContained inline = return inline
394452
395−bodyToBlocks :: ReaderOptions -> Docx -> Body -> [Block]
396−bodyToBlocks opts docx (Body bps) =
397− map (makeHeaderAnchors) $
398− blocksToDefinitions $
399− blocksToBullets $
400− concatMap (bodyPartToBlocks opts docx) bps
453+bodyToBlocks :: Body -> DocxContext [Block]
454+bodyToBlocks (Body bps) = do
455+ blks <- concatMapM bodyPartToBlocks bps >>=
456+ walkM rewriteLink
457+ return $
458+ blocksToDefinitions $
459+ blocksToBullets $ blks
401460
402461docxToBlocks :: ReaderOptions -> Docx -> [Block]
403−docxToBlocks opts d@(Docx (Document _ body) _ _ _ _) = bodyToBlocks opts d body
404−
462+docxToBlocks opts d@(Docx (Document _ body) _ _ _ _) =
463+ let dState = DState { docxAnchorMap = M.empty }
464+ dEnv = DEnv { docxOptions = opts
465+ , docxDocument = d}
466+ in
467+ evalDocxContext (bodyToBlocks body) dEnv dState
405468
406469ilToCode :: Inline -> String
407470ilToCode (Str s) = s
408471ilToCode Space = " "
409472ilToCode _ = ""
410473
411−
412474isHeaderClass :: String -> Maybe Int
413475isHeaderClass s | "Heading" `isPrefixOf` s =
414476 case reads (drop (length "Heading") s) :: [(Int, String)] of
@@ -416,8 +478,3 @@ isHeaderClass s | "Heading" `isPrefixOf` s =
416478 ((n, "") : []) -> Just n
417479 _ -> Nothing
418480isHeaderClass _ = Nothing
419−
420−blksToInlines :: [Block] -> [Inline]
421−blksToInlines (Para ils : _) = ils
422−blksToInlines (Plain ils : _) = ils
423−blksToInlines _ = []