aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc')
-rw-r--r--src/Text/Pandoc/Readers/Docx.hs78
-rw-r--r--src/Text/Pandoc/Readers/Docx/Parse.hs114
-rw-r--r--src/Text/Pandoc/Readers/HTML.hs18
-rw-r--r--src/Text/Pandoc/Readers/Org.hs2
-rw-r--r--src/Text/Pandoc/Readers/Txt2Tags.hs55
-rw-r--r--src/Text/Pandoc/Shared.hs3
-rw-r--r--src/Text/Pandoc/Writers/Docx.hs127
-rw-r--r--src/Text/Pandoc/Writers/DokuWiki.hs182
-rw-r--r--src/Text/Pandoc/Writers/EPUB.hs30
-rw-r--r--src/Text/Pandoc/Writers/LaTeX.hs20
10 files changed, 429 insertions, 200 deletions
diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs
index a1c16a03a..8ebe59569 100644
--- a/src/Text/Pandoc/Readers/Docx.hs
+++ b/src/Text/Pandoc/Readers/Docx.hs
@@ -95,6 +95,7 @@ import Control.Monad.Reader
import Control.Monad.State
import Control.Applicative ((<$>))
import Data.Sequence (ViewL(..), viewl)
+import qualified Data.Sequence as Seq (null)
readDocx :: ReaderOptions
-> B.ByteString
@@ -196,12 +197,6 @@ fixAuthors mv = mv
codeStyles :: [String]
codeStyles = ["VerbatimChar"]
-strongStyles :: [String]
-strongStyles = ["Strong", "Bold"]
-
-emphStyles :: [String]
-emphStyles = ["Emphasis", "Italic"]
-
blockQuoteDivs :: [String]
blockQuoteDivs = ["Quote", "BlockQuote", "BlockQuotation"]
@@ -228,27 +223,44 @@ parPartToString (InternalHyperLink _ runs) = concatMap runToString runs
parPartToString (ExternalHyperLink _ runs) = concatMap runToString runs
parPartToString _ = ""
+blacklistedCharStyles :: [String]
+blacklistedCharStyles = ["Hyperlink"]
+
+resolveDependentRunStyle :: RunStyle -> RunStyle
+resolveDependentRunStyle rPr
+ | Just (s, _) <- rStyle rPr, s `elem` blacklistedCharStyles =
+ rPr
+ | Just (_, cs) <- rStyle rPr =
+ let rPr' = resolveDependentRunStyle cs
+ in
+ RunStyle { isBold = case isBold rPr of
+ Just bool -> Just bool
+ Nothing -> isBold rPr'
+ , isItalic = case isItalic rPr of
+ Just bool -> Just bool
+ Nothing -> isItalic rPr'
+ , isSmallCaps = case isSmallCaps rPr of
+ Just bool -> Just bool
+ Nothing -> isSmallCaps rPr'
+ , isStrike = case isStrike rPr of
+ Just bool -> Just bool
+ Nothing -> isStrike rPr'
+ , rVertAlign = case rVertAlign rPr of
+ Just valign -> Just valign
+ Nothing -> rVertAlign rPr'
+ , rUnderline = case rUnderline rPr of
+ Just ulstyle -> Just ulstyle
+ Nothing -> rUnderline rPr'
+ , rStyle = rStyle rPr }
+ | otherwise = rPr
+
runStyleToTransform :: RunStyle -> (Inlines -> Inlines)
runStyleToTransform rPr
- | Just s <- rStyle rPr
+ | Just (s, _) <- rStyle rPr
, s `elem` spansToKeep =
let rPr' = rPr{rStyle = Nothing}
in
(spanWith ("", [s], [])) . (runStyleToTransform rPr')
- | Just s <- rStyle rPr
- , s `elem` emphStyles =
- let rPr' = rPr{rStyle = Nothing, isItalic = Nothing}
- in
- case isItalic rPr of
- Just False -> runStyleToTransform rPr'
- _ -> emph . (runStyleToTransform rPr')
- | Just s <- rStyle rPr
- , s `elem` strongStyles =
- let rPr' = rPr{rStyle = Nothing, isBold = Nothing}
- in
- case isBold rPr of
- Just False -> runStyleToTransform rPr'
- _ -> strong . (runStyleToTransform rPr')
| Just True <- isItalic rPr =
emph . (runStyleToTransform rPr {isItalic = Nothing})
| Just True <- isBold rPr =
@@ -257,22 +269,22 @@ runStyleToTransform rPr
smallcaps . (runStyleToTransform rPr {isSmallCaps = Nothing})
| Just True <- isStrike rPr =
strikeout . (runStyleToTransform rPr {isStrike = Nothing})
- | isSuperScript rPr =
- superscript . (runStyleToTransform rPr {isSuperScript = False})
- | isSubScript rPr =
- subscript . (runStyleToTransform rPr {isSubScript = False})
+ | Just SupScrpt <- rVertAlign rPr =
+ superscript . (runStyleToTransform rPr {rVertAlign = Nothing})
+ | Just SubScrpt <- rVertAlign rPr =
+ subscript . (runStyleToTransform rPr {rVertAlign = Nothing})
| Just "single" <- rUnderline rPr =
emph . (runStyleToTransform rPr {rUnderline = Nothing})
| otherwise = id
runToInlines :: Run -> DocxContext Inlines
runToInlines (Run rs runElems)
- | Just s <- rStyle rs
+ | Just (s, _) <- rStyle rs
, s `elem` codeStyles =
return $ code $ concatMap runElemToString runElems
| otherwise = do
let ils = concatReduce (map runElemToInlines runElems)
- return $ (runStyleToTransform rs) ils
+ return $ (runStyleToTransform $ resolveDependentRunStyle rs) ils
runToInlines (Footnote bps) = do
blksList <- concatReduce <$> (mapM bodyPartToBlocks bps)
return $ note blksList
@@ -380,11 +392,21 @@ makeHeaderAnchor' (Header n (_, classes, kvs) ils) =
return $ Header n (newIdent, classes, kvs) ils
makeHeaderAnchor' blk = return blk
+-- Rewrite a standalone paragraph block as a plain
+singleParaToPlain :: Blocks -> Blocks
+singleParaToPlain blks
+ | (Para (ils) :< seeq) <- viewl $ unMany blks
+ , Seq.null seeq =
+ singleton $ Plain ils
+singleParaToPlain blks = blks
+
cellToBlocks :: Cell -> DocxContext Blocks
cellToBlocks (Cell bps) = concatReduce <$> mapM bodyPartToBlocks bps
rowToBlocksList :: Row -> DocxContext [Blocks]
-rowToBlocksList (Row cells) = mapM cellToBlocks cells
+rowToBlocksList (Row cells) = do
+ blksList <- mapM cellToBlocks cells
+ return $ map singleParaToPlain blksList
trimLineBreaks :: [Inline] -> [Inline]
trimLineBreaks [] = []
diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs
index 939fcde27..e7a6c3ffb 100644
--- a/src/Text/Pandoc/Readers/Docx/Parse.hs
+++ b/src/Text/Pandoc/Readers/Docx/Parse.hs
@@ -43,13 +43,13 @@ module Text.Pandoc.Readers.Docx.Parse ( Docx(..)
, Relationship
, Media
, RunStyle(..)
+ , VertAlign(..)
, ParIndentation(..)
, ParagraphStyle(..)
, Row(..)
, Cell(..)
, archiveToDocx
) where
-
import Codec.Archive.Zip
import Text.XML.Light
import Data.Maybe
@@ -72,6 +72,7 @@ data ReaderEnv = ReaderEnv { envNotes :: Notes
, envRelationships :: [Relationship]
, envMedia :: Media
, envFont :: Maybe Font
+ , envCharStyles :: CharStyleMap
}
deriving Show
@@ -119,6 +120,10 @@ data Body = Body [BodyPart]
type Media = [(FilePath, B.ByteString)]
+type CharStyle = (String, RunStyle)
+
+type CharStyleMap = M.Map String RunStyle
+
data Numbering = Numbering NameSpaces [Numb] [AbstractNumb]
deriving Show
@@ -196,14 +201,16 @@ data Run = Run RunStyle [RunElem]
data RunElem = TextRun String | LnBrk | Tab
deriving Show
+data VertAlign = BaseLn | SupScrpt | SubScrpt
+ deriving Show
+
data RunStyle = RunStyle { isBold :: Maybe Bool
, isItalic :: Maybe Bool
, isSmallCaps :: Maybe Bool
, isStrike :: Maybe Bool
- , isSuperScript :: Bool
- , isSubScript :: Bool
+ , rVertAlign :: Maybe VertAlign
, rUnderline :: Maybe String
- , rStyle :: Maybe String }
+ , rStyle :: Maybe CharStyle}
deriving Show
defaultRunStyle :: RunStyle
@@ -211,11 +218,9 @@ defaultRunStyle = RunStyle { isBold = Nothing
, isItalic = Nothing
, isSmallCaps = Nothing
, isStrike = Nothing
- , isSuperScript = False
- , isSubScript = False
+ , rVertAlign = Nothing
, rUnderline = Nothing
- , rStyle = Nothing
- }
+ , rStyle = Nothing}
type Target = String
@@ -237,7 +242,8 @@ archiveToDocx archive = do
numbering = archiveToNumbering archive
rels = archiveToRelationships archive
media = archiveToMedia archive
- rEnv = ReaderEnv notes numbering rels media Nothing
+ styles = archiveToStyles archive
+ rEnv = ReaderEnv notes numbering rels media Nothing styles
doc <- runD (archiveToDocument archive) rEnv
return $ Docx doc
@@ -257,6 +263,53 @@ elemToBody ns element | isElem ns "w" "body" element =
(\bps -> return $ Body bps)
elemToBody _ _ = throwError WrongElem
+archiveToStyles :: Archive -> CharStyleMap
+archiveToStyles zf =
+ let stylesElem = findEntryByPath "word/styles.xml" zf >>=
+ (parseXMLDoc . UTF8.toStringLazy . fromEntry)
+ in
+ case stylesElem of
+ Nothing -> M.empty
+ Just styElem ->
+ let namespaces = mapMaybe attrToNSPair (elAttribs styElem)
+ in
+ M.fromList $ buildBasedOnList namespaces styElem Nothing
+
+isBasedOnStyle :: NameSpaces -> Element -> Maybe CharStyle -> Bool
+isBasedOnStyle ns element parentStyle
+ | isElem ns "w" "style" element
+ , Just "character" <- findAttr (elemName ns "w" "type") element
+ , Just basedOnVal <- findChild (elemName ns "w" "basedOn") element >>=
+ findAttr (elemName ns "w" "val")
+ , Just (parentId, _) <- parentStyle = (basedOnVal == parentId)
+ | isElem ns "w" "style" element
+ , Just "character" <- findAttr (elemName ns "w" "type") element
+ , Nothing <- findChild (elemName ns "w" "basedOn") element
+ , Nothing <- parentStyle = True
+ | otherwise = False
+
+elemToCharStyle :: NameSpaces -> Element -> Maybe CharStyle -> Maybe CharStyle
+elemToCharStyle ns element parentStyle
+ | isElem ns "w" "style" element
+ , Just "character" <- findAttr (elemName ns "w" "type") element
+ , Just styleId <- findAttr (elemName ns "w" "styleId") element =
+ Just (styleId, elemToRunStyle ns element parentStyle)
+ | otherwise = Nothing
+
+getStyleChildren :: NameSpaces -> Element -> Maybe CharStyle -> [CharStyle]
+getStyleChildren ns element parentStyle
+ | isElem ns "w" "styles" element =
+ mapMaybe (\e -> elemToCharStyle ns e parentStyle) $
+ filterChildren (\e' -> isBasedOnStyle ns e' parentStyle) element
+ | otherwise = []
+
+buildBasedOnList :: NameSpaces -> Element -> Maybe CharStyle -> [CharStyle]
+buildBasedOnList ns element rootStyle =
+ case (getStyleChildren ns element rootStyle) of
+ [] -> []
+ stys -> stys ++
+ (concatMap (\s -> buildBasedOnList ns element (Just s)) stys)
+
archiveToNotes :: Archive -> Notes
archiveToNotes zf =
let fnElem = findEntryByPath "word/footnotes.xml" zf
@@ -627,7 +680,8 @@ elemToRun ns element
elemToRun ns element
| isElem ns "w" "r" element = do
runElems <- elemToRunElems ns element
- return $ Run (elemToRunStyle ns element) runElems
+ runStyle <- elemToRunStyleD ns element
+ return $ Run runStyle runElems
elemToRun _ _ = throwError WrongElem
elemToParagraphStyle :: NameSpaces -> Element -> ParagraphStyle
@@ -667,9 +721,22 @@ checkOnOff ns rPr tag
| Just _ <- findChild tag rPr = Just True
checkOnOff _ _ _ = Nothing
-
-elemToRunStyle :: NameSpaces -> Element -> RunStyle
-elemToRunStyle ns element
+elemToRunStyleD :: NameSpaces -> Element -> D RunStyle
+elemToRunStyleD ns element
+ | Just rPr <- findChild (elemName ns "w" "rPr") element = do
+ charStyles <- asks envCharStyles
+ let parentSty = case
+ findChild (elemName ns "w" "rStyle") rPr >>=
+ findAttr (elemName ns "w" "val")
+ of
+ Just styName | Just style <- M.lookup styName charStyles ->
+ Just (styName, style)
+ _ -> Nothing
+ return $ elemToRunStyle ns element parentSty
+elemToRunStyleD _ _ = return defaultRunStyle
+
+elemToRunStyle :: NameSpaces -> Element -> Maybe CharStyle -> RunStyle
+elemToRunStyle ns element parentStyle
| Just rPr <- findChild (elemName ns "w" "rPr") element =
RunStyle
{
@@ -677,22 +744,19 @@ elemToRunStyle ns element
, isItalic = checkOnOff ns rPr (elemName ns "w" "i")
, isSmallCaps = checkOnOff ns rPr (elemName ns "w" "smallCaps")
, isStrike = checkOnOff ns rPr (elemName ns "w" "strike")
- , isSuperScript =
- (Just "superscript" ==
- (findChild (elemName ns "w" "vertAlign") rPr >>=
- findAttr (elemName ns "w" "val")))
- , isSubScript =
- (Just "subscript" ==
- (findChild (elemName ns "w" "vertAlign") rPr >>=
- findAttr (elemName ns "w" "val")))
+ , rVertAlign =
+ findChild (elemName ns "w" "vertAlign") rPr >>=
+ findAttr (elemName ns "w" "val") >>=
+ \v -> Just $ case v of
+ "superscript" -> SupScrpt
+ "subscript" -> SubScrpt
+ _ -> BaseLn
, rUnderline =
findChild (elemName ns "w" "u") rPr >>=
findAttr (elemName ns "w" "val")
- , rStyle =
- findChild (elemName ns "w" "rStyle") rPr >>=
- findAttr (elemName ns "w" "val")
+ , rStyle = parentStyle
}
-elemToRunStyle _ _ = defaultRunStyle
+elemToRunStyle _ _ _ = defaultRunStyle
elemToRunElem :: NameSpaces -> Element -> D RunElem
elemToRunElem ns element
diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs
index bd60a74fa..4ea5f41d5 100644
--- a/src/Text/Pandoc/Readers/HTML.hs
+++ b/src/Text/Pandoc/Readers/HTML.hs
@@ -91,16 +91,20 @@ replaceNotes' x = return x
data HTMLState =
HTMLState
{ parserState :: ParserState,
- noteTable :: [(String, Blocks)]
+ noteTable :: [(String, Blocks)]
}
data HTMLLocal = HTMLLocal { quoteContext :: QuoteContext
, inChapter :: Bool -- ^ Set if in chapter section
+ , inPlain :: Bool -- ^ Set if in pPlain
}
setInChapter :: HTMLParser s a -> HTMLParser s a
setInChapter = local (\s -> s {inChapter = True})
+setInPlain :: HTMLParser s a -> HTMLParser s a
+setInPlain = local (\s -> s {inPlain = True})
+
type HTMLParser s = ParserT s HTMLState (Reader HTMLLocal)
type TagParser = HTMLParser [Tag String]
@@ -141,8 +145,8 @@ block = do
, pTable
, pHead
, pBody
- , pPlain
, pDiv
+ , pPlain
, pRawHtmlBlock
]
when tr $ trace (printf "line %d: %s" (sourceLine pos)
@@ -422,7 +426,7 @@ pBlockQuote = do
pPlain :: TagParser Blocks
pPlain = do
- contents <- trimInlines . mconcat <$> many1 inline
+ contents <- setInPlain $ trimInlines . mconcat <$> many1 inline
if B.isNull contents
then return mempty
else return $ B.plain contents
@@ -579,7 +583,11 @@ pSpan = try $ do
pRawHtmlInline :: TagParser Inlines
pRawHtmlInline = do
- result <- pSatisfy (tagComment (const True)) <|> pSatisfy isInlineTag
+ inplain <- asks inPlain
+ result <- pSatisfy (tagComment (const True))
+ <|> if inplain
+ then pSatisfy (not . isBlockTag)
+ else pSatisfy isInlineTag
parseRaw <- getOption readerParseRaw
if parseRaw
then return $ B.rawInline "html" $ renderTags' [result]
@@ -919,7 +927,7 @@ instance HasMeta HTMLState where
deleteMeta s st = st {parserState = deleteMeta s $ parserState st}
instance Default HTMLLocal where
- def = HTMLLocal NoQuote False
+ def = HTMLLocal NoQuote False False
instance HasLastStrPosition HTMLState where
setLastStrPos s st = st {parserState = setLastStrPos s (parserState st)}
diff --git a/src/Text/Pandoc/Readers/Org.hs b/src/Text/Pandoc/Readers/Org.hs
index e1c29d1e8..62421d2fb 100644
--- a/src/Text/Pandoc/Readers/Org.hs
+++ b/src/Text/Pandoc/Readers/Org.hs
@@ -483,7 +483,7 @@ exampleCode :: String -> Blocks
exampleCode = B.codeBlockWith ("", ["example"], [])
exampleLine :: OrgParser String
-exampleLine = try $ string ": " *> anyLine
+exampleLine = try $ skipSpaces *> string ": " *> anyLine
-- Drawers for properties or a logbook
drawer :: OrgParser (F Blocks)
diff --git a/src/Text/Pandoc/Readers/Txt2Tags.hs b/src/Text/Pandoc/Readers/Txt2Tags.hs
index 3a51b9d84..6f8c19ac7 100644
--- a/src/Text/Pandoc/Readers/Txt2Tags.hs
+++ b/src/Text/Pandoc/Readers/Txt2Tags.hs
@@ -73,11 +73,13 @@ instance Default T2TMeta where
getT2TMeta :: [FilePath] -> FilePath -> IO T2TMeta
getT2TMeta inps out = do
curDate <- formatTime defaultTimeLocale "%F" <$> getZonedTime
- let getModTime = fmap (formatTime defaultTimeLocale "%F") .
+ let getModTime = fmap (formatTime defaultTimeLocale "%T") .
getModificationTime
- curMtime <- catchIOError
- (maximum <$> mapM getModTime inps)
- (const (return ""))
+ curMtime <- case inps of
+ [] -> formatTime defaultTimeLocale "%T" <$> getZonedTime
+ _ -> catchIOError
+ (maximum <$> mapM getModTime inps)
+ (const (return ""))
return $ T2TMeta curDate curMtime (intercalate ", " inps) out
-- | Read Txt2Tags from an input string returning a Pandoc document
@@ -91,13 +93,42 @@ readTxt2TagsNoMacros = readTxt2Tags def
parseT2T :: T2T Pandoc
parseT2T = do
- _ <- (Nothing <$ try blankline) <|> (Just <$> (count 3 anyLine))
+ -- Parse header if standalone flag is set
+ standalone <- getOption readerStandalone
+ when standalone parseHeader
+ body <- mconcat <$> manyTill block eof
+ meta' <- stateMeta <$> getState
+ return $ Pandoc meta' (B.toList body)
+
+parseHeader :: T2T ()
+parseHeader = do
+ () <$ try blankline <|> header
+ meta <- stateMeta <$> getState
+ optional blanklines
config <- manyTill setting (notFollowedBy setting)
-- TODO: Handle settings better
- let settings = foldr (\(k,v) -> B.setMeta k (MetaString v)) nullMeta config
- updateState (\s -> s {stateMeta = settings})
- body <- mconcat <$> manyTill block eof
- return $ Pandoc mempty (B.toList body)
+ let settings = foldr (\(k,v) -> B.setMeta k (MetaString v)) meta config
+ updateState (\s -> s {stateMeta = settings}) <* optional blanklines
+
+header :: T2T ()
+header = titleline >> authorline >> dateline
+
+headerline :: B.ToMetaValue a => String -> T2T a -> T2T ()
+headerline field p = (() <$ try blankline)
+ <|> (p >>= updateState . B.setMeta field)
+
+titleline :: T2T ()
+titleline =
+ headerline "title" (trimInlines . mconcat <$> manyTill inline newline)
+
+authorline :: T2T ()
+authorline =
+ headerline "author" (sepBy author (char ';') <* newline)
+ where
+ author = trimInlines . mconcat <$> many (notFollowedBy (char ';' <|> newline) >> inline)
+
+dateline :: T2T ()
+dateline = headerline "date" (trimInlines . mconcat <$> manyTill inline newline)
type Keyword = String
type Value = String
@@ -242,7 +273,7 @@ indentWith n = count n space
table :: T2T Blocks
table = try $ do
- header <- fmap snd <$> option mempty (try headerRow)
+ tableHeader <- fmap snd <$> option mempty (try headerRow)
rows <- many1 (many commentLine *> tableRow)
let columns = transpose rows
let ncolumns = length columns
@@ -250,7 +281,7 @@ table = try $ do
let rows' = map (map snd) rows
let size = maximum (map length rows')
let rowsPadded = map (pad size) rows'
- let headerPadded = if (not (null header)) then pad size header else mempty
+ let headerPadded = if (not (null tableHeader)) then pad size tableHeader else mempty
return $ B.table mempty
(zip aligns (replicate ncolumns 0.0))
headerPadded rowsPadded
@@ -497,7 +528,7 @@ image = try $ do
-- Characters used in markup
specialChars :: String
-specialChars = "%*-_/|:+"
+specialChars = "%*-_/|:+;"
tab :: T2T Char
tab = char '\t'
diff --git a/src/Text/Pandoc/Shared.hs b/src/Text/Pandoc/Shared.hs
index ced3a48db..54d252d43 100644
--- a/src/Text/Pandoc/Shared.hs
+++ b/src/Text/Pandoc/Shared.hs
@@ -796,7 +796,8 @@ fetchItem sourceURL s =
mime = case takeExtension fp of
".gz" -> getMimeType $ dropExtension fp
x -> getMimeType x
- ensureEscaped = escapeURIString isAllowedInURI
+ ensureEscaped x@(_:':':'\\':_) = x -- likely windows path
+ ensureEscaped x = escapeURIString isAllowedInURI x
-- | Like 'fetchItem', but also looks for items in a 'MediaBag'.
fetchItem' :: MediaBag -> Maybe String -> String
diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs
index 21d440eb8..09321d1cc 100644
--- a/src/Text/Pandoc/Writers/Docx.hs
+++ b/src/Text/Pandoc/Writers/Docx.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}
{-
Copyright (C) 2012-2014 John MacFarlane <jgm@berkeley.edu>
@@ -29,7 +29,6 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Conversion of 'Pandoc' documents to docx.
-}
module Text.Pandoc.Writers.Docx ( writeDocx ) where
-import Data.Maybe (fromMaybe)
import Data.List ( intercalate, isPrefixOf, isSuffixOf )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
@@ -39,6 +38,10 @@ import qualified Text.Pandoc.UTF8 as UTF8
import Text.Pandoc.Compat.Monoid ((<>))
import Codec.Archive.Zip
import Data.Time.Clock.POSIX
+import Data.Time.Clock
+import Data.Time.Format
+import System.Environment
+import System.Locale
import Text.Pandoc.Definition
import Text.Pandoc.Generic
import Text.Pandoc.ImageSize
@@ -60,7 +63,7 @@ import qualified Control.Exception as E
import Text.Pandoc.MIME (MimeType, getMimeType, getMimeTypeDef,
extensionFromMimeType)
import Control.Applicative ((<$>), (<|>))
-import Data.Maybe (mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
data ListMarker = NoMarker
| BulletMarker
@@ -96,6 +99,11 @@ data WriterState = WriterState{
, stListLevel :: Int
, stListNumId :: Int
, stLists :: [ListMarker]
+ , stInsId :: Int
+ , stDelId :: Int
+ , stInDel :: Bool
+ , stChangesAuthor :: String
+ , stChangesDate :: String
}
defaultWriterState :: WriterState
@@ -109,13 +117,24 @@ defaultWriterState = WriterState{
, stListLevel = -1
, stListNumId = 1
, stLists = [NoMarker]
+ , stInsId = 1
+ , stDelId = 1
+ , stInDel = False
+ , stChangesAuthor = "unknown"
+ , stChangesDate = "1969-12-31T19:00:00Z"
}
type WS a = StateT WriterState IO a
mknode :: Node t => String -> [(String,String)] -> t -> Element
mknode s attrs =
- add_attrs (map (\(k,v) -> Attr (unqual k) v) attrs) . node (unqual s)
+ add_attrs (map (\(k,v) -> Attr (nodename k) v) attrs) . node (nodename s)
+
+nodename :: String -> QName
+nodename s = QName{ qName = name, qURI = Nothing, qPrefix = prefix }
+ where (name, prefix) = case break (==':') s of
+ (xs,[]) -> (xs, Nothing)
+ (ys, _:zs) -> (zs, Just ys)
toLazy :: B.ByteString -> BL.ByteString
toLazy = BL.fromChunks . (:[])
@@ -131,6 +150,8 @@ writeDocx :: WriterOptions -- ^ Writer options
writeDocx opts doc@(Pandoc meta _) = do
let datadir = writerUserDataDir opts
let doc' = walk fixDisplayMath doc
+ username <- lookup "USERNAME" <$> getEnvironment
+ utctime <- getCurrentTime
refArchive <- liftM (toArchive . toLazy) $
case writerReferenceDocx opts of
Just f -> B.readFile f
@@ -138,8 +159,9 @@ writeDocx opts doc@(Pandoc meta _) = do
distArchive <- liftM (toArchive . toLazy) $ readDataFile Nothing "reference.docx"
((contents, footnotes), st) <- runStateT (writeOpenXML opts{writerWrapText = False} doc')
- defaultWriterState
- epochtime <- floor `fmap` getPOSIXTime
+ defaultWriterState{ stChangesAuthor = fromMaybe "unknown" username
+ , stChangesDate = formatTime defaultTimeLocale "%FT%XZ" utctime}
+ let epochtime = floor $ utcTimeToPOSIXSeconds utctime
let imgs = M.elems $ stImages st
-- create entries for images in word/media/...
@@ -151,7 +173,7 @@ writeDocx opts doc@(Pandoc meta _) = do
let wname f qn = qPrefix qn == Just "w" && f (qName qn)
let mbsectpr = filterElementName (wname (=="sectPr")) parsedDoc
- let sectpr = maybe (mknode "w:sectPr" [] $ ()) id mbsectpr
+ let sectpr = fromMaybe (mknode "w:sectPr" [] ()) mbsectpr
let stdAttributes =
[("xmlns:w","http://schemas.openxmlformats.org/wordprocessingml/2006/main")
@@ -166,7 +188,7 @@ writeDocx opts doc@(Pandoc meta _) = do
let contents' = contents ++ [sectpr]
let docContents = mknode "w:document" stdAttributes
- $ mknode "w:body" [] $ contents'
+ $ mknode "w:body" [] contents'
parsedRels <- parseXml refArchive distArchive "word/_rels/document.xml.rels"
let isHeaderNode e = findAttr (QName "Type" Nothing Nothing) e == Just "http://schemas.openxmlformats.org/officeDocument/2006/relationships/header"
@@ -174,7 +196,7 @@ writeDocx opts doc@(Pandoc meta _) = do
let headers = filterElements isHeaderNode parsedRels
let footers = filterElements isFooterNode parsedRels
- let extractTarget e = findAttr (QName "Target" Nothing Nothing) e
+ let extractTarget = findAttr (QName "Target" Nothing Nothing)
-- we create [Content_Types].xml and word/_rels/document.xml.rels
-- from scratch rather than reading from reference.docx,
@@ -277,7 +299,7 @@ writeDocx opts doc@(Pandoc meta _) = do
-- footnote rels
let footnoteRelEntry = toEntry "word/_rels/footnotes.xml.rels" epochtime
$ renderXml $ mknode "Relationships" [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")]
- $ linkrels
+ linkrels
-- styles
let newstyles = styleToOpenXml $ writerHighlightStyle opts
@@ -297,7 +319,8 @@ writeDocx opts doc@(Pandoc meta _) = do
-- otherwise things break:
[Elem e | e <- allElts
, qName (elName e) == "abstractNum" ] ++
- [Elem e | e <- allElts, qName (elName e) == "num" ] }
+ [Elem e | e <- allElts
+ , qName (elName e) == "num" ] }
let docPropsPath = "docProps/core.xml"
let docProps = mknode "cp:coreProperties"
[("xmlns:cp","http://schemas.openxmlformats.org/package/2006/metadata/core-properties")
@@ -308,8 +331,8 @@ writeDocx opts doc@(Pandoc meta _) = do
$ mknode "dc:title" [] (stringify $ docTitle meta)
: mknode "dc:creator" [] (intercalate "; " (map stringify $ docAuthors meta))
: maybe []
- (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] $ x
- , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] $ x
+ (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x
+ , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x
]) (normalizeDate $ stringify $ docDate meta)
let docPropsEntry = toEntry docPropsPath epochtime $ renderXml docProps
@@ -340,7 +363,7 @@ writeDocx opts doc@(Pandoc meta _) = do
settingsEntry <- entryFromArchive distArchive "word/settings.xml"
webSettingsEntry <- entryFromArchive refArchive "word/webSettings.xml"
headerFooterEntries <- mapM (entryFromArchive refArchive) $
- mapMaybe (\e -> fmap ("word/" ++) $ extractTarget e)
+ mapMaybe (fmap ("word/" ++) . extractTarget)
(headers ++ footers)
let miscRelEntries = [ e | e <- zEntries refArchive
, "word/_rels/" `isPrefixOf` (eRelativePath e)
@@ -470,7 +493,7 @@ mkLvl marker lvl =
patternFor _ s = s ++ "."
getNumId :: WS Int
-getNumId = ((999 +) . length) `fmap` gets stLists
+getNumId = (((baseListId - 1) +) . length) `fmap` gets stLists
-- | Convert Pandoc document to two lists of
-- OpenXML elements (the main document and footnotes).
@@ -501,7 +524,7 @@ writeOpenXML opts (Pandoc meta blocks) = do
let convertSpace (Str x : Space : Str y : xs) = Str (x ++ " " ++ y) : xs
convertSpace (Str x : Str y : xs) = Str (x ++ y) : xs
convertSpace xs = xs
- let blocks' = bottomUp convertSpace $ blocks
+ let blocks' = bottomUp convertSpace blocks
doc' <- blocksToOpenXML opts blocks'
notes' <- reverse `fmap` gets stFootnotes
let meta' = title ++ subtitle ++ authors ++ date ++ abstract
@@ -525,13 +548,17 @@ getUniqueId = liftIO $ (show . (+ 20) . hashUnique) `fmap` newUnique
-- | Convert a Pandoc block element to OpenXML.
blockToOpenXML :: WriterOptions -> Block -> WS [Element]
blockToOpenXML _ Null = return []
+blockToOpenXML opts (Div (_,["references"],_) bs) = do
+ let (hs, bs') = span isHeaderBlock bs
+ header <- blocksToOpenXML opts hs
+ -- We put the Bibliography style on paragraphs after the header
+ rest <- withParaProp (pStyle "Bibliography") $ blocksToOpenXML opts bs'
+ return (header ++ rest)
blockToOpenXML opts (Div _ bs) = blocksToOpenXML opts bs
blockToOpenXML opts (Header lev (ident,_,_) lst) = do
-
paraProps <- withParaProp (pStyle $ "Heading" ++ show lev) $
getParaProps False
contents <- inlinesToOpenXML opts lst
-
usedIdents <- gets stSectionIds
let bookmarkName = if null ident
then uniqueIdent lst usedIdents
@@ -581,13 +608,12 @@ blockToOpenXML opts (Table caption aligns widths headers rows) = do
let cellToOpenXML (al, cell) = withParaProp (alignmentFor al)
$ blocksToOpenXML opts cell
headers' <- mapM cellToOpenXML $ zip aligns headers
- rows' <- mapM (\cells -> mapM cellToOpenXML $ zip aligns cells)
- $ rows
+ rows' <- mapM (mapM cellToOpenXML . zip aligns) rows
let borderProps = mknode "w:tcPr" []
[ mknode "w:tcBorders" []
$ mknode "w:bottom" [("w:val","single")] ()
, mknode "w:vAlign" [("w:val","bottom")] () ]
- let emptyCell = [mknode "w:p" [] [mknode "w:pPr" [] $
+ let emptyCell = [mknode "w:p" [] [mknode "w:pPr" []
[mknode "w:pStyle" [("w:val","Compact")] ()]]]
let mkcell border contents = mknode "w:tc" []
$ [ borderProps | border ] ++
@@ -596,12 +622,15 @@ blockToOpenXML opts (Table caption aligns widths headers rows) = do
else contents
let mkrow border cells = mknode "w:tr" [] $ map (mkcell border) cells
let textwidth = 7920 -- 5.5 in in twips, 1/20 pt
+ let 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", show (floor (textwidth * w) :: Integer))] ()
return $
- [ mknode "w:tbl" []
+ mknode "w:tbl" []
( mknode "w:tblPr" []
- ( [ mknode "w:tblStyle" [("w:val","TableNormal")] () ] ++
+ ( mknode "w:tblStyle" [("w:val","TableNormal")] () :
+ mknode "w:tblW" [("w:type", "pct"), ("w:w", show rowwidth)] () :
[ mknode "w:tblCaption" [("w:val", captionStr)] ()
| not (null caption) ] )
: mknode "w:tblGrid" []
@@ -610,8 +639,7 @@ blockToOpenXML opts (Table caption aligns widths headers rows) = do
else map mkgridcol widths)
: [ mkrow True headers' | not (all null headers) ] ++
map (mkrow False) rows'
- )
- ] ++ caption'
+ ) : caption'
blockToOpenXML opts (BulletList lst) = do
let marker = BulletMarker
addList marker
@@ -678,7 +706,7 @@ getTextProps = do
props <- gets stTextProperties
return $ if null props
then []
- else [mknode "w:rPr" [] $ props]
+ else [mknode "w:rPr" [] props]
pushTextProp :: Element -> WS ()
pushTextProp d = modify $ \s -> s{ stTextProperties = d : stTextProperties s }
@@ -724,20 +752,49 @@ withParaProp d p = do
formattedString :: String -> WS [Element]
formattedString str = do
props <- getTextProps
+ inDel <- gets stInDel
return [ mknode "w:r" [] $
props ++
- [ mknode "w:t" [("xml:space","preserve")] str ] ]
+ [ mknode (if inDel then "w:delText" else "w:t")
+ [("xml:space","preserve")] str ] ]
-- | Convert an inline element to OpenXML.
inlineToOpenXML :: WriterOptions -> Inline -> WS [Element]
inlineToOpenXML _ (Str str) = formattedString str
inlineToOpenXML opts Space = inlineToOpenXML opts (Str " ")
-inlineToOpenXML opts (Span (_,classes,_) ils) = do
- let off x = withTextProp (mknode x [("w:val","0")] ())
- ((if "csl-no-emph" `elem` classes then off "w:i" else id) .
- (if "csl-no-strong" `elem` classes then off "w:b" else id) .
- (if "csl-no-smallcaps" `elem` classes then off "w:smallCaps" else id))
- $ inlinesToOpenXML opts ils
+inlineToOpenXML opts (Span (_,classes,kvs) ils)
+ | "insertion" `elem` classes = do
+ defaultAuthor <- gets stChangesAuthor
+ defaultDate <- gets stChangesDate
+ let author = fromMaybe defaultAuthor (lookup "author" kvs)
+ date = fromMaybe defaultDate (lookup "date" kvs)
+ insId <- gets stInsId
+ modify $ \s -> s{stInsId = (insId + 1)}
+ x <- inlinesToOpenXML opts ils
+ return [ mknode "w:ins" [("w:id", (show insId)),
+ ("w:author", author),
+ ("w:date", date)]
+ x ]
+ | "deletion" `elem` classes = do
+ defaultAuthor <- gets stChangesAuthor
+ defaultDate <- gets stChangesDate
+ let author = fromMaybe defaultAuthor (lookup "author" kvs)
+ date = fromMaybe defaultDate (lookup "date" kvs)
+ delId <- gets stDelId
+ modify $ \s -> s{stDelId = (delId + 1)}
+ modify $ \s -> s{stInDel = True}
+ x <- inlinesToOpenXML opts ils
+ modify $ \s -> s{stInDel = False}
+ return [ mknode "w:del" [("w:id", (show delId)),
+ ("w:author", author),
+ ("w:date", date)]
+ x ]
+ | otherwise = do
+ let off x = withTextProp (mknode x [("w:val","0")] ())
+ ((if "csl-no-emph" `elem` classes then off "w:i" else id) .
+ (if "csl-no-strong" `elem` classes then off "w:b" else id) .
+ (if "csl-no-smallcaps" `elem` classes then off "w:smallCaps" else id))
+ $ inlinesToOpenXML opts ils
inlineToOpenXML opts (Strong lst) =
withTextProp (mknode "w:b" [] ()) $ inlinesToOpenXML opts lst
inlineToOpenXML opts (Emph lst) =
@@ -912,6 +969,6 @@ parseXml refArchive distArchive relpath =
fitToPage :: (Integer, Integer) -> (Integer, Integer)
fitToPage (x, y)
--5440680 is the emu width size of a letter page in portrait, minus the margins
- | x > 5440680 =
+ | x > 5440680 =
(5440680, round $ (5440680 / ((fromIntegral :: Integer -> Double) x)) * (fromIntegral y))
| otherwise = (x, y)
diff --git a/src/Text/Pandoc/Writers/DokuWiki.hs b/src/Text/Pandoc/Writers/DokuWiki.hs
index 26f9b5f62..e02c6575d 100644
--- a/src/Text/Pandoc/Writers/DokuWiki.hs
+++ b/src/Text/Pandoc/Writers/DokuWiki.hs
@@ -40,35 +40,59 @@ DokuWiki: <https://www.dokuwiki.org/dokuwiki>
module Text.Pandoc.Writers.DokuWiki ( writeDokuWiki ) where
import Text.Pandoc.Definition
-import Text.Pandoc.Options
-import Text.Pandoc.Shared
-import Text.Pandoc.Writers.Shared
-import Text.Pandoc.Templates (renderTemplate')
+import Text.Pandoc.Options ( WriterOptions(
+ writerTableOfContents
+ , writerStandalone
+ , writerTemplate) )
+import Text.Pandoc.Shared ( escapeURI, removeFormatting, camelCaseToHyphenated
+ , trimr, normalize, substitute )
+import Text.Pandoc.Writers.Shared ( defField, metaToJSON )
+import Text.Pandoc.Templates ( renderTemplate' )
import Data.List ( intersect, intercalate, isPrefixOf )
+import Data.Default (Default(..))
import Network.URI ( isURI )
-import Control.Monad.State
+import Control.Monad ( zipWithM )
+import Control.Monad.State ( modify, State, get, evalState )
+import Control.Monad.Reader ( ReaderT, runReaderT, ask, local )
+import Control.Applicative ( (<$>) )
data WriterState = WriterState {
stNotes :: Bool -- True if there are notes
- , stIndent :: String -- Indent after the marker at the beginning of list items
+ }
+
+data WriterEnvironment = WriterEnvironment {
+ stIndent :: String -- Indent after the marker at the beginning of list items
, stUseTags :: Bool -- True if we should use HTML tags because we're in a complex list
+ , stBackSlashLB :: Bool -- True if we should produce formatted strings with newlines (as in a table cell)
}
+instance Default WriterState where
+ def = WriterState { stNotes = False }
+
+instance Default WriterEnvironment where
+ def = WriterEnvironment { stIndent = ""
+ , stUseTags = False
+ , stBackSlashLB = False }
+
+type DokuWiki = ReaderT WriterEnvironment (State WriterState)
+
-- | Convert Pandoc to DokuWiki.
writeDokuWiki :: WriterOptions -> Pandoc -> String
writeDokuWiki opts document =
- evalState (pandocToDokuWiki opts $ normalize document)
- (WriterState { stNotes = False, stIndent = "", stUseTags = False })
+ runDokuWiki (pandocToDokuWiki opts $ normalize document)
+
+runDokuWiki :: DokuWiki a -> a
+runDokuWiki = flip evalState def . flip runReaderT def
-- | Return DokuWiki representation of document.
-pandocToDokuWiki :: WriterOptions -> Pandoc -> State WriterState String
+pandocToDokuWiki :: WriterOptions -> Pandoc -> DokuWiki String
pandocToDokuWiki opts (Pandoc meta blocks) = do
metadata <- metaToJSON opts
(fmap trimr . blockListToDokuWiki opts)
(inlineListToDokuWiki opts)
meta
body <- blockListToDokuWiki opts blocks
- notesExist <- get >>= return . stNotes
+ notesExist <- stNotes <$> get
let notes = if notesExist
then "" -- TODO Was "\n<references />" Check whether I can really remove this:
-- if it is definitely to do with footnotes, can remove this whole bit
@@ -90,7 +114,7 @@ escapeString = substitute "__" "%%__%%" .
-- | Convert Pandoc block element to DokuWiki.
blockToDokuWiki :: WriterOptions -- ^ Options
-> Block -- ^ Block element
- -> State WriterState String
+ -> DokuWiki String
blockToDokuWiki _ Null = return ""
@@ -113,8 +137,8 @@ blockToDokuWiki opts (Para [Image txt (src,'f':'i':'g':':':tit)]) = do
return $ "{{:" ++ src ++ opt ++ "}}\n"
blockToDokuWiki opts (Para inlines) = do
- indent <- gets stIndent
- useTags <- gets stUseTags
+ indent <- stIndent <$> ask
+ useTags <- stUseTags <$> ask
contents <- inlineListToDokuWiki opts inlines
return $ if useTags
then "<HTML><p></HTML>" ++ contents ++ "<HTML></p></HTML>"
@@ -174,54 +198,54 @@ blockToDokuWiki opts (Table capt aligns _ headers rows') = do
unlines body'
blockToDokuWiki opts x@(BulletList items) = do
- oldUseTags <- get >>= return . stUseTags
- indent <- get >>= return . stIndent
+ oldUseTags <- stUseTags <$> ask
+ indent <- stIndent <$> ask
+ backSlash <- stBackSlashLB <$> ask
let useTags = oldUseTags || not (isSimpleList x)
if useTags
then do
- modify $ \s -> s { stUseTags = True }
- contents <- mapM (listItemToDokuWiki opts) items
- modify $ \s -> s { stUseTags = oldUseTags }
+ contents <- local (\s -> s { stUseTags = True })
+ (mapM (listItemToDokuWiki opts) items)
return $ "<HTML><ul></HTML>\n" ++ vcat contents ++ "<HTML></ul></HTML>\n"
else do
- modify $ \s -> s { stIndent = stIndent s ++ " " }
- contents <- mapM (listItemToDokuWiki opts) items
- modify $ \s -> s { stIndent = indent }
+ contents <- local (\s -> s { stIndent = stIndent s ++ " "
+ , stBackSlashLB = backSlash})
+ (mapM (listItemToDokuWiki opts) items)
return $ vcat contents ++ if null indent then "\n" else ""
blockToDokuWiki opts x@(OrderedList attribs items) = do
- oldUseTags <- get >>= return . stUseTags
- indent <- get >>= return . stIndent
+ oldUseTags <- stUseTags <$> ask
+ indent <- stIndent <$> ask
+ backSlash <- stBackSlashLB <$> ask
let useTags = oldUseTags || not (isSimpleList x)
if useTags
then do
- modify $ \s -> s { stUseTags = True }
- contents <- mapM (orderedListItemToDokuWiki opts) items
- modify $ \s -> s { stUseTags = oldUseTags }
+ contents <- local (\s -> s { stUseTags = True })
+ (mapM (orderedListItemToDokuWiki opts) items)
return $ "<HTML><ol" ++ listAttribsToString attribs ++ "></HTML>\n" ++ vcat contents ++ "<HTML></ol></HTML>\n"
else do
- modify $ \s -> s { stIndent = stIndent s ++ " " }
- contents <- mapM (orderedListItemToDokuWiki opts) items
- modify $ \s -> s { stIndent = indent }
+ contents <- local (\s -> s { stIndent = stIndent s ++ " "
+ , stBackSlashLB = backSlash})
+ (mapM (orderedListItemToDokuWiki opts) items)
return $ vcat contents ++ if null indent then "\n" else ""
-- TODO Need to decide how to make definition lists work on dokuwiki - I don't think there
-- is a specific representation of them.
-- TODO This creates double '; ; ' if there is a bullet or ordered list inside a definition list
blockToDokuWiki opts x@(DefinitionList items) = do
- oldUseTags <- get >>= return . stUseTags
- indent <- get >>= return . stIndent
+ oldUseTags <- stUseTags <$> ask
+ indent <- stIndent <$> ask
+ backSlash <- stBackSlashLB <$> ask
let useTags = oldUseTags || not (isSimpleList x)
if useTags
then do
- modify $ \s -> s { stUseTags = True }
- contents <- mapM (definitionListItemToDokuWiki opts) items
- modify $ \s -> s { stUseTags = oldUseTags }
+ contents <- local (\s -> s { stUseTags = True })
+ (mapM (definitionListItemToDokuWiki opts) items)
return $ "<HTML><dl></HTML>\n" ++ vcat contents ++ "<HTML></dl></HTML>\n"
else do
- modify $ \s -> s { stIndent = stIndent s ++ " " }
- contents <- mapM (definitionListItemToDokuWiki opts) items
- modify $ \s -> s { stIndent = indent }
+ contents <- local (\s -> s { stIndent = stIndent s ++ " "
+ , stBackSlashLB = backSlash})
+ (mapM (definitionListItemToDokuWiki opts) items)
return $ vcat contents ++ if null indent then "\n" else ""
-- Auxiliary functions for lists:
@@ -238,42 +262,48 @@ listAttribsToString (startnum, numstyle, _) =
else "")
-- | Convert bullet list item (list of blocks) to DokuWiki.
-listItemToDokuWiki :: WriterOptions -> [Block] -> State WriterState String
+listItemToDokuWiki :: WriterOptions -> [Block] -> DokuWiki String
listItemToDokuWiki opts items = do
contents <- blockListToDokuWiki opts items
- useTags <- get >>= return . stUseTags
+ useTags <- stUseTags <$> ask
if useTags
then return $ "<HTML><li></HTML>" ++ contents ++ "<HTML></li></HTML>"
else do
- indent <- get >>= return . stIndent
- return $ indent ++ "* " ++ contents
+ indent <- stIndent <$> ask
+ backSlash <- stBackSlashLB <$> ask
+ let indent' = if backSlash then (drop 2 indent) else indent
+ return $ indent' ++ "* " ++ contents
-- | Convert ordered list item (list of blocks) to DokuWiki.
-- | TODO Emiminate dreadful duplication of text from listItemToDokuWiki
-orderedListItemToDokuWiki :: WriterOptions -> [Block] -> State WriterState String
+orderedListItemToDokuWiki :: WriterOptions -> [Block] -> DokuWiki String
orderedListItemToDokuWiki opts items = do
contents <- blockListToDokuWiki opts items
- useTags <- get >>= return . stUseTags
+ useTags <- stUseTags <$> ask
if useTags
then return $ "<HTML><li></HTML>" ++ contents ++ "<HTML></li></HTML>"
else do
- indent <- get >>= return . stIndent
- return $ indent ++ "- " ++ contents
+ indent <- stIndent <$> ask
+ backSlash <- stBackSlashLB <$> ask
+ let indent' = if backSlash then (drop 2 indent) else indent
+ return $ indent' ++ "- " ++ contents
-- | Convert definition list item (label, list of blocks) to DokuWiki.
definitionListItemToDokuWiki :: WriterOptions
-> ([Inline],[[Block]])
- -> State WriterState String
+ -> DokuWiki String
definitionListItemToDokuWiki opts (label, items) = do
labelText <- inlineListToDokuWiki opts label
contents <- mapM (blockListToDokuWiki opts) items
- useTags <- get >>= return . stUseTags
+ useTags <- stUseTags <$> ask
if useTags
then return $ "<HTML><dt></HTML>" ++ labelText ++ "<HTML></dt></HTML>\n" ++
(intercalate "\n" $ map (\d -> "<HTML><dd></HTML>" ++ d ++ "<HTML></dd></HTML>") contents)
else do
- indent <- get >>= return . stIndent
- return $ indent ++ "* **" ++ labelText ++ "** " ++ concat contents
+ indent <- stIndent <$> ask
+ backSlash <- stBackSlashLB <$> ask
+ let indent' = if backSlash then (drop 2 indent) else indent
+ return $ indent' ++ "* **" ++ labelText ++ "** " ++ concat contents
-- | True if the list can be handled by simple wiki markup, False if HTML tags will be needed.
isSimpleList :: Block -> Bool
@@ -319,6 +349,13 @@ isSimpleBlockQuote _ = False
vcat :: [String] -> String
vcat = intercalate "\n"
+backSlashLineBreaks :: String -> String
+backSlashLineBreaks cs = reverse $ g $ reverse $ concatMap f cs
+ where f '\n' = "\\\\ "
+ f c = [c]
+ g (' ' : '\\':'\\': xs) = xs
+ g s = s
+
-- Auxiliary functions for tables:
-- TODO Eliminate copy-and-pasted code in tableHeaderToDokuWiki and tableRowToDokuWiki
@@ -326,11 +363,11 @@ tableHeaderToDokuWiki :: WriterOptions
-> [String]
-> Int
-> [[Block]]
- -> State WriterState String
+ -> DokuWiki String
tableHeaderToDokuWiki opts alignStrings rownum cols' = do
let celltype = if rownum == 0 then "" else ""
- cols'' <- sequence $ zipWith
- (\alignment item -> tableItemToDokuWiki opts celltype alignment item)
+ cols'' <- zipWithM
+ (tableItemToDokuWiki opts celltype)
alignStrings cols'
return $ "^ " ++ "" ++ joinHeaders cols'' ++ " ^"
@@ -338,11 +375,11 @@ tableRowToDokuWiki :: WriterOptions
-> [String]
-> Int
-> [[Block]]
- -> State WriterState String
+ -> DokuWiki String
tableRowToDokuWiki opts alignStrings rownum cols' = do
let celltype = if rownum == 0 then "" else ""
- cols'' <- sequence $ zipWith
- (\alignment item -> tableItemToDokuWiki opts celltype alignment item)
+ cols'' <- zipWithM
+ (tableItemToDokuWiki opts celltype)
alignStrings cols'
return $ "| " ++ "" ++ joinColumns cols'' ++ " |"
@@ -357,11 +394,12 @@ tableItemToDokuWiki :: WriterOptions
-> String
-> String
-> [Block]
- -> State WriterState String
+ -> DokuWiki String
-- TODO Fix celltype and align' defined but not used
tableItemToDokuWiki opts _celltype _align' item = do
let mkcell x = "" ++ x ++ ""
- contents <- blockListToDokuWiki opts item
+ contents <- local (\s -> s { stBackSlashLB = True }) $
+ blockListToDokuWiki opts item
return $ mkcell contents
-- | Concatenates columns together.
@@ -375,20 +413,23 @@ joinHeaders = intercalate " ^ "
-- | Convert list of Pandoc block elements to DokuWiki.
blockListToDokuWiki :: WriterOptions -- ^ Options
-> [Block] -- ^ List of block elements
- -> State WriterState String
-blockListToDokuWiki opts blocks =
- mapM (blockToDokuWiki opts) blocks >>= return . vcat
+ -> DokuWiki String
+blockListToDokuWiki opts blocks = do
+ backSlash <- stBackSlashLB <$> ask
+ if backSlash
+ then (backSlashLineBreaks . vcat) <$> mapM (blockToDokuWiki opts) blocks
+ else vcat <$> mapM (blockToDokuWiki opts) blocks
-- | Convert list of Pandoc inline elements to DokuWiki.
-inlineListToDokuWiki :: WriterOptions -> [Inline] -> State WriterState String
-inlineListToDokuWiki opts lst = mapM (inlineToDokuWiki opts) lst >>= return . concat
+inlineListToDokuWiki :: WriterOptions -> [Inline] -> DokuWiki String
+inlineListToDokuWiki opts lst =
+ concat <$> (mapM (inlineToDokuWiki opts) lst)
-- | Convert Pandoc inline element to DokuWiki.
-inlineToDokuWiki :: WriterOptions -> Inline -> State WriterState String
+inlineToDokuWiki :: WriterOptions -> Inline -> DokuWiki String
-inlineToDokuWiki opts (Span _attrs ils) = do
- contents <- inlineListToDokuWiki opts ils
- return contents
+inlineToDokuWiki opts (Span _attrs ils) =
+ inlineListToDokuWiki opts ils
inlineToDokuWiki opts (Emph lst) = do
contents <- inlineListToDokuWiki opts lst
@@ -461,11 +502,10 @@ inlineToDokuWiki opts (Link txt (src, _)) = do
_ -> src -- link to a help page
inlineToDokuWiki opts (Image alt (source, tit)) = do
alt' <- inlineListToDokuWiki opts alt
- let txt = if (null tit)
- then if null alt
- then ""
- else "|" ++ alt'
- else "|" ++ tit
+ let txt = case (tit, alt) of
+ ("", []) -> ""
+ ("", _ ) -> "|" ++ alt'
+ (_ , _ ) -> "|" ++ tit
return $ "{{:" ++ source ++ txt ++ "}}"
inlineToDokuWiki opts (Note contents) = do
diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs
index 62986df75..ffd5bf101 100644
--- a/src/Text/Pandoc/Writers/EPUB.hs
+++ b/src/Text/Pandoc/Writers/EPUB.hs
@@ -94,7 +94,7 @@ data EPUBMetadata = EPUBMetadata{
, epubRights :: Maybe String
, epubCoverImage :: Maybe String
, epubStylesheet :: Maybe Stylesheet
- , epubPageDirection :: ProgressionDirection
+ , epubPageDirection :: Maybe ProgressionDirection
} deriving Show
data Stylesheet = StylesheetPath FilePath
@@ -123,7 +123,7 @@ data Title = Title{
, titleType :: Maybe String
} deriving Show
-data ProgressionDirection = LTR | RTL | Default deriving Show
+data ProgressionDirection = LTR | RTL deriving Show
dcName :: String -> QName
dcName n = QName n Nothing (Just "dc")
@@ -322,14 +322,11 @@ metadataFromMeta opts meta = EPUBMetadata{
stylesheet = (StylesheetContents <$> writerEpubStylesheet opts) `mplus`
((StylesheetPath . metaValueToString) <$>
lookupMeta "stylesheet" meta)
- pageDirection = maybe Default stringToPageDirection
- (lookupMeta "page-progression-direction" meta)
- stringToPageDirection (metaValueToString -> s) =
- case s of
- "ltr" -> LTR
- "rtl" -> RTL
- _ -> Default
-
+ pageDirection = case map toLower . metaValueToString <$>
+ lookupMeta "page-progression-direction" meta of
+ Just "ltr" -> Just LTR
+ Just "rtl" -> Just RTL
+ _ -> Nothing
-- | Produce an EPUB file from a Pandoc document.
writeEPUB :: WriterOptions -- ^ Writer options
@@ -394,11 +391,13 @@ writeEPUB opts doc@(Pandoc meta _) = do
let mkFontEntry f = mkEntry (takeFileName f) `fmap` B.readFile f
fontEntries <- mapM mkFontEntry $ writerEpubFonts opts'
- -- set page progression direction
+ -- set page progression direction attribution
let progressionDirection = case epubPageDirection metadata of
- LTR -> "ltr"
- RTL -> "rtl"
- Default -> "default"
+ Just LTR | epub3 ->
+ [("page-progression-direction", "ltr")]
+ Just RTL | epub3 ->
+ [("page-progression-direction", "rtl")]
+ _ -> []
-- body pages
@@ -519,8 +518,7 @@ writeEPUB opts doc@(Pandoc meta _) = do
(pictureNode x)]) ++
map pictureNode picEntries ++
map fontNode fontEntries
- , unode "spine" ! [("toc","ncx")
- ,("page-progression-direction", progressionDirection)] $
+ , unode "spine" ! ([("toc","ncx")] ++ progressionDirection) $
case epubCoverImage metadata of
Nothing -> []
Just _ -> [ unode "itemref" !
diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs
index d200ecee1..acbe8a48d 100644
--- a/src/Text/Pandoc/Writers/LaTeX.hs
+++ b/src/Text/Pandoc/Writers/LaTeX.hs
@@ -465,18 +465,24 @@ blockToLaTeX (DefinitionList lst) = do
return $ text ("\\begin{description}" ++ inc) $$ spacing $$ vcat items $$
"\\end{description}"
blockToLaTeX HorizontalRule = return $
- "\\begin{center}\\rule{3in}{0.4pt}\\end{center}"
+ "\\begin{center}\\rule{0.5\\linewidth}{\\linethickness}\\end{center}"
blockToLaTeX (Header level (id',classes,_) lst) =
sectionHeader ("unnumbered" `elem` classes) id' level lst
blockToLaTeX (Table caption aligns widths heads rows) = do
headers <- if all null heads
then return empty
- else ($$ "\\midrule\\endhead") `fmap`
+ else ($$ "\\midrule\n") `fmap`
(tableRowToLaTeX True aligns widths) heads
+ let endhead = if all null heads
+ then empty
+ else text "\\endhead"
captionText <- inlineListToLaTeX caption
let capt = if isEmpty captionText
then empty
- else text "\\caption" <> braces captionText <> "\\\\"
+ else text "\\caption" <> braces captionText
+ <> "\\tabularnewline\n\\toprule\n"
+ <> headers
+ <> "\\endfirsthead"
rows' <- mapM (tableRowToLaTeX False aligns widths) rows
let colDescriptors = text $ concat $ map toColDescriptor aligns
modify $ \s -> s{ stTable = True }
@@ -484,8 +490,9 @@ blockToLaTeX (Table caption aligns widths heads rows) = do
braces ("@{}" <> colDescriptors <> "@{}")
-- the @{} removes extra space at beginning and end
$$ capt
- $$ "\\toprule\\addlinespace"
+ $$ "\\toprule"
$$ headers
+ $$ endhead
$$ vcat rows'
$$ "\\bottomrule"
$$ "\\end{longtable}"
@@ -512,7 +519,7 @@ tableRowToLaTeX header aligns widths cols = do
let scaleFactor = 0.97 ** fromIntegral (length aligns)
let widths' = map (scaleFactor *) widths
cells <- mapM (tableCellToLaTeX header) $ zip3 widths' aligns cols
- return $ hsep (intersperse "&" cells) $$ "\\\\\\addlinespace"
+ return $ hsep (intersperse "&" cells) <> "\\tabularnewline"
-- For simple latex tables (without minipages or parboxes),
-- we need to go to some lengths to get line breaks working:
@@ -549,7 +556,8 @@ tableCellToLaTeX header (width, align, blocks) = do
AlignDefault -> "\\raggedright"
return $ ("\\begin{minipage}" <> valign <>
braces (text (printf "%.2f\\columnwidth" width)) <>
- (halign <> cr <> cellContents <> cr) <> "\\end{minipage}")
+ (halign <> "\\strut" <> cr <> cellContents <> cr) <>
+ "\\strut\\end{minipage}")
$$ case notes of
[] -> empty
ns -> (case length ns of
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-03 01:39:14 +0000