opensource/pandoc
3
0
Fork 0
mirror of https://github.com/jgm/pandoc.git synced 2026-08-28 17:20:47 +08:00
Code Issues Packages Projects Releases Wiki Activity

Rename Text.Pandoc.XMLParser -> Text.Pandoc.XML.Light...

Browse Source 
..and add new definitions isomorphic to xml-light's, but with
Text instead of String.  This allows us to keep most of the code in
existing readers that use xml-light, but avoid lots of unnecessary
allocation.

We also add versions of the functions from xml-light's
Text.XML.Light.Output and Text.XML.Light.Proc that operate
on our modified XML types, and functions that convert
xml-light types to our types (since some of our dependencies,
like texmath, use xml-light).

Update golden tests for docx and pptx.

OOXML test: Use `showContent` instead of `ppContent` in `displayDiff`.

Docx: Do a manual traversal to unwrap sdt and smartTag.
This is faster, and needed to pass the tests.

Benchmarks:

A = prior to 8ca191604d (Feb 8)
B = as of 8ca191604d (Feb 8)
C = this commit

| Reader  |  A    | B      | C     |
| ------- | ----- | ------ | ----- |
| docbook | 18 ms | 12 ms  | 10 ms |
| opml    | 65 ms | 62 ms  | 35 ms |
| jats    | 15 ms | 11 ms  |  9 ms |
| docx    | 72 ms | 69 ms  | 44 ms |
| odt     | 78 ms | 41 ms  | 28 ms |
| epub    | 64 ms | 61 ms  | 56 ms |
| fb2     | 14 ms | 5  ms  | 4 ms  |
This commit is contained in:
John MacFarlane
2021-02-14 22:29:21 -08:00
parent b5b576184c
commit 967e7f5fb9
102 changed files with 1388 additions and 930 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.hlint.yaml
+1
View File
@@ -14,6 +14,7 @@
- ignore: {name: "Reduce duplication"} # TODO: could be more fine-grained
- ignore: {name: "Use &&&"}
- ignore: {name: "Use String"}
- ignore: {name: "Use camelCase"}
- ignore: {name: "Use fmap"} # specific for GHC 7.8 compat
- ignore: {name: "Use isDigit"}
pandoc.cabal
+1 -1
View File
@@ -687,7 +687,7 @@ library
Text.Pandoc.Lua.PandocLua,
Text.Pandoc.Lua.Util,
Text.Pandoc.Lua.Walk,
Text.Pandoc.XMLParser,
Text.Pandoc.XML.Light,
Text.Pandoc.CSS,
Text.Pandoc.CSV,
Text.Pandoc.RoffChar,
src/Text/Pandoc/ImageSize.hs
+4 -5
View File
@@ -44,8 +44,7 @@ import Numeric (showFFloat)
import Text.Pandoc.Definition
import Text.Pandoc.Options
import qualified Text.Pandoc.UTF8 as UTF8
import qualified Text.XML.Light as Xml
import Text.Pandoc.XMLParser (parseXMLElement)
import Text.Pandoc.XML.Light hiding (Attr)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as TE
@@ -332,12 +331,12 @@ svgSize opts img = do
doc <- either (const mzero) return $ parseXMLElement
$ TL.fromStrict $ UTF8.toText img
let viewboxSize = do
vb <- Xml.findAttrBy (== Xml.QName "viewBox" Nothing Nothing) doc
[_,_,w,h] <- mapM safeRead (T.words (T.pack vb))
vb <- findAttrBy (== QName "viewBox" Nothing Nothing) doc
[_,_,w,h] <- mapM safeRead (T.words vb)
return (w,h)
let dpi = fromIntegral $ writerDpi opts
let dirToInt dir = do
dim <- Xml.findAttrBy (== Xml.QName dir Nothing Nothing) doc >>= lengthToDim . T.pack
dim <- findAttrBy (== QName dir Nothing Nothing) doc >>= lengthToDim
return $ inPixel opts dim
w <- dirToInt "width" <|> (fst <$> viewboxSize)
h <- dirToInt "height" <|> (snd <$> viewboxSize)
src/Text/Pandoc/Readers/DocBook.hs
+38 -38
View File
@@ -31,8 +31,7 @@ import Text.Pandoc.Options
import Text.Pandoc.Logging (LogMessage(..))
import Text.Pandoc.Shared (crFilter, safeRead, extractSpaces)
import Text.TeXMath (readMathML, writeTeX)
import Text.XML.Light
import Text.Pandoc.XMLParser (parseXMLContents)
import Text.Pandoc.XML.Light
{-
@@ -578,26 +577,27 @@ normalizeTree = everywhere (mkT go)
where go :: [Content] -> [Content]
go (Text (CData CDataRaw _ _):xs) = xs
go (Text (CData CDataText s1 z):Text (CData CDataText s2 _):xs) =
Text (CData CDataText (s1 ++ s2) z):xs
Text (CData CDataText (s1 <> s2) z):xs
go (Text (CData CDataText s1 z):CRef r:xs) =
Text (CData CDataText (s1 ++ convertEntity r) z):xs
Text (CData CDataText (s1 <> convertEntity r) z):xs
go (CRef r:Text (CData CDataText s1 z):xs) =
Text (CData CDataText (convertEntity r ++ s1) z):xs
Text (CData CDataText (convertEntity r <> s1) z):xs
go (CRef r1:CRef r2:xs) =
Text (CData CDataText (convertEntity r1 ++ convertEntity r2) Nothing):xs
Text (CData CDataText (convertEntity r1 <>
convertEntity r2) Nothing):xs
go xs = xs
convertEntity :: String -> String
convertEntity e = Data.Maybe.fromMaybe (map toUpper e) (lookupEntity e)
convertEntity :: Text -> Text
convertEntity e = maybe (T.map toUpper e) T.pack (lookupEntity $ T.unpack e)
-- convenience function to get an attribute value, defaulting to ""
attrValue :: String -> Element -> Text
attrValue :: Text -> Element -> Text
attrValue attr elt =
maybe "" T.pack (lookupAttrBy (\x -> qName x == attr) (elAttribs elt))
fromMaybe "" (lookupAttrBy (\x -> qName x == attr) (elAttribs elt))
-- convenience function
named :: Text -> Element -> Bool
named s e = qName (elName e) == T.unpack s
named s e = qName (elName e) == s
--
@@ -634,7 +634,7 @@ isBlockElement :: Content -> Bool
isBlockElement (Elem e) = qName (elName e) `elem` blockTags
isBlockElement _ = False
blockTags :: [String]
blockTags :: [Text]
blockTags =
[ "abstract"
, "ackno"
@@ -721,7 +721,7 @@ blockTags =
, "variablelist"
] ++ admonitionTags
admonitionTags :: [String]
admonitionTags :: [Text]
admonitionTags = ["important","caution","note","tip","warning"]
-- Trim leading and trailing newline characters
@@ -779,10 +779,10 @@ getBlocks e = mconcat <$>
parseBlock :: PandocMonad m => Content -> DB m Blocks
parseBlock (Text (CData CDataRaw _ _)) = return mempty -- DOCTYPE
parseBlock (Text (CData _ s _)) = if all isSpace s
parseBlock (Text (CData _ s _)) = if T.all isSpace s
then return mempty
else return $ plain $ trimInlines $ text $ T.pack s
parseBlock (CRef x) = return $ plain $ str $ T.toUpper $ T.pack x
else return $ plain $ trimInlines $ text s
parseBlock (CRef x) = return $ plain $ str $ T.toUpper x
parseBlock (Elem e) =
case qName (elName e) of
"toc" -> skip -- skip TOC, since in pandoc it's autogenerated
@@ -837,7 +837,7 @@ parseBlock (Elem e) =
"refsect2" -> sect 2
"refsect3" -> sect 3
"refsection" -> gets dbSectionLevel >>= sect . (+1)
l | l `elem` admonitionTags -> parseAdmonition $ T.pack l
l | l `elem` admonitionTags -> parseAdmonition l
"area" -> skip
"areaset" -> skip
"areaspec" -> skip
@@ -899,7 +899,7 @@ parseBlock (Elem e) =
"subtitle" -> return mempty -- handled in parent element
_ -> skip >> getBlocks e
where skip = do
let qn = T.pack $ qName $ elName e
let qn = qName $ elName e
let name = if "pi-" `T.isPrefixOf` qn
then "<?" <> qn <> "?>"
else qn
@@ -911,7 +911,7 @@ parseBlock (Elem e) =
"" -> []
x -> [x]
return $ codeBlockWith (attrValue "id" e, classes', [])
$ trimNl $ T.pack $ strContentRecursive e
$ trimNl $ strContentRecursive e
parseBlockquote = do
attrib <- case filterChild (named "attribution") e of
Nothing -> return mempty
@@ -965,7 +965,7 @@ parseBlock (Elem e) =
w <- findAttr (unqual "colwidth") c
n <- safeRead $ "0" <> T.filter (\x ->
(x >= '0' && x <= '9')
|| x == '.') (T.pack w)
|| x == '.') w
if n > 0 then Just n else Nothing
let numrows = case bodyrows of
[] -> 0
@@ -1048,12 +1048,12 @@ parseMixed container conts = do
x <- parseMixed container rs
return $ p <> b <> x
parseRow :: PandocMonad m => [String] -> Element -> DB m [Cell]
parseRow :: PandocMonad m => [Text] -> Element -> DB m [Cell]
parseRow cn = do
let isEntry x = named "entry" x || named "td" x || named "th" x
mapM (parseEntry cn) . filterChildren isEntry
parseEntry :: PandocMonad m => [String] -> Element -> DB m Cell
parseEntry :: PandocMonad m => [Text] -> Element -> DB m Cell
parseEntry cn el = do
let colDistance sa ea = do
let iStrt = elemIndex sa cn
@@ -1075,7 +1075,7 @@ getInlines :: PandocMonad m => Element -> DB m Inlines
getInlines e' = trimInlines . mconcat <$>
mapM parseInline (elContent e')
strContentRecursive :: Element -> String
strContentRecursive :: Element -> Text
strContentRecursive = strContent .
(\e' -> e'{ elContent = map elementToStr $ elContent e' })
@@ -1084,9 +1084,9 @@ elementToStr (Elem e') = Text $ CData CDataText (strContentRecursive e') Nothing
elementToStr x = x
parseInline :: PandocMonad m => Content -> DB m Inlines
parseInline (Text (CData _ s _)) = return $ text $ T.pack s
parseInline (Text (CData _ s _)) = return $ text s
parseInline (CRef ref) =
return $ text $ maybe (T.toUpper $ T.pack ref) T.pack $ lookupEntity ref
return $ text $ maybe (T.toUpper ref) T.pack $ lookupEntity (T.unpack ref)
parseInline (Elem e) =
case qName (elName e) of
"anchor" -> do
@@ -1138,7 +1138,7 @@ parseInline (Elem e) =
"userinput" -> codeWithLang
"systemitem" -> codeWithLang
"varargs" -> return $ code "(...)"
"keycap" -> return (str $ T.pack $ strContent e)
"keycap" -> return (str $ strContent e)
"keycombo" -> keycombo <$>
mapM parseInline (elContent e)
"menuchoice" -> menuchoice <$>
@@ -1150,17 +1150,17 @@ parseInline (Elem e) =
let title = case attrValue "endterm" e of
"" -> maybe "???" xrefTitleByElem
(findElementById linkend content)
endterm -> maybe "???" (T.pack . strContent)
endterm -> maybe "???" strContent
(findElementById endterm content)
return $ link ("#" <> linkend) "" (text title)
"email" -> return $ link ("mailto:" <> T.pack (strContent e)) ""
$ str $ T.pack $ strContent e
"uri" -> return $ link (T.pack $ strContent e) "" $ str $ T.pack $ strContent e
"email" -> return $ link ("mailto:" <> strContent e) ""
$ str $ strContent e
"uri" -> return $ link (strContent e) "" $ str $ strContent e
"ulink" -> innerInlines (link (attrValue "url" e) "")
"link" -> do
ils <- innerInlines id
let href = case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of
Just h -> T.pack h
Just h -> h
_ -> "#" <> attrValue "linkend" e
let ils' = if ils == mempty then str href else ils
let attr = (attrValue "id" e, T.words $ attrValue "role" e, [])
@@ -1180,7 +1180,7 @@ parseInline (Elem e) =
"pi-asciidoc-br" -> return linebreak
_ -> skip >> innerInlines id
where skip = do
let qn = T.pack $ qName $ elName e
let qn = qName $ elName e
let name = if "pi-" `T.isPrefixOf` qn
then "<?" <> qn <> "?>"
else qn
@@ -1193,7 +1193,7 @@ parseInline (Elem e) =
let classes' = case attrValue "language" e of
"" -> []
l -> [l]
return $ codeWith (attrValue "id" e,classes',[]) $ T.pack $ strContentRecursive e
return $ codeWith (attrValue "id" e,classes',[]) $ strContentRecursive e
simpleList = mconcat . intersperse (str "," <> space) <$> mapM getInlines
(filterChildren (named "member") e)
segmentedList = do
@@ -1234,10 +1234,10 @@ parseInline (Elem e) =
"sect5" -> descendantContent "title" el
"cmdsynopsis" -> descendantContent "command" el
"funcsynopsis" -> descendantContent "function" el
_ -> T.pack $ qName (elName el) ++ "_title"
_ -> qName (elName el) <> "_title"
where
xrefLabel = attrValue "xreflabel" el
descendantContent name = maybe "???" (T.pack . strContent)
descendantContent name = maybe "???" strContent
. filterElementName (\n -> qName n == name)
-- | Extract a math equation from an element
@@ -1258,7 +1258,7 @@ equation e constructor =
mathMLEquations :: [Text]
mathMLEquations = map writeTeX $ rights $ readMath
(\x -> qName (elName x) == "math" && qPrefix (elName x) == Just "mml")
(readMathML . T.pack . showElement)
(readMathML . showElement)
latexEquations :: [Text]
latexEquations = readMath (\x -> qName (elName x) == "mathphrase")
@@ -1272,8 +1272,8 @@ equation e constructor =
-- | Get the actual text stored in a CData block. 'showContent'
-- returns the text still surrounded by the [[CDATA]] tags.
showVerbatimCData :: Content -> Text
showVerbatimCData (Text (CData _ d _)) = T.pack d
showVerbatimCData c = T.pack $ showContent c
showVerbatimCData (Text (CData _ d _)) = d
showVerbatimCData c = showContent c
-- | Set the prefix of a name to 'Nothing'
src/Text/Pandoc/Readers/Docx/Parse.hs
+75 -88
View File
@@ -63,6 +63,7 @@ import Data.Char (chr, ord, readLitChar)
import Data.List
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Text (Text)
import Data.Maybe
import System.FilePath
import Text.Pandoc.Readers.Docx.Util
@@ -72,9 +73,7 @@ import qualified Text.Pandoc.UTF8 as UTF8
import Text.TeXMath (Exp)
import Text.TeXMath.Readers.OMML (readOMML)
import Text.TeXMath.Unicode.Fonts (Font (..), getUnicode, textToFont)
import Text.XML.Light
import qualified Text.XML.Light.Cursor as XMLC
import Text.Pandoc.XMLParser (parseXMLElement)
import Text.Pandoc.XML.Light
data ReaderEnv = ReaderEnv { envNotes :: Notes
, envComments :: Comments
@@ -128,37 +127,23 @@ mapD f xs =
in
concatMapM handler xs
unwrap :: NameSpaces -> Content -> [Content]
unwrap ns (Elem element)
unwrapElement :: NameSpaces -> Element -> [Element]
unwrapElement ns element
| isElem ns "w" "sdt" element
, Just sdtContent <- findChildByName ns "w" "sdtContent" element
= concatMap (unwrap ns . Elem) (elChildren sdtContent)
= concatMap (unwrapElement ns) (elChildren sdtContent)
| isElem ns "w" "smartTag" element
= concatMap (unwrap ns . Elem) (elChildren element)
unwrap _ content = [content]
= concatMap (unwrapElement ns) (elChildren element)
| otherwise
= [element{ elContent = concatMap (unwrapContent ns) (elContent element) }]
unwrapChild :: NameSpaces -> Content -> Content
unwrapChild ns (Elem element) =
Elem $ element { elContent = concatMap (unwrap ns) (elContent element) }
unwrapChild _ content = content
unwrapContent :: NameSpaces -> Content -> [Content]
unwrapContent ns (Elem element) = map Elem $ unwrapElement ns element
unwrapContent _ content = [content]
walkDocument' :: NameSpaces -> XMLC.Cursor -> XMLC.Cursor
walkDocument' ns cur =
let modifiedCur = XMLC.modifyContent (unwrapChild ns) cur
in
case XMLC.nextDF modifiedCur of
Just cur' -> walkDocument' ns cur'
Nothing -> XMLC.root modifiedCur
walkDocument :: NameSpaces -> Element -> Maybe Element
walkDocument :: NameSpaces -> Element -> Element
walkDocument ns element =
let cur = XMLC.fromContent (Elem element)
cur' = walkDocument' ns cur
in
case XMLC.toTree cur' of
Elem element' -> Just element'
_ -> Nothing
element{ elContent = concatMap (unwrapContent ns) (elContent element) }
newtype Docx = Docx Document
deriving Show
@@ -361,9 +346,9 @@ getDocumentXmlPath zf = do
fp <- findAttr (QName "Target" Nothing Nothing) rel
-- sometimes there will be a leading slash, which windows seems to
-- have trouble with.
return $ case fp of
return $ case T.unpack fp of
'/' : fp' -> fp'
_ -> fp
fp' -> fp'
archiveToDocument :: Archive -> D Document
archiveToDocument zf = do
@@ -372,7 +357,7 @@ archiveToDocument zf = do
docElem <- maybeToD $ parseXMLFromEntry entry
let namespaces = elemToNameSpaces docElem
bodyElem <- maybeToD $ findChildByName namespaces "w" "body" docElem
let bodyElem' = fromMaybe bodyElem (walkDocument namespaces bodyElem)
let bodyElem' = walkDocument namespaces bodyElem
body <- elemToBody namespaces bodyElem'
return $ Document namespaces body
@@ -414,8 +399,8 @@ archiveToNotes zf =
fn_namespaces = maybe [] elemToNameSpaces fnElem
en_namespaces = maybe [] elemToNameSpaces enElem
ns = unionBy (\x y -> fst x == fst y) fn_namespaces en_namespaces
fn = fnElem >>= walkDocument ns >>= elemToNotes ns "footnote"
en = enElem >>= walkDocument ns >>= elemToNotes ns "endnote"
fn = fnElem >>= elemToNotes ns "footnote" . walkDocument ns
en = enElem >>= elemToNotes ns "endnote" . walkDocument ns
in
Notes ns fn en
@@ -424,7 +409,8 @@ archiveToComments zf =
let cmtsElem = findEntryByPath "word/comments.xml" zf
>>= parseXMLFromEntry
cmts_namespaces = maybe [] elemToNameSpaces cmtsElem
cmts = elemToComments cmts_namespaces <$> (cmtsElem >>= walkDocument cmts_namespaces)
cmts = elemToComments cmts_namespaces . walkDocument cmts_namespaces <$>
cmtsElem
in
case cmts of
Just c -> Comments cmts_namespaces c
@@ -443,8 +429,8 @@ filePathToRelType path docXmlPath =
relElemToRelationship :: DocumentLocation -> Element -> Maybe Relationship
relElemToRelationship relType element | qName (elName element) == "Relationship" =
do
relId <- findAttrText (QName "Id" Nothing Nothing) element
target <- findAttrText (QName "Target" Nothing Nothing) element
relId <- findAttr (QName "Id" Nothing Nothing) element
target <- findAttr (QName "Target" Nothing Nothing) element
return $ Relationship relType relId target
relElemToRelationship _ _ = Nothing
@@ -485,10 +471,10 @@ lookupLevel numId ilvl (Numbering _ numbs absNumbs) = do
loElemToLevelOverride :: NameSpaces -> Element -> Maybe LevelOverride
loElemToLevelOverride ns element
| isElem ns "w" "lvlOverride" element = do
ilvl <- findAttrTextByName ns "w" "ilvl" element
ilvl <- findAttrByName ns "w" "ilvl" element
let startOverride = findChildByName ns "w" "startOverride" element
>>= findAttrByName ns "w" "val"
>>= (\s -> listToMaybe (map fst (reads s :: [(Integer, String)])))
>>= stringToInteger
lvl = findChildByName ns "w" "lvl" element
>>= levelElemToLevel ns
return $ LevelOverride ilvl startOverride lvl
@@ -497,9 +483,9 @@ loElemToLevelOverride _ _ = Nothing
numElemToNum :: NameSpaces -> Element -> Maybe Numb
numElemToNum ns element
| isElem ns "w" "num" element = do
numId <- findAttrTextByName ns "w" "numId" element
numId <- findAttrByName ns "w" "numId" element
absNumId <- findChildByName ns "w" "abstractNumId" element
>>= findAttrTextByName ns "w" "val"
>>= findAttrByName ns "w" "val"
let lvlOverrides = mapMaybe
(loElemToLevelOverride ns)
(findChildrenByName ns "w" "lvlOverride" element)
@@ -509,7 +495,7 @@ numElemToNum _ _ = Nothing
absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb
absNumElemToAbsNum ns element
| isElem ns "w" "abstractNum" element = do
absNumId <- findAttrTextByName ns "w" "abstractNumId" element
absNumId <- findAttrByName ns "w" "abstractNumId" element
let levelElems = findChildrenByName ns "w" "lvl" element
levels = mapMaybe (levelElemToLevel ns) levelElems
return $ AbstractNumb absNumId levels
@@ -518,14 +504,14 @@ absNumElemToAbsNum _ _ = Nothing
levelElemToLevel :: NameSpaces -> Element -> Maybe Level
levelElemToLevel ns element
| isElem ns "w" "lvl" element = do
ilvl <- findAttrTextByName ns "w" "ilvl" element
ilvl <- findAttrByName ns "w" "ilvl" element
fmt <- findChildByName ns "w" "numFmt" element
>>= findAttrTextByName ns "w" "val"
>>= findAttrByName ns "w" "val"
txt <- findChildByName ns "w" "lvlText" element
>>= findAttrTextByName ns "w" "val"
>>= findAttrByName ns "w" "val"
let start = findChildByName ns "w" "start" element
>>= findAttrByName ns "w" "val"
>>= (\s -> listToMaybe (map fst (reads s :: [(Integer, String)])))
>>= stringToInteger
return (Level ilvl fmt txt start)
levelElemToLevel _ _ = Nothing
@@ -546,11 +532,11 @@ archiveToNumbering :: Archive -> Numbering
archiveToNumbering archive =
fromMaybe (Numbering [] [] []) (archiveToNumbering' archive)
elemToNotes :: NameSpaces -> String -> Element -> Maybe (M.Map T.Text Element)
elemToNotes :: NameSpaces -> Text -> Element -> Maybe (M.Map T.Text Element)
elemToNotes ns notetype element
| isElem ns "w" (notetype <> "s") element =
let pairs = mapMaybe
(\e -> findAttrTextByName ns "w" "id" e >>=
(\e -> findAttrByName ns "w" "id" e >>=
(\a -> Just (a, e)))
(findChildrenByName ns "w" notetype element)
in
@@ -562,7 +548,7 @@ elemToComments :: NameSpaces -> Element -> M.Map T.Text Element
elemToComments ns element
| isElem ns "w" "comments" element =
let pairs = mapMaybe
(\e -> findAttrTextByName ns "w" "id" e >>=
(\e -> findAttrByName ns "w" "id" e >>=
(\a -> Just (a, e)))
(findChildrenByName ns "w" "comment" element)
in
@@ -622,12 +608,12 @@ elemToParIndentation ns element | isElem ns "w" "ind" element =
stringToInteger
, hangingParIndent =
findAttrByName ns "w" "hanging" element >>=
stringToInteger}
stringToInteger }
elemToParIndentation _ _ = Nothing
testBitMask :: String -> Int -> Bool
testBitMask :: Text -> Int -> Bool
testBitMask bitMaskS n =
case (reads ("0x" ++ bitMaskS) :: [(Int, String)]) of
case (reads ("0x" ++ T.unpack bitMaskS) :: [(Int, String)]) of
[] -> False
((n', _) : _) -> (n' .|. n) /= 0
@@ -642,7 +628,7 @@ elemToBodyPart ns element
| isElem ns "w" "p" element
, (c:_) <- findChildrenByName ns "m" "oMathPara" element =
do
expsLst <- eitherToD $ readOMML $ T.pack $ showElement c
expsLst <- eitherToD $ readOMML $ showElement c
return $ OMathPara expsLst
elemToBodyPart ns element
| isElem ns "w" "p" element
@@ -666,7 +652,7 @@ elemToBodyPart ns element
| isElem ns "w" "tbl" element = do
let caption' = findChildByName ns "w" "tblPr" element
>>= findChildByName ns "w" "tblCaption"
>>= findAttrTextByName ns "w" "val"
>>= findAttrByName ns "w" "val"
caption = fromMaybe "" caption'
grid' = case findChildByName ns "w" "tblGrid" element of
Just g -> elemToTblGrid ns g
@@ -705,8 +691,8 @@ getTitleAndAlt :: NameSpaces -> Element -> (T.Text, T.Text)
getTitleAndAlt ns element =
let mbDocPr = findChildByName ns "wp" "inline" element >>=
findChildByName ns "wp" "docPr"
title = fromMaybe "" (mbDocPr >>= findAttrTextByName ns "" "title")
alt = fromMaybe "" (mbDocPr >>= findAttrTextByName ns "" "descr")
title = fromMaybe "" (mbDocPr >>= findAttrByName ns "" "title")
alt = fromMaybe "" (mbDocPr >>= findAttrByName ns "" "descr")
in (title, alt)
elemToParPart :: NameSpaces -> Element -> D ParPart
@@ -718,7 +704,7 @@ elemToParPart ns element
= let (title, alt) = getTitleAndAlt ns drawingElem
a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
drawing = findElement (QName "blip" (Just a_ns) (Just "a")) picElem
>>= findAttrTextByName ns "r" "embed"
>>= findAttrByName ns "r" "embed"
in
case drawing of
Just s -> expandDrawingId s >>= (\(fp, bs) -> return $ Drawing fp title alt bs $ elemToExtent drawingElem)
@@ -728,7 +714,7 @@ elemToParPart ns element
| isElem ns "w" "r" element
, Just _ <- findChildByName ns "w" "pict" element =
let drawing = findElement (elemName ns "v" "imagedata") element
>>= findAttrTextByName ns "r" "id"
>>= findAttrByName ns "r" "id"
in
case drawing of
-- Todo: check out title and attr for deprecated format.
@@ -797,7 +783,7 @@ elemToParPart ns element
fldCharState <- gets stateFldCharState
case fldCharState of
FldCharOpen -> do
info <- eitherToD $ parseFieldInfo $ T.pack $ strContent instrText
info <- eitherToD $ parseFieldInfo $ strContent instrText
modify $ \st -> st{stateFldCharState = FldCharFieldInfo info}
return NullParPart
_ -> return NullParPart
@@ -818,48 +804,48 @@ elemToParPart ns element
return $ ChangedRuns change runs
elemToParPart ns element
| isElem ns "w" "bookmarkStart" element
, Just bmId <- findAttrTextByName ns "w" "id" element
, Just bmName <- findAttrTextByName ns "w" "name" element =
, Just bmId <- findAttrByName ns "w" "id" element
, Just bmName <- findAttrByName ns "w" "name" element =
return $ BookMark bmId bmName
elemToParPart ns element
| isElem ns "w" "hyperlink" element
, Just relId <- findAttrTextByName ns "r" "id" element = do
, Just relId <- findAttrByName ns "r" "id" element = do
location <- asks envLocation
runs <- mapD (elemToRun ns) (elChildren element)
rels <- asks envRelationships
case lookupRelationship location relId rels of
Just target ->
case findAttrTextByName ns "w" "anchor" element of
case findAttrByName ns "w" "anchor" element of
Just anchor -> return $ ExternalHyperLink (target <> "#" <> anchor) runs
Nothing -> return $ ExternalHyperLink target runs
Nothing -> return $ ExternalHyperLink "" runs
elemToParPart ns element
| isElem ns "w" "hyperlink" element
, Just anchor <- findAttrTextByName ns "w" "anchor" element = do
, Just anchor <- findAttrByName ns "w" "anchor" element = do
runs <- mapD (elemToRun ns) (elChildren element)
return $ InternalHyperLink anchor runs
elemToParPart ns element
| isElem ns "w" "commentRangeStart" element
, Just cmtId <- findAttrTextByName ns "w" "id" element = do
, Just cmtId <- findAttrByName ns "w" "id" element = do
(Comments _ commentMap) <- asks envComments
case M.lookup cmtId commentMap of
Just cmtElem -> elemToCommentStart ns cmtElem
Nothing -> throwError WrongElem
elemToParPart ns element
| isElem ns "w" "commentRangeEnd" element
, Just cmtId <- findAttrTextByName ns "w" "id" element =
, Just cmtId <- findAttrByName ns "w" "id" element =
return $ CommentEnd cmtId
elemToParPart ns element
| isElem ns "m" "oMath" element =
fmap PlainOMath (eitherToD $ readOMML $ T.pack $ showElement element)
fmap PlainOMath (eitherToD $ readOMML $ showElement element)
elemToParPart _ _ = throwError WrongElem
elemToCommentStart :: NameSpaces -> Element -> D ParPart
elemToCommentStart ns element
| isElem ns "w" "comment" element
, Just cmtId <- findAttrTextByName ns "w" "id" element
, Just cmtAuthor <- findAttrTextByName ns "w" "author" element
, cmtDate <- findAttrTextByName ns "w" "date" element = do
, Just cmtId <- findAttrByName ns "w" "id" element
, Just cmtAuthor <- findAttrByName ns "w" "author" element
, cmtDate <- findAttrByName ns "w" "date" element = do
bps <- mapD (elemToBodyPart ns) (elChildren element)
return $ CommentStart cmtId cmtAuthor cmtDate bps
elemToCommentStart _ _ = throwError WrongElem
@@ -878,7 +864,7 @@ elemToExtent drawingElem =
where
wp_ns = "http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawing"
getDim at = findElement (QName "extent" (Just wp_ns) (Just "wp")) drawingElem
>>= findAttr (QName at Nothing Nothing) >>= safeRead . T.pack
>>= findAttr (QName at Nothing Nothing) >>= safeRead
childElemToRun :: NameSpaces -> Element -> D Run
@@ -889,7 +875,7 @@ childElemToRun ns element
= let (title, alt) = getTitleAndAlt ns element
a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
drawing = findElement (QName "blip" (Just a_ns) (Just "a")) picElem
>>= findAttrText (QName "embed" (lookup "r" ns) (Just "r"))
>>= findAttr (QName "embed" (lookup "r" ns) (Just "r"))
in
case drawing of
Just s -> expandDrawingId s >>=
@@ -902,7 +888,7 @@ childElemToRun ns element
= return InlineChart
childElemToRun ns element
| isElem ns "w" "footnoteReference" element
, Just fnId <- findAttrTextByName ns "w" "id" element = do
, Just fnId <- findAttrByName ns "w" "id" element = do
notes <- asks envNotes
case lookupFootnote fnId notes of
Just e -> do bps <- local (\r -> r {envLocation=InFootnote}) $ mapD (elemToBodyPart ns) (elChildren e)
@@ -910,7 +896,7 @@ childElemToRun ns element
Nothing -> return $ Footnote []
childElemToRun ns element
| isElem ns "w" "endnoteReference" element
, Just enId <- findAttrTextByName ns "w" "id" element = do
, Just enId <- findAttrByName ns "w" "id" element = do
notes <- asks envNotes
case lookupEndnote enId notes of
Just e -> do bps <- local (\r -> r {envLocation=InEndnote}) $ mapD (elemToBodyPart ns) (elChildren e)
@@ -963,15 +949,15 @@ getParStyleField _ _ = Nothing
getTrackedChange :: NameSpaces -> Element -> Maybe TrackedChange
getTrackedChange ns element
| isElem ns "w" "ins" element || isElem ns "w" "moveTo" element
, Just cId <- findAttrTextByName ns "w" "id" element
, Just cAuthor <- findAttrTextByName ns "w" "author" element
, mcDate <- findAttrTextByName ns "w" "date" element =
, Just cId <- findAttrByName ns "w" "id" element
, Just cAuthor <- findAttrByName ns "w" "author" element
, mcDate <- findAttrByName ns "w" "date" element =
Just $ TrackedChange Insertion (ChangeInfo cId cAuthor mcDate)
getTrackedChange ns element
| isElem ns "w" "del" element || isElem ns "w" "moveFrom" element
, Just cId <- findAttrTextByName ns "w" "id" element
, Just cAuthor <- findAttrTextByName ns "w" "author" element
, mcDate <- findAttrTextByName ns "w" "date" element =
, Just cId <- findAttrByName ns "w" "id" element
, Just cAuthor <- findAttrByName ns "w" "author" element
, mcDate <- findAttrByName ns "w" "date" element =
Just $ TrackedChange Deletion (ChangeInfo cId cAuthor mcDate)
getTrackedChange _ _ = Nothing
@@ -980,7 +966,7 @@ elemToParagraphStyle ns element sty
| Just pPr <- findChildByName ns "w" "pPr" element =
let style =
mapMaybe
(fmap ParaStyleId . findAttrTextByName ns "w" "val")
(fmap ParaStyleId . findAttrByName ns "w" "val")
(findChildrenByName ns "w" "pStyle" pPr)
in ParagraphStyle
{pStyle = mapMaybe (`M.lookup` sty) style
@@ -1012,7 +998,7 @@ elemToRunStyleD ns element
charStyles <- asks envCharStyles
let parentSty =
findChildByName ns "w" "rStyle" rPr >>=
findAttrTextByName ns "w" "val" >>=
findAttrByName ns "w" "val" >>=
flip M.lookup charStyles . CharStyleId
return $ elemToRunStyle ns element parentSty
elemToRunStyleD _ _ = return defaultRunStyle
@@ -1022,7 +1008,7 @@ elemToRunElem ns element
| isElem ns "w" "t" element
|| isElem ns "w" "delText" element
|| isElem ns "m" "t" element = do
let str = T.pack $ strContent element
let str = strContent element
font <- asks envFont
case font of
Nothing -> return $ TextRun str
@@ -1044,14 +1030,14 @@ getSymChar :: NameSpaces -> Element -> RunElem
getSymChar ns element
| Just s <- lowerFromPrivate <$> getCodepoint
, Just font <- getFont =
case readLitChar ("\\x" ++ s) of
case readLitChar ("\\x" ++ T.unpack s) of
[(char, _)] -> TextRun . maybe "" T.singleton $ getUnicode font char
_ -> TextRun ""
where
getCodepoint = findAttrByName ns "w" "char" element
getFont = textToFont . T.pack =<< findAttrByName ns "w" "font" element
lowerFromPrivate ('F':xs) = '0':xs
lowerFromPrivate xs = xs
getFont = textToFont =<< findAttrByName ns "w" "font" element
lowerFromPrivate t | "F" `T.isPrefixOf` t = "0" <> T.drop 1 t
| otherwise = t
getSymChar _ _ = TextRun ""
elemToRunElems :: NameSpaces -> Element -> D [RunElem]
@@ -1061,8 +1047,9 @@ elemToRunElems ns element
let qualName = elemName ns "w"
let font = do
fontElem <- findElement (qualName "rFonts") element
textToFont . T.pack =<<
foldr ((<|>) . (flip findAttr fontElem . qualName)) Nothing ["ascii", "hAnsi"]
textToFont =<<
foldr ((<|>) . (flip findAttr fontElem . qualName))
Nothing ["ascii", "hAnsi"]
local (setFont font) (mapD (elemToRunElem ns) (elChildren element))
elemToRunElems _ _ = throwError WrongElem
src/Text/Pandoc/Readers/Docx/Parse/Styles.hs
+17 -14
View File
@@ -48,12 +48,13 @@ import Data.Function (on)
import Data.String (IsString(..))
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Read
import Data.Text (Text)
import Data.Maybe
import Data.Coerce
import Text.Pandoc.Readers.Docx.Util
import qualified Text.Pandoc.UTF8 as UTF8
import Text.XML.Light
import Text.Pandoc.XMLParser (parseXMLElement)
import Text.Pandoc.XML.Light
newtype CharStyleId = CharStyleId T.Text
deriving (Show, Eq, Ord, IsString, FromStyleId)
@@ -109,7 +110,7 @@ data RunStyle = RunStyle { isBold :: Maybe Bool
, isRTL :: Maybe Bool
, isForceCTL :: Maybe Bool
, rVertAlign :: Maybe VertAlign
, rUnderline :: Maybe String
, rUnderline :: Maybe Text
, rParentStyle :: Maybe CharStyle
}
deriving Show
@@ -159,7 +160,7 @@ isBasedOnStyle ns element parentStyle
, Just styleType <- findAttrByName ns "w" "type" element
, styleType == cStyleType parentStyle
, Just basedOnVal <- findChildByName ns "w" "basedOn" element >>=
findAttrTextByName ns "w" "val"
findAttrByName ns "w" "val"
, Just ps <- parentStyle = basedOnVal == fromStyleId (getStyleId ps)
| isElem ns "w" "style" element
, Just styleType <- findAttrByName ns "w" "type" element
@@ -169,7 +170,7 @@ isBasedOnStyle ns element parentStyle
| otherwise = False
class HasStyleId a => ElemToStyle a where
cStyleType :: Maybe a -> String
cStyleType :: Maybe a -> Text
elemToStyle :: NameSpaces -> Element -> Maybe a -> Maybe a
class FromStyleId (StyleId a) => HasStyleId a where
@@ -226,8 +227,10 @@ buildBasedOnList ns element rootStyle =
stys -> stys ++
concatMap (buildBasedOnList ns element . Just) stys
stringToInteger :: String -> Maybe Integer
stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)])
stringToInteger :: Text -> Maybe Integer
stringToInteger s = case Data.Text.Read.decimal s of
Right (x,_) -> Just x
Left _ -> Nothing
checkOnOff :: NameSpaces -> Element -> QName -> Maybe Bool
checkOnOff ns rPr tag
@@ -247,7 +250,7 @@ checkOnOff _ _ _ = Nothing
elemToCharStyle :: NameSpaces
-> Element -> Maybe CharStyle -> Maybe CharStyle
elemToCharStyle ns element parentStyle
= CharStyle <$> (CharStyleId <$> findAttrTextByName ns "w" "styleId" element)
= CharStyle <$> (CharStyleId <$> findAttrByName ns "w" "styleId" element)
<*> getElementStyleName ns element
<*> Just (elemToRunStyle ns element parentStyle)
@@ -281,7 +284,7 @@ elemToRunStyle _ _ _ = defaultRunStyle
getHeaderLevel :: NameSpaces -> Element -> Maybe (ParaStyleName, Int)
getHeaderLevel ns element
| Just styleName <- getElementStyleName ns element
, Just n <- stringToInteger . T.unpack =<<
, Just n <- stringToInteger =<<
(T.stripPrefix "heading " . T.toLower $
fromStyleName styleName)
, n > 0 = Just (styleName, fromInteger n)
@@ -289,8 +292,8 @@ getHeaderLevel _ _ = Nothing
getElementStyleName :: Coercible T.Text a => NameSpaces -> Element -> Maybe a
getElementStyleName ns el = coerce <$>
((findChildByName ns "w" "name" el >>= findAttrTextByName ns "w" "val")
<|> findAttrTextByName ns "w" "styleId" el)
((findChildByName ns "w" "name" el >>= findAttrByName ns "w" "val")
<|> findAttrByName ns "w" "styleId" el)
getNumInfo :: NameSpaces -> Element -> Maybe (T.Text, T.Text)
getNumInfo ns element = do
@@ -298,15 +301,15 @@ getNumInfo ns element = do
findChildByName ns "w" "numPr"
lvl = fromMaybe "0" (numPr >>=
findChildByName ns "w" "ilvl" >>=
findAttrTextByName ns "w" "val")
findAttrByName ns "w" "val")
numId <- numPr >>=
findChildByName ns "w" "numId" >>=
findAttrTextByName ns "w" "val"
findAttrByName ns "w" "val"
return (numId, lvl)
elemToParStyleData :: NameSpaces -> Element -> Maybe ParStyle -> Maybe ParStyle
elemToParStyleData ns element parentStyle
| Just styleId <- findAttrTextByName ns "w" "styleId" element
| Just styleId <- findAttrByName ns "w" "styleId" element
, Just styleName <- getElementStyleName ns element
= Just $ ParStyle
{
src/Text/Pandoc/Readers/Docx/Util.hs
+11 -16
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Readers.Docx.StyleMaps
Copyright : © 2014-2020 Jesse Rosenthal <jrosenthal@jhu.edu>,
@@ -18,51 +19,45 @@ module Text.Pandoc.Readers.Docx.Util (
, elemToNameSpaces
, findChildByName
, findChildrenByName
, findAttrText
, findAttrByName
, findAttrTextByName
) where
import Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Text.XML.Light
import Data.Text (Text)
import Text.Pandoc.XML.Light
type NameSpaces = [(String, String)]
type NameSpaces = [(Text, Text)]
elemToNameSpaces :: Element -> NameSpaces
elemToNameSpaces = mapMaybe attrToNSPair . elAttribs
attrToNSPair :: Attr -> Maybe (String, String)
attrToNSPair :: Attr -> Maybe (Text, Text)
attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val)
attrToNSPair _ = Nothing
elemName :: NameSpaces -> String -> String -> QName
elemName :: NameSpaces -> Text -> Text -> QName
elemName ns prefix name =
QName name (lookup prefix ns) (if null prefix then Nothing else Just prefix)
QName name (lookup prefix ns) (if T.null prefix then Nothing else Just prefix)
isElem :: NameSpaces -> String -> String -> Element -> Bool
isElem :: NameSpaces -> Text -> Text -> Element -> Bool
isElem ns prefix name element =
let ns' = ns ++ elemToNameSpaces element
in qName (elName element) == name &&
qURI (elName element) == lookup prefix ns'
findChildByName :: NameSpaces -> String -> String -> Element -> Maybe Element
findChildByName :: NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName ns pref name el =
let ns' = ns ++ elemToNameSpaces el
in findChild (elemName ns' pref name) el
findChildrenByName :: NameSpaces -> String -> String -> Element -> [Element]
findChildrenByName :: NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName ns pref name el =
let ns' = ns ++ elemToNameSpaces el
in findChildren (elemName ns' pref name) el
findAttrText :: QName -> Element -> Maybe T.Text
findAttrText x = fmap T.pack . findAttr x
findAttrByName :: NameSpaces -> String -> String -> Element -> Maybe String
findAttrByName :: NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName ns pref name el =
let ns' = ns ++ elemToNameSpaces el
in findAttr (elemName ns' pref name) el
findAttrTextByName :: NameSpaces -> String -> String -> Element -> Maybe T.Text
findAttrTextByName a b c = fmap T.pack . findAttrByName a b c
src/Text/Pandoc/Readers/EPUB.hs
+34 -31
View File
@@ -23,8 +23,8 @@ import Control.DeepSeq (NFData, deepseq)
import Control.Monad (guard, liftM, liftM2, mplus)
import Control.Monad.Except (throwError)
import qualified Data.ByteString.Lazy as BL (ByteString)
import Data.List (isInfixOf)
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Map as M (Map, elems, fromList, lookup)
import Data.Maybe (mapMaybe)
import qualified Data.Text.Lazy as TL
@@ -40,13 +40,12 @@ import Text.Pandoc.Extensions (Extension (Ext_raw_html), enableExtension)
import Text.Pandoc.MIME (MimeType)
import Text.Pandoc.Options (ReaderOptions (..))
import Text.Pandoc.Readers.HTML (readHtml)
import Text.Pandoc.Shared (addMetaField, collapseFilePath, escapeURI)
import Text.Pandoc.Shared (addMetaField, collapseFilePath, escapeURI, tshow)
import qualified Text.Pandoc.UTF8 as UTF8 (toTextLazy)
import Text.Pandoc.Walk (query, walk)
import Text.XML.Light
import Text.Pandoc.XMLParser (parseXMLElement)
import Text.Pandoc.XML.Light
type Items = M.Map String (FilePath, MimeType)
type Items = M.Map Text (FilePath, MimeType)
readEPUB :: PandocMonad m => ReaderOptions -> BL.ByteString -> m Pandoc
readEPUB opts bytes = case toArchiveOrFail bytes of
@@ -126,26 +125,27 @@ imageToPandoc s = B.doc . B.para $ B.image (T.pack s) "" mempty
imageMimes :: [MimeType]
imageMimes = ["image/gif", "image/jpeg", "image/png"]
type CoverId = String
type CoverId = Text
type CoverImage = FilePath
parseManifest :: (PandocMonad m) => Element -> Maybe CoverId -> m (Maybe CoverImage, Items)
parseManifest :: (PandocMonad m)
=> Element -> Maybe CoverId -> m (Maybe CoverImage, Items)
parseManifest content coverId = do
manifest <- findElementE (dfName "manifest") content
let items = findChildren (dfName "item") manifest
r <- mapM parseItem items
let cover = findAttr (emptyName "href") =<< filterChild findCover manifest
return (cover `mplus` coverId, M.fromList r)
return (T.unpack <$> (cover `mplus` coverId), M.fromList r)
where
findCover e = maybe False (isInfixOf "cover-image")
findCover e = maybe False (T.isInfixOf "cover-image")
(findAttr (emptyName "properties") e)
|| Just True == liftM2 (==) coverId (findAttr (emptyName "id") e)
parseItem e = do
uid <- findAttrE (emptyName "id") e
href <- findAttrE (emptyName "href") e
mime <- findAttrE (emptyName "media-type") e
return (uid, (href, T.pack mime))
return (uid, (T.unpack href, mime))
parseSpine :: PandocMonad m => Items -> Element -> m [(FilePath, MimeType)]
parseSpine is e = do
@@ -173,11 +173,11 @@ parseMeta content = do
-- http://www.idpf.org/epub/30/spec/epub30-publications.html#sec-metadata-elem
parseMetaItem :: Element -> Meta -> Meta
parseMetaItem e@(stripNamespace . elName -> field) meta =
addMetaField (renameMeta field) (B.str $ T.pack $ strContent e) meta
addMetaField (renameMeta field) (B.str $ strContent e) meta
renameMeta :: String -> T.Text
renameMeta :: Text -> Text
renameMeta "creator" = "author"
renameMeta s = T.pack s
renameMeta s = s
getManifest :: PandocMonad m => Archive -> m (String, Element)
getManifest archive = do
@@ -187,7 +187,7 @@ getManifest archive = do
ns <- mkE "xmlns not in namespaces" (lookup "xmlns" namespaces)
as <- fmap (map attrToPair . elAttribs)
(findElementE (QName "rootfile" (Just ns) Nothing) docElem)
manifestFile <- mkE "Root not found" (lookup "full-path" as)
manifestFile <- T.unpack <$> mkE "Root not found" (lookup "full-path" as)
let rootdir = dropFileName manifestFile
--mime <- lookup "media-type" as
manifest <- findEntryByPathE manifestFile archive
@@ -201,7 +201,8 @@ fixInternalReferences pathToFile =
. walk (fixBlockIRs filename)
. walk (fixInlineIRs filename)
where
(root, T.unpack . escapeURI . T.pack -> filename) = splitFileName pathToFile
(root, T.unpack . escapeURI . T.pack -> filename) =
splitFileName pathToFile
fixInlineIRs :: String -> Inline -> Inline
fixInlineIRs s (Span as v) =
@@ -214,7 +215,7 @@ fixInlineIRs s (Link as is t) =
Link (fixAttrs s as) is t
fixInlineIRs _ v = v
prependHash :: [T.Text] -> Inline -> Inline
prependHash :: [Text] -> Inline -> Inline
prependHash ps l@(Link attr is (url, tit))
| or [s `T.isPrefixOf` url | s <- ps] =
Link attr is ("#" <> url, tit)
@@ -231,16 +232,17 @@ fixBlockIRs s (CodeBlock as code) =
fixBlockIRs _ b = b
fixAttrs :: FilePath -> B.Attr -> B.Attr
fixAttrs s (ident, cs, kvs) = (addHash s ident, filter (not . T.null) cs, removeEPUBAttrs kvs)
fixAttrs s (ident, cs, kvs) =
(addHash s ident, filter (not . T.null) cs, removeEPUBAttrs kvs)
addHash :: String -> T.Text -> T.Text
addHash :: FilePath -> Text -> Text
addHash _ "" = ""
addHash s ident = T.pack (takeFileName s) <> "#" <> ident
removeEPUBAttrs :: [(T.Text, T.Text)] -> [(T.Text, T.Text)]
removeEPUBAttrs :: [(Text, Text)] -> [(Text, Text)]
removeEPUBAttrs kvs = filter (not . isEPUBAttr) kvs
isEPUBAttr :: (T.Text, a) -> Bool
isEPUBAttr :: (Text, a) -> Bool
isEPUBAttr (k, _) = "epub:" `T.isPrefixOf` k
-- Library
@@ -257,33 +259,33 @@ uncurry3 f (a, b, c) = f a b c
-- Utility
stripNamespace :: QName -> String
stripNamespace :: QName -> Text
stripNamespace (QName v _ _) = v
attrToNSPair :: Attr -> Maybe (String, String)
attrToNSPair :: Attr -> Maybe (Text, Text)
attrToNSPair (Attr (QName "xmlns" _ _) val) = Just ("xmlns", val)
attrToNSPair _ = Nothing
attrToPair :: Attr -> (String, String)
attrToPair :: Attr -> (Text, Text)
attrToPair (Attr (QName name _ _) val) = (name, val)
defaultNameSpace :: Maybe String
defaultNameSpace :: Maybe Text
defaultNameSpace = Just "http://www.idpf.org/2007/opf"
dfName :: String -> QName
dfName :: Text -> QName
dfName s = QName s defaultNameSpace Nothing
emptyName :: String -> QName
emptyName :: Text -> QName
emptyName s = QName s Nothing Nothing
-- Convert Maybe interface to Either
findAttrE :: PandocMonad m => QName -> Element -> m String
findAttrE :: PandocMonad m => QName -> Element -> m Text
findAttrE q e = mkE "findAttr" $ findAttr q e
findEntryByPathE :: PandocMonad m => FilePath -> Archive -> m Entry
findEntryByPathE (normalise . unEscapeString -> path) a =
mkE ("No entry on path: " ++ path) $ findEntryByPath path a
mkE ("No entry on path: " <> T.pack path) $ findEntryByPath path a
parseXMLDocE :: PandocMonad m => Entry -> m Element
parseXMLDocE entry =
@@ -293,7 +295,8 @@ parseXMLDocE entry =
fp = T.pack $ eRelativePath entry
findElementE :: PandocMonad m => QName -> Element -> m Element
findElementE e x = mkE ("Unable to find element: " ++ show e) $ findElement e x
findElementE e x =
mkE ("Unable to find element: " <> tshow e) $ findElement e x
mkE :: PandocMonad m => String -> Maybe a -> m a
mkE s = maybe (throwError . PandocParseError $ T.pack s) return
mkE :: PandocMonad m => Text -> Maybe a -> m a
mkE s = maybe (throwError . PandocParseError $ s) return
src/Text/Pandoc/Readers/FB2.hs
+47 -46
View File
@@ -25,7 +25,6 @@ TODO:
module Text.Pandoc.Readers.FB2 ( readFB2 ) where
import Control.Monad.Except (throwError)
import Control.Monad.State.Strict
import Data.ByteString.Lazy.Char8 ( pack )
import Data.ByteString.Base64.Lazy
import Data.Functor
import Data.List (intersperse)
@@ -42,8 +41,8 @@ import Text.Pandoc.Error
import Text.Pandoc.Logging
import Text.Pandoc.Options
import Text.Pandoc.Shared (crFilter)
import Text.XML.Light
import Text.Pandoc.XMLParser (parseXMLElement)
import Text.Pandoc.XML.Light
import qualified Text.Pandoc.UTF8 as UTF8
type FB2 m = StateT FB2State m
@@ -85,12 +84,12 @@ removeHash t = case T.uncons t of
Just ('#', xs) -> xs
_ -> t
convertEntity :: String -> Text
convertEntity e = maybe (T.toUpper $ T.pack e) T.pack $ lookupEntity e
convertEntity :: Text -> Text
convertEntity e = maybe (T.toUpper e) T.pack $ lookupEntity (T.unpack e)
parseInline :: PandocMonad m => Content -> FB2 m Inlines
parseInline (Elem e) =
case T.pack $ qName $ elName e of
case qName $ elName e of
"strong" -> strong <$> parseStyleType e
"emphasis" -> emph <$> parseStyleType e
"style" -> parseNamedStyle e
@@ -98,12 +97,12 @@ parseInline (Elem e) =
"strikethrough" -> strikeout <$> parseStyleType e
"sub" -> subscript <$> parseStyleType e
"sup" -> superscript <$> parseStyleType e
"code" -> pure $ code $ T.pack $ strContent e
"code" -> pure $ code $ strContent e
"image" -> parseInlineImageElement e
name -> do
report $ IgnoredElement name
pure mempty
parseInline (Text x) = pure $ text $ T.pack $ cdData x
parseInline (Text x) = pure $ text $ cdData x
parseInline (CRef r) = pure $ str $ convertEntity r
parseSubtitle :: PandocMonad m => Element -> FB2 m Blocks
@@ -113,7 +112,7 @@ parseSubtitle e = headerWith ("", ["unnumbered"], []) <$> gets fb2SectionLevel <
parseRootElement :: PandocMonad m => Element -> FB2 m Blocks
parseRootElement e =
case T.pack $ qName $ elName e of
case qName $ elName e of
"FictionBook" -> do
-- Parse notes before parsing the rest of the content.
case filterChild isNotesBody e of
@@ -146,7 +145,7 @@ parseNote e =
Just sectionId -> do
content <- mconcat <$> mapM parseSectionChild (dropTitle $ elChildren e)
oldNotes <- gets fb2Notes
modify $ \s -> s { fb2Notes = M.insert ("#" <> T.pack sectionId) content oldNotes }
modify $ \s -> s { fb2Notes = M.insert ("#" <> sectionId) content oldNotes }
pure ()
where
isTitle x = qName (elName x) == "title"
@@ -158,7 +157,7 @@ parseNote e =
-- | Parse a child of @\<FictionBook>@ element.
parseFictionBookChild :: PandocMonad m => Element -> FB2 m Blocks
parseFictionBookChild e =
case T.pack $ qName $ elName e of
case qName $ elName e of
"stylesheet" -> pure mempty -- stylesheet is ignored
"description" -> mempty <$ mapM_ parseDescriptionChild (elChildren e)
"body" -> if isNotesBody e
@@ -170,7 +169,7 @@ parseFictionBookChild e =
-- | Parse a child of @\<description>@ element.
parseDescriptionChild :: PandocMonad m => Element -> FB2 m ()
parseDescriptionChild e =
case T.pack $ qName $ elName e of
case qName $ elName e of
"title-info" -> mapM_ parseTitleInfoChild (elChildren e)
"src-title-info" -> pure () -- ignore
"document-info" -> pure ()
@@ -184,7 +183,7 @@ parseDescriptionChild e =
-- | Parse a child of @\<body>@ element.
parseBodyChild :: PandocMonad m => Element -> FB2 m Blocks
parseBodyChild e =
case T.pack $ qName $ elName e of
case qName $ elName e of
"image" -> parseImageElement e
"title" -> header <$> gets fb2SectionLevel <*> parseTitleType (elContent e)
"epigraph" -> parseEpigraph e
@@ -198,7 +197,10 @@ parseBinaryElement e =
(Nothing, _) -> report $ IgnoredElement "binary without id attribute"
(Just _, Nothing) ->
report $ IgnoredElement "binary without content-type attribute"
(Just filename, contentType) -> insertMedia filename (T.pack <$> contentType) (decodeLenient (pack (strContent e)))
(Just filename, contentType) ->
insertMedia (T.unpack filename) contentType
(decodeLenient
(UTF8.fromTextLazy . TL.fromStrict . strContent $ e))
-- * Type parsers
@@ -208,13 +210,13 @@ parseAuthor e = T.unwords . catMaybes <$> mapM parseAuthorChild (elChildren e)
parseAuthorChild :: PandocMonad m => Element -> FB2 m (Maybe Text)
parseAuthorChild e =
case T.pack $ qName $ elName e of
"first-name" -> pure $ Just $ T.pack $ strContent e
"middle-name" -> pure $ Just $ T.pack $ strContent e
"last-name" -> pure $ Just $ T.pack $ strContent e
"nickname" -> pure $ Just $ T.pack $ strContent e
"home-page" -> pure $ Just $ T.pack $ strContent e
"email" -> pure $ Just $ T.pack $ strContent e
case qName $ elName e of
"first-name" -> pure $ Just $ strContent e
"middle-name" -> pure $ Just $ strContent e
"last-name" -> pure $ Just $ strContent e
"nickname" -> pure $ Just $ strContent e
"home-page" -> pure $ Just $ strContent e
"email" -> pure $ Just $ strContent e
name -> do
report $ IgnoredElement $ name <> " in author"
pure Nothing
@@ -238,13 +240,13 @@ parseTitleContent _ = pure Nothing
parseImageElement :: PandocMonad m => Element -> FB2 m Blocks
parseImageElement e =
case href of
Just src -> pure $ para $ imageWith (imgId, [], []) (removeHash $ T.pack src) title alt
Just src -> pure $ para $ imageWith (imgId, [], []) (removeHash src) title alt
Nothing -> do
report $ IgnoredElement " image without href"
pure mempty
where alt = maybe mempty (str . T.pack) $ findAttr (unqual "alt") e
title = maybe "" T.pack $ findAttr (unqual "title") e
imgId = maybe "" T.pack $ findAttr (unqual "id") e
where alt = maybe mempty str $ findAttr (unqual "alt") e
title = fromMaybe "" $ findAttr (unqual "title") e
imgId = fromMaybe "" $ findAttr (unqual "id") e
href = findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e
-- | Parse @pType@
@@ -258,7 +260,7 @@ parseCite e = blockQuote . mconcat <$> mapM parseCiteChild (elChildren e)
-- | Parse @citeType@ child
parseCiteChild :: PandocMonad m => Element -> FB2 m Blocks
parseCiteChild e =
case T.pack $ qName $ elName e of
case qName $ elName e of
"p" -> para <$> parsePType e
"poem" -> parsePoem e
"empty-line" -> pure horizontalRule
@@ -273,13 +275,13 @@ parsePoem e = mconcat <$> mapM parsePoemChild (elChildren e)
parsePoemChild :: PandocMonad m => Element -> FB2 m Blocks
parsePoemChild e =
case T.pack $ qName $ elName e of
case qName $ elName e of
"title" -> parseTitle e
"subtitle" -> parseSubtitle e
"epigraph" -> parseEpigraph e
"stanza" -> parseStanza e
"text-author" -> para <$> parsePType e
"date" -> pure $ para $ text $ T.pack $ strContent e
"date" -> pure $ para $ text $ strContent e
name -> report (UnexpectedXmlElement name "poem") $> mempty
parseStanza :: PandocMonad m => Element -> FB2 m Blocks
@@ -292,7 +294,7 @@ joinLineBlocks [] = []
parseStanzaChild :: PandocMonad m => Element -> FB2 m Blocks
parseStanzaChild e =
case T.pack $ qName $ elName e of
case qName $ elName e of
"title" -> parseTitle e
"subtitle" -> parseSubtitle e
"v" -> lineBlock . (:[]) <$> parsePType e
@@ -302,11 +304,11 @@ parseStanzaChild e =
parseEpigraph :: PandocMonad m => Element -> FB2 m Blocks
parseEpigraph e =
divWith (divId, ["epigraph"], []) . mconcat <$> mapM parseEpigraphChild (elChildren e)
where divId = maybe "" T.pack $ findAttr (unqual "id") e
where divId = fromMaybe "" $ findAttr (unqual "id") e
parseEpigraphChild :: PandocMonad m => Element -> FB2 m Blocks
parseEpigraphChild e =
case T.pack $ qName $ elName e of
case qName $ elName e of
"p" -> para <$> parsePType e
"poem" -> parsePoem e
"cite" -> parseCite e
@@ -320,7 +322,7 @@ parseAnnotation e = mconcat <$> mapM parseAnnotationChild (elChildren e)
parseAnnotationChild :: PandocMonad m => Element -> FB2 m Blocks
parseAnnotationChild e =
case T.pack $ qName $ elName e of
case qName $ elName e of
"p" -> para <$> parsePType e
"poem" -> parsePoem e
"cite" -> parseCite e
@@ -334,14 +336,14 @@ parseSection :: PandocMonad m => Element -> FB2 m Blocks
parseSection e = do
n <- gets fb2SectionLevel
modify $ \st -> st{ fb2SectionLevel = n + 1 }
let sectionId = maybe "" T.pack $ findAttr (unqual "id") e
let sectionId = fromMaybe "" $ findAttr (unqual "id") e
bs <- divWith (sectionId, ["section"], []) . mconcat <$> mapM parseSectionChild (elChildren e)
modify $ \st -> st{ fb2SectionLevel = n }
pure bs
parseSectionChild :: PandocMonad m => Element -> FB2 m Blocks
parseSectionChild e =
case T.pack $ qName $ elName e of
case qName $ elName e of
"title" -> parseBodyChild e
"epigraph" -> parseEpigraph e
"image" -> parseImageElement e
@@ -363,16 +365,16 @@ parseStyleType e = mconcat <$> mapM parseInline (elContent e)
parseNamedStyle :: PandocMonad m => Element -> FB2 m Inlines
parseNamedStyle e = do
content <- mconcat <$> mapM parseNamedStyleChild (elContent e)
let lang = maybeToList $ ("lang",) . T.pack <$> findAttr (QName "lang" Nothing (Just "xml")) e
let lang = maybeToList $ ("lang",) <$> findAttr (QName "lang" Nothing (Just "xml")) e
case findAttr (unqual "name") e of
Just name -> pure $ spanWith ("", [T.pack name], lang) content
Just name -> pure $ spanWith ("", [name], lang) content
Nothing -> do
report $ IgnoredElement "link without required name"
pure mempty
parseNamedStyleChild :: PandocMonad m => Content -> FB2 m Inlines
parseNamedStyleChild (Elem e) =
case T.pack $ qName (elName e) of
case qName (elName e) of
"strong" -> strong <$> parseStyleType e
"emphasis" -> emph <$> parseStyleType e
"style" -> parseNamedStyle e
@@ -380,7 +382,7 @@ parseNamedStyleChild (Elem e) =
"strikethrough" -> strikeout <$> parseStyleType e
"sub" -> subscript <$> parseStyleType e
"sup" -> superscript <$> parseStyleType e
"code" -> pure $ code $ T.pack $ strContent e
"code" -> pure $ code $ strContent e
"image" -> parseInlineImageElement e
name -> do
report $ IgnoredElement $ name <> " in style"
@@ -392,7 +394,7 @@ parseLinkType :: PandocMonad m => Element -> FB2 m Inlines
parseLinkType e = do
content <- mconcat <$> mapM parseStyleLinkType (elContent e)
notes <- gets fb2Notes
case T.pack <$> findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of
case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of
Just href -> case findAttr (QName "type" Nothing Nothing) e of
Just "note" -> case M.lookup href notes of
Nothing -> pure $ link href "" content
@@ -419,15 +421,14 @@ parseTable _ = pure mempty -- TODO: tables are not supported yet
-- | Parse @title-infoType@
parseTitleInfoChild :: PandocMonad m => Element -> FB2 m ()
parseTitleInfoChild e =
case T.pack $ qName (elName e) of
case qName (elName e) of
"genre" -> pure ()
"author" -> parseAuthor e >>= \author -> modify (\st -> st {fb2Authors = author:fb2Authors st})
"book-title" -> modify (setMeta "title" (text $ T.pack $ strContent e))
"book-title" -> modify (setMeta "title" (text $ strContent e))
"annotation" -> parseAnnotation e >>= modify . setMeta "abstract"
"keywords" -> modify (setMeta "keywords" (map (MetaString . trim) $ T.splitOn ","
$ T.pack
$ strContent e))
"date" -> modify (setMeta "date" (text $ T.pack $ strContent e))
"date" -> modify (setMeta "date" (text $ strContent e))
"coverpage" -> parseCoverPage e
"lang" -> pure ()
"src-lang" -> pure ()
@@ -441,7 +442,7 @@ parseCoverPage e =
Just img -> case href of
Just src -> modify (setMeta "cover-image" (MetaString $ removeHash src))
Nothing -> pure ()
where href = T.pack <$> findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) img
where href = findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) img
Nothing -> pure ()
-- | Parse @inlineImageType@ element
@@ -454,5 +455,5 @@ parseInlineImageElement e =
Nothing -> do
report $ IgnoredElement "inline image without href"
pure mempty
where alt = maybe mempty (str . T.pack) $ findAttr (unqual "alt") e
href = T.pack <$> findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e
where alt = maybe mempty str $ findAttr (unqual "alt") e
href = findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e
src/Text/Pandoc/Readers/JATS.hs
+25 -33
View File
@@ -16,7 +16,7 @@ module Text.Pandoc.Readers.JATS ( readJATS ) where
import Control.Monad.State.Strict
import Control.Monad.Except (throwError)
import Text.Pandoc.Error (PandocError(..))
import Data.Char (isDigit, isSpace, toUpper)
import Data.Char (isDigit, isSpace)
import Data.Default
import Data.Generics
import Data.List (foldl', intersperse)
@@ -31,8 +31,7 @@ import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Options
import Text.Pandoc.Shared (crFilter, safeRead, extractSpaces)
import Text.TeXMath (readMathML, writeTeX)
import Text.XML.Light
import Text.Pandoc.XMLParser (parseXMLContents)
import Text.Pandoc.XML.Light
import qualified Data.Set as S (fromList, member)
import Data.Set ((\\))
@@ -67,29 +66,29 @@ normalizeTree = everywhere (mkT go)
where go :: [Content] -> [Content]
go (Text (CData CDataRaw _ _):xs) = xs
go (Text (CData CDataText s1 z):Text (CData CDataText s2 _):xs) =
Text (CData CDataText (s1 ++ s2) z):xs
Text (CData CDataText (s1 <> s2) z):xs
go (Text (CData CDataText s1 z):CRef r:xs) =
Text (CData CDataText (s1 ++ convertEntity r) z):xs
Text (CData CDataText (s1 <> convertEntity r) z):xs
go (CRef r:Text (CData CDataText s1 z):xs) =
Text (CData CDataText (convertEntity r ++ s1) z):xs
Text (CData CDataText (convertEntity r <> s1) z):xs
go (CRef r1:CRef r2:xs) =
Text (CData CDataText (convertEntity r1 ++ convertEntity r2) Nothing):xs
Text (CData CDataText (convertEntity r1 <> convertEntity r2) Nothing):xs
go xs = xs
convertEntity :: String -> String
convertEntity e = Data.Maybe.fromMaybe (map toUpper e) (lookupEntity e)
convertEntity :: Text -> Text
convertEntity e = maybe (T.toUpper e) T.pack (lookupEntity $ T.unpack e)
-- convenience function to get an attribute value, defaulting to ""
attrValue :: String -> Element -> Text
attrValue :: Text -> Element -> Text
attrValue attr =
fromMaybe "" . maybeAttrValue attr
maybeAttrValue :: String -> Element -> Maybe Text
maybeAttrValue :: Text -> Element -> Maybe Text
maybeAttrValue attr elt =
T.pack <$> lookupAttrBy (\x -> qName x == attr) (elAttribs elt)
lookupAttrBy (\x -> qName x == attr) (elAttribs elt)
-- convenience function
named :: String -> Element -> Bool
named :: Text -> Element -> Bool
named s e = qName (elName e) == s
--
@@ -155,10 +154,10 @@ getBlocks e = mconcat <$>
parseBlock :: PandocMonad m => Content -> JATS m Blocks
parseBlock (Text (CData CDataRaw _ _)) = return mempty -- DOCTYPE
parseBlock (Text (CData _ s _)) = if all isSpace s
parseBlock (Text (CData _ s _)) = if T.all isSpace s
then return mempty
else return $ plain $ trimInlines $ text $ T.pack s
parseBlock (CRef x) = return $ plain $ str $ T.toUpper $ T.pack x
else return $ plain $ trimInlines $ text s
parseBlock (CRef x) = return $ plain $ str $ T.toUpper x
parseBlock (Elem e) =
case qName (elName e) of
"p" -> parseMixed para (elContent e)
@@ -207,7 +206,7 @@ parseBlock (Elem e) =
"" -> []
x -> [x]
return $ codeBlockWith (attrValue "id" e, classes', [])
$ trimNl $ textContentRecursive e
$ trimNl $ strContentRecursive e
parseBlockquote = do
attrib <- case filterChild (named "attribution") e of
Nothing -> return mempty
@@ -271,7 +270,7 @@ parseBlock (Elem e) =
Just "center" -> AlignCenter
_ -> AlignDefault
let toWidth c = do
w <- findAttrText (unqual "colwidth") c
w <- findAttr (unqual "colwidth") c
n <- safeRead $ "0" <> T.filter (\x -> isDigit x || x == '.') w
if n > 0 then Just n else Nothing
let numrows = foldl' max 0 $ map length bodyrows
@@ -442,16 +441,10 @@ parseRef e = do
Nothing -> return $ Map.insert "id" (toMetaValue refId) mempty
-- TODO handle mixed-citation
findAttrText :: QName -> Element -> Maybe Text
findAttrText x = fmap T.pack . findAttr x
textContent :: Element -> Text
textContent = T.pack . strContent
textContent = strContent
textContentRecursive :: Element -> Text
textContentRecursive = T.pack . strContentRecursive
strContentRecursive :: Element -> String
strContentRecursive :: Element -> Text
strContentRecursive = strContent .
(\e' -> e'{ elContent = map elementToStr $ elContent e' })
@@ -460,9 +453,8 @@ elementToStr (Elem e') = Text $ CData CDataText (strContentRecursive e') Nothing
elementToStr x = x
parseInline :: PandocMonad m => Content -> JATS m Inlines
parseInline (Text (CData _ s _)) = return $ text $ T.pack s
parseInline (CRef ref) =
return . text . maybe (T.toUpper $ T.pack ref) T.pack $ lookupEntity ref
parseInline (Text (CData _ s _)) = return $ text s
parseInline (CRef ref) = return . text . convertEntity $ ref
parseInline (Elem e) =
case qName (elName e) of
"italic" -> innerInlines emph
@@ -507,9 +499,9 @@ parseInline (Elem e) =
else linkWith attr ("#" <> rid) "" ils
"ext-link" -> do
ils <- innerInlines id
let title = fromMaybe "" $ findAttrText (QName "title" (Just "http://www.w3.org/1999/xlink") Nothing) e
let title = fromMaybe "" $ findAttr (QName "title" (Just "http://www.w3.org/1999/xlink") Nothing) e
let href = case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of
Just h -> T.pack h
Just h -> h
_ -> "#" <> attrValue "rid" e
let ils' = if ils == mempty then str href else ils
let attr = (attrValue "id" e, [], [])
@@ -529,7 +521,7 @@ parseInline (Elem e) =
where innerInlines f = extractSpaces f . mconcat <$>
mapM parseInline (elContent e)
mathML x =
case readMathML . T.pack . showElement $ everywhere (mkT removePrefix) x of
case readMathML . showElement $ everywhere (mkT removePrefix) x of
Left _ -> mempty
Right m -> writeTeX m
formula constructor = do
@@ -547,4 +539,4 @@ parseInline (Elem e) =
let classes' = case attrValue "language" e of
"" -> []
l -> [l]
return $ codeWith (attrValue "id" e,classes',[]) $ textContentRecursive e
return $ codeWith (attrValue "id" e,classes',[]) $ strContentRecursive e
src/Text/Pandoc/Readers/OPML.hs
+12 -17
View File
@@ -13,7 +13,6 @@ Conversion of OPML to 'Pandoc' document.
module Text.Pandoc.Readers.OPML ( readOPML ) where
import Control.Monad.State.Strict
import Data.Char (toUpper)
import Data.Default
import Data.Generics
import Data.Maybe (fromMaybe)
@@ -28,8 +27,7 @@ import Text.Pandoc.Error (PandocError(..))
import Text.Pandoc.Readers.HTML (readHtml)
import Text.Pandoc.Readers.Markdown (readMarkdown)
import Text.Pandoc.Shared (crFilter, blocksToInlines')
import Text.XML.Light
import Text.Pandoc.XMLParser (parseXMLContents)
import Text.Pandoc.XML.Light
import Control.Monad.Except (throwError)
type OPML m = StateT OPMLState m
@@ -69,25 +67,22 @@ normalizeTree = everywhere (mkT go)
where go :: [Content] -> [Content]
go (Text (CData CDataRaw _ _):xs) = xs
go (Text (CData CDataText s1 z):Text (CData CDataText s2 _):xs) =
Text (CData CDataText (s1 ++ s2) z):xs
Text (CData CDataText (s1 <> s2) z):xs
go (Text (CData CDataText s1 z):CRef r:xs) =
Text (CData CDataText (s1 ++ convertEntity r) z):xs
Text (CData CDataText (s1 <> convertEntity r) z):xs
go (CRef r:Text (CData CDataText s1 z):xs) =
Text (CData CDataText (convertEntity r ++ s1) z):xs
Text (CData CDataText (convertEntity r <> s1) z):xs
go (CRef r1:CRef r2:xs) =
Text (CData CDataText (convertEntity r1 ++ convertEntity r2) Nothing):xs
Text (CData CDataText (convertEntity r1 <> convertEntity r2) Nothing):xs
go xs = xs
convertEntity :: String -> String
convertEntity e = Data.Maybe.fromMaybe (map toUpper e) (lookupEntity e)
convertEntity :: Text -> Text
convertEntity e = maybe (T.toUpper e) T.pack (lookupEntity (T.unpack e))
-- convenience function to get an attribute value, defaulting to ""
attrValue :: String -> Element -> Text
attrValue :: Text -> Element -> Text
attrValue attr elt =
maybe "" T.pack (lookupAttrBy (\x -> qName x == attr) (elAttribs elt))
textContent :: Element -> Text
textContent = T.pack . strContent
fromMaybe "" (lookupAttrBy (\x -> qName x == attr) (elAttribs elt))
-- exceptT :: PandocMonad m => Either PandocError a -> OPML m a
-- exceptT = either throwError return
@@ -111,11 +106,11 @@ parseBlock :: PandocMonad m => Content -> OPML m Blocks
parseBlock (Elem e) =
case qName (elName e) of
"ownerName" -> mempty <$ modify (\st ->
st{opmlDocAuthors = [text $ textContent e]})
st{opmlDocAuthors = [text $ strContent e]})
"dateModified" -> mempty <$ modify (\st ->
st{opmlDocDate = text $ textContent e})
st{opmlDocDate = text $ strContent e})
"title" -> mempty <$ modify (\st ->
st{opmlDocTitle = text $ textContent e})
st{opmlDocTitle = text $ strContent e})
"outline" -> gets opmlSectionLevel >>= sect . (+1)
"?xml" -> return mempty
_ -> getBlocks e
src/Text/Pandoc/Readers/Odt.hs
+2 -3
View File
@@ -14,8 +14,7 @@ Entry point to the odt reader.
module Text.Pandoc.Readers.Odt ( readOdt ) where
import Codec.Archive.Zip
import qualified Text.XML.Light as XML
import Text.Pandoc.XMLParser (parseXMLElement)
import Text.Pandoc.XML.Light
import qualified Data.ByteString.Lazy as B
@@ -91,7 +90,7 @@ archiveToOdt archive = do
--
entryToXmlElem :: Entry -> Either PandocError XML.Element
entryToXmlElem :: Entry -> Either PandocError Element
entryToXmlElem entry =
case parseXMLElement . UTF8.toTextLazy . fromEntry $ entry of
Right x -> Right x
src/Text/Pandoc/Readers/Odt/ContentReader.hs
+7 -6
View File
@@ -29,14 +29,14 @@ import Control.Monad ((<=<))
import qualified Data.ByteString.Lazy as B
import Data.Foldable (fold)
import Data.List (find, stripPrefix)
import Data.List (find)
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Maybe
import Data.Semigroup (First(..), Option(..))
import Text.TeXMath (readMathML, writeTeX)
import qualified Text.XML.Light as XML
import qualified Text.Pandoc.XML.Light as XML
import Text.Pandoc.Builder hiding (underline)
import Text.Pandoc.MediaBag (MediaBag, insertMedia)
@@ -557,7 +557,7 @@ read_plain_text = fst ^&&& read_plain_text' >>% recover
>>?% mappend
--
extractText :: XML.Content -> Fallible T.Text
extractText (XML.Text cData) = succeedWith (T.pack $ XML.cdData cData)
extractText (XML.Text cData) = succeedWith (XML.cdData cData)
extractText _ = failEmpty
read_text_seq :: InlineMatcher
@@ -777,14 +777,14 @@ read_frame_img =
"" -> returnV mempty -< ()
src' -> do
let exts = extensionsFromList [Ext_auto_identifiers]
resource <- lookupResource -< src'
resource <- lookupResource -< T.unpack src'
_ <- updateMediaWithResource -< resource
w <- findAttrText' NsSVG "width" -< ()
h <- findAttrText' NsSVG "height" -< ()
titleNodes <- matchChildContent' [ read_frame_title ] -< ()
alt <- matchChildContent [] read_plain_text -< ()
arr (firstMatch . uncurry4 imageWith) -<
(image_attributes w h, T.pack src', inlineListToIdentifier exts (toList titleNodes), alt)
(image_attributes w h, src', inlineListToIdentifier exts (toList titleNodes), alt)
read_frame_title :: InlineMatcher
read_frame_title = matchingElement NsSVG "title" (matchChildContent [] read_plain_text)
@@ -804,7 +804,8 @@ read_frame_mathml =
case fold src of
"" -> returnV mempty -< ()
src' -> do
let path = fromMaybe src' (stripPrefix "./" src') ++ "/content.xml"
let path = T.unpack $
fromMaybe src' (T.stripPrefix "./" src') <> "/content.xml"
(_, mathml) <- lookupResource -< path
case readMathML (UTF8.toText $ B.toStrict mathml) of
Left _ -> returnV mempty -< ()
src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hs
+2 -1
View File
@@ -14,9 +14,10 @@ typesafe Haskell namespace identifiers and unsafe "real world" namespaces.
module Text.Pandoc.Readers.Odt.Generic.Namespaces where
import qualified Data.Map as M
import Data.Text (Text)
--
type NameSpaceIRI = String
type NameSpaceIRI = Text
--
type NameSpaceIRIs nsID = M.Map nsID NameSpaceIRI
src/Text/Pandoc/Readers/Odt/Generic/Utils.hs
+9 -24
View File
@@ -20,7 +20,6 @@ module Text.Pandoc.Readers.Odt.Generic.Utils
, reverseComposition
, tryToRead
, Lookupable(..)
, readLookupables
, readLookupable
, readPercent
, findBy
@@ -30,11 +29,11 @@ module Text.Pandoc.Readers.Odt.Generic.Utils
import Control.Category (Category, (<<<), (>>>))
import qualified Control.Category as Cat (id)
import Control.Monad (msum)
import Data.Char (isSpace)
import qualified Data.Foldable as F (Foldable, foldr)
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
-- | Equivalent to
-- > foldr (.) id
@@ -76,8 +75,8 @@ swing = flip.(.flip id)
-- (nobody wants that) while the latter returns "to much" for simple purposes.
-- This function instead applies 'reads' and returns the first match (if any)
-- in a 'Maybe'.
tryToRead :: (Read r) => String -> Maybe r
tryToRead = reads >>> listToMaybe >>> fmap fst
tryToRead :: (Read r) => Text -> Maybe r
tryToRead = (reads . T.unpack) >>> listToMaybe >>> fmap fst
-- | A version of 'reads' that requires a '%' sign after the number
readPercent :: ReadS Int
@@ -88,26 +87,12 @@ readPercent s = [ (i,s') | (i , r ) <- reads s
-- | Data that can be looked up.
-- This is mostly a utility to read data with kind *.
class Lookupable a where
lookupTable :: [(String, a)]
-- | The idea is to use this function as if there was a declaration like
--
-- > instance (Lookupable a) => (Read a) where
-- > readsPrec _ = readLookupables
-- .
-- But including this code in this form would need UndecideableInstances.
-- That is a bad idea. Luckily 'readLookupable' (without the s at the end)
-- can be used directly in almost any case.
readLookupables :: (Lookupable a) => String -> [(a,String)]
readLookupables s = [ (a,rest) | (word,rest) <- lex s,
a <- maybeToList (lookup word lookupTable)
]
lookupTable :: [(Text, a)]
-- | Very similar to a simple 'lookup' in the 'lookupTable', but with a lexer.
readLookupable :: (Lookupable a) => String -> Maybe a
readLookupable s = msum
$ map ((`lookup` lookupTable).fst)
$ lex s
readLookupable :: (Lookupable a) => Text -> Maybe a
readLookupable s =
lookup (T.takeWhile (not . isSpace) $ T.dropWhile isSpace s) lookupTable
uncurry3 :: (a->b->c -> z) -> (a,b,c ) -> z
uncurry4 :: (a->b->c->d -> z) -> (a,b,c,d ) -> z
src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs
+11 -12
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
@@ -60,11 +61,11 @@ import Control.Arrow
import Data.Bool ( bool )
import Data.Either ( rights )
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Text (Text)
import Data.Default
import Data.Maybe
import qualified Text.XML.Light as XML
import qualified Text.Pandoc.XML.Light as XML
import Text.Pandoc.Readers.Odt.Arrows.State
import Text.Pandoc.Readers.Odt.Arrows.Utils
@@ -78,13 +79,13 @@ import Text.Pandoc.Readers.Odt.Generic.Fallible
--------------------------------------------------------------------------------
--
type ElementName = String
type AttributeName = String
type AttributeValue = String
type TextAttributeValue = T.Text
type ElementName = Text
type AttributeName = Text
type AttributeValue = Text
type TextAttributeValue = Text
--
type NameSpacePrefix = String
type NameSpacePrefix = Text
--
type NameSpacePrefixes nsID = M.Map nsID NameSpacePrefix
@@ -461,7 +462,7 @@ lookupDefaultingAttr :: (NameSpaceID nsID, Lookupable a, Default a)
lookupDefaultingAttr nsID attrName
= lookupAttrWithDefault nsID attrName def
-- | Return value as a (Maybe String)
-- | Return value as a (Maybe Text)
findAttr' :: (NameSpaceID nsID)
=> nsID -> AttributeName
-> XMLConverter nsID extraState x (Maybe AttributeValue)
@@ -477,7 +478,6 @@ findAttrText' nsID attrName
= qualifyName nsID attrName
&&& getCurrentElement
>>% XML.findAttr
>>^ fmap T.pack
-- | Return value as string or fail
findAttr :: (NameSpaceID nsID)
@@ -492,7 +492,6 @@ findAttrText :: (NameSpaceID nsID)
-> FallibleXMLConverter nsID extraState x TextAttributeValue
findAttrText nsID attrName
= findAttr' nsID attrName
>>^ fmap T.pack
>>> maybeToChoice
-- | Return value as string or return provided default value
@@ -511,7 +510,7 @@ findAttrTextWithDefault :: (NameSpaceID nsID)
-> XMLConverter nsID extraState x TextAttributeValue
findAttrTextWithDefault nsID attrName deflt
= findAttr' nsID attrName
>>^ maybe deflt T.pack
>>^ fromMaybe deflt
-- | Read and return value or fail
readAttr :: (NameSpaceID nsID, Read attrValue)
@@ -748,7 +747,7 @@ matchContent lookups fallback
-- Internals
--------------------------------------------------------------------------------
stringToBool' :: String -> Maybe Bool
stringToBool' :: Text -> Maybe Bool
stringToBool' val | val `elem` trueValues = Just True
| val `elem` falseValues = Just False
| otherwise = Nothing
src/Text/Pandoc/Readers/Odt/Namespaces.hs
+6 -5
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Reader.Odt.Namespaces
Copyright : Copyright (C) 2015 Martin Linnemann
@@ -13,10 +14,10 @@ Namespaces used in odt files.
module Text.Pandoc.Readers.Odt.Namespaces ( Namespace (..)
) where
import Data.List (isPrefixOf)
import qualified Data.Map as M (empty, insert)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Text.Pandoc.Readers.Odt.Generic.Namespaces
@@ -30,7 +31,7 @@ instance NameSpaceID Namespace where
findID :: NameSpaceIRI -> Maybe Namespace
findID iri = listToMaybe [nsID | (iri',nsID) <- nsIDs, iri' `isPrefixOf` iri]
findID iri = listToMaybe [nsID | (iri',nsID) <- nsIDs, iri' `T.isPrefixOf` iri]
nsIDmap :: NameSpaceIRIs Namespace
nsIDmap = foldr (uncurry $ flip M.insert) M.empty nsIDs
@@ -54,12 +55,12 @@ data Namespace = -- Open Document core
-- Core XML (basically only for the 'id'-attribute)
| NsXML
-- Fallback
| NsOther String
| NsOther Text
deriving ( Eq, Ord, Show )
-- | Not the actual iri's, but large prefixes of them - this way there are
-- less versioning problems and the like.
nsIDs :: [(String,Namespace)]
nsIDs :: [(Text, Namespace)]
nsIDs = [
("urn:oasis:names:tc:opendocument:xmlns:animation" , NsAnim ),
("urn:oasis:names:tc:opendocument:xmlns:chart" , NsChart ),
src/Text/Pandoc/Readers/Odt/StyleReader.hs
+13 -10
View File
@@ -2,6 +2,7 @@
{-# LANGUAGE Arrows #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Readers.Odt.StyleReader
Copyright : Copyright (C) 2015 Martin Linnemann
@@ -46,11 +47,13 @@ import qualified Data.Foldable as F
import Data.List (unfoldr)
import qualified Data.Map as M
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Set as S
import qualified Text.XML.Light as XML
import qualified Text.Pandoc.XML.Light as XML
import Text.Pandoc.Shared (safeRead)
import Text.Pandoc.Shared (safeRead, tshow)
import Text.Pandoc.Readers.Odt.Arrows.Utils
@@ -90,7 +93,7 @@ instance Default FontPitch where
--
-- Thus, we want
type FontFaceName = String
type FontFaceName = Text
type FontPitches = M.Map FontFaceName FontPitch
@@ -151,7 +154,7 @@ findPitch = ( lookupAttr NsStyle "font-pitch"
-- Definitions of main data
--------------------------------------------------------------------------------
type StyleName = String
type StyleName = Text
-- | There are two types of styles: named styles with a style family and an
-- optional style parent, and default styles for each style family,
@@ -355,8 +358,8 @@ getListLevelStyle level ListStyle{..} =
-- \^ simpler, but in general less efficient
data ListLevelStyle = ListLevelStyle { listLevelType :: ListLevelType
, listItemPrefix :: Maybe String
, listItemSuffix :: Maybe String
, listItemPrefix :: Maybe Text
, listItemSuffix :: Maybe Text
, listItemFormat :: ListItemNumberFormat
, listItemStart :: Int
}
@@ -366,9 +369,9 @@ instance Show ListLevelStyle where
show ListLevelStyle{..} = "<LLS|"
++ show listLevelType
++ "|"
++ maybeToString listItemPrefix
++ maybeToString (T.unpack <$> listItemPrefix)
++ show listItemFormat
++ maybeToString listItemSuffix
++ maybeToString (T.unpack <$> listItemSuffix)
++ ">"
where maybeToString = fromMaybe ""
@@ -471,7 +474,7 @@ readTextProperties =
)
where isFontEmphasised = [("normal",False),("italic",True),("oblique",True)]
isFontBold = ("normal",False):("bold",True)
:map ((,True).show) ([100,200..900]::[Int])
:map ((,True) . tshow) ([100,200..900]::[Int])
readUnderlineMode :: StyleReaderSafe _x (Maybe UnderlineMode)
readUnderlineMode = readLineMode "text-underline-mode"
@@ -481,7 +484,7 @@ readStrikeThroughMode :: StyleReaderSafe _x (Maybe UnderlineMode)
readStrikeThroughMode = readLineMode "text-line-through-mode"
"text-line-through-style"
readLineMode :: String -> String -> StyleReaderSafe _x (Maybe UnderlineMode)
readLineMode :: Text -> Text -> StyleReaderSafe _x (Maybe UnderlineMode)
readLineMode modeAttr styleAttr = proc x -> do
isUL <- searchAttr NsStyle styleAttr False isLinePresent -< x
mode <- lookupAttr' NsStyle modeAttr -< x
src/Text/Pandoc/Writers/Docx.hs
+130 -133
View File
@@ -31,6 +31,7 @@ import qualified Data.Map as M
import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import Data.Time.Clock.POSIX
import Data.Digest.Pure.SHA (sha1, showDigest)
@@ -57,19 +58,19 @@ import Text.Pandoc.Writers.Math
import Text.Pandoc.Writers.Shared
import Text.Printf (printf)
import Text.TeXMath
import Text.XML.Light as XML
import Text.XML.Light.Cursor as XMLC
import Text.Pandoc.Writers.OOXML
import Text.Pandoc.XML.Light as XML
import Data.Generics (mkT, everywhere)
data ListMarker = NoMarker
| BulletMarker
| NumberMarker ListNumberStyle ListNumberDelim Int
deriving (Show, Read, Eq, Ord)
listMarkerToId :: ListMarker -> String
listMarkerToId :: ListMarker -> Text
listMarkerToId NoMarker = "990"
listMarkerToId BulletMarker = "991"
listMarkerToId (NumberMarker sty delim n) =
listMarkerToId (NumberMarker sty delim n) = T.pack $
'9' : '9' : styNum : delimNum : show n
where styNum = case sty of
DefaultStyle -> '2'
@@ -106,8 +107,8 @@ data WriterEnv = WriterEnv{ envTextProperties :: EnvProps
, envListLevel :: Int
, envListNumId :: Int
, envInDel :: Bool
, envChangesAuthor :: T.Text
, envChangesDate :: T.Text
, envChangesAuthor :: Text
, envChangesDate :: Text
, envPrintWidth :: Integer
}
@@ -125,9 +126,9 @@ defaultWriterEnv = WriterEnv{ envTextProperties = mempty
data WriterState = WriterState{
stFootnotes :: [Element]
, stComments :: [([(T.Text, T.Text)], [Inline])]
, stSectionIds :: Set.Set T.Text
, stExternalLinks :: M.Map String String
, stComments :: [([(Text, Text)], [Inline])]
, stSectionIds :: Set.Set Text
, stExternalLinks :: M.Map Text Text
, stImages :: M.Map FilePath (String, String, Maybe MimeType, B.ByteString)
, stLists :: [ListMarker]
, stInsId :: Int
@@ -164,18 +165,18 @@ defaultWriterState = WriterState{
type WS m = ReaderT WriterEnv (StateT WriterState m)
renumIdMap :: Int -> [Element] -> M.Map String String
renumIdMap :: Int -> [Element] -> M.Map Text Text
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" <> tshow n) (renumIdMap (n+1) es)
| otherwise = renumIdMap n es
replaceAttr :: (QName -> Bool) -> String -> [XML.Attr] -> [XML.Attr]
replaceAttr :: (QName -> Bool) -> Text -> [XML.Attr] -> [XML.Attr]
replaceAttr f val = map $
\a -> if f (attrKey a) then XML.Attr (attrKey a) val else a
renumId :: (QName -> Bool) -> M.Map String String -> Element -> Element
renumId :: (QName -> Bool) -> M.Map Text Text -> Element -> Element
renumId f renumMap e
| Just oldId <- findAttrBy f e
, Just newId <- M.lookup oldId renumMap =
@@ -184,18 +185,12 @@ renumId f renumMap e
e { elAttribs = attrs' }
| otherwise = e
renumIds :: (QName -> Bool) -> M.Map String String -> [Element] -> [Element]
renumIds :: (QName -> Bool) -> M.Map Text Text -> [Element] -> [Element]
renumIds f renumMap = map (renumId f renumMap)
findAttrTextBy :: (QName -> Bool) -> Element -> Maybe T.Text
findAttrTextBy x = fmap T.pack . findAttrBy x
lookupAttrTextBy :: (QName -> Bool) -> [XML.Attr] -> Maybe T.Text
lookupAttrTextBy x = fmap T.pack . lookupAttrBy x
-- | Certain characters are invalid in XML even if escaped.
-- See #1992
stripInvalidChars :: T.Text -> T.Text
stripInvalidChars :: Text -> Text
stripInvalidChars = T.filter isValidChar
-- | See XML reference
@@ -234,11 +229,11 @@ writeDocx opts doc = do
-- Gets the template size
let mbpgsz = mbsectpr >>= filterElementName (wname (=="pgSz"))
let mbAttrSzWidth = mbpgsz >>= lookupAttrTextBy ((=="w") . qName) . elAttribs
let mbAttrSzWidth = mbpgsz >>= lookupAttrBy ((=="w") . qName) . elAttribs
let mbpgmar = mbsectpr >>= filterElementName (wname (=="pgMar"))
let mbAttrMarLeft = mbpgmar >>= lookupAttrTextBy ((=="left") . qName) . elAttribs
let mbAttrMarRight = mbpgmar >>= lookupAttrTextBy ((=="right") . qName) . elAttribs
let mbAttrMarLeft = mbpgmar >>= lookupAttrBy ((=="left") . qName) . elAttribs
let mbAttrMarRight = mbpgmar >>= lookupAttrBy ((=="right") . qName) . elAttribs
-- Get the available area (converting the size and the margins to int and
-- doing the difference
@@ -250,24 +245,21 @@ writeDocx opts doc = do
-- styles
mblang <- toLang $ getLang opts meta
-- TODO FIXME avoid this generic traversal!
-- lang is in w:docDefaults / w:rPr / w:lang
let addLang :: Element -> Element
addLang e = case (\l -> XMLC.toTree . go (T.unpack $ renderLang l) $
XMLC.fromElement e) <$> mblang 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
addLang = case mblang of
Nothing -> id
Just l -> everywhere (mkT (go (renderLang l)))
where
go :: Text -> Element -> Element
go l e'
| qName (elName e') == "lang"
= e'{ elAttribs = map (setvalattr l) $ elAttribs e' }
| otherwise = e'
setvalattr l (XML.Attr qn@(QName "val" _ _) _) = XML.Attr qn l
setvalattr _ x = x
let stylepath = "word/styles.xml"
styledoc <- addLang <$> parseXml refArchive distArchive stylepath
@@ -337,12 +329,13 @@ writeDocx opts doc = do
-- [Content_Types].xml
let mkOverrideNode (part', contentType') = mknode "Override"
[("PartName",part'),("ContentType",contentType')] ()
[("PartName", T.pack part')
,("ContentType", contentType')] ()
let mkImageOverride (_, imgpath, mbMimeType, _) =
mkOverrideNode ("/word/" ++ imgpath,
maybe "application/octet-stream" T.unpack mbMimeType)
mkOverrideNode ("/word/" <> imgpath,
fromMaybe "application/octet-stream" mbMimeType)
let mkMediaOverride imgpath =
mkOverrideNode ('/':imgpath, T.unpack $ getMimeTypeDef imgpath)
mkOverrideNode ("/" <> imgpath, getMimeTypeDef imgpath)
let overrides = map mkOverrideNode (
[("/word/webSettings.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.webSettings+xml")
@@ -369,13 +362,14 @@ writeDocx opts doc = do
,("/word/footnotes.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.footnotes+xml")
] ++
map (\x -> (maybe "" ("/word/" ++) $ extractTarget x,
map (\x -> (maybe "" (T.unpack . ("/word/" <>)) (extractTarget x),
"application/vnd.openxmlformats-officedocument.wordprocessingml.header+xml")) headers ++
map (\x -> (maybe "" ("/word/" ++) $ extractTarget x,
map (\x -> (maybe "" (T.unpack . ("/word/" <>)) (extractTarget x),
"application/vnd.openxmlformats-officedocument.wordprocessingml.footer+xml")) footers) ++
map mkImageOverride imgs ++
[ mkMediaOverride (eRelativePath e) | e <- zEntries refArchive
, "word/media/" `isPrefixOf` eRelativePath e ]
[ mkMediaOverride (eRelativePath e)
| e <- zEntries refArchive
, "word/media/" `isPrefixOf` eRelativePath e ]
let defaultnodes = [mknode "Default"
[("Extension","xml"),("ContentType","application/xml")] (),
@@ -421,7 +415,7 @@ writeDocx opts doc = do
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",T.pack ident),("Target",T.pack 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
@@ -489,10 +483,10 @@ writeDocx opts doc = do
numbering <- parseXml refArchive distArchive numpath
let newNumElts = mkNumbering (stLists st)
let pandocAdded e =
case findAttrTextBy ((== "abstractNumId") . qName) e >>= safeRead of
case findAttrBy ((== "abstractNumId") . qName) e >>= safeRead of
Just numid -> numid >= (990 :: Int)
Nothing ->
case findAttrTextBy ((== "numId") . qName) e >>= safeRead of
case findAttrBy ((== "numId") . qName) e >>= safeRead of
Just numid -> numid >= (1000 :: Int)
Nothing -> False
let oldElts = filter (not . pandocAdded) $ onlyElems (elContent numbering)
@@ -514,7 +508,7 @@ writeDocx opts doc = do
let extraCoreProps = ["subject","lang","category","description"]
let extraCorePropsMap = M.fromList $ zip extraCoreProps
["dc:subject","dc:language","cp:category","dc:description"]
let lookupMetaString' :: T.Text -> Meta -> T.Text
let lookupMetaString' :: Text -> Meta -> Text
lookupMetaString' key' meta' =
case key' of
"description" -> T.intercalate "_x000d_\n" (map stringify $ lookupMetaBlocks "description" meta')
@@ -530,21 +524,21 @@ writeDocx opts doc = do
: mktnode "dc:creator" [] (T.intercalate "; " (map stringify $ docAuthors meta))
: [ mktnode (M.findWithDefault "" k extraCorePropsMap) [] (lookupMetaString' k meta)
| k <- M.keys (unMeta meta), k `elem` extraCoreProps]
++ mknode "cp:keywords" [] (T.unpack $ T.intercalate ", " keywords)
++ mknode "cp:keywords" [] (T.intercalate ", " keywords)
: (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x
, mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x
]) (formatTime defaultTimeLocale "%FT%XZ" utctime)
]) (T.pack $ formatTime defaultTimeLocale "%FT%XZ" utctime)
let docPropsEntry = toEntry docPropsPath epochtime $ renderXml docProps
-- docProps/custom.xml
let customProperties :: [(String, String)]
customProperties = [ (T.unpack k, T.unpack $ lookupMetaString k meta)
let customProperties :: [(Text, Text)]
customProperties = [ (k, lookupMetaString k meta)
| k <- M.keys (unMeta meta)
, k `notElem` (["title", "author", "keywords"]
++ extraCoreProps)]
let mkCustomProp (k, v) pid = mknode "property"
[("fmtid","{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
,("pid", show pid)
,("pid", tshow pid)
,("name", k)] $ mknode "vt:lpwstr" [] v
let customPropsPath = "docProps/custom.xml"
let customProps = mknode "Properties"
@@ -594,7 +588,8 @@ writeDocx opts doc = do
fontTableEntry <- entryFromArchive refArchive "word/fontTable.xml"
webSettingsEntry <- entryFromArchive refArchive "word/webSettings.xml"
headerFooterEntries <- mapM (entryFromArchive refArchive . ("word/" ++)) $
mapMaybe extractTarget (headers ++ footers)
mapMaybe (fmap T.unpack . extractTarget)
(headers ++ footers)
let miscRelEntries = [ e | e <- zEntries refArchive
, "word/_rels/" `isPrefixOf` eRelativePath e
, ".xml.rels" `isSuffixOf` eRelativePath e
@@ -620,8 +615,8 @@ newParaPropToOpenXml (fromStyleName -> s) =
let styleId = T.filter (not . isSpace) s
in mknode "w:style" [ ("w:type", "paragraph")
, ("w:customStyle", "1")
, ("w:styleId", T.unpack styleId)]
[ mknode "w:name" [("w:val", T.unpack s)] ()
, ("w:styleId", styleId)]
[ mknode "w:name" [("w:val", s)] ()
, mknode "w:basedOn" [("w:val","BodyText")] ()
, mknode "w:qFormat" [] ()
]
@@ -631,8 +626,8 @@ newTextPropToOpenXml (fromStyleName -> s) =
let styleId = T.filter (not . isSpace) s
in mknode "w:style" [ ("w:type", "character")
, ("w:customStyle", "1")
, ("w:styleId", T.unpack styleId)]
[ mknode "w:name" [("w:val", T.unpack s)] ()
, ("w:styleId", styleId)]
[ mknode "w:name" [("w:val", s)] ()
, mknode "w:basedOn" [("w:val","BodyTextChar")] ()
]
@@ -643,13 +638,14 @@ styleToOpenXml sm style =
toStyle toktype | hasStyleName (fromString $ show toktype) (smCharStyle sm) = Nothing
| otherwise = Just $
mknode "w:style" [("w:type","character"),
("w:customStyle","1"),("w:styleId",show toktype)]
[ mknode "w:name" [("w:val",show toktype)] ()
("w:customStyle","1"),("w:styleId", tshow toktype)]
[ mknode "w:name" [("w:val", tshow toktype)] ()
, mknode "w:basedOn" [("w:val","VerbatimChar")] ()
, mknode "w:rPr" [] $
[ mknode "w:color" [("w:val",tokCol toktype)] ()
[ mknode "w:color" [("w:val", tokCol toktype)] ()
| tokCol toktype /= "auto" ] ++
[ mknode "w:shd" [("w:val","clear"),("w:fill",tokBg toktype)] ()
[ 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 ] ++
@@ -657,10 +653,10 @@ styleToOpenXml sm style =
]
tokStyles = tokenStyles style
tokFeature f toktype = maybe False f $ M.lookup toktype tokStyles
tokCol toktype = maybe "auto" (drop 1 . fromColor)
tokCol toktype = maybe "auto" (T.pack . drop 1 . fromColor)
$ (tokenColor =<< M.lookup toktype tokStyles)
`mplus` defaultColor style
tokBg toktype = maybe "auto" (drop 1 . fromColor)
tokBg toktype = maybe "auto" (T.pack . drop 1 . fromColor)
$ (tokenBackground =<< M.lookup toktype tokStyles)
`mplus` backgroundColor style
parStyle | hasStyleName "Source Code" (smParaStyle sm) = Nothing
@@ -673,10 +669,11 @@ styleToOpenXml sm style =
, 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", T.pack $ drop 1 $ fromColor col)] ()]) (backgroundColor style)
]
copyChildren :: (PandocMonad m) => Archive -> Archive -> String -> Integer -> [String] -> m Entry
copyChildren :: (PandocMonad m)
=> Archive -> Archive -> String -> Integer -> [Text] -> m Entry
copyChildren refArchive distArchive path timestamp elNames = do
ref <- parseXml refArchive distArchive path
dist <- parseXml distArchive distArchive path
@@ -685,7 +682,7 @@ copyChildren refArchive distArchive path timestamp elNames = do
}
where
strName QName{qName=name, qPrefix=prefix}
| Just p <- prefix = p++":"++name
| Just p <- prefix = p <> ":" <> name
| otherwise = name
shouldCopy = (`elem` elNames) . strName
cleanElem el@Element{elName=name} = Elem el{elName=name{qURI=Nothing}}
@@ -706,35 +703,35 @@ maxListLevel = 8
mkNum :: ListMarker -> Int -> Element
mkNum marker numid =
mknode "w:num" [("w:numId",show numid)]
mknode "w:num" [("w:numId",tshow numid)]
$ mknode "w:abstractNumId" [("w:val",listMarkerToId marker)] ()
: case marker of
NoMarker -> []
BulletMarker -> []
NumberMarker _ _ start ->
map (\lvl -> mknode "w:lvlOverride" [("w:ilvl",show (lvl :: Int))]
$ mknode "w:startOverride" [("w:val",show start)] ())
map (\lvl -> mknode "w:lvlOverride" [("w:ilvl",tshow (lvl :: Int))]
$ mknode "w:startOverride" [("w:val",tshow start)] ())
[0..maxListLevel]
mkAbstractNum :: ListMarker -> Integer -> Element
mkAbstractNum marker nsid =
mknode "w:abstractNum" [("w:abstractNumId",listMarkerToId marker)]
$ mknode "w:nsid" [("w:val", printf "%8x" nsid)] ()
$ mknode "w:nsid" [("w:val", T.pack $ printf "%8x" nsid)] ()
: mknode "w:multiLevelType" [("w:val","multilevel")] ()
: map (mkLvl marker)
[0..maxListLevel]
mkLvl :: ListMarker -> Int -> Element
mkLvl marker lvl =
mknode "w:lvl" [("w:ilvl",show lvl)] $
mknode "w:lvl" [("w:ilvl",tshow 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:lvlText" [("w:val", lvltxt)] ()
, mknode "w:lvlJc" [("w:val","left")] ()
, mknode "w:pPr" []
[ mknode "w:ind" [ ("w:left",show $ lvl * step + step)
, ("w:hanging",show (hang :: Int))
[ mknode "w:ind" [ ("w:left",tshow $ lvl * step + step)
, ("w:hanging",tshow (hang :: Int))
] ()
]
]
@@ -743,8 +740,8 @@ mkLvl marker lvl =
NoMarker -> ("bullet"," ","1")
BulletMarker -> ("bullet",bulletFor lvl,"1")
NumberMarker st de n -> (styleFor st lvl
,patternFor de ("%" ++ show (lvl + 1))
,show n)
,patternFor de ("%" <> tshow (lvl + 1))
,tshow n)
step = 720
hang = 480
bulletFor 0 = "\x2022" -- filled circle
@@ -767,9 +764,9 @@ mkLvl marker lvl =
styleFor DefaultStyle 5 = "lowerRoman"
styleFor DefaultStyle x = styleFor DefaultStyle (x `mod` 6)
styleFor _ _ = "decimal"
patternFor OneParen s = s ++ ")"
patternFor TwoParens s = "(" ++ s ++ ")"
patternFor _ s = s ++ "."
patternFor OneParen s = s <> ")"
patternFor TwoParens s = "(" <> s <> ")"
patternFor _ s = s <> "."
getNumId :: (PandocMonad m) => WS m Int
getNumId = (((baseListId - 1) +) . length) `fmap` gets stLists
@@ -777,8 +774,8 @@ getNumId = (((baseListId - 1) +) . length) `fmap` gets stLists
makeTOC :: (PandocMonad m) => WriterOptions -> WS m [Element]
makeTOC opts = do
let depth = "1-"++show (writerTOCDepth opts)
let tocCmd = "TOC \\o \""++depth++"\" \\h \\z \\u"
let depth = "1-" <> tshow (writerTOCDepth opts)
let tocCmd = "TOC \\o \"" <> depth <> "\" \\h \\z \\u"
tocTitle <- gets stTocTitle
title <- withParaPropM (pStyleM "TOC Heading") (blocksToOpenXML opts [Para tocTitle])
return
@@ -831,7 +828,7 @@ writeOpenXML opts (Pandoc meta blocks) = do
let toComment (kvs, ils) = do
annotation <- inlinesToOpenXML opts ils
return $
mknode "w:comment" [('w':':':T.unpack k,T.unpack v) | (k,v) <- kvs]
mknode "w:comment" [("w:" <> k, v) | (k,v) <- kvs]
[ mknode "w:p" [] $
map Elem
[ mknode "w:pPr" []
@@ -867,24 +864,24 @@ pStyleM :: (PandocMonad m) => ParaStyleName -> WS m XML.Element
pStyleM styleName = do
pStyleMap <- gets (smParaStyle . stStyleMaps)
let sty' = getStyleIdFromName styleName pStyleMap
return $ mknode "w:pStyle" [("w:val", T.unpack $ fromStyleId sty')] ()
return $ mknode "w:pStyle" [("w:val", fromStyleId sty')] ()
rStyleM :: (PandocMonad m) => CharStyleName -> WS m XML.Element
rStyleM styleName = do
cStyleMap <- gets (smCharStyle . stStyleMaps)
let sty' = getStyleIdFromName styleName cStyleMap
return $ mknode "w:rStyle" [("w:val", T.unpack $ fromStyleId sty')] ()
return $ mknode "w:rStyle" [("w:val", fromStyleId sty')] ()
getUniqueId :: (PandocMonad m) => WS m String
getUniqueId :: (PandocMonad m) => WS m Text
-- the + 20 is to ensure that there are no clashes with the rIds
-- already in word/document.xml.rel
getUniqueId = do
n <- gets stCurId
modify $ \st -> st{stCurId = n + 1}
return $ show n
return $ tshow n
-- | Key for specifying user-defined docx styles.
dynamicStyleKey :: T.Text
dynamicStyleKey :: Text
dynamicStyleKey = "custom-style"
-- | Convert a Pandoc block element to OpenXML.
@@ -979,7 +976,7 @@ blockToOpenXML' opts (Para lst)
blockToOpenXML' opts (LineBlock lns) = blockToOpenXML opts $ linesToPara lns
blockToOpenXML' _ b@(RawBlock format str)
| format == Format "openxml" = return [
Text (CData CDataRaw (T.unpack str) Nothing)
Text (CData CDataRaw str Nothing)
]
| otherwise = do
report $ BlockNotRendered b
@@ -1036,7 +1033,7 @@ blockToOpenXML' opts (Table _ blkCapt specs thead tbody tfoot) = do
let fullrow = 5000 -- 100% specified in pct
let rowwidth = fullrow * sum widths
let mkgridcol w = mknode "w:gridCol"
[("w:w", show (floor (textwidth * w) :: Integer))] ()
[("w:w", tshow (floor (textwidth * w) :: Integer))] ()
let hasHeader = not $ all null headers
modify $ \s -> s { stInTable = False }
-- for compatibility with Word <= 2007, we include a val with a bitmask
@@ -1054,16 +1051,16 @@ blockToOpenXML' opts (Table _ blkCapt specs thead tbody tfoot) = do
mknode "w:tbl" []
( mknode "w:tblPr" []
( mknode "w:tblStyle" [("w:val","Table")] () :
mknode "w:tblW" [("w:type", "pct"), ("w:w", show rowwidth)] () :
mknode "w:tblW" [("w:type", "pct"), ("w:w", tshow rowwidth)] () :
mknode "w:tblLook" [("w:firstRow",if hasHeader then "1" else "0")
,("w:lastRow","0")
,("w:firstColumn","0")
,("w:lastColumn","0")
,("w:noHBand","0")
,("w:noVBand","0")
,("w:val", printf "%04x" tblLookVal)
,("w:val", T.pack $ printf "%04x" tblLookVal)
] () :
[ mknode "w:tblCaption" [("w:val", T.unpack captionStr)] ()
[ mknode "w:tblCaption" [("w:val", captionStr)] ()
| not (null caption) ] )
: mknode "w:tblGrid" []
(if all (==0) widths
@@ -1126,7 +1123,7 @@ listItemToOpenXML opts numid (first:rest) = do
modify $ \st -> st{ stInList = oldInList }
return $ first'' ++ rest''
alignmentToString :: Alignment -> [Char]
alignmentToString :: Alignment -> Text
alignmentToString alignment = case alignment of
AlignLeft -> "left"
AlignRight -> "right"
@@ -1169,8 +1166,8 @@ getParaProps displayMathPara = do
listLevel <- asks envListLevel
numid <- asks envListNumId
let listPr = [mknode "w:numPr" []
[ mknode "w:ilvl" [("w:val",show listLevel)] ()
, mknode "w:numId" [("w:val",show numid)] () ] | listLevel >= 0 && not displayMathPara]
[ mknode "w:ilvl" [("w:val",tshow listLevel)] ()
, mknode "w:numId" [("w:val",tshow numid)] () ] | listLevel >= 0 && not displayMathPara]
return $ case listPr ++ squashProps props of
[] -> []
ps -> [mknode "w:pPr" [] ps]
@@ -1185,7 +1182,7 @@ withParaPropM md p = do
d <- md
withParaProp d p
formattedString :: PandocMonad m => T.Text -> WS m [Element]
formattedString :: PandocMonad m => Text -> WS m [Element]
formattedString str =
-- properly handle soft hyphens
case splitTextBy (=='\173') str of
@@ -1194,7 +1191,7 @@ formattedString str =
sh <- formattedRun [mknode "w:softHyphen" [] ()]
intercalate sh <$> mapM formattedString' ws
formattedString' :: PandocMonad m => T.Text -> WS m [Element]
formattedString' :: PandocMonad m => Text -> WS m [Element]
formattedString' str = do
inDel <- asks envInDel
formattedRun [ mktnode (if inDel then "w:delText" else "w:t")
@@ -1226,7 +1223,7 @@ inlineToOpenXML' opts (Span ("",["csl-right-inline"],[]) ils) =
mknode "w:r" []
(mknode "w:t"
[("xml:space","preserve")]
("\t" :: String))] ++)
("\t" :: Text))] ++)
<$> inlinesToOpenXML opts ils
inlineToOpenXML' opts (Span ("",["csl-indent"],[]) ils) =
inlinesToOpenXML opts ils
@@ -1236,17 +1233,17 @@ inlineToOpenXML' _ (Span (ident,["comment-start"],kvs) ils) = do
let ident' = fromMaybe ident (lookup "id" kvs)
kvs' = filter (("id" /=) . fst) kvs
modify $ \st -> st{ stComments = (("id",ident'):kvs', ils) : stComments st }
return [ Elem $ mknode "w:commentRangeStart" [("w:id", T.unpack ident')] () ]
return [ Elem $ 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 . map Elem $
[ mknode "w:commentRangeEnd" [("w:id", T.unpack ident')] ()
[ mknode "w:commentRangeEnd" [("w:id", ident')] ()
, mknode "w:r" []
[ mknode "w:rPr" []
[ mknode "w:rStyle" [("w:val", "CommentReference")] () ]
, mknode "w:commentReference" [("w:id", T.unpack ident')] () ]
, mknode "w:commentReference" [("w:id", ident')] () ]
]
inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do
stylemod <- case lookup dynamicStyleKey kvs of
@@ -1270,8 +1267,8 @@ inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do
defaultAuthor <- asks envChangesAuthor
let author = fromMaybe defaultAuthor (lookup "author" kvs)
let mdate = lookup "date" kvs
return $ ("w:author", T.unpack author) :
maybe [] (\date -> [("w:date", T.unpack date)]) mdate
return $ ("w:author", author) :
maybe [] (\date -> [("w:date", date)]) mdate
insmod <- if "insertion" `elem` classes
then do
changeAuthorDate <- getChangeAuthorDate
@@ -1281,7 +1278,7 @@ inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do
x <- f
return [Elem $
mknode "w:ins"
(("w:id", show insId) : changeAuthorDate) x]
(("w:id", tshow insId) : changeAuthorDate) x]
else return id
delmod <- if "deletion" `elem` classes
then do
@@ -1291,7 +1288,7 @@ inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do
return $ \f -> local (\env->env{envInDel=True}) $ do
x <- f
return [Elem $ mknode "w:del"
(("w:id", show delId) : changeAuthorDate) x]
(("w:id", tshow delId) : changeAuthorDate) x]
else return id
contents <- insmod $ delmod $ dirmod $ stylemod $ pmod
$ inlinesToOpenXML opts ils
@@ -1322,7 +1319,7 @@ inlineToOpenXML' opts (Strikeout lst) =
inlineToOpenXML' _ LineBreak = return [Elem br]
inlineToOpenXML' _ il@(RawInline f str)
| f == Format "openxml" = return
[Text (CData CDataRaw (T.unpack str) Nothing)]
[Text (CData CDataRaw str Nothing)]
| otherwise = do
report $ InlineNotRendered il
return []
@@ -1335,7 +1332,7 @@ inlineToOpenXML' opts (Math mathType str) = do
when (mathType == DisplayMath) setFirstPara
res <- (lift . lift) (convertMath writeOMML mathType str)
case res of
Right r -> return [Elem r]
Right r -> return [Elem $ fromXLElement r]
Left il -> inlineToOpenXML' opts il
inlineToOpenXML' opts (Cite _ lst) = inlinesToOpenXML opts lst
inlineToOpenXML' opts (Code attrs str) = do
@@ -1348,7 +1345,7 @@ inlineToOpenXML' opts (Code attrs str) = do
mknode "w:r" []
[ mknode "w:rPr" [] $
maybeToList (lookup toktype tokTypesMap)
, mknode "w:t" [("xml:space","preserve")] (T.unpack tok) ]
, mknode "w:t" [("xml:space","preserve")] tok ]
withTextPropM (rStyleM "Verbatim Char")
$ if isNothing (writerHighlightStyle opts)
then unhighlighted
@@ -1365,7 +1362,7 @@ inlineToOpenXML' opts (Note bs) = do
let notemarker = mknode "w:r" []
[ mknode "w:rPr" [] footnoteStyle
, mknode "w:footnoteRef" [] () ]
let notemarkerXml = RawInline (Format "openxml") $ T.pack $ ppElement notemarker
let notemarkerXml = RawInline (Format "openxml") $ ppElement notemarker
let insertNoteRef (Plain ils : xs) = Plain (notemarkerXml : Space : ils) : xs
insertNoteRef (Para ils : xs) = Para (notemarkerXml : Space : ils) : xs
insertNoteRef xs = Para [notemarkerXml] : xs
@@ -1384,17 +1381,17 @@ inlineToOpenXML' opts (Note bs) = do
inlineToOpenXML' opts (Link _ txt (T.uncons -> Just ('#', xs),_)) = do
contents <- withTextPropM (rStyleM "Hyperlink") $ inlinesToOpenXML opts txt
return
[ Elem $ mknode "w:hyperlink" [("w:anchor", T.unpack $ toBookmarkName xs)] contents ]
[ Elem $ mknode "w:hyperlink" [("w:anchor", toBookmarkName xs)] contents ]
-- external link:
inlineToOpenXML' opts (Link _ txt (src,_)) = do
contents <- withTextPropM (rStyleM "Hyperlink") $ inlinesToOpenXML opts txt
extlinks <- gets stExternalLinks
id' <- case M.lookup (T.unpack src) extlinks of
id' <- case M.lookup src extlinks of
Just i -> return i
Nothing -> do
i <- ("rId"++) `fmap` getUniqueId
i <- ("rId" <>) <$> getUniqueId
modify $ \st -> st{ stExternalLinks =
M.insert (T.unpack src) i extlinks }
M.insert src i extlinks }
return i
return [ Elem $ mknode "w:hyperlink" [("r:id",id')] contents ]
inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do
@@ -1414,17 +1411,17 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do
,("noChangeAspect","1")] ()
nvPicPr = mknode "pic:nvPicPr" []
[ mknode "pic:cNvPr"
[("descr",T.unpack src),("id","0"),("name","Picture")] ()
[("descr",src),("id","0"),("name","Picture")] ()
, cNvPicPr ]
blipFill = mknode "pic:blipFill" []
[ mknode "a:blip" [("r:embed",ident)] ()
[ mknode "a:blip" [("r:embed",T.pack 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)] () ]
, mknode "a:ext" [("cx",tshow xemu)
,("cy",tshow yemu)] () ]
prstGeom = mknode "a:prstGeom" [("prst","rect")] $
mknode "a:avLst" [] ()
ln = mknode "a:ln" [("w","9525")]
@@ -1445,12 +1442,12 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do
imgElt = mknode "w:r" [] $
mknode "w:drawing" [] $
mknode "wp:inline" []
[ mknode "wp:extent" [("cx",show xemu),("cy",show yemu)] ()
[ mknode "wp:extent" [("cx",tshow xemu),("cy",tshow yemu)] ()
, mknode "wp:effectExtent"
[("b","0"),("l","0"),("r","0"),("t","0")] ()
, mknode "wp:docPr"
[ ("descr", T.unpack $ stringify alt)
, ("title", T.unpack title)
[ ("descr", stringify alt)
, ("title", title)
, ("id","1")
, ("name","Picture")
] ()
@@ -1463,7 +1460,7 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do
Just imgData -> return [Elem $ generateImgElt imgData]
Nothing -> ( do --try
(img, mt) <- P.fetchItem src
ident <- ("rId"++) `fmap` getUniqueId
ident <- ("rId" <>) <$> getUniqueId
let
imgext = case mt >>= extensionFromMimeType of
@@ -1477,10 +1474,10 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do
Just Svg -> ".svg"
Just Emf -> ".emf"
Nothing -> ""
imgpath = "media/" <> ident <> T.unpack imgext
mbMimeType = mt <|> getMimeType imgpath
imgpath = "media/" <> ident <> imgext
mbMimeType = mt <|> getMimeType (T.unpack imgpath)
imgData = (ident, imgpath, mbMimeType, img)
imgData = (T.unpack ident, T.unpack imgpath, mbMimeType, img)
if T.null imgext
then -- without an extension there is no rule for content type
@@ -1538,20 +1535,20 @@ withDirection x = do
, envTextProperties = EnvProps textStyle textProps'
}
wrapBookmark :: (PandocMonad m) => T.Text -> [Content] -> WS m [Content]
wrapBookmark :: (PandocMonad m) => Text -> [Content] -> WS m [Content]
wrapBookmark "" contents = return contents
wrapBookmark ident contents = do
id' <- getUniqueId
let bookmarkStart = mknode "w:bookmarkStart"
[("w:id", id')
,("w:name", T.unpack $ toBookmarkName ident)] ()
,("w:name", toBookmarkName ident)] ()
bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] ()
return $ Elem bookmarkStart : contents ++ [Elem bookmarkEnd]
-- Word imposes a 40 character limit on bookmark names and requires
-- that they begin with a letter. So we just use a hash of the
-- identifier when otherwise we'd have an illegal bookmark name.
toBookmarkName :: T.Text -> T.Text
toBookmarkName :: Text -> Text
toBookmarkName s
| Just (c, _) <- T.uncons s
, isLetter c
src/Text/Pandoc/Writers/EPUB.hs
+173 -183
View File
@@ -24,12 +24,13 @@ import Control.Monad.State.Strict (StateT, evalState, evalStateT, get,
gets, lift, modify)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.Char (isAlphaNum, isAscii, isDigit, toLower)
import Data.Char (isAlphaNum, isAscii, isDigit)
import Data.List (isInfixOf, isPrefixOf)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isNothing, mapMaybe, isJust)
import qualified Data.Set as Set
import qualified Data.Text as TS
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import Network.HTTP (urlEncode)
import System.FilePath (takeExtension, takeFileName, makeRelative)
@@ -48,16 +49,13 @@ import Text.Pandoc.Options (EPUBVersion (..), HTMLMathMethod (..),
ObfuscationMethod (NoObfuscation), WrapOption (..),
WriterOptions (..))
import Text.Pandoc.Shared (makeSections, normalizeDate, renderTags',
safeRead, stringify, trim, uniqueIdent, tshow)
stringify, uniqueIdent, tshow)
import qualified Text.Pandoc.UTF8 as UTF8
import Text.Pandoc.UUID (getRandomUUID)
import Text.Pandoc.Walk (query, walk, walkM)
import Text.Pandoc.Writers.HTML (writeHtmlStringForEPUB)
import Text.Printf (printf)
import Text.XML.Light (Attr (..), Element (..), Node (..), QName (..),
add_attrs, lookupAttr, node, onlyElems,
ppElement, showElement, strContent, unode, unqual)
import Text.Pandoc.XMLParser (parseXMLContents)
import Text.Pandoc.XML.Light
import Text.Pandoc.XML (escapeStringForXML)
import Text.DocTemplates (FromContext(lookupContext), Context(..),
ToContext(toVal), Val(..))
@@ -69,7 +67,7 @@ newtype Chapter = Chapter [Block]
data EPUBState = EPUBState {
stMediaPaths :: [(FilePath, (FilePath, Maybe Entry))]
, stMediaNextId :: Int
, stEpubSubdir :: String
, stEpubSubdir :: FilePath
}
type E m = StateT EPUBState m
@@ -78,62 +76,63 @@ data EPUBMetadata = EPUBMetadata{
epubIdentifier :: [Identifier]
, epubTitle :: [Title]
, epubDate :: [Date]
, epubLanguage :: String
, epubLanguage :: Text
, epubCreator :: [Creator]
, epubContributor :: [Creator]
, epubSubject :: [String]
, epubDescription :: Maybe String
, epubType :: Maybe String
, epubFormat :: Maybe String
, epubPublisher :: Maybe String
, epubSource :: Maybe String
, epubRelation :: Maybe String
, epubCoverage :: Maybe String
, epubRights :: Maybe String
, epubBelongsToCollection :: Maybe String
, epubGroupPosition :: Maybe String
, epubCoverImage :: Maybe String
, epubSubject :: [Text]
, epubDescription :: Maybe Text
, epubType :: Maybe Text
, epubFormat :: Maybe Text
, epubPublisher :: Maybe Text
, epubSource :: Maybe Text
, epubRelation :: Maybe Text
, epubCoverage :: Maybe Text
, epubRights :: Maybe Text
, epubBelongsToCollection :: Maybe Text
, epubGroupPosition :: Maybe Text
, epubCoverImage :: Maybe FilePath
, epubStylesheets :: [FilePath]
, epubPageDirection :: Maybe ProgressionDirection
, epubIbooksFields :: [(String, String)]
, epubCalibreFields :: [(String, String)]
, epubIbooksFields :: [(Text, Text)]
, epubCalibreFields :: [(Text, Text)]
} deriving Show
data Date = Date{
dateText :: String
, dateEvent :: Maybe String
dateText :: Text
, dateEvent :: Maybe Text
} deriving Show
data Creator = Creator{
creatorText :: String
, creatorRole :: Maybe String
, creatorFileAs :: Maybe String
creatorText :: Text
, creatorRole :: Maybe Text
, creatorFileAs :: Maybe Text
} deriving Show
data Identifier = Identifier{
identifierText :: String
, identifierScheme :: Maybe String
identifierText :: Text
, identifierScheme :: Maybe Text
} deriving Show
data Title = Title{
titleText :: String
, titleFileAs :: Maybe String
, titleType :: Maybe String
titleText :: Text
, titleFileAs :: Maybe Text
, titleType :: Maybe Text
} deriving Show
data ProgressionDirection = LTR | RTL deriving Show
dcName :: String -> QName
dcName :: Text -> QName
dcName n = QName n Nothing (Just "dc")
dcNode :: Node t => String -> t -> Element
dcNode :: Node t => Text -> t -> Element
dcNode = node . dcName
opfName :: String -> QName
opfName :: Text -> QName
opfName n = QName n Nothing (Just "opf")
toId :: FilePath -> String
toId = map (\x -> if isAlphaNum x || x == '-' || x == '_'
toId :: FilePath -> Text
toId = T.pack .
map (\x -> if isAlphaNum x || x == '-' || x == '_'
then x
else '_') . takeFileName
@@ -141,8 +140,8 @@ removeNote :: Inline -> Inline
removeNote (Note _) = Str ""
removeNote x = x
toVal' :: String -> Val TS.Text
toVal' = toVal . TS.pack
toVal' :: Text -> Val T.Text
toVal' = toVal
mkEntry :: PandocMonad m => FilePath -> B.ByteString -> E m Entry
mkEntry path content = do
@@ -172,21 +171,21 @@ getEPUBMetadata opts meta = do
if null (epubIdentifier m)
then do
randomId <- getRandomUUID
return $ m{ epubIdentifier = [Identifier (show randomId) Nothing] }
return $ m{ epubIdentifier = [Identifier (tshow randomId) Nothing] }
else return m
let addLanguage m =
if null (epubLanguage m)
if T.null (epubLanguage m)
then case lookupContext "lang" (writerVariables opts) of
Just x -> return m{ epubLanguage = TS.unpack x }
Just x -> return m{ epubLanguage = x }
Nothing -> do
mLang <- lift $ P.lookupEnv "LANG"
let localeLang =
case mLang of
Just lang ->
TS.map (\c -> if c == '_' then '-' else c) $
TS.takeWhile (/='.') lang
T.map (\c -> if c == '_' then '-' else c) $
T.takeWhile (/='.') lang
Nothing -> "en-US"
return m{ epubLanguage = TS.unpack localeLang }
return m{ epubLanguage = localeLang }
else return m
let fixDate m =
if null (epubDate m)
@@ -201,7 +200,7 @@ getEPUBMetadata opts meta = do
then return m
else do
let authors' = map stringify $ docAuthors meta
let toAuthor name = Creator{ creatorText = TS.unpack name
let toAuthor name = Creator{ creatorText = name
, creatorRole = Just "aut"
, creatorFileAs = Nothing }
return $ m{ epubCreator = map toAuthor authors' ++ epubCreator m }
@@ -249,31 +248,31 @@ addMetadataFromXML e@(Element (QName name _ (Just "dc")) attrs _ _) md
where getAttr n = lookupAttr (opfName n) attrs
addMetadataFromXML e@(Element (QName "meta" _ _) attrs _ _) md =
case getAttr "property" of
Just s | "ibooks:" `isPrefixOf` s ->
md{ epubIbooksFields = (drop 7 s, strContent e) :
Just s | "ibooks:" `T.isPrefixOf` s ->
md{ epubIbooksFields = (T.drop 7 s, strContent e) :
epubIbooksFields md }
_ -> case getAttr "name" of
Just s | "calibre:" `isPrefixOf` s ->
Just s | "calibre:" `T.isPrefixOf` s ->
md{ epubCalibreFields =
(drop 8 s, fromMaybe "" $ getAttr "content") :
(T.drop 8 s, fromMaybe "" $ getAttr "content") :
epubCalibreFields md }
_ -> md
where getAttr n = lookupAttr (unqual n) attrs
addMetadataFromXML _ md = md
metaValueToString :: MetaValue -> String
metaValueToString (MetaString s) = TS.unpack s
metaValueToString (MetaInlines ils) = TS.unpack $ stringify ils
metaValueToString (MetaBlocks bs) = TS.unpack $ stringify bs
metaValueToString :: MetaValue -> Text
metaValueToString (MetaString s) = s
metaValueToString (MetaInlines ils) = stringify ils
metaValueToString (MetaBlocks bs) = stringify bs
metaValueToString (MetaBool True) = "true"
metaValueToString (MetaBool False) = "false"
metaValueToString _ = ""
metaValueToPaths :: MetaValue -> [FilePath]
metaValueToPaths (MetaList xs) = map metaValueToString xs
metaValueToPaths x = [metaValueToString x]
metaValueToPaths (MetaList xs) = map (T.unpack . metaValueToString) xs
metaValueToPaths x = [T.unpack $ metaValueToString x]
getList :: TS.Text -> Meta -> (MetaValue -> a) -> [a]
getList :: T.Text -> Meta -> (MetaValue -> a) -> [a]
getList s meta handleMetaValue =
case lookupMeta s meta of
Just (MetaList xs) -> map handleMetaValue xs
@@ -297,7 +296,7 @@ getTitle meta = getList "title" meta handleMetaValue
, titleType = metaValueToString <$> M.lookup "type" m }
handleMetaValue mv = Title (metaValueToString mv) Nothing Nothing
getCreator :: TS.Text -> Meta -> [Creator]
getCreator :: T.Text -> Meta -> [Creator]
getCreator s meta = getList s meta handleMetaValue
where handleMetaValue (MetaMap m) =
Creator{ creatorText = maybe "" metaValueToString $ M.lookup "text" m
@@ -305,7 +304,7 @@ getCreator s meta = getList s meta handleMetaValue
, creatorRole = metaValueToString <$> M.lookup "role" m }
handleMetaValue mv = Creator (metaValueToString mv) Nothing Nothing
getDate :: TS.Text -> Meta -> [Date]
getDate :: T.Text -> Meta -> [Date]
getDate s meta = getList s meta handleMetaValue
where handleMetaValue (MetaMap m) =
Date{ dateText = fromMaybe "" $
@@ -314,7 +313,7 @@ getDate s meta = getList s meta handleMetaValue
handleMetaValue mv = Date { dateText = fromMaybe "" $ normalizeDate' $ metaValueToString mv
, dateEvent = Nothing }
simpleList :: TS.Text -> Meta -> [String]
simpleList :: T.Text -> Meta -> [Text]
simpleList s meta =
case lookupMeta s meta of
Just (MetaList xs) -> map metaValueToString xs
@@ -339,7 +338,7 @@ metadataFromMeta opts meta = EPUBMetadata{
, epubCoverage = coverage
, epubRights = rights
, epubBelongsToCollection = belongsToCollection
, epubGroupPosition = groupPosition
, epubGroupPosition = groupPosition
, epubCoverImage = coverImage
, epubStylesheets = stylesheets
, epubPageDirection = pageDirection
@@ -363,31 +362,30 @@ metadataFromMeta opts meta = EPUBMetadata{
coverage = metaValueToString <$> lookupMeta "coverage" meta
rights = metaValueToString <$> lookupMeta "rights" meta
belongsToCollection = metaValueToString <$> lookupMeta "belongs-to-collection" meta
groupPosition = metaValueToString <$> lookupMeta "group-position" meta
coverImage =
(TS.unpack <$> lookupContext "epub-cover-image"
(writerVariables opts))
groupPosition = metaValueToString <$> lookupMeta "group-position" meta
coverImage = T.unpack <$>
lookupContext "epub-cover-image" (writerVariables opts)
`mplus` (metaValueToString <$> lookupMeta "cover-image" meta)
mCss = lookupMeta "css" meta <|> lookupMeta "stylesheet" meta
stylesheets = maybe [] metaValueToPaths mCss ++
case lookupContext "css" (writerVariables opts) of
Just xs -> map TS.unpack xs
Just xs -> map T.unpack xs
Nothing ->
case lookupContext "css" (writerVariables opts) of
Just x -> [TS.unpack x]
Just x -> [T.unpack x]
Nothing -> []
pageDirection = case map toLower . metaValueToString <$>
pageDirection = case T.toLower . metaValueToString <$>
lookupMeta "page-progression-direction" meta of
Just "ltr" -> Just LTR
Just "rtl" -> Just RTL
_ -> Nothing
ibooksFields = case lookupMeta "ibooks" meta of
Just (MetaMap mp)
-> M.toList $ M.mapKeys TS.unpack $ M.map metaValueToString mp
-> M.toList $ M.map metaValueToString mp
_ -> []
calibreFields = case lookupMeta "calibre" meta of
Just (MetaMap mp)
-> M.toList $ M.mapKeys TS.unpack $ M.map metaValueToString mp
-> M.toList $ M.map metaValueToString mp
_ -> []
-- | Produce an EPUB2 file from a Pandoc document.
@@ -413,9 +411,11 @@ writeEPUB :: PandocMonad m
writeEPUB epubVersion opts doc = do
let epubSubdir = writerEpubSubdirectory opts
-- sanity check on epubSubdir
unless (TS.all (\c -> isAscii c && isAlphaNum c) epubSubdir) $
unless (T.all (\c -> isAscii c && isAlphaNum c) epubSubdir) $
throwError $ PandocEpubSubdirectoryError epubSubdir
let initState = EPUBState { stMediaPaths = [], stMediaNextId = 0, stEpubSubdir = TS.unpack epubSubdir }
let initState = EPUBState { stMediaPaths = []
, stMediaNextId = 0
, stEpubSubdir = T.unpack epubSubdir }
evalStateT (pandocToEPUB epubVersion opts doc) initState
pandocToEPUB :: PandocMonad m
@@ -439,7 +439,7 @@ pandocToEPUB version opts doc = do
[] -> case epubTitle metadata of
[] -> "UNTITLED"
(x:_) -> titleText x
x -> TS.unpack $ stringify x
x -> stringify x
-- stylesheet
stylesheets <- case epubStylesheets metadata of
@@ -461,7 +461,8 @@ pandocToEPUB version opts doc = do
(ListVal $ map
(\e -> toVal' $
(if useprefix then "../" else "") <>
makeRelative epubSubdir (eRelativePath e))
T.pack
(makeRelative epubSubdir (eRelativePath e)))
stylesheetEntries)
mempty
@@ -490,18 +491,19 @@ pandocToEPUB version opts doc = do
case imageSize opts' (B.toStrict imgContent) of
Right sz -> return $ sizeInPixels sz
Left err' -> (0, 0) <$ report
(CouldNotDetermineImageSize (TS.pack img) err')
(CouldNotDetermineImageSize (T.pack img) err')
cpContent <- lift $ writeHtml
opts'{ writerVariables =
Context (M.fromList [
("coverpage", toVal' "true"),
("pagetitle", toVal $
escapeStringForXML $ TS.pack plainTitle),
("cover-image", toVal' coverImageName),
escapeStringForXML plainTitle),
("cover-image",
toVal' $ T.pack coverImageName),
("cover-image-width", toVal' $
show coverImageWidth),
tshow coverImageWidth),
("cover-image-height", toVal' $
show coverImageHeight)]) <>
tshow coverImageHeight)]) <>
cssvars True <> vars }
(Pandoc meta [])
coverEntry <- mkEntry "text/cover.xhtml" cpContent
@@ -517,7 +519,7 @@ pandocToEPUB version opts doc = do
("titlepage", toVal' "true"),
("body-type", toVal' "frontmatter"),
("pagetitle", toVal $
escapeStringForXML $ TS.pack plainTitle)])
escapeStringForXML plainTitle)])
<> cssvars True <> vars }
(Pandoc meta [])
tpEntry <- mkEntry "text/title_page.xhtml" tpContent
@@ -526,7 +528,7 @@ pandocToEPUB version opts doc = do
let matchingGlob f = do
xs <- lift $ P.glob f
when (null xs) $
report $ CouldNotFetchResource (TS.pack f) "glob did not match any font files"
report $ CouldNotFetchResource (T.pack f) "glob did not match any font files"
return xs
let mkFontEntry f = mkEntry ("fonts/" ++ takeFileName f) =<<
lift (P.readFileLazy f)
@@ -573,13 +575,13 @@ pandocToEPUB version opts doc = do
let chapters' = secsToChapters secs
let extractLinkURL' :: Int -> Inline -> [(TS.Text, TS.Text)]
let extractLinkURL' :: Int -> Inline -> [(T.Text, T.Text)]
extractLinkURL' num (Span (ident, _, _) _)
| not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)]
| not (T.null ident) = [(ident, showChapter num <> "#" <> ident)]
extractLinkURL' num (Link (ident, _, _) _ _)
| not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)]
| not (T.null ident) = [(ident, showChapter num <> "#" <> ident)]
extractLinkURL' num (Image (ident, _, _) _ _)
| not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)]
| not (T.null ident) = [(ident, showChapter num <> "#" <> ident)]
extractLinkURL' num (RawInline fmt raw)
| isHtmlFormat fmt
= foldr (\tag ->
@@ -587,18 +589,18 @@ pandocToEPUB version opts doc = do
TagOpen{} ->
case fromAttrib "id" tag of
"" -> id
x -> ((x, TS.pack (showChapter num) <> "#" <> x):)
x -> ((x, showChapter num <> "#" <> x):)
_ -> id)
[] (parseTags raw)
extractLinkURL' _ _ = []
let extractLinkURL :: Int -> Block -> [(TS.Text, TS.Text)]
let extractLinkURL :: Int -> Block -> [(T.Text, T.Text)]
extractLinkURL num (Div (ident, _, _) _)
| not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)]
| not (T.null ident) = [(ident, showChapter num <> "#" <> ident)]
extractLinkURL num (Header _ (ident, _, _) _)
| not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)]
| not (T.null ident) = [(ident, showChapter num <> "#" <> ident)]
extractLinkURL num (Table (ident,_,_) _ _ _ _ _)
| not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)]
| not (T.null ident) = [(ident, showChapter num <> "#" <> ident)]
extractLinkURL num (RawBlock fmt raw)
| isHtmlFormat fmt
= foldr (\tag ->
@@ -606,7 +608,7 @@ pandocToEPUB version opts doc = do
TagOpen{} ->
case fromAttrib "id" tag of
"" -> id
x -> ((x, TS.pack (showChapter num) <> "#" <> x):)
x -> ((x, showChapter num <> "#" <> x):)
_ -> id)
[] (parseTags raw)
extractLinkURL num b = query (extractLinkURL' num) b
@@ -617,7 +619,7 @@ pandocToEPUB version opts doc = do
let fixInternalReferences :: Inline -> Inline
fixInternalReferences (Link attr lab (src, tit))
| Just ('#', xs) <- TS.uncons src = case lookup xs reftable of
| Just ('#', xs) <- T.uncons src = case lookup xs reftable of
Just ys -> Link attr lab (ys, tit)
Nothing -> Link attr lab (src, tit)
fixInternalReferences x = x
@@ -630,7 +632,7 @@ pandocToEPUB version opts doc = do
chapters'
let chapToEntry num (Chapter bs) =
mkEntry ("text/" ++ showChapter num) =<<
mkEntry ("text/" ++ T.unpack (showChapter num)) =<<
writeHtml opts'{ writerVariables =
Context (M.fromList
[("body-type", toVal' bodyType),
@@ -677,12 +679,12 @@ pandocToEPUB version opts doc = do
let chapterNode ent = unode "item" !
([("id", toId $ makeRelative epubSubdir
$ eRelativePath ent),
("href", makeRelative epubSubdir
("href", T.pack $ makeRelative epubSubdir
$ eRelativePath ent),
("media-type", "application/xhtml+xml")]
++ case props ent of
[] -> []
xs -> [("properties", unwords xs)])
xs -> [("properties", T.unwords xs)])
$ ()
let chapterRefNode ent = unode "itemref" !
@@ -691,17 +693,17 @@ pandocToEPUB version opts doc = do
let pictureNode ent = unode "item" !
[("id", toId $ makeRelative epubSubdir
$ eRelativePath ent),
("href", makeRelative epubSubdir
("href", T.pack $ makeRelative epubSubdir
$ eRelativePath ent),
("media-type",
maybe "application/octet-stream" TS.unpack
fromMaybe "application/octet-stream"
$ mediaTypeOf $ eRelativePath ent)] $ ()
let fontNode ent = unode "item" !
[("id", toId $ makeRelative epubSubdir
$ eRelativePath ent),
("href", makeRelative epubSubdir
("href", T.pack $ makeRelative epubSubdir
$ eRelativePath ent),
("media-type", maybe "" TS.unpack $
("media-type", fromMaybe "" $
getMimeType $ eRelativePath ent)] $ ()
let tocTitle = maybe plainTitle
@@ -710,7 +712,7 @@ pandocToEPUB version opts doc = do
(x:_) -> return $ identifierText x -- use first identifier as UUID
[] -> throwError $ PandocShouldNeverHappenError "epubIdentifier is null" -- shouldn't happen
currentTime <- lift P.getTimestamp
let contentsData = UTF8.fromStringLazy $ ppTopElement $
let contentsData = UTF8.fromTextLazy $ TL.fromStrict $ ppTopElement $
unode "package" !
([("version", case version of
EPUB2 -> "2.0"
@@ -728,7 +730,8 @@ pandocToEPUB version opts doc = do
,("media-type","application/xhtml+xml")] ++
[("properties","nav") | epub3 ]) $ ()
] ++
[ unode "item" ! [("id","stylesheet" ++ show n), ("href",fp)
[ unode "item" ! [("id","stylesheet" <> tshow n)
, ("href", T.pack fp)
,("media-type","text/css")] $ () |
(n :: Int, fp) <- zip [1..] (map
(makeRelative epubSubdir . eRelativePath)
@@ -773,7 +776,7 @@ pandocToEPUB version opts doc = do
let tocLevel = writerTOCDepth opts
let navPointNode :: PandocMonad m
=> (Int -> [Inline] -> TS.Text -> [Element] -> Element)
=> (Int -> [Inline] -> T.Text -> [Element] -> Element)
-> Block -> StateT Int m [Element]
navPointNode formatter (Div (ident,_,_)
(Header lvl (_,_,kvs) ils : children)) =
@@ -783,7 +786,7 @@ pandocToEPUB version opts doc = do
n <- get
modify (+1)
let num = fromMaybe "" $ lookup "number" kvs
let tit = if writerNumberSections opts && not (TS.null num)
let tit = if writerNumberSections opts && not (T.null num)
then Span ("", ["section-header-number"], [])
[Str num] : Space : ils
else ils
@@ -797,21 +800,21 @@ pandocToEPUB version opts doc = do
concat <$> mapM (navPointNode formatter) bs
navPointNode _ _ = return []
let navMapFormatter :: Int -> [Inline] -> TS.Text -> [Element] -> Element
let navMapFormatter :: Int -> [Inline] -> T.Text -> [Element] -> Element
navMapFormatter n tit src subs = unode "navPoint" !
[("id", "navPoint-" ++ show n)] $
[ unode "navLabel" $ unode "text" $ TS.unpack $ stringify tit
, unode "content" ! [("src", "text/" <> TS.unpack src)] $ ()
[("id", "navPoint-" <> tshow n)] $
[ unode "navLabel" $ unode "text" $ stringify tit
, unode "content" ! [("src", "text/" <> src)] $ ()
] ++ subs
let tpNode = unode "navPoint" ! [("id", "navPoint-0")] $
[ unode "navLabel" $ unode "text" (TS.unpack $ stringify $ docTitle' meta)
[ unode "navLabel" $ unode "text" (stringify $ docTitle' meta)
, unode "content" ! [("src", "text/title_page.xhtml")]
$ () ]
navMap <- lift $ evalStateT
(concat <$> mapM (navPointNode navMapFormatter) secs) 1
let tocData = UTF8.fromStringLazy $ ppTopElement $
let tocData = B.fromStrict $ UTF8.fromText $ ppTopElement $
unode "ncx" ! [("version","2005-1")
,("xmlns","http://www.daisy.org/z3986/2005/ncx/")] $
[ unode "head" $
@@ -833,11 +836,11 @@ pandocToEPUB version opts doc = do
]
tocEntry <- mkEntry "toc.ncx" tocData
let navXhtmlFormatter :: Int -> [Inline] -> TS.Text -> [Element] -> Element
let navXhtmlFormatter :: Int -> [Inline] -> T.Text -> [Element] -> Element
navXhtmlFormatter n tit src subs = unode "li" !
[("id", "toc-li-" ++ show n)] $
[("id", "toc-li-" <> tshow n)] $
(unode "a" !
[("href", "text/" <> TS.unpack src)]
[("href", "text/" <> src)]
$ titElements)
: case subs of
[] -> []
@@ -850,7 +853,7 @@ pandocToEPUB version opts doc = do
, writerVariables =
Context (M.fromList
[("pagetitle", toVal $
escapeStringForXML $ TS.pack plainTitle)])
escapeStringForXML plainTitle)])
<> writerVariables opts}
(Pandoc nullMeta
[Plain $ walk clean tit])) of
@@ -865,7 +868,7 @@ pandocToEPUB version opts doc = do
tocBlocks <- lift $ evalStateT
(concat <$> mapM (navPointNode navXhtmlFormatter) secs) 1
let navBlocks = [RawBlock (Format "html")
$ TS.pack $ showElement $ -- prettyprinting introduces bad spaces
$ showElement $ -- prettyprinting introduces bad spaces
unode navtag ! ([("epub:type","toc") | epub3] ++
[("id","toc")]) $
[ unode "h1" ! [("id","toc-title")] $ tocTitle
@@ -875,21 +878,21 @@ pandocToEPUB version opts doc = do
[ unode "a" ! [("href",
"text/title_page.xhtml")
,("epub:type", "titlepage")] $
("Title Page" :: String) ] :
("Title Page" :: Text) ] :
[ unode "li"
[ unode "a" ! [("href", "text/cover.xhtml")
,("epub:type", "cover")] $
("Cover" :: String)] |
("Cover" :: Text)] |
isJust (epubCoverImage metadata)
] ++
[ unode "li"
[ unode "a" ! [("href", "#toc")
,("epub:type", "toc")] $
("Table of Contents" :: String)
("Table of Contents" :: Text)
] | writerTableOfContents opts
]
else []
let landmarks = [RawBlock (Format "html") $ TS.pack $ ppElement $
let landmarks = [RawBlock (Format "html") $ ppElement $
unode "nav" ! [("epub:type","landmarks")
,("id","landmarks")
,("hidden","hidden")] $
@@ -910,22 +913,22 @@ pandocToEPUB version opts doc = do
UTF8.fromStringLazy "application/epub+zip"
-- container.xml
let containerData = UTF8.fromStringLazy $ ppTopElement $
let containerData = B.fromStrict $ UTF8.fromText $ ppTopElement $
unode "container" ! [("version","1.0")
,("xmlns","urn:oasis:names:tc:opendocument:xmlns:container")] $
unode "rootfiles" $
unode "rootfile" ! [("full-path",
(if null epubSubdir
then ""
else epubSubdir ++ "/") ++ "content.opf")
else T.pack epubSubdir <> "/") <> "content.opf")
,("media-type","application/oebps-package+xml")] $ ()
containerEntry <- mkEntry "META-INF/container.xml" containerData
-- com.apple.ibooks.display-options.xml
let apple = UTF8.fromStringLazy $ ppTopElement $
let apple = B.fromStrict $ UTF8.fromText $ ppTopElement $
unode "display_options" $
unode "platform" ! [("name","*")] $
unode "option" ! [("name","specified-fonts")] $ ("true" :: String)
unode "option" ! [("name","specified-fonts")] $ ("true" :: Text)
appleEntry <- mkEntry "META-INF/com.apple.ibooks.display-options.xml" apple
-- construct archive
@@ -947,7 +950,8 @@ metadataElement version md currentTime =
++ publisherNodes ++ sourceNodes ++ relationNodes
++ coverageNodes ++ rightsNodes ++ coverImageNodes
++ modifiedNodes ++ belongsToCollectionNodes
withIds base f = concat . zipWith f (map (\x -> base ++ ('-' : show x))
withIds base f = concat . zipWith f (map (\x -> base <>
T.cons '-' (tshow x))
([1..] :: [Int]))
identifierNodes = withIds "epub-id" toIdentifierNode $
epubIdentifier md
@@ -961,9 +965,9 @@ metadataElement version md currentTime =
(x:_) -> [dcNode "date" ! [("id","epub-date")]
$ dateText x]
ibooksNodes = map ibooksNode (epubIbooksFields md)
ibooksNode (k, v) = unode "meta" ! [("property", "ibooks:" ++ k)] $ v
ibooksNode (k, v) = unode "meta" ! [("property", "ibooks:" <> k)] $ v
calibreNodes = map calibreNode (epubCalibreFields md)
calibreNode (k, v) = unode "meta" ! [("name", "calibre:" ++ k),
calibreNode (k, v) = unode "meta" ! [("name", "calibre:" <> k),
("content", v)] $ ()
languageNodes = [dcTag "language" $ epubLanguage md]
creatorNodes = withIds "epub-creator" (toCreatorNode "creator") $
@@ -989,12 +993,12 @@ metadataElement version md currentTime =
maybe []
(\belongsToCollection -> (unode "meta" ! [("property", "belongs-to-collection"), ("id", "epub-id-1")] $ belongsToCollection )
:
[unode "meta" ! [("refines", "#epub-id-1"), ("property", "collection-type")] $ ("series" :: String) ])
[unode "meta" ! [("refines", "#epub-id-1"), ("property", "collection-type")] $ ("series" :: Text) ])
(epubBelongsToCollection md)++
maybe []
(\groupPosition -> [unode "meta" ! [("refines", "#epub-id-1"), ("property", "group-position")] $ groupPosition ])
(epubGroupPosition md)
dcTag n s = unode ("dc:" ++ n) s
dcTag n s = unode ("dc:" <> n) s
dcTag' n s = [dcTag n s]
toIdentifierNode id' (Identifier txt scheme)
| version == EPUB2 = [dcNode "identifier" !
@@ -1002,7 +1006,7 @@ metadataElement version md currentTime =
txt]
| otherwise = (dcNode "identifier" ! [("id",id')] $ txt) :
maybe [] ((\x -> [unode "meta" !
[ ("refines",'#':id')
[ ("refines","#" <> id')
, ("property","identifier-type")
, ("scheme","onix:codelist5")
]
@@ -1018,10 +1022,10 @@ metadataElement version md currentTime =
(creatorRole creator >>= toRelator)) $ creatorText creator]
| otherwise = [dcNode s ! [("id",id')] $ creatorText creator] ++
maybe [] (\x -> [unode "meta" !
[("refines",'#':id'),("property","file-as")] $ x])
[("refines","#" <> id'),("property","file-as")] $ x])
(creatorFileAs creator) ++
maybe [] (\x -> [unode "meta" !
[("refines",'#':id'),("property","role"),
[("refines","#" <> id'),("property","role"),
("scheme","marc:relators")] $ x])
(creatorRole creator >>= toRelator)
toTitleNode id' title
@@ -1033,16 +1037,16 @@ metadataElement version md currentTime =
| otherwise = [dcNode "title" ! [("id",id')] $ titleText title]
++
maybe [] (\x -> [unode "meta" !
[("refines",'#':id'),("property","file-as")] $ x])
[("refines","#" <> id'),("property","file-as")] $ x])
(titleFileAs title) ++
maybe [] (\x -> [unode "meta" !
[("refines",'#':id'),("property","title-type")] $ x])
[("refines","#" <> id'),("property","title-type")] $ x])
(titleType title)
toDateNode id' date = [dcNode "date" !
(("id",id') :
maybe [] (\x -> [("opf:event",x)]) (dateEvent date)) $
dateText date]
schemeToOnix :: String -> String
schemeToOnix :: Text -> Text
schemeToOnix "ISBN-10" = "02"
schemeToOnix "GTIN-13" = "03"
schemeToOnix "UPC" = "04"
@@ -1060,48 +1064,48 @@ metadataElement version md currentTime =
schemeToOnix "OLCC" = "28"
schemeToOnix _ = "01"
showDateTimeISO8601 :: UTCTime -> String
showDateTimeISO8601 = formatTime defaultTimeLocale "%FT%TZ"
showDateTimeISO8601 :: UTCTime -> Text
showDateTimeISO8601 = T.pack . formatTime defaultTimeLocale "%FT%TZ"
transformTag :: PandocMonad m
=> Tag TS.Text
-> E m (Tag TS.Text)
=> Tag T.Text
-> E m (Tag T.Text)
transformTag tag@(TagOpen name attr)
| name `elem` ["video", "source", "img", "audio"] &&
isNothing (lookup "data-external" attr) = do
let src = fromAttrib "src" tag
let poster = fromAttrib "poster" tag
newsrc <- modifyMediaRef $ TS.unpack src
newposter <- modifyMediaRef $ TS.unpack poster
newsrc <- modifyMediaRef $ T.unpack src
newposter <- modifyMediaRef $ T.unpack poster
let attr' = filter (\(x,_) -> x /= "src" && x /= "poster") attr ++
[("src", "../" <> newsrc) | not (TS.null newsrc)] ++
[("poster", "../" <> newposter) | not (TS.null newposter)]
[("src", "../" <> newsrc) | not (T.null newsrc)] ++
[("poster", "../" <> newposter) | not (T.null newposter)]
return $ TagOpen name attr'
transformTag tag = return tag
modifyMediaRef :: PandocMonad m
=> FilePath
-> E m TS.Text
-> E m T.Text
modifyMediaRef "" = return ""
modifyMediaRef oldsrc = do
media <- gets stMediaPaths
case lookup oldsrc media of
Just (n,_) -> return $ TS.pack n
Just (n,_) -> return $ T.pack n
Nothing -> catchError
(do (img, mbMime) <- P.fetchItem $ TS.pack oldsrc
let ext = maybe (takeExtension (takeWhile (/='?') oldsrc)) TS.unpack
(do (img, mbMime) <- P.fetchItem $ T.pack oldsrc
let ext = maybe (takeExtension (takeWhile (/='?') oldsrc)) T.unpack
(("." <>) <$> (mbMime >>= extensionFromMimeType))
newName <- getMediaNextNewName ext
let newPath = "media/" ++ newName
entry <- mkEntry newPath (B.fromChunks . (:[]) $ img)
modify $ \st -> st{ stMediaPaths =
(oldsrc, (newPath, Just entry)):media}
return $ TS.pack newPath)
return $ T.pack newPath)
(\e -> do
report $ CouldNotFetchResource (TS.pack oldsrc) (tshow e)
return $ TS.pack oldsrc)
report $ CouldNotFetchResource (T.pack oldsrc) (tshow e)
return $ T.pack oldsrc)
getMediaNextNewName :: PandocMonad m => String -> E m String
getMediaNextNewName :: PandocMonad m => FilePath -> E m FilePath
getMediaNextNewName ext = do
nextId <- gets stMediaNextId
modify $ \st -> st { stMediaNextId = nextId + 1 }
@@ -1128,11 +1132,11 @@ transformInline :: PandocMonad m
-> Inline
-> E m Inline
transformInline _opts (Image attr lab (src,tit)) = do
newsrc <- modifyMediaRef $ TS.unpack src
newsrc <- modifyMediaRef $ T.unpack src
return $ Image attr lab ("../" <> newsrc, tit)
transformInline opts x@(Math t m)
| WebTeX url <- writerHTMLMathMethod opts = do
newsrc <- modifyMediaRef (TS.unpack url <> urlEncode (TS.unpack m))
newsrc <- modifyMediaRef (T.unpack url <> urlEncode (T.unpack m))
let mathclass = if t == DisplayMath then "display" else "inline"
return $ Span ("",["math",mathclass],[])
[Image nullAttr [x] ("../" <> newsrc, "")]
@@ -1143,40 +1147,26 @@ transformInline _opts (RawInline fmt raw)
return $ RawInline fmt (renderTags' tags')
transformInline _ x = return x
(!) :: (t -> Element) -> [(String, String)] -> t -> Element
(!) :: (t -> Element) -> [(Text, Text)] -> t -> Element
(!) f attrs n = add_attrs (map (\(k,v) -> Attr (unqual k) v) attrs) (f n)
-- | Version of 'ppTopElement' that specifies UTF-8 encoding.
ppTopElement :: Element -> String
ppTopElement = ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++) . unEntity . ppElement
-- unEntity removes numeric entities introduced by ppElement
-- (kindlegen seems to choke on these).
where unEntity [] = ""
unEntity ('&':'#':xs) =
let (ds,ys) = break (==';') xs
rest = drop 1 ys
in case safeRead (TS.pack $ "'\\" <> ds <> "'") of
Just x -> x : unEntity rest
Nothing -> '&':'#':unEntity xs
unEntity (x:xs) = x : unEntity xs
mediaTypeOf :: FilePath -> Maybe MimeType
mediaTypeOf x =
let mediaPrefixes = ["image", "video", "audio"] in
case getMimeType x of
Just y | any (`TS.isPrefixOf` y) mediaPrefixes -> Just y
Just y | any (`T.isPrefixOf` y) mediaPrefixes -> Just y
_ -> Nothing
-- Returns filename for chapter number.
showChapter :: Int -> String
showChapter = printf "ch%03d.xhtml"
showChapter :: Int -> Text
showChapter = T.pack . printf "ch%03d.xhtml"
-- Add identifiers to any headers without them.
addIdentifiers :: WriterOptions -> [Block] -> [Block]
addIdentifiers opts bs = evalState (mapM go bs) Set.empty
where go (Header n (ident,classes,kvs) ils) = do
ids <- get
let ident' = if TS.null ident
let ident' = if T.null ident
then uniqueIdent (writerExtensions opts) ils ids
else ident
modify $ Set.insert ident'
@@ -1184,27 +1174,27 @@ addIdentifiers opts bs = evalState (mapM go bs) Set.empty
go x = return x
-- Variant of normalizeDate that allows partial dates: YYYY, YYYY-MM
normalizeDate' :: String -> Maybe String
normalizeDate' = fmap TS.unpack . go . trim . TS.pack
normalizeDate' :: Text -> Maybe Text
normalizeDate' = go . T.strip
where
go xs
| TS.length xs == 4 -- YYY
, TS.all isDigit xs = Just xs
| (y, s) <- TS.splitAt 4 xs -- YYY-MM
, Just ('-', m) <- TS.uncons s
, TS.length m == 2
, TS.all isDigit y && TS.all isDigit m = Just xs
| T.length xs == 4 -- YYY
, T.all isDigit xs = Just xs
| (y, s) <- T.splitAt 4 xs -- YYY-MM
, Just ('-', m) <- T.uncons s
, T.length m == 2
, T.all isDigit y && T.all isDigit m = Just xs
| otherwise = normalizeDate xs
toRelator :: String -> Maybe String
toRelator :: Text -> Maybe Text
toRelator x
| x `elem` relators = Just x
| otherwise = lookup (map toLower x) relatorMap
| otherwise = lookup (T.toLower x) relatorMap
relators :: [String]
relators :: [Text]
relators = map snd relatorMap
relatorMap :: [(String, String)]
relatorMap :: [(Text, Text)]
relatorMap =
[("abridger", "abr")
,("actor", "act")
src/Text/Pandoc/Writers/FB2.hs
+53 -74
View File
@@ -25,15 +25,12 @@ import Data.ByteString.Base64 (encode)
import Data.Char (isAscii, isControl, isSpace)
import Data.Either (lefts, rights)
import Data.List (intercalate)
import Data.Text (Text, pack)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as TE
import Network.HTTP (urlEncode)
import Text.XML.Light
import qualified Text.XML.Light as X
import qualified Text.XML.Light.Cursor as XC
import Text.Pandoc.XMLParser (parseXMLContents)
import Text.Pandoc.XML.Light as X
import Text.Pandoc.Class.PandocMonad (PandocMonad, report)
import qualified Text.Pandoc.Class.PandocMonad as P
@@ -44,6 +41,7 @@ import Text.Pandoc.Options (HTMLMathMethod (..), WriterOptions (..), def)
import Text.Pandoc.Shared (capitalize, isURI, orderedListMarkers,
makeSections, tshow, stringify)
import Text.Pandoc.Writers.Shared (lookupMetaString, toLegacyTable)
import Data.Generics (everywhere, mkT)
-- | Data to be written at the end of the document:
-- (foot)notes, URLs, references, images.
@@ -88,7 +86,7 @@ pandocToFB2 opts (Pandoc meta blocks) = do
(imgs,missing) <- get >>= (lift . fetchImages . imagesToFetch)
let body' = replaceImagesWithAlt missing body
let fb2_xml = el "FictionBook" (fb2_attrs, [desc, body'] ++ notes ++ imgs)
return $ pack $ xml_head ++ showContent fb2_xml ++ "\n"
return $ xml_head <> showContent fb2_xml <> "\n"
where
xml_head = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
fb2_attrs =
@@ -100,8 +98,8 @@ pandocToFB2 opts (Pandoc meta blocks) = do
description :: PandocMonad m => Meta -> FBM m Content
description meta' = do
let genre = case lookupMetaString "genre" meta' of
"" -> el "genre" ("unrecognised" :: String)
s -> el "genre" (T.unpack s)
"" -> el "genre" ("unrecognised" :: Text)
s -> el "genre" s
bt <- booktitle meta'
let as = authors meta'
dd <- docdate meta'
@@ -112,7 +110,7 @@ description meta' = do
Just (MetaInlines [Str s]) -> [el "lang" $ iso639 s]
Just (MetaString s) -> [el "lang" $ iso639 s]
_ -> []
where iso639 = T.unpack . T.takeWhile (/= '-') -- Convert BCP 47 to ISO 639
where iso639 = T.takeWhile (/= '-') -- Convert BCP 47 to ISO 639
let coverimage url = do
let img = Image nullAttr mempty (url, "")
im <- insertImage InlineImage img
@@ -124,7 +122,7 @@ description meta' = do
return $ el "description"
[ el "title-info" (genre :
(as ++ bt ++ annotation ++ dd ++ coverpage ++ lang))
, el "document-info" [el "program-used" ("pandoc" :: String)]
, el "document-info" [el "program-used" ("pandoc" :: Text)]
]
booktitle :: PandocMonad m => Meta -> FBM m [Content]
@@ -137,15 +135,15 @@ authors meta' = cMap author (docAuthors meta')
author :: [Inline] -> [Content]
author ss =
let ws = words . cMap plain $ ss
email = el "email" <$> take 1 (filter ('@' `elem`) ws)
ws' = filter ('@' `notElem`) ws
let ws = T.words $ mconcat $ map plain ss
email = el "email" <$> take 1 (filter (T.any (=='@')) ws)
ws' = filter (not . T.any (== '@')) ws
names = case ws' of
[nickname] -> [ el "nickname" nickname ]
[fname, lname] -> [ el "first-name" fname
, el "last-name" lname ]
(fname:rest) -> [ el "first-name" fname
, el "middle-name" (concat . init $ rest)
, el "middle-name" (T.concat . init $ rest)
, el "last-name" (last rest) ]
[] -> []
in list $ el "author" (names ++ email)
@@ -206,7 +204,7 @@ renderFootnotes = do
el "body" ([uattr "name" "notes"], map renderFN (reverse fns))
where
renderFN (n, idstr, cs) =
let fn_texts = el "title" (el "p" (show n)) : cs
let fn_texts = el "title" (el "p" (tshow n)) : cs
in el "section" ([uattr "id" idstr], fn_texts)
-- | Fetch images and encode them for the FictionBook XML.
@@ -282,7 +280,7 @@ isMimeType s =
where
types = ["text","image","audio","video","application","message","multipart"]
valid c = isAscii c && not (isControl c) && not (isSpace c) &&
c `notElem` ("()<>@,;:\\\"/[]?=" :: String)
c `notElem` ("()<>@,;:\\\"/[]?=" :: [Char])
footnoteID :: Int -> Text
footnoteID i = "n" <> tshow i
@@ -306,7 +304,7 @@ blockToXml (Para [Image atr alt (src,tgt)])
= insertImage NormalImage (Image atr alt (src,tit))
blockToXml (Para ss) = list . el "p" <$> cMapM toXml ss
blockToXml (CodeBlock _ s) = return . spaceBeforeAfter .
map (el "p" . el "code" . T.unpack) . T.lines $ s
map (el "p" . el "code") . T.lines $ s
blockToXml (RawBlock f str) =
if f == Format "fb2"
then
@@ -346,11 +344,11 @@ blockToXml (Table _ blkCapt specs thead tbody tfoot) = do
c <- el "emphasis" <$> cMapM toXml caption
return [el "table" (hd <> bd), el "p" c]
where
mkrow :: PandocMonad m => String -> [[Block]] -> [Alignment] -> FBM m Content
mkrow :: PandocMonad m => Text -> [[Block]] -> [Alignment] -> FBM m Content
mkrow tag cells aligns' =
el "tr" <$> mapM (mkcell tag) (zip cells aligns')
--
mkcell :: PandocMonad m => String -> ([Block], Alignment) -> FBM m Content
mkcell :: PandocMonad m => Text -> ([Block], Alignment) -> FBM m Content
mkcell tag (cell, align) = do
cblocks <- cMapM blockToXml cell
return $ el tag ([align_attr align], cblocks)
@@ -424,7 +422,7 @@ toXml (Quoted DoubleQuote ss) = do
inner <- cMapM toXml ss
return $ [txt "“"] ++ inner ++ [txt "”"]
toXml (Cite _ ss) = cMapM toXml ss -- FIXME: support citation styles
toXml (Code _ s) = return [el "code" $ T.unpack s]
toXml (Code _ s) = return [el "code" s]
toXml Space = return [txt " "]
toXml SoftBreak = return [txt "\n"]
toXml LineBreak = return [txt "\n"]
@@ -456,7 +454,7 @@ insertMath immode formula = do
let imgurl = url <> T.pack (urlEncode $ T.unpack formula)
let img = Image nullAttr alt (imgurl, "")
insertImage immode img
_ -> return [el "code" $ T.unpack formula]
_ -> return [el "code" formula]
insertImage :: PandocMonad m => ImageMode -> Inline -> FBM m [Content]
insertImage immode (Image _ alt (url,ttl)) = do
@@ -471,31 +469,16 @@ insertImage immode (Image _ alt (url,ttl)) = do
el "image" $
[ attr ("l","href") ("#" <> fname)
, attr ("l","type") (tshow immode)
, uattr "alt" (T.pack $ cMap plain alt) ]
, uattr "alt" (mconcat $ map plain alt) ]
++ ttlattr
insertImage _ _ = error "unexpected inline instead of image"
replaceImagesWithAlt :: [Text] -> Content -> Content
replaceImagesWithAlt missingHrefs body =
let cur = XC.fromContent body
cur' = replaceAll cur
in XC.toTree . XC.root $ cur'
replaceImagesWithAlt missingHrefs = everywhere (mkT go)
where
--
replaceAll :: XC.Cursor -> XC.Cursor
replaceAll c =
let n = XC.current c
c' = if isImage n && isMissing n
then XC.modifyContent replaceNode c
else c
in case XC.nextDF c' of
(Just cnext) -> replaceAll cnext
Nothing -> c' -- end of document
--
isImage :: Content -> Bool
isImage (Elem e) = elName e == uname "image"
isImage _ = False
--
go c = if isMissing c
then replaceNode c
else c
isMissing (Elem img@Element{}) =
let imgAttrs = elAttribs img
badAttrs = map (attr ("l","href")) missingHrefs
@@ -505,18 +488,18 @@ replaceImagesWithAlt missingHrefs body =
replaceNode :: Content -> Content
replaceNode n@(Elem img@Element{}) =
let attrs = elAttribs img
alt = getAttrVal attrs (uname "alt")
alt = getAttrVal attrs (unqual "alt")
imtype = getAttrVal attrs (qname "l" "type")
in case (alt, imtype) of
(Just alt', Just imtype') ->
if imtype' == show NormalImage
if imtype' == tshow NormalImage
then el "p" alt'
else txt $ T.pack alt'
(Just alt', Nothing) -> txt $ T.pack alt' -- no type attribute
else txt alt'
(Just alt', Nothing) -> txt alt' -- no type attribute
_ -> n -- don't replace if alt text is not found
replaceNode n = n
--
getAttrVal :: [X.Attr] -> QName -> Maybe String
getAttrVal :: [X.Attr] -> QName -> Maybe Text
getAttrVal attrs name =
case filter ((name ==) . attrKey) attrs of
(a:_) -> Just (attrVal a)
@@ -524,7 +507,7 @@ replaceImagesWithAlt missingHrefs body =
-- | Wrap all inlines with an XML tag (given its unqualified name).
wrap :: PandocMonad m => String -> [Inline] -> FBM m Content
wrap :: PandocMonad m => Text -> [Inline] -> FBM m Content
wrap tagname inlines = el tagname `liftM` cMapM toXml inlines
-- " Create a singleton list.
@@ -532,31 +515,31 @@ list :: a -> [a]
list = (:[])
-- | Convert an 'Inline' to plaintext.
plain :: Inline -> String
plain (Str s) = T.unpack s
plain (Emph ss) = cMap plain ss
plain (Underline ss) = cMap plain ss
plain (Span _ ss) = cMap plain ss
plain (Strong ss) = cMap plain ss
plain (Strikeout ss) = cMap plain ss
plain (Superscript ss) = cMap plain ss
plain (Subscript ss) = cMap plain ss
plain (SmallCaps ss) = cMap plain ss
plain (Quoted _ ss) = cMap plain ss
plain (Cite _ ss) = cMap plain ss -- FIXME
plain (Code _ s) = T.unpack s
plain :: Inline -> Text
plain (Str s) = s
plain (Emph ss) = mconcat $ map plain ss
plain (Underline ss) = mconcat $ map plain ss
plain (Span _ ss) = mconcat $ map plain ss
plain (Strong ss) = mconcat $ map plain ss
plain (Strikeout ss) = mconcat $ map plain ss
plain (Superscript ss) = mconcat $ map plain ss
plain (Subscript ss) = mconcat $ map plain ss
plain (SmallCaps ss) = mconcat $ map plain ss
plain (Quoted _ ss) = mconcat $ map plain ss
plain (Cite _ ss) = mconcat $ map plain ss -- FIXME
plain (Code _ s) = s
plain Space = " "
plain SoftBreak = " "
plain LineBreak = "\n"
plain (Math _ s) = T.unpack s
plain (Math _ s) = s
plain (RawInline _ _) = ""
plain (Link _ text (url,_)) = concat (map plain text ++ [" <", T.unpack url, ">"])
plain (Image _ alt _) = cMap plain alt
plain (Link _ text (url,_)) = mconcat (map plain text ++ [" <", url, ">"])
plain (Image _ alt _) = mconcat $ map plain alt
plain (Note _) = "" -- FIXME
-- | Create an XML element.
el :: (Node t)
=> String -- ^ unqualified element name
=> Text -- ^ unqualified element name
-> t -- ^ node contents
-> Content -- ^ XML content
el name cs = Elem $ unode name cs
@@ -569,22 +552,18 @@ spaceBeforeAfter cs =
-- | Create a plain-text XML content.
txt :: Text -> Content
txt s = Text $ CData CDataText (T.unpack s) Nothing
txt s = Text $ CData CDataText s Nothing
-- | Create an XML attribute with an unqualified name.
uattr :: String -> Text -> Text.XML.Light.Attr
uattr name = Attr (uname name) . T.unpack
uattr :: Text -> Text -> X.Attr
uattr name = Attr (unqual name)
-- | Create an XML attribute with a qualified name from given namespace.
attr :: (String, String) -> Text -> Text.XML.Light.Attr
attr (ns, name) = Attr (qname ns name) . T.unpack
-- | Unqualified name
uname :: String -> QName
uname name = QName name Nothing Nothing
attr :: (Text, Text) -> Text -> X.Attr
attr (ns, name) = Attr (qname ns name)
-- | Qualified name
qname :: String -> String -> QName
qname :: Text -> Text -> QName
qname ns name = QName name Nothing (Just ns)
-- | Abbreviation for 'concatMap'.
src/Text/Pandoc/Writers/ODT.hs
+9 -7
View File
@@ -40,9 +40,9 @@ import Text.Pandoc.UTF8 (fromStringLazy, fromTextLazy, toTextLazy)
import Text.Pandoc.Walk
import Text.Pandoc.Writers.OpenDocument (writeOpenDocument)
import Text.Pandoc.XML
import Text.Pandoc.XMLParser (parseXMLElement)
import Text.Pandoc.XML.Light
import Text.TeXMath
import Text.XML.Light
import qualified Text.XML.Light as XL
newtype ODTState = ODTState { stEntries :: [Entry]
}
@@ -181,18 +181,20 @@ updateStyleWithLang (Just lang) arch = do
PandocXMLError "styles.xml" msg
Right d -> return $
toEntry "styles.xml" epochtime
( fromStringLazy
( fromTextLazy
. TL.fromStrict
. ppTopElement
. addLang lang $ d )
else return e) (zEntries arch)
return arch{ zEntries = entries }
-- TODO FIXME avoid this generic traversal!
addLang :: Lang -> Element -> Element
addLang lang = everywhere' (mkT updateLangAttr)
where updateLangAttr (Attr n@(QName "language" _ (Just "fo")) _)
= Attr n (T.unpack $ langLanguage lang)
= Attr n (langLanguage lang)
updateLangAttr (Attr n@(QName "country" _ (Just "fo")) _)
= Attr n (T.unpack $ langRegion lang)
= Attr n (langRegion lang)
updateLangAttr x = x
-- | transform both Image and Math elements
@@ -238,8 +240,8 @@ transformPicMath _ (Math t math) = do
case writeMathML dt <$> readTeX math of
Left _ -> return $ Math t math
Right r -> do
let conf = useShortEmptyTags (const False) defaultConfigPP
let mathml = ppcTopElement conf r
let conf = XL.useShortEmptyTags (const False) XL.defaultConfigPP
let mathml = XL.ppcTopElement conf r
epochtime <- floor `fmap` lift P.getPOSIXTime
let dirname = "Formula-" ++ show (length entries) ++ "/"
let fname = dirname ++ "content.xml"
src/Text/Pandoc/Writers/OOXML.hs
+17 -18
View File
@@ -29,33 +29,32 @@ import Control.Monad.Except (throwError)
import Text.Pandoc.Error
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8
import Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Data.Text (Text)
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import qualified Text.Pandoc.UTF8 as UTF8
import Text.XML.Light as XML
import Text.Pandoc.XMLParser (parseXMLElement)
import Text.Pandoc.XML.Light
mknode :: Node t => String -> [(String,String)] -> t -> Element
mknode :: Node t => Text -> [(Text,Text)] -> t -> Element
mknode s attrs =
add_attrs (map (\(k,v) -> Attr (nodename k) v) attrs) . node (nodename s)
mktnode :: String -> [(String,String)] -> T.Text -> Element
mktnode s attrs = mknode s attrs . T.unpack
mktnode :: Text -> [(Text,Text)] -> T.Text -> Element
mktnode s attrs = mknode s attrs
nodename :: String -> QName
nodename :: Text -> 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)
where (name, prefix) = case T.break (==':') s of
(xs,ys) -> case T.uncons ys of
Nothing -> (xs, Nothing)
Just (_,zs) -> (zs, Just xs)
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)
renderXml elt = BL.fromStrict (UTF8.fromText (showTopElement elt))
parseXml :: PandocMonad m => Archive -> Archive -> String -> m Element
parseXml refArchive distArchive relpath =
@@ -70,25 +69,25 @@ parseXml refArchive distArchive relpath =
-- Copied from Util
attrToNSPair :: XML.Attr -> Maybe (String, String)
attrToNSPair (XML.Attr (QName s _ (Just "xmlns")) val) = Just (s, val)
attrToNSPair :: Attr -> Maybe (Text, Text)
attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val)
attrToNSPair _ = Nothing
elemToNameSpaces :: Element -> NameSpaces
elemToNameSpaces = mapMaybe attrToNSPair . elAttribs
elemName :: NameSpaces -> String -> String -> QName
elemName :: NameSpaces -> Text -> Text -> QName
elemName ns prefix name =
QName name (lookup prefix ns) (if null prefix then Nothing else Just prefix)
QName name (lookup prefix ns) (if T.null prefix then Nothing else Just prefix)
isElem :: NameSpaces -> String -> String -> Element -> Bool
isElem :: NameSpaces -> Text -> Text -> Element -> Bool
isElem ns prefix name element =
let ns' = ns ++ elemToNameSpaces element
in qName (elName element) == name &&
qURI (elName element) == lookup prefix ns'
type NameSpaces = [(String, String)]
type NameSpaces = [(Text, Text)]
-- | Scales the image to fit the page
-- sizes are passed in emu
src/Text/Pandoc/Writers/Powerpoint/Output.hs
+103 -98
View File
@@ -20,16 +20,16 @@ import Control.Monad.Except (throwError, catchError)
import Control.Monad.Reader
import Control.Monad.State
import Codec.Archive.Zip
import Data.Char (toUpper)
import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf, intersperse)
import Data.Default
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read
import Data.Time (formatTime, defaultTimeLocale)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension)
import Text.XML.Light
import Text.Pandoc.XMLParser (parseXMLElement)
import Text.Pandoc.XML.Light as XML
import Text.Pandoc.Definition
import qualified Text.Pandoc.UTF8 as UTF8
import Text.Pandoc.Class.PandocMonad (PandocMonad)
@@ -48,6 +48,7 @@ import Text.DocTemplates (FromContext(lookupContext))
import Text.TeXMath
import Text.Pandoc.Writers.Math (convertMath)
import Text.Pandoc.Writers.Powerpoint.Presentation
import Text.Pandoc.Shared (tshow)
import Skylighting (fromColor)
-- |The 'EMU' type is used to specify sizes in English Metric Units.
@@ -84,10 +85,13 @@ getPresentationSize refArchive distArchive = do
sldSize <- findChild (elemName ns "p" "sldSz") presElement
cxS <- findAttr (QName "cx" Nothing Nothing) sldSize
cyS <- findAttr (QName "cy" Nothing Nothing) sldSize
(cx, _) <- listToMaybe $ reads cxS :: Maybe (Integer, String)
(cy, _) <- listToMaybe $ reads cyS :: Maybe (Integer, String)
cx <- readTextAsInteger cxS
cy <- readTextAsInteger cyS
return (cx `div` 12700, cy `div` 12700)
readTextAsInteger :: Text -> Maybe Integer
readTextAsInteger = either (const Nothing) (Just . fst) . Data.Text.Read.decimal
data WriterEnv = WriterEnv { envRefArchive :: Archive
, envDistArchive :: Archive
, envUTCTime :: UTCTime
@@ -161,9 +165,6 @@ runP env st p = evalStateT (runReaderT p env) st
--------------------------------------------------------------------
findAttrText :: QName -> Element -> Maybe T.Text
findAttrText n = fmap T.pack . findAttr n
monospaceFont :: Monad m => P m T.Text
monospaceFont = do
vars <- writerVariables <$> asks envOpts
@@ -171,10 +172,9 @@ monospaceFont = do
Just s -> return s
Nothing -> return "Courier"
-- Kept as string for XML.Light
fontSizeAttributes :: Monad m => RunProps -> P m [(String, String)]
fontSizeAttributes :: Monad m => RunProps -> P m [(Text, Text)]
fontSizeAttributes RunProps { rPropForceSize = Just sz } =
return [("sz", show $ sz * 100)]
return [("sz", tshow $ sz * 100)]
fontSizeAttributes _ = return []
copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive
@@ -365,7 +365,7 @@ shapeHasId :: NameSpaces -> T.Text -> Element -> Bool
shapeHasId ns ident element
| Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element
, Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr
, Just nm <- findAttrText (QName "id" Nothing Nothing) cNvPr =
, Just nm <- findAttr (QName "id" Nothing Nothing) cNvPr =
nm == ident
| otherwise = False
@@ -396,10 +396,10 @@ getShapeDimensions ns element
ext <- findChild (elemName ns "a" "ext") xfrm
cxS <- findAttr (QName "cx" Nothing Nothing) ext
cyS <- findAttr (QName "cy" Nothing Nothing) ext
(x, _) <- listToMaybe $ reads xS
(y, _) <- listToMaybe $ reads yS
(cx, _) <- listToMaybe $ reads cxS
(cy, _) <- listToMaybe $ reads cyS
x <- readTextAsInteger xS
y <- readTextAsInteger yS
cx <- readTextAsInteger cxS
cy <- readTextAsInteger cyS
return ((x `div` 12700, y `div` 12700),
(cx `div` 12700, cy `div` 12700))
| otherwise = Nothing
@@ -430,7 +430,7 @@ getContentShapeSize ns layout master
Nothing -> do let mbSz =
findChild (elemName ns "p" "nvSpPr") sp >>=
findChild (elemName ns "p" "cNvPr") >>=
findAttrText (QName "id" Nothing Nothing) >>=
findAttr (QName "id" Nothing Nothing) >>=
flip getMasterShapeDimensionsById master
case mbSz of
Just sz' -> return sz'
@@ -450,8 +450,8 @@ buildSpTree ns spTreeElem newShapes =
fn _ = True
replaceNamedChildren :: NameSpaces
-> String
-> String
-> Text
-> Text
-> [Element]
-> Element
-> Element
@@ -654,10 +654,10 @@ createCaption contentShapeDimensions paraElements = do
]
, mknode "p:spPr" []
[ mknode "a:xfrm" []
[ mknode "a:off" [("x", show $ 12700 * x),
("y", show $ 12700 * (y + cy - captionHeight))] ()
, mknode "a:ext" [("cx", show $ 12700 * cx),
("cy", show $ 12700 * captionHeight)] ()
[ mknode "a:off" [("x", tshow $ 12700 * x),
("y", tshow $ 12700 * (y + cy - captionHeight))] ()
, mknode "a:ext" [("cx", tshow $ 12700 * cx),
("cy", tshow $ 12700 * captionHeight)] ()
]
, mknode "a:prstGeom" [("prst", "rect")]
[ mknode "a:avLst" [] ()
@@ -706,11 +706,13 @@ makePicElements layout picProps mInfo alt = do
,("noChangeAspect","1")] ()
-- cNvPr will contain the link information so we do that separately,
-- and register the link if necessary.
let cNvPrAttr = [("descr", mInfoFilePath mInfo), ("id","0"),("name","Picture 1")]
let cNvPrAttr = [("descr", T.pack $ mInfoFilePath mInfo),
("id","0"),
("name","Picture 1")]
cNvPr <- case picPropLink picProps of
Just link -> do idNum <- registerLink link
return $ mknode "p:cNvPr" cNvPrAttr $
mknode "a:hlinkClick" [("r:id", "rId" <> show idNum)] ()
mknode "a:hlinkClick" [("r:id", "rId" <> tshow idNum)] ()
Nothing -> return $ mknode "p:cNvPr" cNvPrAttr ()
let nvPicPr = mknode "p:nvPicPr" []
[ cNvPr
@@ -718,13 +720,13 @@ makePicElements layout picProps mInfo alt = do
, mknode "p:nvPr" [] ()]
let blipFill = mknode "p:blipFill" []
[ mknode "a:blip" [("r:embed", "rId" <>
show (mInfoLocalId mInfo))] ()
tshow (mInfoLocalId mInfo))] ()
, mknode "a:stretch" [] $
mknode "a:fillRect" [] () ]
let xfrm = mknode "a:xfrm" []
[ mknode "a:off" [("x",show xoff'), ("y",show yoff')] ()
, mknode "a:ext" [("cx",show dimX')
,("cy",show dimY')] () ]
[ mknode "a:off" [("x", tshow xoff'), ("y", tshow yoff')] ()
, mknode "a:ext" [("cx", tshow dimX')
,("cy", tshow dimY')] () ]
let prstGeom = mknode "a:prstGeom" [("prst","rect")] $
mknode "a:avLst" [] ()
let ln = mknode "a:ln" [("w","9525")]
@@ -763,7 +765,7 @@ paraElemToElements (Run rpr s) = do
Just DoubleStrike -> [("strike", "dblStrike")]
Nothing -> []) <>
(case rBaseline rpr of
Just n -> [("baseline", show n)]
Just n -> [("baseline", tshow n)]
Nothing -> []) <>
(case rCap rpr of
Just NoCapitals -> [("cap", "none")]
@@ -780,43 +782,44 @@ paraElemToElements (Run rpr s) = do
return $ case link of
InternalTarget _ ->
let linkAttrs =
[ ("r:id", "rId" <> show idNum)
[ ("r:id", "rId" <> tshow idNum)
, ("action", "ppaction://hlinksldjump")
]
in [mknode "a:hlinkClick" linkAttrs ()]
-- external
ExternalTarget _ ->
let linkAttrs =
[ ("r:id", "rId" <> show idNum)
[ ("r:id", "rId" <> tshow idNum)
]
in [mknode "a:hlinkClick" linkAttrs ()]
Nothing -> return []
let colorContents = case rSolidFill rpr of
Just color ->
case fromColor color of
'#':hx -> [mknode "a:solidFill" []
[mknode "a:srgbClr" [("val", map toUpper hx)] ()]
]
'#':hx ->
[mknode "a:solidFill" []
[mknode "a:srgbClr"
[("val", T.toUpper $ T.pack hx)] ()]]
_ -> []
Nothing -> []
codeFont <- monospaceFont
let codeContents =
[mknode "a:latin" [("typeface", T.unpack codeFont)] () | rPropCode rpr]
[mknode "a:latin" [("typeface", codeFont)] () | rPropCode rpr]
let propContents = linkProps <> colorContents <> codeContents
return [Elem $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents
, mknode "a:t" [] $ T.unpack s
, mknode "a:t" [] s
]]
paraElemToElements (MathElem mathType texStr) = do
isInSpkrNotes <- asks envInSpeakerNotes
if isInSpkrNotes
then paraElemToElements $ Run def $ unTeXString texStr
else do res <- convertMath writeOMML mathType (unTeXString texStr)
case res of
case fromXLElement <$> res of
Right r -> return [Elem $ mknode "a14:m" [] $ addMathInfo r]
Left (Str s) -> paraElemToElements (Run def s)
Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback"
paraElemToElements (RawOOXMLParaElem str) = return
[Text (CData CDataRaw (T.unpack str) Nothing)]
[Text (CData CDataRaw str Nothing)]
-- This is a bit of a kludge -- really requires adding an option to
@@ -824,9 +827,10 @@ paraElemToElements (RawOOXMLParaElem str) = return
-- step at a time.
addMathInfo :: Element -> Element
addMathInfo element =
let mathspace = Attr { attrKey = QName "m" Nothing (Just "xmlns")
, attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math"
}
let mathspace =
Attr { attrKey = QName "m" Nothing (Just "xmlns")
, attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math"
}
in add_attr mathspace element
-- We look through the element to see if it contains an a14:m
@@ -849,13 +853,13 @@ surroundWithMathAlternate element =
paragraphToElement :: PandocMonad m => Paragraph -> P m Element
paragraphToElement par = do
let
attrs = [("lvl", show $ pPropLevel $ paraProps par)] <>
attrs = [("lvl", tshow $ pPropLevel $ paraProps par)] <>
(case pPropMarginLeft (paraProps par) of
Just px -> [("marL", show $ pixelsToEmu px)]
Just px -> [("marL", tshow $ pixelsToEmu px)]
Nothing -> []
) <>
(case pPropIndent (paraProps par) of
Just px -> [("indent", show $ pixelsToEmu px)]
Just px -> [("indent", tshow $ pixelsToEmu px)]
Nothing -> []
) <>
(case pPropAlign (paraProps par) of
@@ -867,7 +871,7 @@ paragraphToElement par = do
props = [] <>
(case pPropSpaceBefore $ paraProps par of
Just px -> [mknode "a:spcBef" [] [
mknode "a:spcPts" [("val", show $ 100 * px)] ()
mknode "a:spcPts" [("val", tshow $ 100 * px)] ()
]
]
Nothing -> []
@@ -910,7 +914,7 @@ shapeToElements layout (Pic picProps fp alt) = do
shapeToElements layout (GraphicFrame tbls cptn) = map Elem <$>
graphicFrameToElements layout tbls cptn
shapeToElements _ (RawOOXMLShape str) = return
[Text (CData CDataRaw (T.unpack str) Nothing)]
[Text (CData CDataRaw str Nothing)]
shapeToElements layout shp = do
element <- shapeToElement layout shp
return [Elem element]
@@ -942,8 +946,10 @@ graphicFrameToElements layout tbls caption = do
[mknode "p:ph" [("idx", "1")] ()]
]
, mknode "p:xfrm" []
[ mknode "a:off" [("x", show $ 12700 * x), ("y", show $ 12700 * y)] ()
, mknode "a:ext" [("cx", show $ 12700 * cx), ("cy", show $ 12700 * cy)] ()
[ mknode "a:off" [("x", tshow $ 12700 * x),
("y", tshow $ 12700 * y)] ()
, mknode "a:ext" [("cx", tshow $ 12700 * cx),
("cy", tshow $ 12700 * cy)] ()
]
] <> elements
@@ -957,7 +963,7 @@ getDefaultTableStyle = do
refArchive <- asks envRefArchive
distArchive <- asks envDistArchive
tblStyleLst <- parseXml refArchive distArchive "ppt/tableStyles.xml"
return $ findAttrText (QName "def" Nothing Nothing) tblStyleLst
return $ findAttr (QName "def" Nothing Nothing) tblStyleLst
graphicToElement :: PandocMonad m => Integer -> Graphic -> P m Element
graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do
@@ -995,7 +1001,7 @@ graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do
let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells
let mkgridcol w = mknode "a:gridCol"
[("w", show ((12700 * w) :: Integer))] ()
[("w", tshow ((12700 * w) :: Integer))] ()
let hasHeader = not (all null hdrCells)
mbDefTblStyle <- getDefaultTableStyle
@@ -1004,7 +1010,7 @@ graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do
, ("bandRow", if tblPrBandRow tblPr then "1" else "0")
] (case mbDefTblStyle of
Nothing -> []
Just sty -> [mknode "a:tableStyleId" [] $ T.unpack sty])
Just sty -> [mknode "a:tableStyleId" [] sty])
return $ mknode "a:graphic" []
[mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")]
@@ -1037,7 +1043,7 @@ findPHType ns spElem phType
-- if it's a named PHType, we want to check that the attribute
-- value matches.
Just phElem | (PHType tp) <- phType ->
case findAttrText (QName "type" Nothing Nothing) phElem of
case findAttr (QName "type" Nothing Nothing) phElem of
Just tp' -> tp == tp'
Nothing -> False
-- if it's an ObjType, we want to check that there is NO
@@ -1204,7 +1210,7 @@ getSlideNumberFieldId notesMaster
, Just txBody <- findChild (elemName ns "p" "txBody") sp
, Just p <- findChild (elemName ns "a" "p") txBody
, Just fld <- findChild (elemName ns "a" "fld") p
, Just fldId <- findAttrText (QName "id" Nothing Nothing) fld =
, Just fldId <- findAttr (QName "id" Nothing Nothing) fld =
return fldId
| otherwise = throwError $
PandocSomeError
@@ -1283,11 +1289,11 @@ speakerNotesSlideNumber pgNum fieldId =
[ mknode "a:bodyPr" [] ()
, mknode "a:lstStyle" [] ()
, mknode "a:p" []
[ mknode "a:fld" [ ("id", T.unpack fieldId)
[ mknode "a:fld" [ ("id", fieldId)
, ("type", "slidenum")
]
[ mknode "a:rPr" [("lang", "en-US")] ()
, mknode "a:t" [] (show pgNum)
, mknode "a:t" [] (tshow pgNum)
]
, mknode "a:endParaRPr" [("lang", "en-US")] ()
]
@@ -1339,7 +1345,7 @@ getSlideIdNum sldId = do
Just n -> return n
Nothing -> throwError $
PandocShouldNeverHappenError $
"Slide Id " <> T.pack (show sldId) <> " not found."
"Slide Id " <> tshow sldId <> " not found."
slideNum :: PandocMonad m => Slide -> P m Int
slideNum slide = getSlideIdNum $ slideId slide
@@ -1356,7 +1362,7 @@ slideToRelId :: PandocMonad m => Slide -> P m T.Text
slideToRelId slide = do
n <- slideNum slide
offset <- asks envSlideIdOffset
return $ "rId" <> T.pack (show $ n + offset)
return $ "rId" <> tshow (n + offset)
data Relationship = Relationship { relId :: Int
@@ -1368,13 +1374,11 @@ elementToRel :: Element -> Maybe Relationship
elementToRel element
| elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing =
do rId <- findAttr (QName "Id" Nothing Nothing) element
numStr <- stripPrefix "rId" rId
num <- case reads numStr :: [(Int, String)] of
(n, _) : _ -> Just n
[] -> Nothing
type' <- findAttrText (QName "Type" Nothing Nothing) element
numStr <- T.stripPrefix "rId" rId
num <- fromIntegral <$> readTextAsInteger numStr
type' <- findAttr (QName "Type" Nothing Nothing) element
target <- findAttr (QName "Target" Nothing Nothing) element
return $ Relationship num type' target
return $ Relationship num type' (T.unpack target)
| otherwise = Nothing
slideToPresRel :: PandocMonad m => Slide -> P m Relationship
@@ -1463,10 +1467,9 @@ topLevelRelsEntry :: PandocMonad m => P m Entry
topLevelRelsEntry = elemToEntry "_rels/.rels" $ relsToElement topLevelRels
relToElement :: Relationship -> Element
relToElement rel = mknode "Relationship" [ ("Id", "rId" <>
show (relId rel))
, ("Type", T.unpack $ relType rel)
, ("Target", relTarget rel) ] ()
relToElement rel = mknode "Relationship" [ ("Id", "rId" <> tshow (relId rel))
, ("Type", relType rel)
, ("Target", T.pack $ relTarget rel) ] ()
relsToElement :: [Relationship] -> Element
relsToElement rels = mknode "Relationships"
@@ -1501,7 +1504,8 @@ slideToSpeakerNotesEntry slide = do
Just element | Just notesIdNum <- mbNotesIdNum ->
Just <$>
elemToEntry
("ppt/notesSlides/notesSlide" <> show notesIdNum <> ".xml")
("ppt/notesSlides/notesSlide" <> show notesIdNum <>
".xml")
element
_ -> return Nothing
@@ -1514,7 +1518,7 @@ slideToSpeakerNotesRelElement slide@Slide{} = do
[("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
[ mknode "Relationship" [ ("Id", "rId2")
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
, ("Target", "../slides/slide" <> show idNum <> ".xml")
, ("Target", "../slides/slide" <> tshow idNum <> ".xml")
] ()
, mknode "Relationship" [ ("Id", "rId1")
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster")
@@ -1547,15 +1551,15 @@ linkRelElement :: PandocMonad m => (Int, LinkTarget) -> P m Element
linkRelElement (rIdNum, InternalTarget targetId) = do
targetIdNum <- getSlideIdNum targetId
return $
mknode "Relationship" [ ("Id", "rId" <> show rIdNum)
mknode "Relationship" [ ("Id", "rId" <> tshow rIdNum)
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
, ("Target", "slide" <> show targetIdNum <> ".xml")
, ("Target", "slide" <> tshow targetIdNum <> ".xml")
] ()
linkRelElement (rIdNum, ExternalTarget (url, _)) =
return $
mknode "Relationship" [ ("Id", "rId" <> show rIdNum)
mknode "Relationship" [ ("Id", "rId" <> tshow rIdNum)
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
, ("Target", T.unpack url)
, ("Target", url)
, ("TargetMode", "External")
] ()
@@ -1567,10 +1571,10 @@ mediaRelElement mInfo =
let ext = fromMaybe "" (mInfoExt mInfo)
in
mknode "Relationship" [ ("Id", "rId" <>
show (mInfoLocalId mInfo))
tshow (mInfoLocalId mInfo))
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image")
, ("Target", "../media/image" <>
show (mInfoGlobalId mInfo) <> T.unpack ext)
tshow (mInfoGlobalId mInfo) <> ext)
] ()
speakerNotesSlideRelElement :: PandocMonad m => Slide -> P m (Maybe Element)
@@ -1580,7 +1584,7 @@ speakerNotesSlideRelElement slide = do
return $ case M.lookup idNum mp of
Nothing -> Nothing
Just n ->
let target = "../notesSlides/notesSlide" <> show n <> ".xml"
let target = "../notesSlides/notesSlide" <> tshow n <> ".xml"
in Just $
mknode "Relationship" [ ("Id", "rId2")
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesSlide")
@@ -1619,9 +1623,9 @@ slideToSlideRelElement slide = do
slideToSldIdElement :: PandocMonad m => Slide -> P m Element
slideToSldIdElement slide = do
n <- slideNum slide
let id' = show $ n + 255
let id' = tshow $ n + 255
rId <- slideToRelId slide
return $ mknode "p:sldId" [("id", id'), ("r:id", T.unpack rId)] ()
return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] ()
presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element
presentationToSldIdLst (Presentation _ slides) = do
@@ -1646,7 +1650,7 @@ presentationToPresentationElement pres@(Presentation _ slds) = do
notesMasterElem = mknode "p:notesMasterIdLst" []
[ mknode
"p:NotesMasterId"
[("r:id", "rId" <> show notesMasterRId)]
[("r:id", "rId" <> tshow notesMasterRId)]
()
]
@@ -1702,17 +1706,17 @@ docPropsElement docProps = do
,("xmlns:dcmitype","http://purl.org/dc/dcmitype/")
,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")]
$
mknode "dc:title" [] (maybe "" T.unpack $ dcTitle docProps)
mknode "dc:title" [] (fromMaybe "" $ dcTitle docProps)
:
mknode "dc:creator" [] (maybe "" T.unpack $ dcCreator docProps)
mknode "dc:creator" [] (fromMaybe "" $ dcCreator docProps)
:
mknode "cp:keywords" [] (T.unpack keywords)
: ( [mknode "dc:subject" [] $ maybe "" T.unpack $ dcSubject docProps | isJust (dcSubject docProps)])
<> ( [mknode "dc:description" [] $ maybe "" T.unpack $ dcDescription docProps | isJust (dcDescription docProps)])
<> ( [mknode "cp:category" [] $ maybe "" T.unpack $ cpCategory docProps | isJust (cpCategory docProps)])
mknode "cp:keywords" [] keywords
: ( [mknode "dc:subject" [] $ fromMaybe "" $ dcSubject docProps | isJust (dcSubject docProps)])
<> ( [mknode "dc:description" [] $ fromMaybe "" $ dcDescription docProps | isJust (dcDescription docProps)])
<> ( [mknode "cp:category" [] $ fromMaybe "" $ cpCategory docProps | isJust (cpCategory docProps)])
<> (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x
, mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x
]) (formatTime defaultTimeLocale "%FT%XZ" utctime)
, mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x
]) (T.pack $ formatTime defaultTimeLocale "%FT%XZ" utctime)
docPropsToEntry :: PandocMonad m => DocProps -> P m Entry
docPropsToEntry docProps = docPropsElement docProps >>=
@@ -1723,8 +1727,8 @@ docCustomPropsElement :: PandocMonad m => DocProps -> P m Element
docCustomPropsElement docProps = do
let mkCustomProp (k, v) pid = mknode "property"
[("fmtid","{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
,("pid", show pid)
,("name", T.unpack k)] $ mknode "vt:lpwstr" [] (T.unpack v)
,("pid", tshow pid)
,("name", k)] $ mknode "vt:lpwstr" [] v
return $ mknode "Properties"
[("xmlns","http://schemas.openxmlformats.org/officeDocument/2006/custom-properties")
,("xmlns:vt","http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes")
@@ -1743,7 +1747,7 @@ viewPropsElement = do
distArchive <- asks envDistArchive
viewPrElement <- parseXml refArchive distArchive "ppt/viewProps.xml"
-- remove "lastView" if it exists:
let notLastView :: Text.XML.Light.Attr -> Bool
let notLastView :: XML.Attr -> Bool
notLastView attr =
qName (attrKey attr) /= "lastView"
return $
@@ -1755,15 +1759,15 @@ makeViewPropsEntry = viewPropsElement >>= elemToEntry "ppt/viewProps.xml"
defaultContentTypeToElem :: DefaultContentType -> Element
defaultContentTypeToElem dct =
mknode "Default"
[("Extension", T.unpack $ defContentTypesExt dct),
("ContentType", T.unpack $ defContentTypesType dct)]
[("Extension", defContentTypesExt dct),
("ContentType", defContentTypesType dct)]
()
overrideContentTypeToElem :: OverrideContentType -> Element
overrideContentTypeToElem oct =
mknode "Override"
[("PartName", overrideContentTypesPart oct),
("ContentType", T.unpack $ overrideContentTypesType oct)]
[("PartName", T.pack $ overrideContentTypesPart oct),
("ContentType", overrideContentTypesType oct)]
()
contentTypesToElement :: ContentTypes -> Element
@@ -1821,7 +1825,8 @@ getSpeakerNotesFilePaths :: PandocMonad m => P m [FilePath]
getSpeakerNotesFilePaths = do
mp <- asks envSpeakerNotesIdMap
let notesIdNums = M.elems mp
return $ map (\n -> "ppt/notesSlides/notesSlide" <> show n <> ".xml") notesIdNums
return $ map (\n -> "ppt/notesSlides/notesSlide" <> show n <> ".xml")
notesIdNums
presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes
presentationToContentTypes p@(Presentation _ slides) = do
@@ -1885,11 +1890,11 @@ getContentType fp
| otherwise = Nothing
-- Kept as String for XML.Light
autoNumAttrs :: ListAttributes -> [(String, String)]
autoNumAttrs :: ListAttributes -> [(Text, Text)]
autoNumAttrs (startNum, numStyle, numDelim) =
numAttr <> typeAttr
where
numAttr = [("startAt", show startNum) | startNum /= 1]
numAttr = [("startAt", tshow startNum) | startNum /= 1]
typeAttr = [("type", typeString <> delimString)]
typeString = case numStyle of
Decimal -> "arabic"
src/Text/Pandoc/XML/Light.hs
+586
View File
@@ -0,0 +1,586 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.XML.Light
Copyright : Copyright (C) 2021 John MacFarlane
License : GNU GPL, version 2 or above
Maintainer : John MacFarlane <jgm@berkeley.edu>
Stability : alpha
Portability : portable
xml-light, which we used in pandoc's the XML-based readers, has
some limitations: in particular, it produces nodes with String
instead of Text, and the parser falls over on processing instructions
(see #7091).
This module exports much of the API of xml-light, but using Text instead
of String. In addition, the xml-light parsers are replaced by xml-conduit's
well-tested parser. (The xml-conduit types are mapped to types
isomorphic to xml-light's, to avoid the need for massive code modifications
elsewhere.) Bridge functions to map xml-light types to this module's
types are also provided (since libraries like texmath still use xml-light).
Another advantage of the xml-conduit parser is that it gives us
detailed information on xml parse errors.
In the future we may want to move to using xml-conduit or another
xml library in the code base, but this change gives us
better performance and accuracy without much change in the
code that used xml-light.
-}
module Text.Pandoc.XML.Light
( -- * Basic types, duplicating those from xml-light but with Text
-- instead of String
Line
, Content(..)
, Element(..)
, Attr(..)
, CData(..)
, CDataKind(..)
, QName(..)
, Node(..)
, unode
, unqual
, add_attr
, add_attrs
-- * Conversion functions from xml-light types
, fromXLQName
, fromXLCData
, fromXLElement
, fromXLAttr
, fromXLContent
-- * Replacement for xml-light's Text.XML.Proc
, strContent
, onlyElems
, elChildren
, onlyText
, findChildren
, filterChildren
, filterChildrenName
, findChild
, filterChild
, filterChildName
, findElement
, filterElement
, filterElementName
, findElements
, filterElements
, filterElementsName
, findAttr
, lookupAttr
, lookupAttrBy
, findAttrBy
-- * Replacement for xml-light's Text.XML.Output
, ppTopElement
, ppElement
, ppContent
, ppcElement
, ppcContent
, showTopElement
, showElement
, showContent
, useShortEmptyTags
, defaultConfigPP
, ConfigPP(..)
-- * Replacement for xml-light's Text.XML.Input
, parseXMLElement
, parseXMLContents
) where
import qualified Control.Exception as E
import qualified Text.XML as Conduit
import Text.XML.Unresolved (InvalidEventStream(..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (Builder, singleton, fromText, toLazyText)
import qualified Data.Map as M
import Data.Data (Data)
import Data.Typeable (Typeable)
import Data.Maybe (mapMaybe, listToMaybe)
import Data.List(find)
import qualified Text.XML.Light as XL
-- Drop in replacement for parseXMLDoc in xml-light.
parseXMLElement :: TL.Text -> Either T.Text Element
parseXMLElement t =
elementToElement . Conduit.documentRoot <$>
either (Left . T.pack . E.displayException) Right
(Conduit.parseText Conduit.def{ Conduit.psRetainNamespaces = True } t)
parseXMLContents :: TL.Text -> Either T.Text [Content]
parseXMLContents t =
case Conduit.parseText Conduit.def{ Conduit.psRetainNamespaces = True } t of
Left e ->
case E.fromException e of
Just (ContentAfterRoot _) ->
elContent <$> parseXMLElement ("<wrapper>" <> t <> "</wrapper>")
_ -> Left . T.pack . E.displayException $ e
Right x -> Right [Elem . elementToElement . Conduit.documentRoot $ x]
elementToElement :: Conduit.Element -> Element
elementToElement (Conduit.Element name attribMap nodes) =
Element (nameToQname name) attrs (mapMaybe nodeToContent nodes) Nothing
where
attrs = map (\(n,v) -> Attr (nameToQname n) v) $
M.toList attribMap
nameToQname (Conduit.Name localName mbns mbpref) =
case mbpref of
Nothing ->
case T.stripPrefix "xmlns:" localName of
Just rest -> QName rest mbns (Just "xmlns")
Nothing -> QName localName mbns mbpref
_ -> QName localName mbns mbpref
nodeToContent :: Conduit.Node -> Maybe Content
nodeToContent (Conduit.NodeElement el) =
Just (Elem (elementToElement el))
nodeToContent (Conduit.NodeContent t) =
Just (Text (CData CDataText t Nothing))
nodeToContent _ = Nothing
unqual :: Text -> QName
unqual x = QName x Nothing Nothing
-- | Add an attribute to an element.
add_attr :: Attr -> Element -> Element
add_attr a e = add_attrs [a] e
-- | Add some attributes to an element.
add_attrs :: [Attr] -> Element -> Element
add_attrs as e = e { elAttribs = as ++ elAttribs e }
--
-- type definitions lightly modified from xml-light
--
-- | A line is an Integer
type Line = Integer
-- | XML content
data Content = Elem Element
| Text CData
| CRef Text
deriving (Show, Typeable, Data)
-- | XML elements
data Element = Element {
elName :: QName,
elAttribs :: [Attr],
elContent :: [Content],
elLine :: Maybe Line
} deriving (Show, Typeable, Data)
-- | XML attributes
data Attr = Attr {
attrKey :: QName,
attrVal :: Text
} deriving (Eq, Ord, Show, Typeable, Data)
-- | XML CData
data CData = CData {
cdVerbatim :: CDataKind,
cdData :: Text,
cdLine :: Maybe Line
} deriving (Show, Typeable, Data)
data CDataKind
= CDataText -- ^ Ordinary character data; pretty printer escapes &, < etc.
| CDataVerbatim -- ^ Unescaped character data; pretty printer embeds it in <![CDATA[..
| CDataRaw -- ^ As-is character data; pretty printer passes it along without any escaping or CDATA wrap-up.
deriving ( Eq, Show, Typeable, Data )
-- | XML qualified names
data QName = QName {
qName :: Text,
qURI :: Maybe Text,
qPrefix :: Maybe Text
} deriving (Show, Typeable, Data)
instance Eq QName where
q1 == q2 = compare q1 q2 == EQ
instance Ord QName where
compare q1 q2 =
case compare (qName q1) (qName q2) of
EQ -> case (qURI q1, qURI q2) of
(Nothing,Nothing) -> compare (qPrefix q1) (qPrefix q2)
(u1,u2) -> compare u1 u2
x -> x
class Node t where
node :: QName -> t -> Element
instance Node ([Attr],[Content]) where
node n (attrs,cont) = Element { elName = n
, elAttribs = attrs
, elContent = cont
, elLine = Nothing
}
instance Node [Attr] where node n as = node n (as,[]::[Content])
instance Node Attr where node n a = node n [a]
instance Node () where node n () = node n ([]::[Attr])
instance Node [Content] where node n cs = node n ([]::[Attr],cs)
instance Node Content where node n c = node n [c]
instance Node ([Attr],Content) where node n (as,c) = node n (as,[c])
instance Node (Attr,Content) where node n (a,c) = node n ([a],[c])
instance Node ([Attr],[Element]) where
node n (as,cs) = node n (as,map Elem cs)
instance Node ([Attr],Element) where node n (as,c) = node n (as,[c])
instance Node (Attr,Element) where node n (a,c) = node n ([a],c)
instance Node [Element] where node n es = node n ([]::[Attr],es)
instance Node Element where node n e = node n [e]
instance Node ([Attr],[CData]) where
node n (as,cs) = node n (as,map Text cs)
instance Node ([Attr],CData) where node n (as,c) = node n (as,[c])
instance Node (Attr,CData) where node n (a,c) = node n ([a],c)
instance Node [CData] where node n es = node n ([]::[Attr],es)
instance Node CData where node n e = node n [e]
instance Node ([Attr],Text) where
node n (as,t) = node n (as, CData { cdVerbatim = CDataText
, cdData = t
, cdLine = Nothing })
instance Node (Attr,Text ) where node n (a,t) = node n ([a],t)
instance Node Text where node n t = node n ([]::[Attr],t)
-- | Create node with unqualified name
unode :: Node t => Text -> t -> Element
unode = node . unqual
--
-- conversion from xml-light
--
fromXLQName :: XL.QName -> QName
fromXLQName qn = QName { qName = T.pack $ XL.qName qn
, qURI = T.pack <$> XL.qURI qn
, qPrefix = T.pack <$> XL.qPrefix qn }
fromXLCData :: XL.CData -> CData
fromXLCData cd = CData { cdVerbatim = case XL.cdVerbatim cd of
XL.CDataText -> CDataText
XL.CDataVerbatim -> CDataVerbatim
XL.CDataRaw -> CDataRaw
, cdData = T.pack $ XL.cdData cd
, cdLine = XL.cdLine cd }
fromXLElement :: XL.Element -> Element
fromXLElement el = Element { elName = fromXLQName $ XL.elName el
, elAttribs = map fromXLAttr $ XL.elAttribs el
, elContent = map fromXLContent $ XL.elContent el
, elLine = XL.elLine el }
fromXLAttr :: XL.Attr -> Attr
fromXLAttr (XL.Attr qn s) = Attr (fromXLQName qn) (T.pack s)
fromXLContent :: XL.Content -> Content
fromXLContent (XL.Elem el) = Elem $ fromXLElement el
fromXLContent (XL.Text cd) = Text $ fromXLCData cd
fromXLContent (XL.CRef s) = CRef (T.pack s)
--
-- copied from xml-light Text.XML.Proc
--
-- | Get the text value of an XML element. This function
-- ignores non-text elements, and concatenates all text elements.
strContent :: Element -> Text
strContent = mconcat . map cdData . onlyText . elContent
-- | Select only the elements from a list of XML content.
onlyElems :: [Content] -> [Element]
onlyElems xs = [ x | Elem x <- xs ]
-- | Select only the elements from a parent.
elChildren :: Element -> [Element]
elChildren e = [ x | Elem x <- elContent e ]
-- | Select only the text from a list of XML content.
onlyText :: [Content] -> [CData]
onlyText xs = [ x | Text x <- xs ]
-- | Find all immediate children with the given name.
findChildren :: QName -> Element -> [Element]
findChildren q e = filterChildren ((q ==) . elName) e
-- | Filter all immediate children wrt a given predicate.
filterChildren :: (Element -> Bool) -> Element -> [Element]
filterChildren p e = filter p (onlyElems (elContent e))
-- | Filter all immediate children wrt a given predicate over their names.
filterChildrenName :: (QName -> Bool) -> Element -> [Element]
filterChildrenName p e = filter (p.elName) (onlyElems (elContent e))
-- | Find an immediate child with the given name.
findChild :: QName -> Element -> Maybe Element
findChild q e = listToMaybe (findChildren q e)
-- | Find an immediate child with the given name.
filterChild :: (Element -> Bool) -> Element -> Maybe Element
filterChild p e = listToMaybe (filterChildren p e)
-- | Find an immediate child with name matching a predicate.
filterChildName :: (QName -> Bool) -> Element -> Maybe Element
filterChildName p e = listToMaybe (filterChildrenName p e)
-- | Find the left-most occurrence of an element matching given name.
findElement :: QName -> Element -> Maybe Element
findElement q e = listToMaybe (findElements q e)
-- | Filter the left-most occurrence of an element wrt. given predicate.
filterElement :: (Element -> Bool) -> Element -> Maybe Element
filterElement p e = listToMaybe (filterElements p e)
-- | Filter the left-most occurrence of an element wrt. given predicate.
filterElementName :: (QName -> Bool) -> Element -> Maybe Element
filterElementName p e = listToMaybe (filterElementsName p e)
-- | Find all non-nested occurances of an element.
-- (i.e., once we have found an element, we do not search
-- for more occurances among the element's children).
findElements :: QName -> Element -> [Element]
findElements qn e = filterElementsName (qn==) e
-- | Find all non-nested occurrences of an element wrt. given predicate.
-- (i.e., once we have found an element, we do not search
-- for more occurances among the element's children).
filterElements :: (Element -> Bool) -> Element -> [Element]
filterElements p e
| p e = [e]
| otherwise = concatMap (filterElements p) $ onlyElems $ elContent e
-- | Find all non-nested occurences of an element wrt a predicate over element names.
-- (i.e., once we have found an element, we do not search
-- for more occurances among the element's children).
filterElementsName :: (QName -> Bool) -> Element -> [Element]
filterElementsName p e = filterElements (p.elName) e
-- | Lookup the value of an attribute.
findAttr :: QName -> Element -> Maybe Text
findAttr x e = lookupAttr x (elAttribs e)
-- | Lookup attribute name from list.
lookupAttr :: QName -> [Attr] -> Maybe Text
lookupAttr x = lookupAttrBy (x ==)
-- | Lookup the first attribute whose name satisfies the given predicate.
lookupAttrBy :: (QName -> Bool) -> [Attr] -> Maybe Text
lookupAttrBy p as = attrVal `fmap` find (p . attrKey) as
-- | Lookup the value of the first attribute whose name
-- satisfies the given predicate.
findAttrBy :: (QName -> Bool) -> Element -> Maybe Text
findAttrBy p e = lookupAttrBy p (elAttribs e)
--
-- duplicates functinos from Text.XML.Output
--
-- | The XML 1.0 header
xmlHeader :: Text
xmlHeader = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
--------------------------------------------------------------------------------
data ConfigPP = ConfigPP
{ shortEmptyTag :: QName -> Bool
, prettify :: Bool
}
-- | Default pretty orinting configuration.
-- * Always use abbreviate empty tags.
defaultConfigPP :: ConfigPP
defaultConfigPP = ConfigPP { shortEmptyTag = const True
, prettify = False
}
-- | The predicate specifies for which empty tags we should use XML's
-- abbreviated notation <TAG />. This is useful if we are working with
-- some XML-ish standards (such as certain versions of HTML) where some
-- empty tags should always be displayed in the <TAG></TAG> form.
useShortEmptyTags :: (QName -> Bool) -> ConfigPP -> ConfigPP
useShortEmptyTags p c = c { shortEmptyTag = p }
-- | Specify if we should use extra white-space to make document more readable.
-- WARNING: This adds additional white-space to text elements,
-- and so it may change the meaning of the document.
useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP
useExtraWhiteSpace p c = c { prettify = p }
-- | A configuration that tries to make things pretty
-- (possibly at the cost of changing the semantics a bit
-- through adding white space.)
prettyConfigPP :: ConfigPP
prettyConfigPP = useExtraWhiteSpace True defaultConfigPP
--------------------------------------------------------------------------------
-- | Pretty printing renders XML documents faithfully,
-- with the exception that whitespace may be added\/removed
-- in non-verbatim character data.
ppTopElement :: Element -> Text
ppTopElement = ppcTopElement prettyConfigPP
-- | Pretty printing elements
ppElement :: Element -> Text
ppElement = ppcElement prettyConfigPP
-- | Pretty printing content
ppContent :: Content -> Text
ppContent = ppcContent prettyConfigPP
-- | Pretty printing renders XML documents faithfully,
-- with the exception that whitespace may be added\/removed
-- in non-verbatim character data.
ppcTopElement :: ConfigPP -> Element -> Text
ppcTopElement c e = T.unlines [xmlHeader,ppcElement c e]
-- | Pretty printing elements
ppcElement :: ConfigPP -> Element -> Text
ppcElement c = TL.toStrict . toLazyText . ppElementS c mempty
-- | Pretty printing content
ppcContent :: ConfigPP -> Content -> Text
ppcContent c = TL.toStrict . toLazyText . ppContentS c mempty
ppcCData :: ConfigPP -> CData -> Text
ppcCData c = TL.toStrict . toLazyText . ppCDataS c mempty
type Indent = Builder
-- | Pretty printing content using ShowT
ppContentS :: ConfigPP -> Indent -> Content -> Builder
ppContentS c i x = case x of
Elem e -> ppElementS c i e
Text t -> ppCDataS c i t
CRef r -> showCRefS r
ppElementS :: ConfigPP -> Indent -> Element -> Builder
ppElementS c i e = i <> tagStart (elName e) (elAttribs e) <>
(case elContent e of
[] | "?" `T.isPrefixOf` qName name -> fromText " ?>"
| shortEmptyTag c name -> fromText " />"
[Text t] -> singleton '>' <> ppCDataS c mempty t <> tagEnd name
cs -> singleton '>' <> nl <>
mconcat (map ((<> nl) . ppContentS c (sp <> i)) cs) <>
i <> tagEnd name
where (nl,sp) = if prettify c then ("\n"," ") else ("","")
)
where name = elName e
ppCDataS :: ConfigPP -> Indent -> CData -> Builder
ppCDataS c i t = i <> if cdVerbatim t /= CDataText || not (prettify c)
then showCDataS t
else foldr cons mempty (T.unpack (showCData t))
where cons :: Char -> Builder -> Builder
cons '\n' ys = singleton '\n' <> i <> ys
cons y ys = singleton y <> ys
--------------------------------------------------------------------------------
-- | Adds the <?xml?> header.
showTopElement :: Element -> Text
showTopElement c = xmlHeader <> showElement c
showContent :: Content -> Text
showContent = ppcContent defaultConfigPP
showElement :: Element -> Text
showElement = ppcElement defaultConfigPP
showCData :: CData -> Text
showCData = ppcCData defaultConfigPP
-- Note: crefs should not contain '&', ';', etc.
showCRefS :: Text -> Builder
showCRefS r = singleton '&' <> fromText r <> singleton ';'
-- | Convert a text element to characters.
showCDataS :: CData -> Builder
showCDataS cd =
case cdVerbatim cd of
CDataText -> escStr (cdData cd)
CDataVerbatim -> fromText "<![CDATA[" <> escCData (cdData cd) <>
fromText "]]>"
CDataRaw -> fromText (cdData cd)
--------------------------------------------------------------------------------
escCData :: Text -> Builder
escCData t
| "]]>" `T.isPrefixOf` t =
fromText "]]]]><![CDATA[>" <> fromText (T.drop 3 t)
escCData t
= case T.uncons t of
Nothing -> mempty
Just (c,t') -> singleton c <> escCData t'
escChar :: Char -> Builder
escChar c = case c of
'<' -> fromText "&lt;"
'>' -> fromText "&gt;"
'&' -> fromText "&amp;"
'"' -> fromText "&quot;"
-- we use &#39 instead of &apos; because IE apparently has difficulties
-- rendering &apos; in xhtml.
-- Reported by Rohan Drape <rohan.drape@gmail.com>.
'\'' -> fromText "&#39;"
_ -> singleton c
{- original xml-light version:
-- NOTE: We escape '\r' explicitly because otherwise they get lost
-- when parsed back in because of then end-of-line normalization rules.
_ | isPrint c || c == '\n' -> singleton c
| otherwise -> showText "&#" . showsT oc . singleton ';'
where oc = ord c
-}
escStr :: Text -> Builder
escStr cs = if T.any needsEscape cs
then mconcat (map escChar (T.unpack cs))
else fromText cs
where
needsEscape '<' = True
needsEscape '>' = True
needsEscape '&' = True
needsEscape '"' = True
needsEscape '\'' = True
needsEscape _ = False
tagEnd :: QName -> Builder
tagEnd qn = fromText "</" <> showQName qn <> singleton '>'
tagStart :: QName -> [Attr] -> Builder
tagStart qn as = singleton '<' <> showQName qn <> as_str
where as_str = if null as
then mempty
else mconcat (map showAttr as)
showAttr :: Attr -> Builder
showAttr (Attr qn v) = singleton ' ' <> showQName qn <>
singleton '=' <>
singleton '"' <> escStr v <> singleton '"'
showQName :: QName -> Builder
showQName q =
case qPrefix q of
Nothing -> fromText (qName q)
Just p -> fromText p <> singleton ':' <> fromText (qName q)
src/Text/Pandoc/XMLParser.hs
-66
View File
@@ -1,66 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.XMLParser
Copyright : Copyright (C) 2021 John MacFarlane
License : GNU GPL, version 2 or above
Maintainer : John MacFarlane <jgm@berkeley.edu>
Stability : alpha
Portability : portable
Bridge to allow using xml-conduit's parser with xml-light's types.
-}
module Text.Pandoc.XMLParser
( parseXMLElement
, parseXMLContents
, module Text.XML.Light.Types
) where
import qualified Control.Exception as E
import qualified Text.XML as Conduit
import Text.XML.Unresolved (InvalidEventStream(..))
import qualified Text.XML.Light as Light
import Text.XML.Light.Types
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Map as M
import Data.Maybe (mapMaybe)
-- Drop in replacement for parseXMLDoc in xml-light.
parseXMLElement :: TL.Text -> Either T.Text Light.Element
parseXMLElement t =
elementToElement . Conduit.documentRoot <$>
either (Left . T.pack . E.displayException) Right
(Conduit.parseText Conduit.def{ Conduit.psRetainNamespaces = True } t)
parseXMLContents :: TL.Text -> Either T.Text [Light.Content]
parseXMLContents t =
case Conduit.parseText Conduit.def{ Conduit.psRetainNamespaces = True } t of
Left e ->
case E.fromException e of
Just (ContentAfterRoot _) ->
elContent <$> parseXMLElement ("<wrapper>" <> t <> "</wrapper>")
_ -> Left . T.pack . E.displayException $ e
Right x -> Right [Light.Elem . elementToElement . Conduit.documentRoot $ x]
elementToElement :: Conduit.Element -> Light.Element
elementToElement (Conduit.Element name attribMap nodes) =
Light.Element (nameToQname name) attrs (mapMaybe nodeToContent nodes) Nothing
where
attrs = map (\(n,v) -> Light.Attr (nameToQname n) (T.unpack v)) $
M.toList attribMap
nameToQname (Conduit.Name localName mbns mbpref) =
case mbpref of
Nothing | "xmlns:" `T.isPrefixOf` localName ->
Light.QName (T.unpack $ T.drop 6 localName) (T.unpack <$> mbns)
(Just "xmlns")
_ -> Light.QName (T.unpack localName) (T.unpack <$> mbns)
(T.unpack <$> mbpref)
nodeToContent :: Conduit.Node -> Maybe Light.Content
nodeToContent (Conduit.NodeElement el) =
Just (Light.Elem (elementToElement el))
nodeToContent (Conduit.NodeContent t) =
Just (Light.Text (Light.CData Light.CDataText (T.unpack t) Nothing))
nodeToContent _ = Nothing
test/Tests/Writers/OOXML.hs
+2 -1
View File
@@ -43,7 +43,8 @@ compareXMLBool _ _ = False
displayDiff :: Content -> Content -> String
displayDiff elemA elemB =
showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB)
showDiff (1,1)
(getDiff (lines $ showContent elemA) (lines $ showContent elemB))
goldenArchive :: FilePath -> IO Archive
goldenArchive fp = toArchive . BL.fromStrict <$> BS.readFile fp
test/docx/golden/block_quotes.docx
BIN
View File
Binary file not shown.
test/docx/golden/codeblock.docx
BIN
View File
Binary file not shown.
test/docx/golden/comments.docx
BIN
View File
Binary file not shown.
test/docx/golden/custom_style_no_reference.docx
BIN
View File
Binary file not shown.
test/docx/golden/custom_style_preserve.docx
BIN
View File
Binary file not shown.
test/docx/golden/custom_style_reference.docx
BIN
View File
Binary file not shown.
test/docx/golden/definition_list.docx
BIN
View File
Binary file not shown.
test/docx/golden/document-properties-short-desc.docx
BIN
View File
Binary file not shown.
test/docx/golden/document-properties.docx
BIN
View File
Binary file not shown.
test/docx/golden/headers.docx
BIN
View File
Binary file not shown.
test/docx/golden/image.docx
BIN
View File
Binary file not shown.
test/docx/golden/inline_code.docx
BIN
View File
Binary file not shown.
test/docx/golden/inline_formatting.docx
BIN
View File
Binary file not shown.
test/docx/golden/inline_images.docx
BIN
View File
Binary file not shown.
test/docx/golden/link_in_notes.docx
BIN
View File
Binary file not shown.
test/docx/golden/links.docx
BIN
View File
Binary file not shown.
test/docx/golden/lists.docx
BIN
View File
Binary file not shown.
test/docx/golden/lists_continuing.docx
BIN
View File
Binary file not shown.
test/docx/golden/lists_multiple_initial.docx
BIN
View File
Binary file not shown.
test/docx/golden/lists_restarting.docx
BIN
View File
Binary file not shown.
test/docx/golden/nested_anchors_in_header.docx
BIN
View File
Binary file not shown.
test/docx/golden/notes.docx
BIN
View File
Binary file not shown.
test/docx/golden/raw-blocks.docx
BIN
View File
Binary file not shown.
test/docx/golden/raw-bookmarks.docx
BIN
View File
Binary file not shown.
test/docx/golden/table_one_row.docx
BIN
View File
Binary file not shown.
test/docx/golden/table_with_list_cell.docx
BIN
View File
Binary file not shown.
test/docx/golden/tables.docx
BIN
View File
Binary file not shown.
test/docx/golden/track_changes_deletion.docx
BIN
View File
Binary file not shown.
test/docx/golden/track_changes_insertion.docx
BIN
View File
Binary file not shown.
test/docx/golden/track_changes_move.docx
BIN
View File
Binary file not shown.
test/docx/golden/track_changes_scrubbed_metadata.docx
BIN
View File
Binary file not shown.
test/docx/golden/unicode.docx
BIN
View File
Binary file not shown.
test/docx/golden/verbatim_subsuper.docx
BIN
View File
Binary file not shown.
test/pptx/code-custom.pptx
BIN
View File
Binary file not shown.
test/pptx/code-custom_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/code.pptx
BIN
View File
Binary file not shown.
test/pptx/code_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/document-properties-short-desc.pptx
BIN
View File
Binary file not shown.
test/pptx/document-properties-short-desc_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/document-properties.pptx
BIN
View File
Binary file not shown.
test/pptx/document-properties_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/endnotes.pptx
BIN
View File
Binary file not shown.
test/pptx/endnotes_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/endnotes_toc.pptx
BIN
View File
Binary file not shown.
test/pptx/endnotes_toc_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/images.pptx
BIN
View File
Binary file not shown.
test/pptx/images_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/inline_formatting.pptx
BIN
View File
Binary file not shown.
test/pptx/inline_formatting_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/lists.pptx
BIN
View File
Binary file not shown.
test/pptx/lists_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/raw_ooxml.pptx
BIN
View File
Binary file not shown.
test/pptx/raw_ooxml_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/remove_empty_slides.pptx
BIN
View File
Binary file not shown.
test/pptx/remove_empty_slides_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/slide_breaks.pptx
BIN
View File
Binary file not shown.
test/pptx/slide_breaks_slide_level_1.pptx
BIN
View File
Binary file not shown.
test/pptx/slide_breaks_slide_level_1_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/slide_breaks_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/slide_breaks_toc.pptx
BIN
View File
Binary file not shown.
test/pptx/slide_breaks_toc_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/speaker_notes.pptx
BIN
View File
Binary file not shown.
test/pptx/speaker_notes_after_metadata.pptx
BIN
View File
Binary file not shown.
test/pptx/speaker_notes_after_metadata_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/speaker_notes_afterheader.pptx
BIN
View File
Binary file not shown.
test/pptx/speaker_notes_afterheader_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/speaker_notes_afterseps.pptx
BIN
View File
Binary file not shown.
test/pptx/speaker_notes_afterseps_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/speaker_notes_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/start_numbering_at.pptx
BIN
View File
Binary file not shown.
test/pptx/start_numbering_at_templated.pptx
BIN
View File
Binary file not shown.
test/pptx/tables.pptx
BIN
View File
Binary file not shown.
test/pptx/tables_templated.pptx
BIN
View File
Binary file not shown.

Some files were not shown because too many files have changed in this diff Show More