diff options
Diffstat (limited to 'src/Text/Pandoc/Writers/Docx.hs')
| -rw-r--r-- | src/Text/Pandoc/Writers/Docx.hs | 923 |
1 files changed, 518 insertions, 405 deletions
diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index 3fc5d22a2..4542389a2 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE ScopedTypeVariables, PatternGuards, ViewPatterns #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} {- -Copyright (C) 2012-2015 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -19,7 +22,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Docx - Copyright : Copyright (C) 2012-2015 John MacFarlane + Copyright : Copyright (C) 2012-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -29,44 +32,44 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to docx. -} module Text.Pandoc.Writers.Docx ( writeDocx ) where -import Data.List ( intercalate, isPrefixOf, isSuffixOf ) +import Codec.Archive.Zip +import Control.Applicative ((<|>)) +import Control.Monad.Except (catchError) +import Control.Monad.Reader +import Control.Monad.State.Strict import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Char (isSpace, ord, toLower) +import Data.List (intercalate, isPrefixOf, isSuffixOf) import qualified Data.Map as M +import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) import qualified Data.Set as Set -import qualified Text.Pandoc.UTF8 as UTF8 -import Codec.Archive.Zip +import qualified Data.Text as T import Data.Time.Clock.POSIX -import System.Environment +import Skylighting +import System.Random (randomR, StdGen, mkStdGen) +import Text.Pandoc.BCP47 (getLang, renderLang) +import Text.Pandoc.Class (PandocMonad, report, toLang) +import qualified Text.Pandoc.Class as P import Text.Pandoc.Compat.Time import Text.Pandoc.Definition import Text.Pandoc.Generic +import Text.Pandoc.Highlighting (highlight) import Text.Pandoc.ImageSize -import Text.Pandoc.Shared hiding (Element) -import Text.Pandoc.Writers.Shared (fixDisplayMath) +import Text.Pandoc.Logging +import Text.Pandoc.MIME (MimeType, extensionFromMimeType, getMimeType, + getMimeTypeDef) import Text.Pandoc.Options -import Text.Pandoc.Readers.TeXMath -import Text.Pandoc.Highlighting ( highlight ) -import Text.Pandoc.Walk -import Text.XML.Light as XML -import Text.TeXMath import Text.Pandoc.Readers.Docx.StyleMap -import Text.Pandoc.Readers.Docx.Util (elemName) -import Control.Monad.Reader -import Control.Monad.State -import Skylighting -import Data.Unique (hashUnique, newUnique) -import System.Random (randomRIO) +import Text.Pandoc.Shared hiding (Element) +import Text.Pandoc.Walk +import Text.Pandoc.Writers.Math +import Text.Pandoc.Writers.Shared (fixDisplayMath, metaValueToInlines) import Text.Printf (printf) -import qualified Control.Exception as E -import Data.Monoid ((<>)) -import qualified Data.Text as T -import Text.Pandoc.MIME (MimeType, getMimeType, getMimeTypeDef, - extensionFromMimeType) -import Control.Applicative ((<|>)) -import Data.Maybe (fromMaybe, mapMaybe, maybeToList, isNothing) -import Data.Char (ord, isSpace, toLower) +import Text.TeXMath +import Text.XML.Light as XML +import Text.XML.Light.Cursor as XMLC +import Text.Pandoc.Writers.OOXML data ListMarker = NoMarker | BulletMarker @@ -79,28 +82,28 @@ listMarkerToId BulletMarker = "991" listMarkerToId (NumberMarker sty delim n) = '9' : '9' : styNum : delimNum : show n where styNum = case sty of - DefaultStyle -> '2' - Example -> '3' - Decimal -> '4' - LowerRoman -> '5' - UpperRoman -> '6' - LowerAlpha -> '7' - UpperAlpha -> '8' + DefaultStyle -> '2' + Example -> '3' + Decimal -> '4' + LowerRoman -> '5' + UpperRoman -> '6' + LowerAlpha -> '7' + UpperAlpha -> '8' delimNum = case delim of - DefaultDelim -> '0' - Period -> '1' - OneParen -> '2' - TwoParens -> '3' + DefaultDelim -> '0' + Period -> '1' + OneParen -> '2' + TwoParens -> '3' data WriterEnv = WriterEnv{ envTextProperties :: [Element] , envParaProperties :: [Element] - , envRTL :: Bool - , envListLevel :: Int - , envListNumId :: Int - , envInDel :: Bool - , envChangesAuthor :: String - , envChangesDate :: String - , envPrintWidth :: Integer + , envRTL :: Bool + , envListLevel :: Int + , envListNumId :: Int + , envInDel :: Bool + , envChangesAuthor :: String + , envChangesDate :: String + , envPrintWidth :: Integer } defaultWriterEnv :: WriterEnv @@ -117,22 +120,25 @@ defaultWriterEnv = WriterEnv{ envTextProperties = [] data WriterState = WriterState{ stFootnotes :: [Element] + , stComments :: [([(String,String)], [Inline])] , stSectionIds :: Set.Set String , stExternalLinks :: M.Map String String - , stImages :: M.Map FilePath (String, String, Maybe MimeType, Element, B.ByteString) + , stImages :: M.Map FilePath (String, String, Maybe MimeType, B.ByteString) , stLists :: [ListMarker] , stInsId :: Int , stDelId :: Int , stStyleMaps :: StyleMaps , stFirstPara :: Bool , stTocTitle :: [Inline] - , stDynamicParaProps :: [String] - , stDynamicTextProps :: [String] + , stDynamicParaProps :: Set.Set String + , stDynamicTextProps :: Set.Set String + , stCurId :: Int } defaultWriterState :: WriterState defaultWriterState = WriterState{ stFootnotes = defaultFootnotes + , stComments = [] , stSectionIds = Set.empty , stExternalLinks = M.empty , stImages = M.empty @@ -141,44 +147,29 @@ defaultWriterState = WriterState{ , stDelId = 1 , stStyleMaps = defaultStyleMaps , stFirstPara = False - , stTocTitle = normalizeInlines [Str "Table of Contents"] - , stDynamicParaProps = [] - , stDynamicTextProps = [] + , stTocTitle = [Str "Table of Contents"] + , stDynamicParaProps = Set.empty + , stDynamicTextProps = Set.empty + , stCurId = 20 } -type WS = ReaderT WriterEnv (StateT WriterState IO) - -mknode :: Node t => String -> [(String,String)] -> t -> Element -mknode s attrs = - add_attrs (map (\(k,v) -> Attr (nodename k) v) attrs) . node (nodename s) +type WS m = ReaderT WriterEnv (StateT WriterState m) -nodename :: String -> QName -nodename s = QName{ qName = name, qURI = Nothing, qPrefix = prefix } - where (name, prefix) = case break (==':') s of - (xs,[]) -> (xs, Nothing) - (ys, _:zs) -> (zs, Just ys) - -toLazy :: B.ByteString -> BL.ByteString -toLazy = BL.fromChunks . (:[]) - -renderXml :: Element -> BL.ByteString -renderXml elt = BL8.pack "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" <> - UTF8.fromStringLazy (showElement elt) renumIdMap :: Int -> [Element] -> M.Map String String renumIdMap _ [] = M.empty renumIdMap n (e:es) | Just oldId <- findAttr (QName "Id" Nothing Nothing) e = - M.insert oldId ("rId" ++ (show n)) (renumIdMap (n+1) es) + M.insert oldId ("rId" ++ show n) (renumIdMap (n+1) es) | otherwise = renumIdMap n es replaceAttr :: (QName -> Bool) -> String -> [XML.Attr] -> [XML.Attr] replaceAttr _ _ [] = [] replaceAttr f val (a:as) | f (attrKey a) = - (XML.Attr (attrKey a) val) : (replaceAttr f val as) - | otherwise = a : (replaceAttr f val as) + XML.Attr (attrKey a) val : replaceAttr f val as + | otherwise = a : replaceAttr f val as -renumId :: (QName -> Bool) -> (M.Map String String) -> Element -> Element +renumId :: (QName -> Bool) -> M.Map String String -> Element -> Element renumId f renumMap e | Just oldId <- findAttrBy f e , Just newId <- M.lookup oldId renumMap = @@ -187,7 +178,7 @@ renumId f renumMap e e { elAttribs = attrs' } | otherwise = e -renumIds :: (QName -> Bool) -> (M.Map String String) -> [Element] -> [Element] +renumIds :: (QName -> Bool) -> M.Map String String -> [Element] -> [Element] renumIds f renumMap = map (renumId f renumMap) -- | Certain characters are invalid in XML even if escaped. @@ -206,38 +197,36 @@ isValidChar (ord -> c) | 0x10000 <= c && c <= 0x10FFFF = True | otherwise = False -metaValueToInlines :: MetaValue -> [Inline] -metaValueToInlines (MetaString s) = normalizeInlines [Str s] -metaValueToInlines (MetaInlines ils) = ils -metaValueToInlines (MetaBlocks bs) = query return bs -metaValueToInlines (MetaBool b) = [Str $ show b] -metaValueToInlines _ = [] - --- | Produce an Docx file from a Pandoc document. -writeDocx :: WriterOptions -- ^ Writer options +writeDocx :: (PandocMonad m) + => WriterOptions -- ^ Writer options -> Pandoc -- ^ Document to convert - -> IO BL.ByteString + -> m BL.ByteString writeDocx opts doc@(Pandoc meta _) = do - let datadir = writerUserDataDir opts - let doc' = walk fixDisplayMath $ doc - username <- lookup "USERNAME" <$> getEnvironment - utctime <- getCurrentTime - distArchive <- getDefaultReferenceDocx datadir - refArchive <- case writerReferenceDocx opts of - Just f -> liftM (toArchive . toLazy) $ B.readFile f - Nothing -> getDefaultReferenceDocx datadir + let doc' = walk fixDisplayMath doc + username <- P.lookupEnv "USERNAME" + utctime <- P.getCurrentTime + distArchive <- (toArchive . BL.fromStrict) <$> do + oldUserDataDir <- P.getUserDataDir + P.setUserDataDir Nothing + res <- P.readDefaultDataFile "reference.docx" + P.setUserDataDir oldUserDataDir + return res + refArchive <- case writerReferenceDoc opts of + Just f -> toArchive <$> P.readFileLazy f + Nothing -> (toArchive . BL.fromStrict) <$> + P.readDataFile "reference.docx" parsedDoc <- parseXml refArchive distArchive "word/document.xml" let wname f qn = qPrefix qn == Just "w" && f (qName qn) let mbsectpr = filterElementName (wname (=="sectPr")) parsedDoc -- Gets the template size - let mbpgsz = mbsectpr >>= (filterElementName (wname (=="pgSz"))) - let mbAttrSzWidth = (elAttribs <$> mbpgsz) >>= (lookupAttrBy ((=="w") . qName)) + let mbpgsz = mbsectpr >>= filterElementName (wname (=="pgSz")) + let mbAttrSzWidth = (elAttribs <$> mbpgsz) >>= lookupAttrBy ((=="w") . qName) - let mbpgmar = mbsectpr >>= (filterElementName (wname (=="pgMar"))) - let mbAttrMarLeft = (elAttribs <$> mbpgmar) >>= (lookupAttrBy ((=="left") . qName)) - let mbAttrMarRight = (elAttribs <$> mbpgmar) >>= (lookupAttrBy ((=="right") . qName)) + let mbpgmar = mbsectpr >>= filterElementName (wname (=="pgMar")) + let mbAttrMarLeft = (elAttribs <$> mbpgmar) >>= lookupAttrBy ((=="left") . qName) + let mbAttrMarRight = (elAttribs <$> mbpgmar) >>= lookupAttrBy ((=="right") . qName) -- Get the avaible area (converting the size and the margins to int and -- doing the difference @@ -248,8 +237,29 @@ writeDocx opts doc@(Pandoc meta _) = do ) -- styles + mblang <- toLang $ getLang opts meta + let addLang :: Element -> Element + addLang e = case mblang >>= \l -> + (return . XMLC.toTree . go (renderLang l) + . XMLC.fromElement) e of + Just (Elem e') -> e' + _ -> e -- return original + where go :: String -> Cursor -> Cursor + go l cursor = case XMLC.findRec (isLangElt . current) cursor of + Nothing -> cursor + Just t -> XMLC.modifyContent (setval l) t + setval :: String -> Content -> Content + setval l (Elem e') = Elem $ e'{ elAttribs = map (setvalattr l) $ + elAttribs e' } + setval _ x = x + setvalattr :: String -> XML.Attr -> XML.Attr + setvalattr l (XML.Attr qn@(QName "val" _ _) _) = XML.Attr qn l + setvalattr _ x = x + isLangElt (Elem e') = qName (elName e') == "lang" + isLangElt _ = False + let stylepath = "word/styles.xml" - styledoc <- parseXml refArchive distArchive stylepath + styledoc <- addLang <$> parseXml refArchive distArchive stylepath -- parse styledoc for heading styles let styleMaps = getStyleMaps styledoc @@ -271,20 +281,20 @@ writeDocx opts doc@(Pandoc meta _) = do envRTL = isRTLmeta , envChangesAuthor = fromMaybe "unknown" username , envChangesDate = formatTime defaultTimeLocale "%FT%XZ" utctime - , envPrintWidth = (maybe 420 (\x -> quot x 20) pgContentWidth) + , envPrintWidth = maybe 420 (\x -> quot x 20) pgContentWidth } - ((contents, footnotes), st) <- runStateT - (runReaderT - (writeOpenXML opts{writerWrapText = WrapNone} doc') - env) - initialSt + ((contents, footnotes, comments), st) <- runStateT + (runReaderT + (writeOpenXML opts{writerWrapText = WrapNone} doc') + env) + initialSt let epochtime = floor $ utcTimeToPOSIXSeconds utctime let imgs = M.elems $ stImages st -- create entries for images in word/media/... - let toImageEntry (_,path,_,_,img) = toEntry ("word/" ++ path) epochtime $ toLazy img + let toImageEntry (_,path,_,img) = toEntry ("word/" ++ path) epochtime $ toLazy img let imageEntries = map toImageEntry imgs let stdAttributes = @@ -316,7 +326,7 @@ writeDocx opts doc@(Pandoc meta _) = do -- [Content_Types].xml let mkOverrideNode (part', contentType') = mknode "Override" [("PartName",part'),("ContentType",contentType')] () - let mkImageOverride (_, imgpath, mbMimeType, _, _) = + let mkImageOverride (_, imgpath, mbMimeType, _) = mkOverrideNode ("/word/" ++ imgpath, fromMaybe "application/octet-stream" mbMimeType) let mkMediaOverride imgpath = @@ -340,6 +350,8 @@ writeDocx opts doc@(Pandoc meta _) = do "application/vnd.openxmlformats-officedocument.wordprocessingml.styles+xml") ,("/word/document.xml", "application/vnd.openxmlformats-officedocument.wordprocessingml.document.main+xml") + ,("/word/comments.xml", + "application/vnd.openxmlformats-officedocument.wordprocessingml.comments+xml") ,("/word/footnotes.xml", "application/vnd.openxmlformats-officedocument.wordprocessingml.footnotes+xml") ] ++ @@ -386,13 +398,16 @@ writeDocx opts doc@(Pandoc meta _) = do ,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/footnotes", "rId7", "footnotes.xml") + ,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments", + "rId8", + "comments.xml") ] let idMap = renumIdMap (length baserels' + 1) (headers ++ footers) let renumHeaders = renumIds (\q -> qName q == "Id") idMap headers let renumFooters = renumIds (\q -> qName q == "Id") idMap footers let baserels = baserels' ++ renumHeaders ++ renumFooters - let toImgRel (ident,path,_,_,_) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"),("Id",ident),("Target",path)] () + let toImgRel (ident,path,_,_) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"),("Id",ident),("Target",path)] () let imgrels = map toImgRel imgs let toLinkRel (src,ident) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink"),("Id",ident),("Target",src),("TargetMode","External") ] () let linkrels = map toLinkRel $ M.toList $ stExternalLinks st @@ -409,7 +424,7 @@ writeDocx opts doc@(Pandoc meta _) = do (elChildren sectpr') in add_attrs (elAttribs sectpr') $ mknode "w:sectPr" [] cs - Nothing -> (mknode "w:sectPr" [] ()) + Nothing -> mknode "w:sectPr" [] () -- let sectpr = fromMaybe (mknode "w:sectPr" [] ()) mbsectpr' let contents' = contents ++ [sectpr] @@ -431,6 +446,10 @@ writeDocx opts doc@(Pandoc meta _) = do $ renderXml $ mknode "Relationships" [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")] linkrels + -- comments + let commentsEntry = toEntry "word/comments.xml" epochtime + $ renderXml $ mknode "w:comments" stdAttributes comments + -- styles -- We only want to inject paragraph and text properties that @@ -438,26 +457,19 @@ writeDocx opts doc@(Pandoc meta _) = do -- are normalized as lowercase. let newDynamicParaProps = filter (\sty -> isNothing $ M.lookup (toLower <$> sty) $ getMap $ sParaStyleMap styleMaps) - (stDynamicParaProps st) + (Set.toList $ stDynamicParaProps st) newDynamicTextProps = filter (\sty -> isNothing $ M.lookup (toLower <$> sty) $ getMap $ sCharStyleMap styleMaps) - (stDynamicTextProps st) + (Set.toList $ stDynamicTextProps st) let newstyles = map newParaPropToOpenXml newDynamicParaProps ++ map newTextPropToOpenXml newDynamicTextProps ++ - (styleToOpenXml styleMaps $ writerHighlightStyle opts) - let styledoc' = styledoc{ elContent = modifyContent (elContent styledoc) } - where - modifyContent - | writerHighlight opts = (++ map Elem newstyles) - | otherwise = filter notTokStyle - notTokStyle (Elem el) = notStyle el || notTokId el - notTokStyle _ = True - notStyle = (/= elemName' "style") . elName - notTokId = maybe True (`notElem` tokStys) . findAttr (elemName' "styleId") - tokStys = "SourceCode" : map show (enumFromTo KeywordTok NormalTok) - elemName' = elemName (sNameSpaces styleMaps) "w" + (case writerHighlightStyle opts of + Nothing -> [] + Just sty -> styleToOpenXml styleMaps sty) + let styledoc' = styledoc{ elContent = elContent styledoc ++ + map Elem newstyles } let styleEntry = toEntry stylepath epochtime $ renderXml styledoc' -- construct word/numbering.xml @@ -472,6 +484,11 @@ writeDocx opts doc@(Pandoc meta _) = do , qName (elName e) == "abstractNum" ] ++ [Elem e | e <- allElts , qName (elName e) == "num" ] } + + let keywords = case lookupMeta "keywords" meta of + Just (MetaList xs) -> map stringify xs + _ -> [] + let docPropsPath = "docProps/core.xml" let docProps = mknode "cp:coreProperties" [("xmlns:cp","http://schemas.openxmlformats.org/package/2006/metadata/core-properties") @@ -481,6 +498,7 @@ writeDocx opts doc@(Pandoc meta _) = do ,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")] $ mknode "dc:title" [] (stringify $ docTitle meta) : mknode "dc:creator" [] (intercalate "; " (map stringify $ docAuthors meta)) + : mknode "cp:keywords" [] (intercalate ", " keywords) : (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x ]) (formatTime defaultTimeLocale "%FT%XZ" utctime) @@ -509,6 +527,7 @@ writeDocx opts doc@(Pandoc meta _) = do , "w:consecutiveHyphenLimit" , "w:hyphenationZone" , "w:doNotHyphenateCap" + , "w:evenAndOddHeaders" ] settingsEntry <- copyChildren refArchive distArchive settingsPath epochtime settingsList @@ -535,6 +554,7 @@ writeDocx opts doc@(Pandoc meta _) = do let archive = foldr addEntryToArchive emptyArchive $ contentTypesEntry : relsEntry : contentEntry : relEntry : footnoteRelEntry : numEntry : styleEntry : footnotesEntry : + commentsEntry : docPropsEntry : docPropsAppEntry : themeEntry : fontTableEntry : settingsEntry : webSettingsEntry : imageEntries ++ headerFooterEntries ++ @@ -583,12 +603,12 @@ styleToOpenXml sm style = [ mknode "w:u" [] () | tokFeature tokenUnderline toktype ] ] tokStyles = tokenStyles style - tokFeature f toktype = maybe False f $ lookup toktype tokStyles + tokFeature f toktype = maybe False f $ M.lookup toktype tokStyles tokCol toktype = maybe "auto" (drop 1 . fromColor) - $ (tokenColor =<< lookup toktype tokStyles) + $ (tokenColor =<< M.lookup toktype tokStyles) `mplus` defaultColor style tokBg toktype = maybe "auto" (drop 1 . fromColor) - $ (tokenBackground =<< lookup toktype tokStyles) + $ (tokenBackground =<< M.lookup toktype tokStyles) `mplus` backgroundColor style parStyle | hasStyleName "Source Code" (sParaStyleMap sm) = Nothing | otherwise = Just $ @@ -599,11 +619,11 @@ styleToOpenXml sm style = , mknode "w:link" [("w:val","VerbatimChar")] () , mknode "w:pPr" [] $ mknode "w:wordWrap" [("w:val","off")] () - : ( maybe [] (\col -> [mknode "w:shd" [("w:val","clear"),("w:fill",drop 1 $ fromColor col)] ()]) - $ backgroundColor style ) + : + maybe [] (\col -> [mknode "w:shd" [("w:val","clear"),("w:fill",drop 1 $ fromColor col)] ()]) (backgroundColor style) ] -copyChildren :: Archive -> Archive -> String -> Integer -> [String] -> IO Entry +copyChildren :: (PandocMonad m) => Archive -> Archive -> String -> Integer -> [String] -> m Entry copyChildren refArchive distArchive path timestamp elNames = do ref <- parseXml refArchive distArchive path dist <- parseXml distArchive distArchive path @@ -622,11 +642,14 @@ copyChildren refArchive distArchive path timestamp elNames = do baseListId :: Int baseListId = 1000 -mkNumbering :: [ListMarker] -> IO [Element] +mkNumbering :: (PandocMonad m) => [ListMarker] -> m [Element] mkNumbering lists = do - elts <- mapM mkAbstractNum (ordNub lists) + elts <- evalStateT (mapM mkAbstractNum (ordNub lists)) (mkStdGen 1848) return $ elts ++ zipWith mkNum lists [baseListId..(baseListId + length lists - 1)] +maxListLevel :: Int +maxListLevel = 8 + mkNum :: ListMarker -> Int -> Element mkNum marker numid = mknode "w:num" [("w:numId",show numid)] @@ -636,15 +659,19 @@ mkNum marker numid = BulletMarker -> [] NumberMarker _ _ start -> map (\lvl -> mknode "w:lvlOverride" [("w:ilvl",show (lvl :: Int))] - $ mknode "w:startOverride" [("w:val",show start)] ()) [0..6] + $ mknode "w:startOverride" [("w:val",show start)] ()) + [0..maxListLevel] -mkAbstractNum :: ListMarker -> IO Element +mkAbstractNum :: (PandocMonad m) => ListMarker -> StateT StdGen m Element mkAbstractNum marker = do - nsid <- randomRIO (0x10000000 :: Integer, 0xFFFFFFFF :: Integer) + gen <- get + let (nsid, gen') = randomR (0x10000000 :: Integer, 0xFFFFFFFF :: Integer) gen + put gen' return $ mknode "w:abstractNum" [("w:abstractNumId",listMarkerToId marker)] $ mknode "w:nsid" [("w:val", printf "%8x" nsid)] () : mknode "w:multiLevelType" [("w:val","multilevel")] () - : map (mkLvl marker) [0..6] + : map (mkLvl marker) + [0..maxListLevel] mkLvl :: ListMarker -> Int -> Element mkLvl marker lvl = @@ -675,33 +702,35 @@ mkLvl marker lvl = bulletFor 3 = "\x2013" bulletFor 4 = "\x2022" bulletFor 5 = "\x2013" - bulletFor _ = "\x2022" - styleFor UpperAlpha _ = "upperLetter" - styleFor LowerAlpha _ = "lowerLetter" - styleFor UpperRoman _ = "upperRoman" - styleFor LowerRoman _ = "lowerRoman" - styleFor Decimal _ = "decimal" + bulletFor x = bulletFor (x `mod` 6) + styleFor UpperAlpha _ = "upperLetter" + styleFor LowerAlpha _ = "lowerLetter" + styleFor UpperRoman _ = "upperRoman" + styleFor LowerRoman _ = "lowerRoman" + styleFor Decimal _ = "decimal" styleFor DefaultStyle 1 = "decimal" styleFor DefaultStyle 2 = "lowerLetter" styleFor DefaultStyle 3 = "lowerRoman" styleFor DefaultStyle 4 = "decimal" styleFor DefaultStyle 5 = "lowerLetter" - styleFor DefaultStyle 6 = "lowerRoman" - styleFor _ _ = "decimal" - patternFor OneParen s = s ++ ")" + styleFor DefaultStyle 0 = "lowerRoman" + styleFor DefaultStyle x = styleFor DefaultStyle (x `mod` 6) + styleFor _ _ = "decimal" + patternFor OneParen s = s ++ ")" patternFor TwoParens s = "(" ++ s ++ ")" - patternFor _ s = s ++ "." + patternFor _ s = s ++ "." -getNumId :: WS Int +getNumId :: (PandocMonad m) => WS m Int getNumId = (((baseListId - 1) +) . length) `fmap` gets stLists -makeTOC :: WriterOptions -> WS [Element] + +makeTOC :: (PandocMonad m) => WriterOptions -> WS m [Element] makeTOC opts | writerTableOfContents opts = do - let depth = "1-"++(show (writerTOCDepth opts)) + let depth = "1-"++show (writerTOCDepth opts) let tocCmd = "TOC \\o \""++depth++"\" \\h \\z \\u" tocTitle <- gets stTocTitle title <- withParaPropM (pStyleM "TOC Heading") (blocksToOpenXML opts [Para tocTitle]) - return $ + return [mknode "w:sdt" [] ([ mknode "w:sdtPr" [] ( mknode "w:docPartObj" [] ( @@ -725,22 +754,20 @@ makeTOC _ = return [] -- | Convert Pandoc document to two lists of -- OpenXML elements (the main document and footnotes). -writeOpenXML :: WriterOptions -> Pandoc -> WS ([Element], [Element]) +writeOpenXML :: (PandocMonad m) => WriterOptions -> Pandoc -> WS m ([Element], [Element],[Element]) writeOpenXML opts (Pandoc meta blocks) = do - let tit = docTitle meta ++ case lookupMeta "subtitle" meta of - Just (MetaBlocks [Plain xs]) -> LineBreak : xs - _ -> [] + let tit = docTitle meta let auths = docAuthors meta let dat = docDate meta let abstract' = case lookupMeta "abstract" meta of - Just (MetaBlocks bs) -> bs + Just (MetaBlocks bs) -> bs Just (MetaInlines ils) -> [Plain ils] - _ -> [] + _ -> [] let subtitle' = case lookupMeta "subtitle" meta of Just (MetaBlocks [Plain xs]) -> xs Just (MetaBlocks [Para xs]) -> xs Just (MetaInlines xs) -> xs - _ -> [] + _ -> [] title <- withParaPropM (pStyleM "Title") $ blocksToOpenXML opts [Para tit | not (null tit)] subtitle <- withParaPropM (pStyleM "Subtitle") $ blocksToOpenXML opts [Para subtitle' | not (null subtitle')] authors <- withParaProp (pCustomStyle "Author") $ blocksToOpenXML opts $ @@ -750,23 +777,40 @@ writeOpenXML opts (Pandoc meta blocks) = do then return [] else withParaProp (pCustomStyle "Abstract") $ blocksToOpenXML opts abstract' let convertSpace (Str x : Space : Str y : xs) = Str (x ++ " " ++ y) : xs - convertSpace (Str x : Str y : xs) = Str (x ++ y) : xs - convertSpace xs = xs + convertSpace (Str x : Str y : xs) = Str (x ++ y) : xs + convertSpace xs = xs let blocks' = bottomUp convertSpace blocks - doc' <- (setFirstPara >> blocksToOpenXML opts blocks') - notes' <- reverse `fmap` gets stFootnotes + doc' <- setFirstPara >> blocksToOpenXML opts blocks' + notes' <- reverse <$> gets stFootnotes + comments <- reverse <$> gets stComments + let toComment (kvs, ils) = do + annotation <- inlinesToOpenXML opts ils + return $ + mknode "w:comment" [('w':':':k,v) | (k,v) <- kvs] + [ mknode "w:p" [] $ + [ mknode "w:pPr" [] + [ mknode "w:pStyle" [("w:val", "CommentText")] () ] + , mknode "w:r" [] + [ mknode "w:rPr" [] + [ mknode "w:rStyle" [("w:val", "CommentReference")] () + , mknode "w:annotationRef" [] () + ] + ] + ] ++ annotation + ] + comments' <- mapM toComment comments toc <- makeTOC opts let meta' = title ++ subtitle ++ authors ++ date ++ abstract ++ toc - return (meta' ++ doc', notes') + return (meta' ++ doc', notes', comments') -- | Convert a list of Pandoc blocks to OpenXML. -blocksToOpenXML :: WriterOptions -> [Block] -> WS [Element] +blocksToOpenXML :: (PandocMonad m) => WriterOptions -> [Block] -> WS m [Element] blocksToOpenXML opts bls = concat `fmap` mapM (blockToOpenXML opts) bls pCustomStyle :: String -> Element pCustomStyle sty = mknode "w:pStyle" [("w:val",sty)] () -pStyleM :: String -> WS XML.Element +pStyleM :: (PandocMonad m) => String -> WS m XML.Element pStyleM styleName = do styleMaps <- gets stStyleMaps let sty' = getStyleId styleName $ sParaStyleMap styleMaps @@ -775,61 +819,75 @@ pStyleM styleName = do rCustomStyle :: String -> Element rCustomStyle sty = mknode "w:rStyle" [("w:val",sty)] () -rStyleM :: String -> WS XML.Element +rStyleM :: (PandocMonad m) => String -> WS m XML.Element rStyleM styleName = do styleMaps <- gets stStyleMaps let sty' = getStyleId styleName $ sCharStyleMap styleMaps return $ mknode "w:rStyle" [("w:val",sty')] () -getUniqueId :: MonadIO m => m String +getUniqueId :: (PandocMonad m) => WS m String -- the + 20 is to ensure that there are no clashes with the rIds -- already in word/document.xml.rel -getUniqueId = liftIO $ (show . (+ 20) . hashUnique) `fmap` newUnique +getUniqueId = do + n <- gets stCurId + modify $ \st -> st{stCurId = n + 1} + return $ show n -- | Key for specifying user-defined docx styles. dynamicStyleKey :: String dynamicStyleKey = "custom-style" -- | Convert a Pandoc block element to OpenXML. -blockToOpenXML :: WriterOptions -> Block -> WS [Element] +blockToOpenXML :: (PandocMonad m) => WriterOptions -> Block -> WS m [Element] blockToOpenXML opts blk = withDirection $ blockToOpenXML' opts blk -blockToOpenXML' :: WriterOptions -> Block -> WS [Element] +blockToOpenXML' :: (PandocMonad m) => WriterOptions -> Block -> WS m [Element] blockToOpenXML' _ Null = return [] -blockToOpenXML' opts (Div (ident,classes,kvs) bs) - | Just sty <- lookup dynamicStyleKey kvs = do - modify $ \s -> s{stDynamicParaProps = sty : (stDynamicParaProps s)} - withParaPropM (pStyleM sty) $ blocksToOpenXML opts bs - | Just "rtl" <- lookup "dir" kvs = do - let kvs' = filter (("dir", "rtl")/=) kvs - local (\env -> env { envRTL = True }) $ - blockToOpenXML opts (Div (ident,classes,kvs') bs) - | Just "ltr" <- lookup "dir" kvs = do - let kvs' = filter (("dir", "ltr")/=) kvs - local (\env -> env { envRTL = False }) $ - blockToOpenXML opts (Div (ident,classes,kvs') bs) -blockToOpenXML' opts (Div (_,["references"],_) bs) = do - let (hs, bs') = span isHeaderBlock bs - header <- blocksToOpenXML opts hs - -- We put the Bibliography style on paragraphs after the header - rest <- withParaPropM (pStyleM "Bibliography") $ blocksToOpenXML opts bs' - return (header ++ rest) -blockToOpenXML' opts (Div _ bs) = blocksToOpenXML opts bs +blockToOpenXML' opts (Div (ident,classes,kvs) bs) = do + stylemod <- case lookup dynamicStyleKey kvs of + Just sty -> do + modify $ \s -> + s{stDynamicParaProps = Set.insert sty + (stDynamicParaProps s)} + return $ withParaPropM (pStyleM sty) + _ -> return id + dirmod <- case lookup "dir" kvs of + Just "rtl" -> return $ local (\env -> env { envRTL = True }) + Just "ltr" -> return $ local (\env -> env { envRTL = False }) + _ -> return id + let (hs, bs') = if "references" `elem` classes + then span isHeaderBlock bs + else ([], bs) + let bibmod = if "references" `elem` classes + then withParaPropM (pStyleM "Bibliography") + else id + header <- dirmod $ stylemod $ blocksToOpenXML opts hs + contents <- dirmod $ bibmod $ stylemod $ blocksToOpenXML opts bs' + if null ident + then return $ header ++ contents + else do + id' <- getUniqueId + let bookmarkStart = mknode "w:bookmarkStart" [("w:id", id') + ,("w:name",ident)] () + let bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] () + return $ bookmarkStart : header ++ contents ++ [bookmarkEnd] blockToOpenXML' opts (Header lev (ident,_,_) lst) = do setFirstPara paraProps <- withParaPropM (pStyleM ("Heading "++show lev)) $ getParaProps False contents <- inlinesToOpenXML opts lst - usedIdents <- gets stSectionIds - let bookmarkName = if null ident - then uniqueIdent lst usedIdents - else ident - modify $ \s -> s{ stSectionIds = Set.insert bookmarkName $ stSectionIds s } - id' <- getUniqueId - let bookmarkStart = mknode "w:bookmarkStart" [("w:id", id') + if null ident + then return [mknode "w:p" [] (paraProps ++contents)] + else do + let bookmarkName = ident + modify $ \s -> s{ stSectionIds = Set.insert bookmarkName + $ stSectionIds s } + id' <- getUniqueId + let bookmarkStart = mknode "w:bookmarkStart" [("w:id", id') ,("w:name",bookmarkName)] () - let bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] () - return [mknode "w:p" [] (paraProps ++ [bookmarkStart, bookmarkEnd] ++ contents)] + let bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] () + return [mknode "w:p" [] (paraProps ++ + [bookmarkStart] ++ contents ++ [bookmarkEnd])] blockToOpenXML' opts (Plain lst) = withParaProp (pCustomStyle "Compact") $ blockToOpenXML opts (Para lst) -- title beginning with fig: indicates that the image is a figure @@ -838,31 +896,34 @@ blockToOpenXML' opts (Para [Image attr alt (src,'f':'i':'g':':':tit)]) = do let prop = pCustomStyle $ if null alt then "Figure" - else "FigureWithCaption" + else "CaptionedFigure" paraProps <- local (\env -> env { envParaProperties = prop : envParaProperties env }) (getParaProps False) contents <- inlinesToOpenXML opts [Image attr alt (src,tit)] captionNode <- withParaProp (pCustomStyle "ImageCaption") $ blockToOpenXML opts (Para alt) return $ mknode "w:p" [] (paraProps ++ contents) : captionNode --- fixDisplayMath sometimes produces a Para [] as artifact -blockToOpenXML' _ (Para []) = return [] -blockToOpenXML' opts (Para lst) = do - isFirstPara <- gets stFirstPara - paraProps <- getParaProps $ case lst of - [Math DisplayMath _] -> True - _ -> False - bodyTextStyle <- pStyleM "Body Text" - let paraProps' = case paraProps of - [] | isFirstPara -> [mknode "w:pPr" [] [pCustomStyle "FirstParagraph"]] - [] -> [mknode "w:pPr" [] [bodyTextStyle]] - ps -> ps - modify $ \s -> s { stFirstPara = False } - contents <- inlinesToOpenXML opts lst - return [mknode "w:p" [] (paraProps' ++ contents)] +blockToOpenXML' opts (Para lst) + | null lst && not (isEnabled Ext_empty_paragraphs opts) = return [] + | otherwise = do + isFirstPara <- gets stFirstPara + paraProps <- getParaProps $ case lst of + [Math DisplayMath _] -> True + _ -> False + bodyTextStyle <- pStyleM "Body Text" + let paraProps' = case paraProps of + [] | isFirstPara -> [mknode "w:pPr" [] + [pCustomStyle "FirstParagraph"]] + [] -> [mknode "w:pPr" [] [bodyTextStyle]] + ps -> ps + modify $ \s -> s { stFirstPara = False } + contents <- inlinesToOpenXML opts lst + return [mknode "w:p" [] (paraProps' ++ contents)] blockToOpenXML' opts (LineBlock lns) = blockToOpenXML opts $ linesToPara lns -blockToOpenXML' _ (RawBlock format str) +blockToOpenXML' _ b@(RawBlock format str) | format == Format "openxml" = return [ x | Elem x <- parseXML str ] - | otherwise = return [] + | otherwise = do + report $ BlockNotRendered b + return [] blockToOpenXML' opts (BlockQuote blocks) = do p <- withParaPropM (pStyleM "Block Text") $ blocksToOpenXML opts blocks setFirstPara @@ -914,9 +975,9 @@ blockToOpenXML' opts (Table caption aligns widths headers rows) = do caption' ++ [mknode "w:tbl" [] ( mknode "w:tblPr" [] - ( mknode "w:tblStyle" [("w:val","TableNormal")] () : + ( mknode "w:tblStyle" [("w:val","Table")] () : mknode "w:tblW" [("w:type", "pct"), ("w:w", show rowwidth)] () : - mknode "w:tblLook" [("w:firstRow","1") | hasHeader ] () : + mknode "w:tblLook" [("w:firstRow",if hasHeader then "1" else "0") ] () : [ mknode "w:tblCaption" [("w:val", captionStr)] () | not (null caption) ] ) : mknode "w:tblGrid" [] @@ -945,7 +1006,7 @@ blockToOpenXML' opts (DefinitionList items) = do setFirstPara return l -definitionListItemToOpenXML :: WriterOptions -> ([Inline],[[Block]]) -> WS [Element] +definitionListItemToOpenXML :: (PandocMonad m) => WriterOptions -> ([Inline],[[Block]]) -> WS m [Element] definitionListItemToOpenXML opts (term,defs) = do term' <- withParaProp (pCustomStyle "DefinitionTerm") $ blockToOpenXML opts (Para term) @@ -953,12 +1014,12 @@ definitionListItemToOpenXML opts (term,defs) = do $ concat `fmap` mapM (blocksToOpenXML opts) defs return $ term' ++ defs' -addList :: ListMarker -> WS () +addList :: (PandocMonad m) => ListMarker -> WS m () addList marker = do lists <- gets stLists modify $ \st -> st{ stLists = lists ++ [marker] } -listItemToOpenXML :: WriterOptions -> Int -> [Block] -> WS [Element] +listItemToOpenXML :: (PandocMonad m) => WriterOptions -> Int -> [Block] -> WS m [Element] listItemToOpenXML _ _ [] = return [] listItemToOpenXML opts numid (first:rest) = do first' <- withNumId numid $ blockToOpenXML opts first @@ -968,121 +1029,162 @@ listItemToOpenXML opts numid (first:rest) = do alignmentToString :: Alignment -> [Char] alignmentToString alignment = case alignment of - AlignLeft -> "left" - AlignRight -> "right" - AlignCenter -> "center" + AlignLeft -> "left" + AlignRight -> "right" + AlignCenter -> "center" AlignDefault -> "left" -- | Convert a list of inline elements to OpenXML. -inlinesToOpenXML :: WriterOptions -> [Inline] -> WS [Element] +inlinesToOpenXML :: (PandocMonad m) => WriterOptions -> [Inline] -> WS m [Element] inlinesToOpenXML opts lst = concat `fmap` mapM (inlineToOpenXML opts) lst -withNumId :: Int -> WS a -> WS a +withNumId :: (PandocMonad m) => Int -> WS m a -> WS m a withNumId numid = local $ \env -> env{ envListNumId = numid } -asList :: WS a -> WS a +asList :: (PandocMonad m) => WS m a -> WS m a asList = local $ \env -> env{ envListLevel = envListLevel env + 1 } -getTextProps :: WS [Element] +getTextProps :: (PandocMonad m) => WS m [Element] getTextProps = do props <- asks envTextProperties return $ if null props then [] else [mknode "w:rPr" [] props] -withTextProp :: Element -> WS a -> WS a +withTextProp :: PandocMonad m => Element -> WS m a -> WS m a withTextProp d p = local (\env -> env {envTextProperties = d : envTextProperties env}) p -withTextPropM :: WS Element -> WS a -> WS a +withTextPropM :: PandocMonad m => WS m Element -> WS m a -> WS m a withTextPropM = (. flip withTextProp) . (>>=) -getParaProps :: Bool -> WS [Element] +getParaProps :: PandocMonad m => Bool -> WS m [Element] getParaProps displayMathPara = do props <- asks envParaProperties listLevel <- asks envListLevel numid <- asks envListNumId - let listPr = if listLevel >= 0 && not displayMathPara - then [ mknode "w:numPr" [] - [ mknode "w:numId" [("w:val",show numid)] () - , mknode "w:ilvl" [("w:val",show listLevel)] () ] - ] - else [] + let listPr = [mknode "w:numPr" [] + [ mknode "w:numId" [("w:val",show numid)] () + , mknode "w:ilvl" [("w:val",show listLevel)] () ] | listLevel >= 0 && not displayMathPara] return $ case props ++ listPr of [] -> [] ps -> [mknode "w:pPr" [] ps] -withParaProp :: Element -> WS a -> WS a +withParaProp :: PandocMonad m => Element -> WS m a -> WS m a withParaProp d p = local (\env -> env {envParaProperties = d : envParaProperties env}) p -withParaPropM :: WS Element -> WS a -> WS a +withParaPropM :: PandocMonad m => WS m Element -> WS m a -> WS m a withParaPropM = (. flip withParaProp) . (>>=) -formattedString :: String -> WS [Element] -formattedString str = do - props <- getTextProps +formattedString :: PandocMonad m => String -> WS m [Element] +formattedString str = + -- properly handle soft hyphens + case splitBy (=='\173') str of + [w] -> formattedString' w + ws -> do + sh <- formattedRun [mknode "w:softHyphen" [] ()] + intercalate sh <$> mapM formattedString' ws + +formattedString' :: PandocMonad m => String -> WS m [Element] +formattedString' str = do inDel <- asks envInDel - return [ mknode "w:r" [] $ - props ++ - [ mknode (if inDel then "w:delText" else "w:t") - [("xml:space","preserve")] (stripInvalidChars str) ] ] + formattedRun [ mknode (if inDel then "w:delText" else "w:t") + [("xml:space","preserve")] (stripInvalidChars str) ] -setFirstPara :: WS () +formattedRun :: PandocMonad m => [Element] -> WS m [Element] +formattedRun els = do + props <- getTextProps + return [ mknode "w:r" [] $ props ++ els ] + +setFirstPara :: PandocMonad m => WS m () setFirstPara = modify $ \s -> s { stFirstPara = True } -- | Convert an inline element to OpenXML. -inlineToOpenXML :: WriterOptions -> Inline -> WS [Element] +inlineToOpenXML :: PandocMonad m => WriterOptions -> Inline -> WS m [Element] inlineToOpenXML opts il = withDirection $ inlineToOpenXML' opts il -inlineToOpenXML' :: WriterOptions -> Inline -> WS [Element] -inlineToOpenXML' _ (Str str) = formattedString str +inlineToOpenXML' :: PandocMonad m => WriterOptions -> Inline -> WS m [Element] +inlineToOpenXML' _ (Str str) = + formattedString str inlineToOpenXML' opts Space = inlineToOpenXML opts (Str " ") inlineToOpenXML' opts SoftBreak = inlineToOpenXML opts (Str " ") -inlineToOpenXML' opts (Span (ident,classes,kvs) ils) - | Just sty <- lookup dynamicStyleKey kvs = do - let kvs' = filter ((dynamicStyleKey, sty)/=) kvs - modify $ \s -> s{stDynamicTextProps = sty : (stDynamicTextProps s)} - withTextProp (rCustomStyle sty) $ - inlineToOpenXML opts (Span (ident,classes,kvs') ils) - | Just "rtl" <- lookup "dir" kvs = do - let kvs' = filter (("dir", "rtl")/=) kvs - local (\env -> env { envRTL = True }) $ - inlineToOpenXML opts (Span (ident,classes,kvs') ils) - | Just "ltr" <- lookup "dir" kvs = do - let kvs' = filter (("dir", "ltr")/=) kvs - local (\env -> env { envRTL = False }) $ - inlineToOpenXML opts (Span (ident,classes,kvs') ils) - | "insertion" `elem` classes = do - defaultAuthor <- asks envChangesAuthor - defaultDate <- asks envChangesDate - let author = fromMaybe defaultAuthor (lookup "author" kvs) - date = fromMaybe defaultDate (lookup "date" kvs) - insId <- gets stInsId - modify $ \s -> s{stInsId = (insId + 1)} - x <- inlinesToOpenXML opts ils - return [ mknode "w:ins" [("w:id", (show insId)), - ("w:author", author), - ("w:date", date)] - x ] - | "deletion" `elem` classes = do - defaultAuthor <- asks envChangesAuthor - defaultDate <- asks envChangesDate - let author = fromMaybe defaultAuthor (lookup "author" kvs) - date = fromMaybe defaultDate (lookup "date" kvs) - delId <- gets stDelId - modify $ \s -> s{stDelId = (delId + 1)} - x <- local (\env -> env {envInDel = True}) (inlinesToOpenXML opts ils) - return [ mknode "w:del" [("w:id", (show delId)), - ("w:author", author), - ("w:date", date)] - x ] - | otherwise = do - let off x = withTextProp (mknode x [("w:val","0")] ()) - ((if "csl-no-emph" `elem` classes then off "w:i" else id) . - (if "csl-no-strong" `elem` classes then off "w:b" else id) . - (if "csl-no-smallcaps" `elem` classes then off "w:smallCaps" else id)) - $ inlinesToOpenXML opts ils +inlineToOpenXML' _ (Span (ident,["comment-start"],kvs) ils) = do + -- prefer the "id" in kvs, since that is the one produced by the docx + -- reader. + let ident' = fromMaybe ident (lookup "id" kvs) + kvs' = filter (("id" /=) . fst) kvs + modify $ \st -> st{ stComments = (("id",ident'):kvs', ils) : stComments st } + return [ mknode "w:commentRangeStart" [("w:id", ident')] () ] +inlineToOpenXML' _ (Span (ident,["comment-end"],kvs) _) = + -- prefer the "id" in kvs, since that is the one produced by the docx + -- reader. + let ident' = fromMaybe ident (lookup "id" kvs) + in + return [ mknode "w:commentRangeEnd" [("w:id", ident')] () + , mknode "w:r" [] + [ mknode "w:rPr" [] + [ mknode "w:rStyle" [("w:val", "CommentReference")] () ] + , mknode "w:commentReference" [("w:id", ident')] () ] + ] +inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do + stylemod <- case lookup dynamicStyleKey kvs of + Just sty -> do + modify $ \s -> + s{stDynamicTextProps = Set.insert sty + (stDynamicTextProps s)} + return $ withTextPropM (rStyleM sty) + _ -> return id + let dirmod = case lookup "dir" kvs of + Just "rtl" -> local (\env -> env { envRTL = True }) + Just "ltr" -> local (\env -> env { envRTL = False }) + _ -> id + let off x = withTextProp (mknode x [("w:val","0")] ()) + let pmod = (if "csl-no-emph" `elem` classes then off "w:i" else id) . + (if "csl-no-strong" `elem` classes then off "w:b" else id) . + (if "csl-no-smallcaps" `elem` classes + then off "w:smallCaps" + else id) + insmod <- if "insertion" `elem` classes + then do + defaultAuthor <- asks envChangesAuthor + defaultDate <- asks envChangesDate + let author = fromMaybe defaultAuthor (lookup "author" kvs) + date = fromMaybe defaultDate (lookup "date" kvs) + insId <- gets stInsId + modify $ \s -> s{stInsId = insId + 1} + return $ \f -> do + x <- f + return [ mknode "w:ins" + [("w:id", show insId), + ("w:author", author), + ("w:date", date)] x ] + else return id + delmod <- if "deletion" `elem` classes + then do + defaultAuthor <- asks envChangesAuthor + defaultDate <- asks envChangesDate + let author = fromMaybe defaultAuthor (lookup "author" kvs) + date = fromMaybe defaultDate (lookup "date" kvs) + delId <- gets stDelId + modify $ \s -> s{stDelId = delId + 1} + return $ \f -> local (\env->env{envInDel=True}) $ do + x <- f + return [mknode "w:del" + [("w:id", show delId), + ("w:author", author), + ("w:date", date)] x] + else return id + contents <- insmod $ delmod $ dirmod $ stylemod $ pmod + $ inlinesToOpenXML opts ils + if null ident + then return contents + else do + id' <- getUniqueId + let bookmarkStart = mknode "w:bookmarkStart" [("w:id", id') + ,("w:name",ident)] () + let bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] () + return $ bookmarkStart : contents ++ [bookmarkEnd] inlineToOpenXML' opts (Strong lst) = withTextProp (mknode "w:b" [] ()) $ inlinesToOpenXML opts lst inlineToOpenXML' opts (Emph lst) = @@ -1100,40 +1202,40 @@ inlineToOpenXML' opts (Strikeout lst) = withTextProp (mknode "w:strike" [] ()) $ inlinesToOpenXML opts lst inlineToOpenXML' _ LineBreak = return [br] -inlineToOpenXML' _ (RawInline f str) +inlineToOpenXML' _ il@(RawInline f str) | f == Format "openxml" = return [ x | Elem x <- parseXML str ] - | otherwise = return [] + | otherwise = do + report $ InlineNotRendered il + return [] inlineToOpenXML' opts (Quoted quoteType lst) = inlinesToOpenXML opts $ [Str open] ++ lst ++ [Str close] where (open, close) = case quoteType of SingleQuote -> ("\x2018", "\x2019") DoubleQuote -> ("\x201C", "\x201D") inlineToOpenXML' opts (Math mathType str) = do - let displayType = if mathType == DisplayMath - then DisplayBlock - else DisplayInline - when (displayType == DisplayBlock) setFirstPara - case writeOMML displayType <$> readTeX str of - Right r -> return [r] - Left e -> do - warn $ "Cannot convert the following TeX math, skipping:\n" ++ str ++ - "\n" ++ e - inlinesToOpenXML opts (texMathToInlines mathType str) + when (mathType == DisplayMath) setFirstPara + res <- (lift . lift) (convertMath writeOMML mathType str) + case res of + Right r -> return [r] + Left il -> inlineToOpenXML' opts il inlineToOpenXML' opts (Cite _ lst) = inlinesToOpenXML opts lst inlineToOpenXML' opts (Code attrs str) = do let unhighlighted = intercalate [br] `fmap` - (mapM formattedString $ lines str) + mapM formattedString (lines str) formatOpenXML _fmtOpts = intercalate [br] . map (map toHlTok) toHlTok (toktype,tok) = mknode "w:r" [] [ mknode "w:rPr" [] [ rCustomStyle (show toktype) ] , mknode "w:t" [("xml:space","preserve")] (T.unpack tok) ] withTextProp (rCustomStyle "VerbatimChar") - $ if writerHighlight opts - then case highlight formatOpenXML attrs str of - Nothing -> unhighlighted - Just h -> return h - else unhighlighted + $ if isNothing (writerHighlightStyle opts) + then unhighlighted + else case highlight (writerSyntaxMap opts) + formatOpenXML attrs str of + Right h -> return h + Left msg -> do + unless (null msg) $ report $ CouldNotHighlight msg + unhighlighted inlineToOpenXML' opts (Note bs) = do notes <- gets stFootnotes notenum <- getUniqueId @@ -1151,7 +1253,7 @@ inlineToOpenXML' opts (Note bs) = do , envTextProperties = [] }) (withParaPropM (pStyleM "Footnote Text") $ blocksToOpenXML opts $ insertNoteRef bs) - let newnote = mknode "w:footnote" [("w:id", notenum)] $ contents + let newnote = mknode "w:footnote" [("w:id", notenum)] contents modify $ \s -> s{ stFootnotes = newnote : notes } return [ mknode "w:r" [] [ mknode "w:rPr" [] footnoteStyle @@ -1173,81 +1275,109 @@ inlineToOpenXML' opts (Link _ txt (src,_)) = do return i return [ mknode "w:hyperlink" [("r:id",id')] contents ] inlineToOpenXML' opts (Image attr alt (src, title)) = do - -- first, check to see if we've already done this image pageWidth <- asks envPrintWidth imgs <- gets stImages - case M.lookup src imgs of - Just (_,_,_,elt,_) -> return [elt] - Nothing -> do - res <- liftIO $ - fetchItem' (writerMediaBag opts) (writerSourceURL opts) src - case res of - Left (_ :: E.SomeException) -> do - warn $ "Could not find image `" ++ src ++ "', skipping..." - -- emit alt text - inlinesToOpenXML opts alt - Right (img, mt) -> do - ident <- ("rId"++) `fmap` getUniqueId - let (xpt,ypt) = desiredSizeInPoints opts attr - (either (const def) id (imageSize img)) - -- 12700 emu = 1 pt - let (xemu,yemu) = fitToPage (xpt * 12700, ypt * 12700) (pageWidth * 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",stringify alt), ("title", title), ("id","1"),("name","Picture")] () - , graphic ] - let imgext = case mt >>= extensionFromMimeType of - Just x -> '.':x - Nothing -> case imageType img of - Just Png -> ".png" - Just Jpeg -> ".jpeg" - Just Gif -> ".gif" - Just Pdf -> ".pdf" - Just Eps -> ".eps" - Nothing -> "" - if null imgext - then -- without an extension there is no rule for content type - inlinesToOpenXML opts alt -- return alt to avoid corrupted docx - else do - let imgpath = "media/" ++ ident ++ imgext - let mbMimeType = mt <|> getMimeType imgpath - -- insert mime type to use in constructing [Content_Types].xml - modify $ \st -> st{ stImages = - M.insert src (ident, imgpath, mbMimeType, imgElt, img) - $ stImages st } - return [imgElt] + let + stImage = M.lookup src imgs + generateImgElt (ident, _, _, img) = + let + (xpt,ypt) = desiredSizeInPoints opts attr + (either (const def) id (imageSize opts img)) + -- 12700 emu = 1 pt + (xemu,yemu) = fitToPage (xpt * 12700, ypt * 12700) + (pageWidth * 12700) + cNvPicPr = mknode "pic:cNvPicPr" [] $ + mknode "a:picLocks" [("noChangeArrowheads","1") + ,("noChangeAspect","1")] () + nvPicPr = mknode "pic:nvPicPr" [] + [ mknode "pic:cNvPr" + [("descr",src),("id","0"),("name","Picture")] () + , cNvPicPr ] + blipFill = mknode "pic:blipFill" [] + [ mknode "a:blip" [("r:embed",ident)] () + , mknode "a:stretch" [] $ + mknode "a:fillRect" [] () + ] + xfrm = mknode "a:xfrm" [] + [ mknode "a:off" [("x","0"),("y","0")] () + , mknode "a:ext" [("cx",show xemu) + ,("cy",show yemu)] () ] + prstGeom = mknode "a:prstGeom" [("prst","rect")] $ + mknode "a:avLst" [] () + ln = mknode "a:ln" [("w","9525")] + [ mknode "a:noFill" [] () + , mknode "a:headEnd" [] () + , mknode "a:tailEnd" [] () ] + spPr = mknode "pic:spPr" [("bwMode","auto")] + [xfrm, prstGeom, mknode "a:noFill" [] (), ln] + graphic = mknode "a:graphic" [] $ + mknode "a:graphicData" + [("uri","http://schemas.openxmlformats.org/drawingml/2006/picture")] + [ mknode "pic:pic" [] + [ nvPicPr + , blipFill + , spPr + ] + ] + 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", stringify alt) + , ("title", title) + , ("id","1") + , ("name","Picture") + ] () + , graphic + ] + in + imgElt + + case stImage of + Just imgData -> return $ [generateImgElt imgData] + Nothing -> ( do --try + (img, mt) <- P.fetchItem src + ident <- ("rId"++) `fmap` getUniqueId + + let + imgext = case mt >>= extensionFromMimeType of + Just x -> '.':x + Nothing -> case imageType img of + Just Png -> ".png" + Just Jpeg -> ".jpeg" + Just Gif -> ".gif" + Just Pdf -> ".pdf" + Just Eps -> ".eps" + Just Svg -> ".svg" + Just Emf -> ".emf" + Nothing -> "" + imgpath = "media/" ++ ident ++ imgext + mbMimeType = mt <|> getMimeType imgpath + + imgData = (ident, imgpath, mbMimeType, img) + + if null imgext + then -- without an extension there is no rule for content type + inlinesToOpenXML opts alt -- return alt to avoid corrupted docx + else do + -- insert mime type to use in constructing [Content_Types].xml + modify $ \st -> st { stImages = M.insert src imgData $ stImages st } + return [generateImgElt imgData] + ) + `catchError` ( \e -> do + report $ CouldNotFetchResource src (show e) + -- emit alt text + inlinesToOpenXML opts alt + ) br :: Element -br = mknode "w:r" [] [mknode "w:br" [("w:type","textWrapping")] () ] +br = breakElement "textWrapping" + +breakElement :: String -> Element +breakElement kind = mknode "w:r" [] [mknode "w:br" [("w:type",kind)] () ] -- Word will insert these footnotes into the settings.xml file -- (whether or not they're visible in the document). If they're in the @@ -1255,35 +1385,18 @@ br = mknode "w:r" [] [mknode "w:br" [("w:type","textWrapping")] () ] -- problems. So we want to make sure we insert them into our document. defaultFootnotes :: [Element] defaultFootnotes = [ mknode "w:footnote" - [("w:type", "separator"), ("w:id", "-1")] $ + [("w:type", "separator"), ("w:id", "-1")] [ mknode "w:p" [] $ [mknode "w:r" [] $ [ mknode "w:separator" [] ()]]] , mknode "w:footnote" - [("w:type", "continuationSeparator"), ("w:id", "0")] $ + [("w:type", "continuationSeparator"), ("w:id", "0")] [ mknode "w:p" [] $ [ mknode "w:r" [] $ [ mknode "w:continuationSeparator" [] ()]]]] -parseXml :: Archive -> Archive -> String -> IO Element -parseXml refArchive distArchive relpath = - case findEntryByPath relpath refArchive `mplus` - findEntryByPath relpath distArchive of - Nothing -> fail $ relpath ++ " missing in reference docx" - Just e -> case parseXMLDoc . UTF8.toStringLazy . fromEntry $ e of - Nothing -> fail $ relpath ++ " corrupt in reference docx" - Just d -> return d - --- | Scales the image to fit the page --- sizes are passed in emu -fitToPage :: (Double, Double) -> Integer -> (Integer, Integer) -fitToPage (x, y) pageWidth - -- Fixes width to the page width and scales the height - | x > fromIntegral pageWidth = - (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y) - | otherwise = (floor x, floor y) - -withDirection :: WS a -> WS a + +withDirection :: PandocMonad m => WS m a -> WS m a withDirection x = do isRTL <- asks envRTL paraProps <- asks envParaProperties @@ -1296,8 +1409,8 @@ withDirection x = do if isRTL -- if we are going right-to-left, we (re?)add the properties. then flip local x $ - \env -> env { envParaProperties = (mknode "w:bidi" [] ()) : paraProps' - , envTextProperties = (mknode "w:rtl" [] ()) : textProps' + \env -> env { envParaProperties = mknode "w:bidi" [] () : paraProps' + , envTextProperties = mknode "w:rtl" [] () : textProps' } else flip local x $ \env -> env { envParaProperties = paraProps' , envTextProperties = textProps' |