Improvements to docx writer.
Avoid reading image files again when we've already processed them.
This commit is contained in:
John MacFarlane
parent
4e4c3537e0
commit
2a0ed1c433
1 changed files with 63 additions and 65 deletions
|
|
@ -59,7 +59,7 @@ data WriterState = WriterState{
|
|||
, stFootnotes :: [Element]
|
||||
, stSectionIds :: [String]
|
||||
, stExternalLinks :: M.Map String String
|
||||
, stImages :: M.Map FilePath (String, B.ByteString)
|
||||
, stImages :: M.Map FilePath (String, String, Element, B.ByteString)
|
||||
, stListLevel :: Int
|
||||
, stListNumId :: Int
|
||||
, stNumStyles :: M.Map ListMarker Int
|
||||
|
|
@ -112,13 +112,7 @@ writeDocx opts doc@(Pandoc (Meta tit auths date) _) = do
|
|||
defaultWriterState
|
||||
epochtime <- floor `fmap` getPOSIXTime
|
||||
let imgs = M.elems $ stImages st
|
||||
let imgPath ident img = "media/" ++ ident ++
|
||||
case imageType img of
|
||||
Just Png -> ".png"
|
||||
Just Jpeg -> ".jpeg"
|
||||
Just Gif -> ".gif"
|
||||
Nothing -> ""
|
||||
let toImgRel (ident,img) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"),("Id",ident),("Target",imgPath ident img)] ()
|
||||
let toImgRel (ident,path,_,_) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"),("Id",ident),("Target",path)] ()
|
||||
let newrels = map toImgRel imgs
|
||||
let relpath = "word/_rels/document.xml.rels"
|
||||
let reldoc = case findEntryByPath relpath refArchive >>=
|
||||
|
|
@ -127,8 +121,7 @@ writeDocx opts doc@(Pandoc (Meta tit auths date) _) = do
|
|||
Nothing -> error $ relpath ++ "missing in reference docx"
|
||||
let reldoc' = reldoc{ elContent = elContent reldoc ++ map Elem newrels }
|
||||
-- create entries for images
|
||||
let toImageEntry (ident,img) = toEntry ("word/" ++ imgPath ident img)
|
||||
epochtime $ toLazy img
|
||||
let toImageEntry (_,path,_,img) = toEntry ("word/" ++ path) epochtime $ toLazy img
|
||||
let imageEntries = map toImageEntry imgs
|
||||
-- NOW get list of external links and images from this, and do what's needed
|
||||
let toLinkRel (src,ident) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink"),("Id",ident),("Target",src),("TargetMode","External") ] ()
|
||||
|
|
@ -626,61 +619,66 @@ inlineToOpenXML opts (Link txt (src,_)) = do
|
|||
return i
|
||||
return [ mknode "w:hyperlink" [("r:id",id')] contents ]
|
||||
inlineToOpenXML opts (Image alt (src, tit)) = do
|
||||
res <- liftIO $ E.try $ getItem (writerUserDataDir opts) src
|
||||
-- res is Right (img, maybeMIMEString) or Left err
|
||||
case res of
|
||||
Left (_ :: E.SomeException) -> do
|
||||
liftIO $ warn $ "Could not find image `" ++ src ++ "', skipping..."
|
||||
inlinesToOpenXML opts alt
|
||||
Right (img, _) -> do
|
||||
imgs <- gets stImages
|
||||
-- TODO move this check to before the getItem
|
||||
-- also TODO, instead of storing ident, imagebs; store
|
||||
-- the whole Element, so we don't have to reconstruct it at all.
|
||||
(ident,size) <- case M.lookup src imgs of
|
||||
Just (i,img') -> return (i, imageSize img')
|
||||
Nothing -> do
|
||||
ident' <- ("rId"++) `fmap` getUniqueId
|
||||
let size' = imageSize img
|
||||
modify $ \st -> st{
|
||||
stImages = M.insert src (ident',img) $ stImages st }
|
||||
return (ident',size')
|
||||
let (xpt,ypt) = maybe (120,120) sizeInPoints size
|
||||
-- 12700 emu = 1 pt
|
||||
let (xemu,yemu) = (xpt * 12700, ypt * 12700)
|
||||
let cNvPicPr = mknode "pic:cNvPicPr" [] $
|
||||
mknode "a:picLocks" [("noChangeArrowheads","1"),("noChangeAspect","1")] ()
|
||||
let nvPicPr = mknode "pic:nvPicPr" []
|
||||
[ mknode "pic:cNvPr"
|
||||
[("descr",src),("id","0"),("name","Picture")] ()
|
||||
, cNvPicPr ]
|
||||
let blipFill = mknode "pic:blipFill" []
|
||||
[ mknode "a:blip" [("r:embed",ident)] ()
|
||||
, mknode "a:stretch" [] $ mknode "a:fillRect" [] () ]
|
||||
let xfrm = mknode "a:xfrm" []
|
||||
[ mknode "a:off" [("x","0"),("y","0")] ()
|
||||
, mknode "a:ext" [("cx",show xemu),("cy",show yemu)] () ]
|
||||
let prstGeom = mknode "a:prstGeom" [("prst","rect")] $
|
||||
mknode "a:avLst" [] ()
|
||||
let ln = mknode "a:ln" [("w","9525")]
|
||||
[ mknode "a:noFill" [] ()
|
||||
, mknode "a:headEnd" [] ()
|
||||
, mknode "a:tailEnd" [] () ]
|
||||
let spPr = mknode "pic:spPr" [("bwMode","auto")]
|
||||
[xfrm, prstGeom, mknode "a:noFill" [] (), ln]
|
||||
let graphic = mknode "a:graphic" [] $
|
||||
mknode "a:graphicData" [("uri","http://schemas.openxmlformats.org/drawingml/2006/picture")]
|
||||
[ mknode "pic:pic" []
|
||||
[ nvPicPr
|
||||
, blipFill
|
||||
, spPr ] ]
|
||||
return [ mknode "w:r" [] $
|
||||
mknode "w:drawing" [] $
|
||||
mknode "wp:inline" []
|
||||
[ mknode "wp:extent" [("cx",show xemu),("cy",show yemu)] ()
|
||||
, mknode "wp:effectExtent" [("b","0"),("l","0"),("r","0"),("t","0")] ()
|
||||
, mknode "wp:docPr" [("descr",tit),("id","1"),("name","Picture")] ()
|
||||
, graphic ] ]
|
||||
-- first, check to see if we've already done this image
|
||||
imgs <- gets stImages
|
||||
case M.lookup src imgs of
|
||||
Just (_,_,elt,_) -> return [elt]
|
||||
Nothing -> do
|
||||
res <- liftIO $ E.try $ getItem (writerUserDataDir opts) src
|
||||
case res of
|
||||
Left (_ :: E.SomeException) -> do
|
||||
liftIO $ warn $ "Could not find image `" ++ src ++ "', skipping..."
|
||||
-- emit alt text
|
||||
inlinesToOpenXML opts alt
|
||||
Right (img, _) -> do
|
||||
ident <- ("rId"++) `fmap` getUniqueId
|
||||
let size = imageSize img
|
||||
let (xpt,ypt) = maybe (120,120) sizeInPoints size
|
||||
-- 12700 emu = 1 pt
|
||||
let (xemu,yemu) = (xpt * 12700, ypt * 12700)
|
||||
let cNvPicPr = mknode "pic:cNvPicPr" [] $
|
||||
mknode "a:picLocks" [("noChangeArrowheads","1"),("noChangeAspect","1")] ()
|
||||
let nvPicPr = mknode "pic:nvPicPr" []
|
||||
[ mknode "pic:cNvPr"
|
||||
[("descr",src),("id","0"),("name","Picture")] ()
|
||||
, cNvPicPr ]
|
||||
let blipFill = mknode "pic:blipFill" []
|
||||
[ mknode "a:blip" [("r:embed",ident)] ()
|
||||
, mknode "a:stretch" [] $ mknode "a:fillRect" [] () ]
|
||||
let xfrm = mknode "a:xfrm" []
|
||||
[ mknode "a:off" [("x","0"),("y","0")] ()
|
||||
, mknode "a:ext" [("cx",show xemu),("cy",show yemu)] () ]
|
||||
let prstGeom = mknode "a:prstGeom" [("prst","rect")] $
|
||||
mknode "a:avLst" [] ()
|
||||
let ln = mknode "a:ln" [("w","9525")]
|
||||
[ mknode "a:noFill" [] ()
|
||||
, mknode "a:headEnd" [] ()
|
||||
, mknode "a:tailEnd" [] () ]
|
||||
let spPr = mknode "pic:spPr" [("bwMode","auto")]
|
||||
[xfrm, prstGeom, mknode "a:noFill" [] (), ln]
|
||||
let graphic = mknode "a:graphic" [] $
|
||||
mknode "a:graphicData" [("uri","http://schemas.openxmlformats.org/drawingml/2006/picture")]
|
||||
[ mknode "pic:pic" []
|
||||
[ nvPicPr
|
||||
, blipFill
|
||||
, spPr ] ]
|
||||
let imgElt = mknode "w:r" [] $
|
||||
mknode "w:drawing" [] $
|
||||
mknode "wp:inline" []
|
||||
[ mknode "wp:extent" [("cx",show xemu),("cy",show yemu)] ()
|
||||
, mknode "wp:effectExtent" [("b","0"),("l","0"),("r","0"),("t","0")] ()
|
||||
, mknode "wp:docPr" [("descr",tit),("id","1"),("name","Picture")] ()
|
||||
, graphic ]
|
||||
modify $ \st -> st{ stImages = M.insert src (ident, imgPath ident img, imgElt, img) $ stImages st }
|
||||
return [imgElt]
|
||||
|
||||
imgPath :: String -> B.ByteString -> String
|
||||
imgPath ident img = "media/" ++ ident ++
|
||||
case imageType img of
|
||||
Just Png -> ".png"
|
||||
Just Jpeg -> ".jpeg"
|
||||
Just Gif -> ".gif"
|
||||
Nothing -> ""
|
||||
|
||||
br :: Element
|
||||
br = mknode "w:r" [] [mknode "w:cr" [] () ]
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue