2013-01-11 12:17:41 -08:00
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2012-01-03 12:10:10 -08:00
|
|
|
{-
|
|
|
|
|
Copyright (C) 2012 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
|
|
|
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
|
|
|
(at your option) any later version.
|
|
|
|
|
|
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
|
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
GNU General Public License for more details.
|
|
|
|
|
|
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
|
|
|
along with this program; if not, write to the Free Software
|
|
|
|
|
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
|
|
|
-}
|
|
|
|
|
|
|
|
|
|
{- |
|
|
|
|
|
Module : Text.Pandoc.Writers.Docx
|
|
|
|
|
Copyright : Copyright (C) 2012 John MacFarlane
|
|
|
|
|
License : GNU GPL, version 2 or above
|
|
|
|
|
|
|
|
|
|
Maintainer : John MacFarlane <jgm@berkeley.edu>
|
|
|
|
|
Stability : alpha
|
|
|
|
|
Portability : portable
|
|
|
|
|
|
|
|
|
|
Conversion of 'Pandoc' documents to docx.
|
|
|
|
|
-}
|
|
|
|
|
module Text.Pandoc.Writers.Docx ( writeDocx ) where
|
2013-02-26 22:59:21 -08:00
|
|
|
import Data.List ( intercalate, groupBy )
|
2013-01-11 12:17:41 -08:00
|
|
|
import qualified Data.ByteString as B
|
|
|
|
|
import qualified Data.ByteString.Lazy as BL
|
2013-07-12 20:58:15 +01:00
|
|
|
import qualified Data.ByteString.Lazy.Char8 as BL8
|
2012-01-03 12:10:10 -08:00
|
|
|
import qualified Data.Map as M
|
2012-09-25 19:54:21 -07:00
|
|
|
import qualified Text.Pandoc.UTF8 as UTF8
|
2013-08-08 10:41:39 -07:00
|
|
|
import Text.Pandoc.Compat.Monoid ((<>))
|
2012-01-03 12:10:10 -08:00
|
|
|
import Codec.Archive.Zip
|
2012-01-28 16:04:35 -08:00
|
|
|
import Data.Time.Clock.POSIX
|
2012-01-03 12:10:10 -08:00
|
|
|
import Text.Pandoc.Definition
|
|
|
|
|
import Text.Pandoc.Generic
|
|
|
|
|
import Text.Pandoc.ImageSize
|
|
|
|
|
import Text.Pandoc.Shared hiding (Element)
|
2012-07-26 22:59:56 -07:00
|
|
|
import Text.Pandoc.Options
|
2012-01-03 12:10:10 -08:00
|
|
|
import Text.Pandoc.Readers.TeXMath
|
|
|
|
|
import Text.Pandoc.Highlighting ( highlight )
|
2013-08-10 18:45:00 -07:00
|
|
|
import Text.Pandoc.Walk
|
2012-01-03 12:10:10 -08:00
|
|
|
import Text.Highlighting.Kate.Types ()
|
|
|
|
|
import Text.XML.Light
|
|
|
|
|
import Text.TeXMath
|
|
|
|
|
import Control.Monad.State
|
|
|
|
|
import Text.Highlighting.Kate
|
2012-10-02 19:20:51 -07:00
|
|
|
import Data.Unique (hashUnique, newUnique)
|
2012-10-02 19:43:18 -07:00
|
|
|
import System.Random (randomRIO)
|
|
|
|
|
import Text.Printf (printf)
|
2013-01-11 12:17:41 -08:00
|
|
|
import qualified Control.Exception as E
|
2013-11-19 13:16:31 -08:00
|
|
|
import Text.Pandoc.MIME (getMimeType, extensionFromMimeType)
|
|
|
|
|
import Control.Applicative ((<|>))
|
2012-01-03 12:10:10 -08:00
|
|
|
|
|
|
|
|
data WriterState = WriterState{
|
|
|
|
|
stTextProperties :: [Element]
|
|
|
|
|
, stParaProperties :: [Element]
|
|
|
|
|
, stFootnotes :: [Element]
|
|
|
|
|
, stSectionIds :: [String]
|
|
|
|
|
, stExternalLinks :: M.Map String String
|
2013-02-25 19:04:20 -08:00
|
|
|
, stImages :: M.Map FilePath (String, String, Maybe String, Element, B.ByteString)
|
2012-01-03 12:10:10 -08:00
|
|
|
, stListLevel :: Int
|
2012-09-05 16:23:40 -07:00
|
|
|
, stListNumId :: Int
|
2012-01-20 13:00:28 -08:00
|
|
|
, stNumStyles :: M.Map ListMarker Int
|
|
|
|
|
, stLists :: [ListMarker]
|
2012-01-03 12:10:10 -08:00
|
|
|
}
|
|
|
|
|
|
|
|
|
|
data ListMarker = NoMarker
|
|
|
|
|
| BulletMarker
|
|
|
|
|
| NumberMarker ListNumberStyle ListNumberDelim Int
|
|
|
|
|
deriving (Show, Read, Eq, Ord)
|
|
|
|
|
|
|
|
|
|
defaultWriterState :: WriterState
|
|
|
|
|
defaultWriterState = WriterState{
|
|
|
|
|
stTextProperties = []
|
|
|
|
|
, stParaProperties = []
|
|
|
|
|
, stFootnotes = []
|
|
|
|
|
, stSectionIds = []
|
|
|
|
|
, stExternalLinks = M.empty
|
|
|
|
|
, stImages = M.empty
|
2012-01-20 13:03:47 -08:00
|
|
|
, stListLevel = -1
|
2012-09-05 16:23:40 -07:00
|
|
|
, stListNumId = 1
|
2012-01-20 13:00:28 -08:00
|
|
|
, stNumStyles = M.fromList [(NoMarker, 0)]
|
|
|
|
|
, stLists = [NoMarker]
|
2012-01-03 12:10:10 -08:00
|
|
|
}
|
|
|
|
|
|
|
|
|
|
type WS a = StateT WriterState IO a
|
|
|
|
|
|
|
|
|
|
mknode :: Node t => String -> [(String,String)] -> t -> Element
|
|
|
|
|
mknode s attrs =
|
|
|
|
|
add_attrs (map (\(k,v) -> Attr (unqual k) v) attrs) . node (unqual s)
|
|
|
|
|
|
2013-01-11 12:17:41 -08:00
|
|
|
toLazy :: B.ByteString -> BL.ByteString
|
|
|
|
|
toLazy = BL.fromChunks . (:[])
|
|
|
|
|
|
2013-07-12 20:58:15 +01:00
|
|
|
renderXml :: Element -> BL.ByteString
|
|
|
|
|
renderXml elt = BL8.pack "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" <>
|
|
|
|
|
UTF8.fromStringLazy (showElement elt)
|
|
|
|
|
|
2012-01-03 12:10:10 -08:00
|
|
|
-- | Produce an Docx file from a Pandoc document.
|
2012-07-24 09:56:00 -07:00
|
|
|
writeDocx :: WriterOptions -- ^ Writer options
|
2012-01-03 12:10:10 -08:00
|
|
|
-> Pandoc -- ^ Document to convert
|
2013-01-11 12:17:41 -08:00
|
|
|
-> IO BL.ByteString
|
2013-05-10 22:53:35 -07:00
|
|
|
writeDocx opts doc@(Pandoc meta _) = do
|
2012-01-03 12:10:10 -08:00
|
|
|
let datadir = writerUserDataDir opts
|
2013-08-10 18:45:00 -07:00
|
|
|
let doc' = walk fixDisplayMath doc
|
2013-01-11 12:17:41 -08:00
|
|
|
refArchive <- liftM (toArchive . toLazy) $
|
2012-07-24 09:56:00 -07:00
|
|
|
case writerReferenceDocx opts of
|
2013-01-11 12:17:41 -08:00
|
|
|
Just f -> B.readFile f
|
|
|
|
|
Nothing -> readDataFile datadir "reference.docx"
|
2012-01-03 12:10:10 -08:00
|
|
|
|
2013-03-18 19:31:48 -07:00
|
|
|
((contents, footnotes), st) <- runStateT (writeOpenXML opts{writerWrapText = False} doc')
|
2012-01-03 12:10:10 -08:00
|
|
|
defaultWriterState
|
2012-01-28 16:04:35 -08:00
|
|
|
epochtime <- floor `fmap` getPOSIXTime
|
2012-01-03 12:10:10 -08:00
|
|
|
let imgs = M.elems $ stImages st
|
2013-02-26 20:29:01 -08:00
|
|
|
|
|
|
|
|
-- we create [Content_Types].xml and word/_rels/document.xml.rels
|
|
|
|
|
-- from scratch rather than reading from reference.docx,
|
|
|
|
|
-- because Word sometimes changes these files when a reference.docx is modified,
|
|
|
|
|
-- e.g. deleting the reference to footnotes.xml or removing default entries
|
|
|
|
|
-- for image content types.
|
|
|
|
|
|
|
|
|
|
-- [Content_Types].xml
|
|
|
|
|
let mkOverrideNode (part', contentType') = mknode "Override"
|
|
|
|
|
[("PartName",part'),("ContentType",contentType')] ()
|
|
|
|
|
let mkImageOverride (_, imgpath, mbMimeType, _, _) =
|
|
|
|
|
mkOverrideNode ("/word/" ++ imgpath, maybe "application/octet-stream" id mbMimeType)
|
|
|
|
|
let overrides = map mkOverrideNode
|
|
|
|
|
[("/word/webSettings.xml",
|
|
|
|
|
"application/vnd.openxmlformats-officedocument.wordprocessingml.webSettings+xml")
|
|
|
|
|
,("/word/numbering.xml",
|
|
|
|
|
"application/vnd.openxmlformats-officedocument.wordprocessingml.numbering+xml")
|
|
|
|
|
,("/word/settings.xml",
|
|
|
|
|
"application/vnd.openxmlformats-officedocument.wordprocessingml.settings+xml")
|
|
|
|
|
,("/word/theme/theme1.xml",
|
|
|
|
|
"application/vnd.openxmlformats-officedocument.theme+xml")
|
|
|
|
|
,("/word/fontTable.xml",
|
|
|
|
|
"application/vnd.openxmlformats-officedocument.wordprocessingml.fontTable+xml")
|
|
|
|
|
,("/docProps/app.xml",
|
|
|
|
|
"application/vnd.openxmlformats-officedocument.extended-properties+xml")
|
|
|
|
|
,("/docProps/core.xml",
|
|
|
|
|
"application/vnd.openxmlformats-package.core-properties+xml")
|
|
|
|
|
,("/word/styles.xml",
|
|
|
|
|
"application/vnd.openxmlformats-officedocument.wordprocessingml.styles+xml")
|
|
|
|
|
,("/word/document.xml",
|
|
|
|
|
"application/vnd.openxmlformats-officedocument.wordprocessingml.document.main+xml")
|
|
|
|
|
,("/word/footnotes.xml",
|
|
|
|
|
"application/vnd.openxmlformats-officedocument.wordprocessingml.footnotes+xml")
|
|
|
|
|
] ++ map mkImageOverride imgs
|
|
|
|
|
let defaultnodes = [mknode "Default"
|
|
|
|
|
[("Extension","xml"),("ContentType","application/xml")] (),
|
|
|
|
|
mknode "Default"
|
|
|
|
|
[("Extension","rels"),("ContentType","application/vnd.openxmlformats-package.relationships+xml")] ()]
|
|
|
|
|
let contentTypesDoc = mknode "Types" [("xmlns","http://schemas.openxmlformats.org/package/2006/content-types")] $ defaultnodes ++ overrides
|
|
|
|
|
let contentTypesEntry = toEntry "[Content_Types].xml" epochtime
|
2013-07-12 20:58:15 +01:00
|
|
|
$ renderXml contentTypesDoc
|
2013-02-25 19:04:20 -08:00
|
|
|
|
|
|
|
|
-- word/_rels/document.xml.rels
|
2013-02-26 20:29:01 -08:00
|
|
|
let toBaseRel (url', id', target') = mknode "Relationship"
|
|
|
|
|
[("Type",url')
|
|
|
|
|
,("Id",id')
|
|
|
|
|
,("Target",target')] ()
|
|
|
|
|
let baserels = map toBaseRel
|
|
|
|
|
[("http://schemas.openxmlformats.org/officeDocument/2006/relationships/numbering",
|
|
|
|
|
"rId1",
|
|
|
|
|
"numbering.xml")
|
|
|
|
|
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles",
|
|
|
|
|
"rId2",
|
|
|
|
|
"styles.xml")
|
|
|
|
|
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/settings",
|
|
|
|
|
"rId3",
|
|
|
|
|
"settings.xml")
|
|
|
|
|
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/webSettings",
|
|
|
|
|
"rId4",
|
|
|
|
|
"webSettings.xml")
|
|
|
|
|
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/fontTable",
|
|
|
|
|
"rId5",
|
|
|
|
|
"fontTable.xml")
|
|
|
|
|
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/theme",
|
|
|
|
|
"rId6",
|
|
|
|
|
"theme/theme1.xml")
|
|
|
|
|
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/footnotes",
|
|
|
|
|
"rId7",
|
|
|
|
|
"footnotes.xml")]
|
|
|
|
|
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
|
|
|
|
|
let reldoc = mknode "Relationships" [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")] $ baserels ++ imgrels ++ linkrels
|
|
|
|
|
let relEntry = toEntry "word/_rels/document.xml.rels" epochtime
|
2013-07-12 20:58:15 +01:00
|
|
|
$ renderXml reldoc
|
2013-02-25 19:04:20 -08:00
|
|
|
|
2013-02-26 20:29:01 -08:00
|
|
|
-- create entries for images in word/media/...
|
2013-02-25 19:04:20 -08:00
|
|
|
let toImageEntry (_,path,_,_,img) = toEntry ("word/" ++ path) epochtime $ toLazy img
|
2012-01-03 12:10:10 -08:00
|
|
|
let imageEntries = map toImageEntry imgs
|
2013-02-25 19:04:20 -08:00
|
|
|
|
2013-02-26 20:29:01 -08:00
|
|
|
-- word/document.xml
|
2013-07-12 20:58:15 +01:00
|
|
|
let contentEntry = toEntry "word/document.xml" epochtime $ renderXml contents
|
2013-02-25 19:04:20 -08:00
|
|
|
|
2013-01-06 10:00:53 -08:00
|
|
|
-- footnotes
|
2013-07-12 20:58:15 +01:00
|
|
|
let footnotesEntry = toEntry "word/footnotes.xml" epochtime $ renderXml footnotes
|
2013-02-25 19:04:20 -08:00
|
|
|
|
2013-01-06 10:00:53 -08:00
|
|
|
-- footnote rels
|
2013-07-12 20:58:15 +01:00
|
|
|
let footnoteRelEntry = toEntry "word/_rels/footnotes.xml.rels" epochtime
|
|
|
|
|
$ renderXml $ mknode "Relationships" [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")]
|
2013-02-26 20:29:01 -08:00
|
|
|
$ linkrels
|
2013-02-25 19:04:20 -08:00
|
|
|
|
2012-01-03 12:10:10 -08:00
|
|
|
-- styles
|
|
|
|
|
let newstyles = styleToOpenXml $ writerHighlightStyle opts
|
|
|
|
|
let stylepath = "word/styles.xml"
|
2013-02-25 19:04:20 -08:00
|
|
|
styledoc <- parseXml refArchive stylepath
|
2013-07-13 13:48:50 -07:00
|
|
|
let styledoc' = styledoc{ elContent = elContent styledoc ++
|
|
|
|
|
[Elem x | x <- newstyles, writerHighlight opts] }
|
2013-07-12 20:58:15 +01:00
|
|
|
let styleEntry = toEntry stylepath epochtime $ renderXml styledoc'
|
2013-02-25 19:04:20 -08:00
|
|
|
|
2012-01-03 12:10:10 -08:00
|
|
|
-- construct word/numbering.xml
|
|
|
|
|
let numpath = "word/numbering.xml"
|
2013-07-12 20:58:15 +01:00
|
|
|
numEntry <- (toEntry numpath epochtime . renderXml)
|
2012-10-02 19:43:18 -07:00
|
|
|
`fmap` mkNumbering (stNumStyles st) (stLists st)
|
2012-01-03 12:10:10 -08:00
|
|
|
let docPropsPath = "docProps/core.xml"
|
|
|
|
|
let docProps = mknode "cp:coreProperties"
|
|
|
|
|
[("xmlns:cp","http://schemas.openxmlformats.org/package/2006/metadata/core-properties")
|
|
|
|
|
,("xmlns:dc","http://purl.org/dc/elements/1.1/")
|
|
|
|
|
,("xmlns:dcterms","http://purl.org/dc/terms/")
|
|
|
|
|
,("xmlns:dcmitype","http://purl.org/dc/dcmitype/")
|
|
|
|
|
,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")]
|
2013-05-10 22:53:35 -07:00
|
|
|
$ mknode "dc:title" [] (stringify $ docTitle meta)
|
2013-11-07 08:46:52 -08:00
|
|
|
: mknode "dc:creator" [] (intercalate "; " (map stringify $ docAuthors meta))
|
|
|
|
|
: maybe []
|
|
|
|
|
(\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] $ x
|
|
|
|
|
, mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] $ x
|
|
|
|
|
]) (normalizeDate $ stringify $ docDate meta)
|
2013-07-12 20:58:15 +01:00
|
|
|
let docPropsEntry = toEntry docPropsPath epochtime $ renderXml docProps
|
|
|
|
|
|
2012-02-11 09:12:58 -08:00
|
|
|
let relsPath = "_rels/.rels"
|
2013-07-12 20:58:15 +01:00
|
|
|
let rels = mknode "Relationships" [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
|
|
|
|
|
$ map (\attrs -> mknode "Relationship" attrs ())
|
|
|
|
|
[ [("Id","rId1")
|
|
|
|
|
,("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument")
|
|
|
|
|
,("Target","word/document.xml")]
|
|
|
|
|
, [("Id","rId4")
|
|
|
|
|
,("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties")
|
|
|
|
|
,("Target","docProps/app.xml")]
|
|
|
|
|
, [("Id","rId3")
|
2013-11-06 19:18:24 -08:00
|
|
|
,("Type","http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties")
|
2013-07-12 20:58:15 +01:00
|
|
|
,("Target","docProps/core.xml")]
|
|
|
|
|
]
|
|
|
|
|
let relsEntry = toEntry relsPath epochtime $ renderXml rels
|
2013-02-25 19:04:20 -08:00
|
|
|
|
2013-07-12 20:58:15 +01:00
|
|
|
let entryFromArchive path = (toEntry path epochtime . renderXml) `fmap`
|
|
|
|
|
parseXml refArchive path
|
|
|
|
|
docPropsAppEntry <- entryFromArchive "docProps/app.xml"
|
|
|
|
|
themeEntry <- entryFromArchive "word/theme/theme1.xml"
|
|
|
|
|
fontTableEntry <- entryFromArchive "word/fontTable.xml"
|
2013-09-19 09:48:02 -07:00
|
|
|
settingsEntry <- entryFromArchive "word/settings.xml"
|
2013-07-12 20:58:15 +01:00
|
|
|
webSettingsEntry <- entryFromArchive "word/webSettings.xml"
|
2013-02-25 19:04:20 -08:00
|
|
|
|
|
|
|
|
-- Create archive
|
2013-07-12 20:58:15 +01:00
|
|
|
let archive = foldr addEntryToArchive emptyArchive $
|
|
|
|
|
contentTypesEntry : relsEntry : contentEntry : relEntry :
|
|
|
|
|
footnoteRelEntry : numEntry : styleEntry : footnotesEntry :
|
|
|
|
|
docPropsEntry : docPropsAppEntry : themeEntry :
|
2013-09-19 09:48:02 -07:00
|
|
|
fontTableEntry : settingsEntry : webSettingsEntry :
|
|
|
|
|
imageEntries
|
2012-01-03 12:10:10 -08:00
|
|
|
return $ fromArchive archive
|
|
|
|
|
|
|
|
|
|
styleToOpenXml :: Style -> [Element]
|
|
|
|
|
styleToOpenXml style = parStyle : map toStyle alltoktypes
|
|
|
|
|
where alltoktypes = enumFromTo KeywordTok NormalTok
|
|
|
|
|
toStyle toktype = mknode "w:style" [("w:type","character"),
|
|
|
|
|
("w:customStyle","1"),("w:styleId",show toktype)]
|
|
|
|
|
[ mknode "w:name" [("w:val",show toktype)] ()
|
|
|
|
|
, mknode "w:basedOn" [("w:val","VerbatimChar")] ()
|
|
|
|
|
, mknode "w:rPr" [] $
|
|
|
|
|
[ mknode "w:color" [("w:val",tokCol toktype)] ()
|
|
|
|
|
| tokCol toktype /= "auto" ] ++
|
|
|
|
|
[ mknode "w:shd" [("w:val","clear"),("w:fill",tokBg toktype)] ()
|
|
|
|
|
| tokBg toktype /= "auto" ] ++
|
|
|
|
|
[ mknode "w:b" [] () | tokFeature tokenBold toktype ] ++
|
|
|
|
|
[ mknode "w:i" [] () | tokFeature tokenItalic toktype ] ++
|
|
|
|
|
[ mknode "w:u" [] () | tokFeature tokenUnderline toktype ]
|
|
|
|
|
]
|
|
|
|
|
tokStyles = tokenStyles style
|
|
|
|
|
tokFeature f toktype = maybe False f $ lookup toktype tokStyles
|
|
|
|
|
tokCol toktype = maybe "auto" (drop 1 . fromColor)
|
|
|
|
|
$ (tokenColor =<< lookup toktype tokStyles)
|
|
|
|
|
`mplus` defaultColor style
|
|
|
|
|
tokBg toktype = maybe "auto" (drop 1 . fromColor)
|
|
|
|
|
$ (tokenBackground =<< lookup toktype tokStyles)
|
|
|
|
|
`mplus` backgroundColor style
|
|
|
|
|
parStyle = mknode "w:style" [("w:type","paragraph"),
|
|
|
|
|
("w:customStyle","1"),("w:styleId","SourceCode")]
|
|
|
|
|
[ mknode "w:name" [("w:val","Source Code")] ()
|
|
|
|
|
, mknode "w:basedOn" [("w:val","Normal")] ()
|
|
|
|
|
, 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 )
|
|
|
|
|
]
|
|
|
|
|
|
2012-10-02 19:43:18 -07:00
|
|
|
mkNumbering :: M.Map ListMarker Int -> [ListMarker] -> IO Element
|
|
|
|
|
mkNumbering markers lists = do
|
|
|
|
|
elts <- mapM mkAbstractNum (M.toList markers)
|
|
|
|
|
return $ mknode "w:numbering"
|
|
|
|
|
[("xmlns:w","http://schemas.openxmlformats.org/wordprocessingml/2006/main")]
|
|
|
|
|
$ elts ++ zipWith (mkNum markers) lists [1..(length lists)]
|
2012-01-03 12:10:10 -08:00
|
|
|
|
2012-01-20 13:00:28 -08:00
|
|
|
mkNum :: M.Map ListMarker Int -> ListMarker -> Int -> Element
|
|
|
|
|
mkNum markers marker numid =
|
2012-01-03 12:10:10 -08:00
|
|
|
mknode "w:num" [("w:numId",show numid)]
|
2012-01-20 13:00:28 -08:00
|
|
|
$ mknode "w:abstractNumId" [("w:val",show absnumid)] ()
|
|
|
|
|
: case marker of
|
|
|
|
|
NoMarker -> []
|
|
|
|
|
BulletMarker -> []
|
|
|
|
|
NumberMarker _ _ start ->
|
|
|
|
|
map (\lvl -> mknode "w:lvlOverride" [("w:ilvl",show (lvl :: Int))]
|
|
|
|
|
$ mknode "w:startOverride" [("w:val",show start)] ()) [0..6]
|
|
|
|
|
where absnumid = maybe 0 id $ M.lookup marker markers
|
2012-01-03 12:10:10 -08:00
|
|
|
|
2012-10-02 19:43:18 -07:00
|
|
|
mkAbstractNum :: (ListMarker,Int) -> IO Element
|
|
|
|
|
mkAbstractNum (marker,numid) = do
|
|
|
|
|
nsid <- randomRIO (0x10000000 :: Integer, 0xFFFFFFFF :: Integer)
|
|
|
|
|
return $ mknode "w:abstractNum" [("w:abstractNumId",show numid)]
|
|
|
|
|
$ mknode "w:nsid" [("w:val", printf "%8x" nsid)] ()
|
|
|
|
|
: mknode "w:multiLevelType" [("w:val","multilevel")] ()
|
2012-01-03 12:10:10 -08:00
|
|
|
: map (mkLvl marker) [0..6]
|
|
|
|
|
|
|
|
|
|
mkLvl :: ListMarker -> Int -> Element
|
|
|
|
|
mkLvl marker lvl =
|
|
|
|
|
mknode "w:lvl" [("w:ilvl",show lvl)] $
|
|
|
|
|
[ mknode "w:start" [("w:val",start)] ()
|
|
|
|
|
| marker /= NoMarker && marker /= BulletMarker ] ++
|
|
|
|
|
[ mknode "w:numFmt" [("w:val",fmt)] ()
|
|
|
|
|
, mknode "w:lvlText" [("w:val",lvltxt)] ()
|
|
|
|
|
, mknode "w:lvlJc" [("w:val","left")] ()
|
|
|
|
|
, mknode "w:pPr" []
|
|
|
|
|
[ mknode "w:tabs" []
|
|
|
|
|
$ mknode "w:tab" [("w:val","num"),("w:pos",show $ lvl * step)] ()
|
|
|
|
|
, mknode "w:ind" [("w:left",show $ lvl * step + hang),("w:hanging",show hang)] ()
|
|
|
|
|
]
|
|
|
|
|
]
|
|
|
|
|
where (fmt, lvltxt, start) =
|
|
|
|
|
case marker of
|
|
|
|
|
NoMarker -> ("bullet"," ","1")
|
|
|
|
|
BulletMarker -> ("bullet",bulletFor lvl,"1")
|
|
|
|
|
NumberMarker st de n -> (styleFor st lvl
|
|
|
|
|
,patternFor de ("%" ++ show (lvl + 1))
|
|
|
|
|
,show n)
|
|
|
|
|
step = 720
|
2012-01-20 13:17:40 -08:00
|
|
|
hang = 480
|
2012-06-01 18:44:00 -07:00
|
|
|
bulletFor 0 = "\x2022" -- filled circle
|
|
|
|
|
bulletFor 1 = "\x2013" -- en dash
|
|
|
|
|
bulletFor 2 = "\x2022" -- hyphen bullet
|
|
|
|
|
bulletFor 3 = "\x2013"
|
|
|
|
|
bulletFor 4 = "\x2022"
|
|
|
|
|
bulletFor 5 = "\x2013"
|
|
|
|
|
bulletFor _ = "\x2022"
|
2012-01-03 12:10:10 -08:00
|
|
|
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 ++ ")"
|
|
|
|
|
patternFor TwoParens s = "(" ++ s ++ ")"
|
|
|
|
|
patternFor _ s = s ++ "."
|
|
|
|
|
|
2012-09-05 16:23:40 -07:00
|
|
|
getNumId :: WS Int
|
|
|
|
|
getNumId = length `fmap` gets stLists
|
|
|
|
|
|
2013-01-06 10:00:53 -08:00
|
|
|
-- | Convert Pandoc document to two OpenXML elements (the main document and footnotes).
|
|
|
|
|
writeOpenXML :: WriterOptions -> Pandoc -> WS (Element, Element)
|
2013-05-10 22:53:35 -07:00
|
|
|
writeOpenXML opts (Pandoc meta blocks) = do
|
|
|
|
|
let tit = docTitle meta ++ case lookupMeta "subtitle" meta of
|
|
|
|
|
Just (MetaBlocks [Plain xs]) -> LineBreak : xs
|
|
|
|
|
_ -> []
|
|
|
|
|
let auths = docAuthors meta
|
|
|
|
|
let dat = docDate meta
|
2012-01-03 12:10:10 -08:00
|
|
|
title <- withParaProp (pStyle "Title") $ blocksToOpenXML opts [Para tit | not (null tit)]
|
|
|
|
|
authors <- withParaProp (pStyle "Authors") $ blocksToOpenXML opts
|
|
|
|
|
[Para (intercalate [LineBreak] auths) | not (null auths)]
|
|
|
|
|
date <- withParaProp (pStyle "Date") $ blocksToOpenXML opts [Para dat | not (null dat)]
|
|
|
|
|
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
|
|
|
|
|
let blocks' = bottomUp convertSpace $ blocks
|
2013-01-06 10:00:53 -08:00
|
|
|
doc' <- blocksToOpenXML opts blocks'
|
2012-01-03 12:10:10 -08:00
|
|
|
notes' <- reverse `fmap` gets stFootnotes
|
2013-05-10 22:53:35 -07:00
|
|
|
let meta' = title ++ authors ++ date
|
2013-01-06 10:00:53 -08:00
|
|
|
let stdAttributes =
|
2012-01-03 12:10:10 -08:00
|
|
|
[("xmlns:w","http://schemas.openxmlformats.org/wordprocessingml/2006/main")
|
|
|
|
|
,("xmlns:m","http://schemas.openxmlformats.org/officeDocument/2006/math")
|
|
|
|
|
,("xmlns:r","http://schemas.openxmlformats.org/officeDocument/2006/relationships")
|
|
|
|
|
,("xmlns:o","urn:schemas-microsoft-com:office:office")
|
|
|
|
|
,("xmlns:v","urn:schemas-microsoft-com:vml")
|
|
|
|
|
,("xmlns:w10","urn:schemas-microsoft-com:office:word")
|
|
|
|
|
,("xmlns:a","http://schemas.openxmlformats.org/drawingml/2006/main")
|
|
|
|
|
,("xmlns:pic","http://schemas.openxmlformats.org/drawingml/2006/picture")
|
|
|
|
|
,("xmlns:wp","http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawing")]
|
2013-05-10 22:53:35 -07:00
|
|
|
let doc = mknode "w:document" stdAttributes $ mknode "w:body" [] (meta' ++ doc')
|
2013-01-06 10:00:53 -08:00
|
|
|
let notes = mknode "w:footnotes" stdAttributes notes'
|
|
|
|
|
return (doc, notes)
|
2012-01-03 12:10:10 -08:00
|
|
|
|
|
|
|
|
-- | Convert a list of Pandoc blocks to OpenXML.
|
|
|
|
|
blocksToOpenXML :: WriterOptions -> [Block] -> WS [Element]
|
|
|
|
|
blocksToOpenXML opts bls = concat `fmap` mapM (blockToOpenXML opts) bls
|
|
|
|
|
|
|
|
|
|
pStyle :: String -> Element
|
|
|
|
|
pStyle sty = mknode "w:pStyle" [("w:val",sty)] ()
|
|
|
|
|
|
|
|
|
|
rStyle :: String -> Element
|
|
|
|
|
rStyle sty = mknode "w:rStyle" [("w:val",sty)] ()
|
|
|
|
|
|
2013-01-06 10:00:53 -08:00
|
|
|
getUniqueId :: MonadIO m => 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
|
|
|
|
|
|
2012-01-03 12:10:10 -08:00
|
|
|
-- | Convert a Pandoc block element to OpenXML.
|
|
|
|
|
blockToOpenXML :: WriterOptions -> Block -> WS [Element]
|
|
|
|
|
blockToOpenXML _ Null = return []
|
2013-08-08 23:14:12 -07:00
|
|
|
blockToOpenXML opts (Div _ bs) = blocksToOpenXML opts bs
|
2012-10-29 22:45:52 -07:00
|
|
|
blockToOpenXML opts (Header lev (ident,_,_) lst) = do
|
2012-01-03 12:10:10 -08:00
|
|
|
contents <- withParaProp (pStyle $ "Heading" ++ show lev) $
|
|
|
|
|
blockToOpenXML opts (Para lst)
|
|
|
|
|
usedIdents <- gets stSectionIds
|
2012-10-29 22:45:52 -07:00
|
|
|
let bookmarkName = if null ident
|
|
|
|
|
then uniqueIdent lst usedIdents
|
|
|
|
|
else ident
|
2012-10-02 19:20:51 -07:00
|
|
|
modify $ \s -> s{ stSectionIds = bookmarkName : stSectionIds s }
|
2013-01-06 10:00:53 -08:00
|
|
|
id' <- getUniqueId
|
|
|
|
|
let bookmarkStart = mknode "w:bookmarkStart" [("w:id", id')
|
2012-10-02 19:20:51 -07:00
|
|
|
,("w:name",bookmarkName)] ()
|
2013-01-06 10:00:53 -08:00
|
|
|
let bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] ()
|
2012-01-03 12:10:10 -08:00
|
|
|
return $ [bookmarkStart] ++ contents ++ [bookmarkEnd]
|
2013-03-30 22:09:24 -07:00
|
|
|
blockToOpenXML opts (Plain lst) = withParaProp (pStyle "Compact")
|
|
|
|
|
$ blockToOpenXML opts (Para lst)
|
2013-01-15 08:45:46 -08:00
|
|
|
-- title beginning with fig: indicates that the image is a figure
|
|
|
|
|
blockToOpenXML opts (Para [Image alt (src,'f':'i':'g':':':tit)]) = do
|
2013-03-18 19:31:48 -07:00
|
|
|
paraProps <- getParaProps False
|
2013-01-14 20:53:08 -08:00
|
|
|
contents <- inlinesToOpenXML opts [Image alt (src,tit)]
|
2012-01-03 12:10:10 -08:00
|
|
|
captionNode <- withParaProp (pStyle "ImageCaption")
|
|
|
|
|
$ blockToOpenXML opts (Para alt)
|
|
|
|
|
return $ mknode "w:p" [] (paraProps ++ contents) : captionNode
|
2013-03-18 19:31:48 -07:00
|
|
|
-- fixDisplayMath sometimes produces a Para [] as artifact
|
|
|
|
|
blockToOpenXML _ (Para []) = return []
|
|
|
|
|
blockToOpenXML opts (Para lst) = do
|
|
|
|
|
paraProps <- getParaProps $ case lst of
|
|
|
|
|
[Math DisplayMath _] -> True
|
|
|
|
|
_ -> False
|
2013-02-26 22:59:21 -08:00
|
|
|
contents <- inlinesToOpenXML opts lst
|
|
|
|
|
return [mknode "w:p" [] (paraProps ++ contents)]
|
2012-01-03 12:10:10 -08:00
|
|
|
blockToOpenXML _ (RawBlock format str)
|
2013-08-10 17:23:51 -07:00
|
|
|
| format == Format "openxml" = return [ x | Elem x <- parseXML str ]
|
|
|
|
|
| otherwise = return []
|
2012-01-03 12:10:10 -08:00
|
|
|
blockToOpenXML opts (BlockQuote blocks) =
|
|
|
|
|
withParaProp (pStyle "BlockQuote") $ blocksToOpenXML opts blocks
|
|
|
|
|
blockToOpenXML opts (CodeBlock attrs str) =
|
|
|
|
|
withParaProp (pStyle "SourceCode") $ blockToOpenXML opts $ Para [Code attrs str]
|
|
|
|
|
blockToOpenXML _ HorizontalRule = return [
|
|
|
|
|
mknode "w:p" [] $ mknode "w:r" [] $ mknode "w:pict" []
|
|
|
|
|
$ mknode "v:rect" [("style","width:0;height:1.5pt"),
|
|
|
|
|
("o:hralign","center"),
|
|
|
|
|
("o:hrstd","t"),("o:hr","t")] () ]
|
|
|
|
|
blockToOpenXML opts (Table caption aligns widths headers rows) = do
|
|
|
|
|
let captionStr = stringify caption
|
|
|
|
|
caption' <- if null caption
|
|
|
|
|
then return []
|
|
|
|
|
else withParaProp (pStyle "TableCaption")
|
|
|
|
|
$ blockToOpenXML opts (Para caption)
|
|
|
|
|
let alignmentFor al = mknode "w:jc" [("w:val",alignmentToString al)] ()
|
|
|
|
|
let cellToOpenXML (al, cell) = withParaProp (alignmentFor al)
|
|
|
|
|
$ blocksToOpenXML opts cell
|
|
|
|
|
headers' <- mapM cellToOpenXML $ zip aligns headers
|
|
|
|
|
rows' <- mapM (\cells -> mapM cellToOpenXML $ zip aligns cells)
|
|
|
|
|
$ rows
|
|
|
|
|
let borderProps = mknode "w:tcPr" []
|
|
|
|
|
[ mknode "w:tcBorders" []
|
|
|
|
|
$ mknode "w:bottom" [("w:val","single")] ()
|
|
|
|
|
, mknode "w:vAlign" [("w:val","bottom")] () ]
|
|
|
|
|
let mkcell border contents = mknode "w:tc" []
|
|
|
|
|
$ [ borderProps | border ] ++
|
|
|
|
|
if null contents
|
|
|
|
|
then [mknode "w:p" [] ()]
|
|
|
|
|
else contents
|
|
|
|
|
let mkrow border cells = mknode "w:tr" [] $ map (mkcell border) cells
|
|
|
|
|
let textwidth = 7920 -- 5.5 in in twips, 1/20 pt
|
|
|
|
|
let mkgridcol w = mknode "w:gridCol"
|
|
|
|
|
[("w:w", show $ (floor (textwidth * w) :: Integer))] ()
|
|
|
|
|
return $
|
|
|
|
|
[ mknode "w:tbl" []
|
|
|
|
|
( mknode "w:tblPr" []
|
2012-02-14 17:41:11 -08:00
|
|
|
( [ mknode "w:tblStyle" [("w:val","TableNormal")] () ] ++
|
|
|
|
|
[ mknode "w:tblCaption" [("w:val", captionStr)] ()
|
|
|
|
|
| not (null caption) ] )
|
2012-01-03 12:10:10 -08:00
|
|
|
: mknode "w:tblGrid" []
|
|
|
|
|
(if all (==0) widths
|
|
|
|
|
then []
|
|
|
|
|
else map mkgridcol widths)
|
|
|
|
|
: [ mkrow True headers' | not (all null headers) ] ++
|
|
|
|
|
map (mkrow False) rows'
|
|
|
|
|
)
|
|
|
|
|
] ++ caption'
|
|
|
|
|
blockToOpenXML opts (BulletList lst) = do
|
|
|
|
|
let marker = BulletMarker
|
2012-01-20 13:00:28 -08:00
|
|
|
addList marker
|
2012-09-05 16:23:40 -07:00
|
|
|
numid <- getNumId
|
|
|
|
|
asList $ concat `fmap` mapM (listItemToOpenXML opts numid) lst
|
2012-01-03 12:10:10 -08:00
|
|
|
blockToOpenXML opts (OrderedList (start, numstyle, numdelim) lst) = do
|
|
|
|
|
let marker = NumberMarker numstyle numdelim start
|
2012-01-20 13:00:28 -08:00
|
|
|
addList marker
|
2012-09-05 16:23:40 -07:00
|
|
|
numid <- getNumId
|
|
|
|
|
asList $ concat `fmap` mapM (listItemToOpenXML opts numid) lst
|
2012-01-03 12:10:10 -08:00
|
|
|
blockToOpenXML opts (DefinitionList items) =
|
|
|
|
|
concat `fmap` mapM (definitionListItemToOpenXML opts) items
|
|
|
|
|
|
|
|
|
|
definitionListItemToOpenXML :: WriterOptions -> ([Inline],[[Block]]) -> WS [Element]
|
|
|
|
|
definitionListItemToOpenXML opts (term,defs) = do
|
|
|
|
|
term' <- withParaProp (pStyle "DefinitionTerm")
|
|
|
|
|
$ blockToOpenXML opts (Para term)
|
|
|
|
|
defs' <- withParaProp (pStyle "Definition")
|
|
|
|
|
$ concat `fmap` mapM (blocksToOpenXML opts) defs
|
|
|
|
|
return $ term' ++ defs'
|
|
|
|
|
|
2012-01-20 13:00:28 -08:00
|
|
|
addList :: ListMarker -> WS ()
|
|
|
|
|
addList marker = do
|
|
|
|
|
lists <- gets stLists
|
|
|
|
|
modify $ \st -> st{ stLists = lists ++ [marker] }
|
|
|
|
|
numStyles <- gets stNumStyles
|
|
|
|
|
case M.lookup marker numStyles of
|
|
|
|
|
Just _ -> return ()
|
|
|
|
|
Nothing -> modify $ \st ->
|
|
|
|
|
st{ stNumStyles = M.insert marker (M.size numStyles + 1) numStyles }
|
2012-01-03 12:10:10 -08:00
|
|
|
|
2012-09-05 16:23:40 -07:00
|
|
|
listItemToOpenXML :: WriterOptions -> Int -> [Block] -> WS [Element]
|
2012-01-03 12:10:10 -08:00
|
|
|
listItemToOpenXML _ _ [] = return []
|
2012-09-05 16:23:40 -07:00
|
|
|
listItemToOpenXML opts numid (first:rest) = do
|
|
|
|
|
first' <- withNumId numid $ blockToOpenXML opts first
|
|
|
|
|
rest' <- withNumId 1 $ blocksToOpenXML opts rest
|
2012-01-03 12:10:10 -08:00
|
|
|
return $ first' ++ rest'
|
|
|
|
|
|
|
|
|
|
alignmentToString :: Alignment -> [Char]
|
|
|
|
|
alignmentToString alignment = case alignment of
|
|
|
|
|
AlignLeft -> "left"
|
|
|
|
|
AlignRight -> "right"
|
|
|
|
|
AlignCenter -> "center"
|
|
|
|
|
AlignDefault -> "left"
|
|
|
|
|
|
|
|
|
|
-- | Convert a list of inline elements to OpenXML.
|
|
|
|
|
inlinesToOpenXML :: WriterOptions -> [Inline] -> WS [Element]
|
|
|
|
|
inlinesToOpenXML opts lst = concat `fmap` mapM (inlineToOpenXML opts) lst
|
|
|
|
|
|
2012-09-05 16:23:40 -07:00
|
|
|
withNumId :: Int -> WS a -> WS a
|
|
|
|
|
withNumId numid p = do
|
|
|
|
|
origNumId <- gets stListNumId
|
|
|
|
|
modify $ \st -> st{ stListNumId = numid }
|
2012-01-03 12:10:10 -08:00
|
|
|
result <- p
|
2012-09-05 16:23:40 -07:00
|
|
|
modify $ \st -> st{ stListNumId = origNumId }
|
2012-01-03 12:10:10 -08:00
|
|
|
return result
|
|
|
|
|
|
|
|
|
|
asList :: WS a -> WS a
|
|
|
|
|
asList p = do
|
|
|
|
|
origListLevel <- gets stListLevel
|
|
|
|
|
modify $ \st -> st{ stListLevel = stListLevel st + 1 }
|
|
|
|
|
result <- p
|
|
|
|
|
modify $ \st -> st{ stListLevel = origListLevel }
|
|
|
|
|
return result
|
|
|
|
|
|
|
|
|
|
getTextProps :: WS [Element]
|
|
|
|
|
getTextProps = do
|
|
|
|
|
props <- gets stTextProperties
|
|
|
|
|
return $ if null props
|
|
|
|
|
then []
|
|
|
|
|
else [mknode "w:rPr" [] $ props]
|
|
|
|
|
|
|
|
|
|
pushTextProp :: Element -> WS ()
|
|
|
|
|
pushTextProp d = modify $ \s -> s{ stTextProperties = d : stTextProperties s }
|
|
|
|
|
|
|
|
|
|
popTextProp :: WS ()
|
|
|
|
|
popTextProp = modify $ \s -> s{ stTextProperties = drop 1 $ stTextProperties s }
|
|
|
|
|
|
|
|
|
|
withTextProp :: Element -> WS a -> WS a
|
|
|
|
|
withTextProp d p = do
|
|
|
|
|
pushTextProp d
|
|
|
|
|
res <- p
|
|
|
|
|
popTextProp
|
|
|
|
|
return res
|
|
|
|
|
|
2013-03-18 19:31:48 -07:00
|
|
|
getParaProps :: Bool -> WS [Element]
|
|
|
|
|
getParaProps displayMathPara = do
|
2012-01-03 12:10:10 -08:00
|
|
|
props <- gets stParaProperties
|
|
|
|
|
listLevel <- gets stListLevel
|
2012-09-05 16:23:40 -07:00
|
|
|
numid <- gets stListNumId
|
2013-03-18 19:31:48 -07:00
|
|
|
let listPr = if listLevel >= 0 && not displayMathPara
|
2012-01-03 12:10:10 -08:00
|
|
|
then [ mknode "w:numPr" []
|
|
|
|
|
[ mknode "w:numId" [("w:val",show numid)] ()
|
|
|
|
|
, mknode "w:ilvl" [("w:val",show listLevel)] () ]
|
|
|
|
|
]
|
|
|
|
|
else []
|
|
|
|
|
return $ case props ++ listPr of
|
|
|
|
|
[] -> []
|
|
|
|
|
ps -> [mknode "w:pPr" [] ps]
|
|
|
|
|
|
|
|
|
|
pushParaProp :: Element -> WS ()
|
|
|
|
|
pushParaProp d = modify $ \s -> s{ stParaProperties = d : stParaProperties s }
|
|
|
|
|
|
|
|
|
|
popParaProp :: WS ()
|
|
|
|
|
popParaProp = modify $ \s -> s{ stParaProperties = drop 1 $ stParaProperties s }
|
|
|
|
|
|
|
|
|
|
withParaProp :: Element -> WS a -> WS a
|
|
|
|
|
withParaProp d p = do
|
|
|
|
|
pushParaProp d
|
|
|
|
|
res <- p
|
|
|
|
|
popParaProp
|
|
|
|
|
return res
|
|
|
|
|
|
|
|
|
|
formattedString :: String -> WS [Element]
|
|
|
|
|
formattedString str = do
|
|
|
|
|
props <- getTextProps
|
|
|
|
|
return [ mknode "w:r" [] $
|
|
|
|
|
props ++
|
|
|
|
|
[ mknode "w:t" [("xml:space","preserve")] str ] ]
|
|
|
|
|
|
|
|
|
|
-- | Convert an inline element to OpenXML.
|
|
|
|
|
inlineToOpenXML :: WriterOptions -> Inline -> WS [Element]
|
|
|
|
|
inlineToOpenXML _ (Str str) = formattedString str
|
|
|
|
|
inlineToOpenXML opts Space = inlineToOpenXML opts (Str " ")
|
2013-11-23 14:52:14 -08:00
|
|
|
inlineToOpenXML opts (Span (_,classes,_) ils) = 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
|
2012-01-03 12:10:10 -08:00
|
|
|
inlineToOpenXML opts (Strong lst) =
|
|
|
|
|
withTextProp (mknode "w:b" [] ()) $ inlinesToOpenXML opts lst
|
|
|
|
|
inlineToOpenXML opts (Emph lst) =
|
|
|
|
|
withTextProp (mknode "w:i" [] ()) $ inlinesToOpenXML opts lst
|
|
|
|
|
inlineToOpenXML opts (Subscript lst) =
|
|
|
|
|
withTextProp (mknode "w:vertAlign" [("w:val","subscript")] ())
|
|
|
|
|
$ inlinesToOpenXML opts lst
|
|
|
|
|
inlineToOpenXML opts (Superscript lst) =
|
|
|
|
|
withTextProp (mknode "w:vertAlign" [("w:val","superscript")] ())
|
|
|
|
|
$ inlinesToOpenXML opts lst
|
|
|
|
|
inlineToOpenXML opts (SmallCaps lst) =
|
|
|
|
|
withTextProp (mknode "w:smallCaps" [] ())
|
|
|
|
|
$ inlinesToOpenXML opts lst
|
|
|
|
|
inlineToOpenXML opts (Strikeout lst) =
|
|
|
|
|
withTextProp (mknode "w:strike" [] ())
|
|
|
|
|
$ inlinesToOpenXML opts lst
|
2012-08-17 18:27:48 -07:00
|
|
|
inlineToOpenXML _ LineBreak = return [br]
|
2012-01-03 12:10:10 -08:00
|
|
|
inlineToOpenXML _ (RawInline f str)
|
2013-08-10 17:23:51 -07:00
|
|
|
| f == Format "openxml" = return [ x | Elem x <- parseXML str ]
|
|
|
|
|
| otherwise = return []
|
2012-01-03 12:10:10 -08:00
|
|
|
inlineToOpenXML opts (Quoted quoteType lst) =
|
|
|
|
|
inlinesToOpenXML opts $ [Str open] ++ lst ++ [Str close]
|
|
|
|
|
where (open, close) = case quoteType of
|
|
|
|
|
SingleQuote -> ("\x2018", "\x2019")
|
|
|
|
|
DoubleQuote -> ("\x201C", "\x201D")
|
2013-02-26 22:59:21 -08:00
|
|
|
inlineToOpenXML opts (Math mathType str) = do
|
|
|
|
|
let displayType = if mathType == DisplayMath
|
|
|
|
|
then DisplayBlock
|
|
|
|
|
else DisplayInline
|
|
|
|
|
case texMathToOMML displayType str of
|
2012-01-03 12:10:10 -08:00
|
|
|
Right r -> return [r]
|
2013-11-01 14:27:22 -07:00
|
|
|
Left _ -> inlinesToOpenXML opts (readTeXMath' mathType str)
|
2012-01-03 12:10:10 -08:00
|
|
|
inlineToOpenXML opts (Cite _ lst) = inlinesToOpenXML opts lst
|
2013-07-13 13:48:50 -07:00
|
|
|
inlineToOpenXML opts (Code attrs str) =
|
2012-01-03 12:10:10 -08:00
|
|
|
withTextProp (rStyle "VerbatimChar")
|
2013-07-13 13:48:50 -07:00
|
|
|
$ if writerHighlight opts
|
|
|
|
|
then case highlight formatOpenXML attrs str of
|
|
|
|
|
Nothing -> unhighlighted
|
|
|
|
|
Just h -> return h
|
|
|
|
|
else unhighlighted
|
|
|
|
|
where unhighlighted = intercalate [br] `fmap`
|
|
|
|
|
(mapM formattedString $ lines str)
|
|
|
|
|
formatOpenXML _fmtOpts = intercalate [br] . map (map toHlTok)
|
2012-01-03 12:10:10 -08:00
|
|
|
toHlTok (toktype,tok) = mknode "w:r" []
|
|
|
|
|
[ mknode "w:rPr" []
|
|
|
|
|
[ rStyle $ show toktype ]
|
|
|
|
|
, mknode "w:t" [("xml:space","preserve")] tok ]
|
|
|
|
|
inlineToOpenXML opts (Note bs) = do
|
|
|
|
|
notes <- gets stFootnotes
|
2013-01-06 10:00:53 -08:00
|
|
|
notenum <- getUniqueId
|
2012-01-03 12:10:10 -08:00
|
|
|
let notemarker = mknode "w:r" []
|
2013-02-26 22:01:47 -08:00
|
|
|
[ mknode "w:rPr" [] (rStyle "FootnoteRef")
|
2012-01-03 12:10:10 -08:00
|
|
|
, mknode "w:footnoteRef" [] () ]
|
2013-08-10 17:23:51 -07:00
|
|
|
let notemarkerXml = RawInline (Format "openxml") $ ppElement notemarker
|
2012-01-03 12:10:10 -08:00
|
|
|
let insertNoteRef (Plain ils : xs) = Plain (notemarkerXml : ils) : xs
|
|
|
|
|
insertNoteRef (Para ils : xs) = Para (notemarkerXml : ils) : xs
|
|
|
|
|
insertNoteRef xs = Para [notemarkerXml] : xs
|
2012-01-20 13:32:56 -08:00
|
|
|
oldListLevel <- gets stListLevel
|
|
|
|
|
oldParaProperties <- gets stParaProperties
|
|
|
|
|
oldTextProperties <- gets stTextProperties
|
|
|
|
|
modify $ \st -> st{ stListLevel = -1, stParaProperties = [], stTextProperties = [] }
|
2012-01-03 12:10:10 -08:00
|
|
|
contents <- withParaProp (pStyle "FootnoteText") $ blocksToOpenXML opts
|
|
|
|
|
$ insertNoteRef bs
|
2012-01-20 13:32:56 -08:00
|
|
|
modify $ \st -> st{ stListLevel = oldListLevel, stParaProperties = oldParaProperties,
|
|
|
|
|
stTextProperties = oldTextProperties }
|
2013-01-06 10:00:53 -08:00
|
|
|
let newnote = mknode "w:footnote" [("w:id", notenum)] $ contents
|
2012-01-03 12:10:10 -08:00
|
|
|
modify $ \s -> s{ stFootnotes = newnote : notes }
|
|
|
|
|
return [ mknode "w:r" []
|
2013-02-26 22:01:47 -08:00
|
|
|
[ mknode "w:rPr" [] (rStyle "FootnoteRef")
|
2013-01-06 10:00:53 -08:00
|
|
|
, mknode "w:footnoteReference" [("w:id", notenum)] () ] ]
|
2012-01-03 12:10:10 -08:00
|
|
|
-- internal link:
|
|
|
|
|
inlineToOpenXML opts (Link txt ('#':xs,_)) = do
|
2013-02-26 22:01:47 -08:00
|
|
|
contents <- withTextProp (rStyle "Link") $ inlinesToOpenXML opts txt
|
2012-01-03 12:10:10 -08:00
|
|
|
return [ mknode "w:hyperlink" [("w:anchor",xs)] contents ]
|
|
|
|
|
-- external link:
|
|
|
|
|
inlineToOpenXML opts (Link txt (src,_)) = do
|
2013-02-26 22:01:47 -08:00
|
|
|
contents <- withTextProp (rStyle "Link") $ inlinesToOpenXML opts txt
|
2012-01-03 12:10:10 -08:00
|
|
|
extlinks <- gets stExternalLinks
|
2013-01-06 10:00:53 -08:00
|
|
|
id' <- case M.lookup src extlinks of
|
2012-01-03 12:10:10 -08:00
|
|
|
Just i -> return i
|
|
|
|
|
Nothing -> do
|
2013-01-06 10:00:53 -08:00
|
|
|
i <- ("rId"++) `fmap` getUniqueId
|
2012-01-03 12:10:10 -08:00
|
|
|
modify $ \st -> st{ stExternalLinks =
|
|
|
|
|
M.insert src i extlinks }
|
|
|
|
|
return i
|
2013-01-06 10:00:53 -08:00
|
|
|
return [ mknode "w:hyperlink" [("r:id",id')] contents ]
|
2012-01-19 23:19:28 -08:00
|
|
|
inlineToOpenXML opts (Image alt (src, tit)) = do
|
2013-01-11 13:41:17 -08:00
|
|
|
-- first, check to see if we've already done this image
|
|
|
|
|
imgs <- gets stImages
|
|
|
|
|
case M.lookup src imgs of
|
2013-02-25 19:04:20 -08:00
|
|
|
Just (_,_,_,elt,_) -> return [elt]
|
2013-01-11 13:41:17 -08:00
|
|
|
Nothing -> do
|
Options: Changed `writerSourceDir` to `writerSourceURL` (now a Maybe).
Previously we used to store the directory of the first input file,
even if it was local, and used this as a base directory for
finding images in ODT, EPUB, Docx, and PDF.
This has been confusing to many users. It seems better to look for
images relative to the current working directory, even if the first
file argument is in another directory.
writerSourceURL is set to 'Just url' when the first command-line
argument is an absolute URL. (So, relative links will be resolved
in relation to the first page.) Otherwise, 'Nothing'.
The ODT, EPUB, Docx, and PDF writers have been modified accordingly.
Note that this change may break some existing workflows. If you
have been assuming that relative links will be interpreted relative
to the directory of the first file argument, you'll need to
make that the current directory before running pandoc.
Closes #942.
2013-08-11 15:58:09 -07:00
|
|
|
res <- liftIO $ fetchItem (writerSourceURL opts) src
|
2013-01-11 13:41:17 -08:00
|
|
|
case res of
|
|
|
|
|
Left (_ :: E.SomeException) -> do
|
2013-01-11 16:19:06 -08:00
|
|
|
liftIO $ warn $ "Could not find image `" ++ src ++ "', skipping..."
|
2013-01-11 13:41:17 -08:00
|
|
|
-- emit alt text
|
|
|
|
|
inlinesToOpenXML opts alt
|
2013-11-19 13:16:31 -08:00
|
|
|
Right (img, mt) -> do
|
2013-01-11 13:41:17 -08:00
|
|
|
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 ]
|
2013-11-19 13:16:31 -08:00
|
|
|
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 -> ""
|
2013-02-25 19:04:20 -08:00
|
|
|
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
|
2013-11-19 13:16:31 -08:00
|
|
|
let mbMimeType = mt <|> getMimeType imgpath
|
2013-02-26 20:29:01 -08:00
|
|
|
-- insert mime type to use in constructing [Content_Types].xml
|
2013-02-25 19:04:20 -08:00
|
|
|
modify $ \st -> st{ stImages =
|
|
|
|
|
M.insert src (ident, imgpath, mbMimeType, imgElt, img)
|
|
|
|
|
$ stImages st }
|
|
|
|
|
return [imgElt]
|
2012-08-17 18:27:48 -07:00
|
|
|
|
|
|
|
|
br :: Element
|
2013-07-04 16:37:44 -07:00
|
|
|
br = mknode "w:r" [] [mknode "w:br" [("w:type","textWrapping")] () ]
|
2013-02-25 19:04:20 -08:00
|
|
|
|
|
|
|
|
parseXml :: Archive -> String -> IO Element
|
|
|
|
|
parseXml refArchive relpath =
|
|
|
|
|
case (findEntryByPath relpath refArchive >>= parseXMLDoc . UTF8.toStringLazy . fromEntry) of
|
|
|
|
|
Just d -> return d
|
|
|
|
|
Nothing -> fail $ relpath ++ " missing in reference docx"
|
|
|
|
|
|
2013-02-26 22:59:21 -08:00
|
|
|
isDisplayMath :: Inline -> Bool
|
|
|
|
|
isDisplayMath (Math DisplayMath _) = True
|
|
|
|
|
isDisplayMath _ = False
|
2013-03-18 19:31:48 -07:00
|
|
|
|
|
|
|
|
stripLeadingTrailingSpace :: [Inline] -> [Inline]
|
|
|
|
|
stripLeadingTrailingSpace = go . reverse . go . reverse
|
|
|
|
|
where go (Space:xs) = xs
|
|
|
|
|
go xs = xs
|
|
|
|
|
|
2013-08-10 18:45:00 -07:00
|
|
|
fixDisplayMath :: Block -> Block
|
2013-03-30 22:09:24 -07:00
|
|
|
fixDisplayMath (Plain lst)
|
|
|
|
|
| any isDisplayMath lst && not (all isDisplayMath lst) =
|
|
|
|
|
-- chop into several paragraphs so each displaymath is its own
|
2013-08-10 18:45:00 -07:00
|
|
|
Div ("",["math"],[]) $ map (Plain . stripLeadingTrailingSpace) $
|
2013-03-30 22:09:24 -07:00
|
|
|
groupBy (\x y -> (isDisplayMath x && isDisplayMath y) ||
|
|
|
|
|
not (isDisplayMath x || isDisplayMath y)) lst
|
2013-03-18 19:31:48 -07:00
|
|
|
fixDisplayMath (Para lst)
|
|
|
|
|
| any isDisplayMath lst && not (all isDisplayMath lst) =
|
|
|
|
|
-- chop into several paragraphs so each displaymath is its own
|
2013-08-10 18:45:00 -07:00
|
|
|
Div ("",["math"],[]) $ map (Para . stripLeadingTrailingSpace) $
|
2013-03-18 19:31:48 -07:00
|
|
|
groupBy (\x y -> (isDisplayMath x && isDisplayMath y) ||
|
|
|
|
|
not (isDisplayMath x || isDisplayMath y)) lst
|
2013-08-10 18:45:00 -07:00
|
|
|
fixDisplayMath x = x
|
