@@ -88,6 +88,9 @@ import qualified Data.ByteString as BS
88import qualified Data.ByteString.Lazy as B
88import qualified Data.ByteString.Lazy as B
89import Data.ByteString.Base64 (encode)
89import Data.ByteString.Base64 (encode)
90import System.FilePath (combine)
90import System.FilePath (combine)
91+import qualified Data.Map as M
92+import Control.Monad.Reader
93+import Control.Monad.State
92readDocx :: ReaderOptions
95readDocx :: ReaderOptions
93 -> B.ByteString
96 -> B.ByteString
@@ -97,11 +100,24 @@ readDocx opts bytes =
97 Just docx -> Pandoc nullMeta (docxToBlocks opts docx)
100 Just docx -> Pandoc nullMeta (docxToBlocks opts docx)
98 Nothing -> error $ "couldn't parse docx file"
101 Nothing -> error $ "couldn't parse docx file"
100−spansToKeep :: [String]
104+data DState = DState { docxHdrLinks :: M.Map String String }
106+data DEnv = DEnv { docxOptions :: ReaderOptions
107+ , docxDocument :: Docx}
109+type DocxContext = ReaderT DEnv (State DState)
111+evalDocxContext :: DocxContext a -> DEnv -> DState -> a
112+evalDocxContext ctx env st = evalState (runReaderT ctx env) st
114+concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
115+concatMapM f xs = liftM concat (mapM f xs)
104-- This is empty, but we put it in for future-proofing.
117-- This is empty, but we put it in for future-proofing.
118+spansToKeep :: [String]
105divsToKeep :: [String]
121divsToKeep :: [String]
106divsToKeep = ["list-item", "Definition", "DefinitionTerm"]
122divsToKeep = ["list-item", "Definition", "DefinitionTerm"]
@@ -213,57 +229,69 @@ inlineCodeContainer (Container f) = case f [] of
213inlineCodeContainer _ = False
229inlineCodeContainer _ = False
216−runToInlines :: ReaderOptions -> Docx -> Run -> [Inline]
232+runToInlines :: Run -> DocxContext [Inline]
217−runToInlines _ _ (Run rs runElems)
233+runToInlines (Run rs runElems)
218 | any inlineCodeContainer (runStyleToContainers rs) =
234 | any inlineCodeContainer (runStyleToContainers rs) =
219 rebuild (runStyleToContainers rs) $ [Str $ runElemsToString runElems]
236 rebuild (runStyleToContainers rs) $ [Str $ runElemsToString runElems]
220 | otherwise =
237 | otherwise =
221 rebuild (runStyleToContainers rs) (concatMap runElemToInlines runElems)
239 rebuild (runStyleToContainers rs) (concatMap runElemToInlines runElems)
222−runToInlines opts docx@(Docx _ notes _ _ _ ) (Footnote fnId) =
240+runToInlines (Footnote fnId) = do
241+ (Docx _ notes _ _ _ ) <- asks docxDocument
223 case (getFootNote fnId notes) of
242 case (getFootNote fnId notes) of
224− Just bodyParts ->
243+ Just bodyParts -> do
225− [Note (concatMap (bodyPartToBlocks opts docx) bodyParts)]
244+ blks <- concatMapM bodyPartToBlocks bodyParts
245+ return $ [Note blks]
226− Nothing ->
246+ Nothing -> return [Note []]
228−runToInlines opts docx@(Docx _ notes _ _ _) (Endnote fnId) =
247+runToInlines (Endnote fnId) = do
248+ (Docx _ notes _ _ _ ) <- asks docxDocument
229 case (getEndNote fnId notes) of
249 case (getEndNote fnId notes) of
230− Just bodyParts ->
250+ Just bodyParts -> do
231− [Note (concatMap (bodyPartToBlocks opts docx) bodyParts)]
251+ blks <- concatMapM bodyPartToBlocks bodyParts
252+ return $ [Note blks]
232− Nothing ->
253+ Nothing -> return [Note []]
235−parPartToInlines :: ReaderOptions -> Docx -> ParPart -> [Inline]
255+parPartToInlines :: ParPart -> DocxContext [Inline]
236−parPartToInlines opts docx (PlainRun r) = runToInlines opts docx r
256+parPartToInlines (PlainRun r) = runToInlines r
237−parPartToInlines opts docx (Insertion _ author date runs) =
257+parPartToInlines (Insertion _ author date runs) = do
258+ opts <- asks docxOptions
238 case readerTrackChanges opts of
259 case readerTrackChanges opts of
239− AcceptChanges -> concatMap (runToInlines opts docx) runs
260+ AcceptChanges -> concatMapM runToInlines runs >>= return
240− RejectChanges -> []
261+ RejectChanges -> return []
241− AllChanges ->
262+ AllChanges -> do
263+ ils <- (concatMapM runToInlines runs)
242− [Span
264+ return [Span
243− ("", ["insertion"], [("author", author), ("date", date)])
265+ ("", ["insertion"], [("author", author), ("date", date)])
244− (concatMap (runToInlines opts docx) runs)]
266+ ils]
245−parPartToInlines opts docx (Deletion _ author date runs) =
267+parPartToInlines (Deletion _ author date runs) = do
268+ opts <- asks docxOptions
246 case readerTrackChanges opts of
269 case readerTrackChanges opts of
247− AcceptChanges -> []
270+ AcceptChanges -> return []
248− RejectChanges -> concatMap (runToInlines opts docx) runs
271+ RejectChanges -> concatMapM runToInlines runs >>= return
249− AllChanges ->
272+ AllChanges -> do
273+ ils <- concatMapM runToInlines runs
250− [Span
274+ return [Span
251− ("", ["deletion"], [("author", author), ("date", date)])
275+ ("", ["deletion"], [("author", author), ("date", date)])
252− (concatMap (runToInlines opts docx) runs)]
276+ ils]
253−parPartToInlines _ _ (BookMark _ anchor) | anchor `elem` dummyAnchors = []
277+parPartToInlines (BookMark _ anchor) | anchor `elem` dummyAnchors = return []
254−parPartToInlines _ _ (BookMark _ anchor) = [Span (anchor, ["anchor"], []) []]
278+parPartToInlines (BookMark _ anchor) = return [Span (anchor, ["anchor"], []) []]
255−parPartToInlines _ (Docx _ _ _ rels _) (Drawing relid) =
279+parPartToInlines (Drawing relid) = do
280+ (Docx _ _ _ rels _) <- asks docxDocument
256− case lookupRelationship relid rels of
281+ return $ case lookupRelationship relid rels of
257 Just target -> [Image [] (combine "word" target, "")]
282 Just target -> [Image [] (combine "word" target, "")]
258 Nothing -> [Image [] ("", "")]
283 Nothing -> [Image [] ("", "")]
259−parPartToInlines opts docx (InternalHyperLink anchor runs) =
284+parPartToInlines (InternalHyperLink anchor runs) = do
260− [Link (concatMap (runToInlines opts docx) runs) ('#' : anchor, "")]
285+ ils <- concatMapM runToInlines runs
261−parPartToInlines opts docx@(Docx _ _ _ rels _) (ExternalHyperLink relid runs) =
286+ return [Link ils ('#' : anchor, "")]
287+parPartToInlines (ExternalHyperLink relid runs) = do
288+ (Docx _ _ _ rels _) <- asks docxDocument
289+ rs <- concatMapM runToInlines runs
262− case lookupRelationship relid rels of
290+ return $ case lookupRelationship relid rels of
263 Just target ->
291 Just target ->
264− [Link (concatMap (runToInlines opts docx) runs) (target, "")]
292+ [Link rs (target, "")]
265 Nothing ->
293 Nothing ->
266− [Link (concatMap (runToInlines opts docx) runs) ("", "")]
294+ [Link rs ("", "")]
268isAnchorSpan :: Inline -> Bool
296isAnchorSpan :: Inline -> Bool
269isAnchorSpan (Span (ident, classes, kvs) ils) =
297isAnchorSpan (Span (ident, classes, kvs) ils) =
@@ -287,25 +315,18 @@ makeHeaderAnchors h@(Header n (_, classes, kvs) ils) =
288makeHeaderAnchors blk = blk
316makeHeaderAnchors blk = blk
290−parPartsToInlines :: ReaderOptions -> Docx -> [ParPart] -> [Inline]
318+parPartsToInlines :: [ParPart] -> DocxContext [Inline]
291−parPartsToInlines opts docx parparts =
319+parPartsToInlines parparts = do
292− --
320+ ils <- concatMapM parPartToInlines parparts >>=
293− -- We're going to skip data-uri's for now. It should be an option,
321+ -- TODO: Option for self-containted images
296− (if False -- TODO depend on option
297− then walk (makeImagesSelfContained docx)
322+ (if False then (walkM makeImagesSelfContained) else return)
298− else id) $
323+ return $ reduceList $ ils
299− -- bottomUp spanTrim $
324+
300− -- bottomUp spanCorrect $
301− -- bottomUp spanReduce $
302− reduceList $ concatMap (parPartToInlines opts docx) parparts
304−cellToBlocks :: ReaderOptions -> Docx -> Cell -> [Block]
325+cellToBlocks :: Cell -> DocxContext [Block]
305−cellToBlocks opts docx (Cell bps) = concatMap (bodyPartToBlocks opts docx) bps
326+cellToBlocks (Cell bps) = concatMapM bodyPartToBlocks bps
307−rowToBlocksList :: ReaderOptions -> Docx -> Row -> [[Block]]
328+rowToBlocksList :: Row -> DocxContext [[Block]]
308−rowToBlocksList opts docx (Row cells) = map (cellToBlocks opts docx) cells
329+rowToBlocksList (Row cells) = mapM cellToBlocks cells
310blockCodeContainer :: Container Block -> Bool
331blockCodeContainer :: Container Block -> Bool
311blockCodeContainer (Container f) = case f [] of
332blockCodeContainer (Container f) = case f [] of
@@ -313,27 +334,32 @@ blockCodeContainer (Container f) = case f [] of
313 _ -> False
334 _ -> False
314blockCodeContainer _ = False
335blockCodeContainer _ = False
316−bodyPartToBlocks :: ReaderOptions -> Docx -> BodyPart -> [Block]
337+bodyPartToBlocks :: BodyPart -> DocxContext [Block]
317−bodyPartToBlocks _ _ (Paragraph pPr parparts)
338+bodyPartToBlocks (Paragraph pPr parparts)
318 | any blockCodeContainer (parStyleToContainers pPr) =
339 | any blockCodeContainer (parStyleToContainers pPr) =
320 otherConts = filter (not . blockCodeContainer) (parStyleToContainers pPr)
341 otherConts = filter (not . blockCodeContainer) (parStyleToContainers pPr)
323 otherConts
345 otherConts
324 [CodeBlock ("", [], []) (concatMap parPartToString parparts)]
346 [CodeBlock ("", [], []) (concatMap parPartToString parparts)]
325−bodyPartToBlocks opts docx (Paragraph pPr parparts) =
347+bodyPartToBlocks (Paragraph pPr parparts) = do
326− case parPartsToInlines opts docx parparts of
348+ ils <- parPartsToInlines parparts
327− [] ->
350+ [] -> return []
330− let parContents = parPartsToInlines opts docx parparts
352+ parContents <- parPartsToInlines parparts
353+ let trimmedContents = reverse $
354+ dropWhile (Space ==) $
331− trimmedContents = reverse $ dropWhile (Space ==) $ reverse $ dropWhile (Space ==) parContents
356+ dropWhile (Space ==) parContents
334 (parStyleToContainers pPr)
359 (parStyleToContainers pPr)
335 [Para trimmedContents]
360 [Para trimmedContents]
336−bodyPartToBlocks opts docx@(Docx _ _ numbering _ _) (ListItem pPr numId lvl parparts) =
361+bodyPartToBlocks (ListItem pPr numId lvl parparts) = do
362+ (Docx _ _ numbering _ _) <- asks docxDocument
338 kvs = case lookupLevel numId lvl numbering of
364 kvs = case lookupLevel numId lvl numbering of
339 Just (_, fmt, txt, Just start) -> [ ("level", lvl)
365 Just (_, fmt, txt, Just start) -> [ ("level", lvl)
@@ -349,23 +375,22 @@ bodyPartToBlocks opts docx@(Docx _ _ numbering _ _) (ListItem pPr numId lvl parp
349 , ("text", txt)
375 , ("text", txt)
351 Nothing -> []
377 Nothing -> []
352− in
378+ blks <- bodyPartToBlocks (Paragraph pPr parparts)
354− ("", ["list-item"], kvs)
379+ return $ [Div ("", ["list-item"], kvs) blks]
355− (bodyPartToBlocks opts docx (Paragraph pPr parparts))]
356−bodyPartToBlocks _ _ (Tbl _ _ _ []) =
380+bodyPartToBlocks (Tbl _ _ _ []) =
357− [Para []]
381+ return [Para []]
358−bodyPartToBlocks opts docx (Tbl cap _ look (r:rs)) =
382+bodyPartToBlocks (Tbl cap _ look (r:rs)) = do
359 let caption = strToInlines cap
383 let caption = strToInlines cap
360 (hdr, rows) = case firstRowFormatting look of
384 (hdr, rows) = case firstRowFormatting look of
361 True -> (Just r, rs)
385 True -> (Just r, rs)
362 False -> (Nothing, r:rs)
386 False -> (Nothing, r:rs)
363− hdrCells = case hdr of
387+ hdrCells <- case hdr of
364− Just r' -> rowToBlocksList opts docx r'
388+ Just r' -> rowToBlocksList r'
365− Nothing -> []
389+ Nothing -> return []
366− cells = map (rowToBlocksList opts docx) rows
391+ cells <- mapM rowToBlocksList rows
368− size = case null hdrCells of
393+ let size = case null hdrCells of
369 True -> length $ head cells
394 True -> length $ head cells
370 False -> length $ hdrCells
395 False -> length $ hdrCells
@@ -374,34 +399,42 @@ bodyPartToBlocks opts docx (Tbl cap _ look (r:rs)) =
374 -- moment. Width information is in the TblGrid field of the Tbl,
399 -- moment. Width information is in the TblGrid field of the Tbl,
375 -- so should be possible. Alignment might be more difficult,
400 -- so should be possible. Alignment might be more difficult,
376 -- since there doesn't seem to be a column entity in docx.
401 -- since there doesn't seem to be a column entity in docx.
377− alignments = take size (repeat AlignDefault)
402+ alignments = replicate size AlignDefault
378− widths = take size (repeat 0) :: [Double]
403+ widths = replicate size 0 :: [Double]
380− [Table caption alignments widths hdrCells cells]
405+ return [Table caption alignments widths hdrCells cells]
383−makeImagesSelfContained :: Docx -> Inline -> Inline
408+makeImagesSelfContained :: Inline -> DocxContext Inline
384−makeImagesSelfContained (Docx _ _ _ _ media) i@(Image alt (uri, title)) =
409+makeImagesSelfContained i@(Image alt (uri, title)) = do
410+ (Docx _ _ _ _ media) <- asks docxDocument
385− case lookup uri media of
411+ return $ case lookup uri media of
386− Just bs -> case getMimeType uri of
413+ case getMimeType uri of
387− Just mime -> let data_uri =
414+ Just mime ->
415+ let data_uri = "data:" ++ mime ++ ";base64," ++
388− "data:" ++ mime ++ ";base64," ++ toString (encode $ BS.concat $ B.toChunks bs)
416+ toString (encode $ BS.concat $ B.toChunks bs)
390− Image alt (data_uri, title)
418+ Image alt (data_uri, title)
391− Nothing -> i
419+ Nothing -> i
392 Nothing -> i
420 Nothing -> i
393−makeImagesSelfContained _ inline = inline
421+makeImagesSelfContained inline = return inline
395−bodyToBlocks :: ReaderOptions -> Docx -> Body -> [Block]
423+bodyToBlocks :: Body -> DocxContext [Block]
396−bodyToBlocks opts docx (Body bps) =
424+bodyToBlocks (Body bps) = do
425+ blks <- concatMapM bodyPartToBlocks bps
397− map (makeHeaderAnchors) $
427+ map (makeHeaderAnchors) $
398− blocksToDefinitions $
428+ blocksToDefinitions $
399− blocksToBullets $
429+ blocksToBullets $ blks
400− concatMap (bodyPartToBlocks opts docx) bps
402docxToBlocks :: ReaderOptions -> Docx -> [Block]
431docxToBlocks :: ReaderOptions -> Docx -> [Block]
403−docxToBlocks opts d@(Docx (Document _ body) _ _ _ _) = bodyToBlocks opts d body
432+docxToBlocks opts d@(Docx (Document _ body) _ _ _ _) =
404−
433+ let dState = DState { docxHdrLinks = M.empty }
434+ dEnv = DEnv { docxOptions = opts
437+ evalDocxContext (bodyToBlocks body) dEnv dState
406ilToCode :: Inline -> String
439ilToCode :: Inline -> String
407ilToCode (Str s) = s
440ilToCode (Str s) = s