diff options
Diffstat (limited to 'src/Text/Pandoc/Writers')
36 files changed, 939 insertions, 616 deletions
diff --git a/src/Text/Pandoc/Writers/AsciiDoc.hs b/src/Text/Pandoc/Writers/AsciiDoc.hs index f91fa8fa0..036185282 100644 --- a/src/Text/Pandoc/Writers/AsciiDoc.hs +++ b/src/Text/Pandoc/Writers/AsciiDoc.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -37,6 +38,7 @@ that it has omitted the construct. AsciiDoc: <http://www.methods.co.nz/asciidoc/> -} module Text.Pandoc.Writers.AsciiDoc (writeAsciiDoc) where +import Prelude import Control.Monad.State.Strict import Data.Aeson (Result (..), Value (String), fromJSON, toJSON) import Data.Char (isPunctuation, isSpace) diff --git a/src/Text/Pandoc/Writers/CommonMark.hs b/src/Text/Pandoc/Writers/CommonMark.hs index 7a6eb2948..98c1101fa 100644 --- a/src/Text/Pandoc/Writers/CommonMark.hs +++ b/src/Text/Pandoc/Writers/CommonMark.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2015-2018 John MacFarlane <jgm@berkeley.edu> @@ -32,11 +33,12 @@ CommonMark: <http://commonmark.org> -} module Text.Pandoc.Writers.CommonMark (writeCommonMark) where +import Prelude import CMarkGFM import Control.Monad.State.Strict (State, get, modify, runState) import Data.Foldable (foldrM) import Data.List (transpose) -import Data.Monoid (Any (..), (<>)) +import Data.Monoid (Any (..)) import Data.Text (Text) import qualified Data.Text as T import Network.HTTP (urlEncode) @@ -114,7 +116,7 @@ blockToNodes _ (CodeBlock (_,classes,_) xs) ns = return blockToNodes opts (RawBlock fmt xs) ns | fmt == Format "html" && isEnabled Ext_raw_html opts = return (node (HTML_BLOCK (T.pack xs)) [] : ns) - | fmt == Format "latex" || fmt == Format "tex" && isEnabled Ext_raw_tex opts + | (fmt == Format "latex" || fmt == Format "tex") && isEnabled Ext_raw_tex opts = return (node (CUSTOM_BLOCK (T.pack xs) T.empty) [] : ns) | otherwise = return ns blockToNodes opts (BlockQuote bs) ns = do diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs index f94c12d89..10e996bdb 100644 --- a/src/Text/Pandoc/Writers/ConTeXt.hs +++ b/src/Text/Pandoc/Writers/ConTeXt.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- @@ -30,6 +31,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' format into ConTeXt. -} module Text.Pandoc.Writers.ConTeXt ( writeConTeXt ) where +import Prelude import Control.Monad.State.Strict import Data.Char (ord, isDigit) import Data.List (intercalate, intersperse) diff --git a/src/Text/Pandoc/Writers/Custom.hs b/src/Text/Pandoc/Writers/Custom.hs index 37b44b646..53b321c7c 100644 --- a/src/Text/Pandoc/Writers/Custom.hs +++ b/src/Text/Pandoc/Writers/Custom.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {- Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of 'Pandoc' documents to custom markup using a lua writer. -} module Text.Pandoc.Writers.Custom ( writeCustom ) where +import Prelude import Control.Arrow ((***)) import Control.Exception import Control.Monad (when) @@ -44,7 +46,7 @@ import Foreign.Lua.Api import Text.Pandoc.Class (PandocIO) import Text.Pandoc.Definition import Text.Pandoc.Error -import Text.Pandoc.Lua.Init (runPandocLua) +import Text.Pandoc.Lua.Init (runPandocLua, registerScriptPath) import Text.Pandoc.Lua.StackInstances () import Text.Pandoc.Lua.Util (addValue, dostring') import Text.Pandoc.Options @@ -106,6 +108,7 @@ writeCustom :: FilePath -> WriterOptions -> Pandoc -> PandocIO Text writeCustom luaFile opts doc@(Pandoc meta _) = do luaScript <- liftIO $ UTF8.readFile luaFile res <- runPandocLua $ do + registerScriptPath luaFile stat <- dostring' luaScript -- check for error in lua script (later we'll change the return type -- to handle this more gracefully): diff --git a/src/Text/Pandoc/Writers/Docbook.hs b/src/Text/Pandoc/Writers/Docbook.hs index 3034fade5..f6e814095 100644 --- a/src/Text/Pandoc/Writers/Docbook.hs +++ b/src/Text/Pandoc/Writers/Docbook.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {- @@ -30,6 +31,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to Docbook XML. -} module Text.Pandoc.Writers.Docbook ( writeDocbook4, writeDocbook5 ) where +import Prelude import Control.Monad.Reader import Data.Char (toLower) import Data.Generics (everywhere, mkT) diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index 5ad6bf82b..1666c0562 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -32,6 +33,7 @@ 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 Prelude import Codec.Archive.Zip import Control.Applicative ((<|>)) import Control.Monad.Except (catchError) @@ -51,7 +53,7 @@ import System.Random (randomR, StdGen, mkStdGen) import Text.Pandoc.BCP47 (getLang, renderLang) import Text.Pandoc.Class (PandocMonad, report, toLang) import qualified Text.Pandoc.Class as P -import Text.Pandoc.Compat.Time +import Data.Time import Text.Pandoc.Definition import Text.Pandoc.Generic import Text.Pandoc.Highlighting (highlight) @@ -123,7 +125,7 @@ data WriterState = WriterState{ , stComments :: [([(String,String)], [Inline])] , stSectionIds :: Set.Set String , stExternalLinks :: M.Map String String - , stImages :: M.Map FilePath (String, String, Maybe MimeType, Element, B.ByteString) + , stImages :: M.Map FilePath (String, String, Maybe MimeType, B.ByteString) , stLists :: [ListMarker] , stInsId :: Int , stDelId :: Int @@ -294,7 +296,7 @@ writeDocx opts doc@(Pandoc meta _) = do let imgs = M.elems $ stImages st -- create entries for images in word/media/... - let toImageEntry (_,path,_,_,img) = toEntry ("word/" ++ path) epochtime $ toLazy img + let toImageEntry (_,path,_,img) = toEntry ("word/" ++ path) epochtime $ toLazy img let imageEntries = map toImageEntry imgs let stdAttributes = @@ -326,7 +328,7 @@ writeDocx opts doc@(Pandoc meta _) = do -- [Content_Types].xml let mkOverrideNode (part', contentType') = mknode "Override" [("PartName",part'),("ContentType",contentType')] () - let mkImageOverride (_, imgpath, mbMimeType, _, _) = + let mkImageOverride (_, imgpath, mbMimeType, _) = mkOverrideNode ("/word/" ++ imgpath, fromMaybe "application/octet-stream" mbMimeType) let mkMediaOverride imgpath = @@ -407,7 +409,7 @@ writeDocx opts doc@(Pandoc meta _) = 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",ident),("Target",path)] () let imgrels = map toImgRel imgs let toLinkRel (src,ident) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink"),("Id",ident),("Target",src),("TargetMode","External") ] () let linkrels = map toLinkRel $ M.toList $ stExternalLinks st @@ -708,12 +710,12 @@ mkLvl marker lvl = styleFor UpperRoman _ = "upperRoman" styleFor LowerRoman _ = "lowerRoman" styleFor Decimal _ = "decimal" - styleFor DefaultStyle 1 = "decimal" - styleFor DefaultStyle 2 = "lowerLetter" - styleFor DefaultStyle 3 = "lowerRoman" - styleFor DefaultStyle 4 = "decimal" - styleFor DefaultStyle 5 = "lowerLetter" - styleFor DefaultStyle 0 = "lowerRoman" + styleFor DefaultStyle 0 = "decimal" + styleFor DefaultStyle 1 = "lowerLetter" + styleFor DefaultStyle 2 = "lowerRoman" + styleFor DefaultStyle 3 = "decimal" + styleFor DefaultStyle 4 = "lowerLetter" + styleFor DefaultStyle 5 = "lowerRoman" styleFor DefaultStyle x = styleFor DefaultStyle (x `mod` 6) styleFor _ _ = "decimal" patternFor OneParen s = s ++ ")" @@ -1109,6 +1111,9 @@ inlineToOpenXML' _ (Str str) = formattedString str inlineToOpenXML' opts Space = inlineToOpenXML opts (Str " ") inlineToOpenXML' opts SoftBreak = inlineToOpenXML opts (Str " ") +inlineToOpenXML' opts (Span (_,["underline"],_) ils) = do + withTextProp (mknode "w:u" [("w:val","single")] ()) $ + inlinesToOpenXML opts ils inlineToOpenXML' _ (Span (ident,["comment-start"],kvs) ils) = do -- prefer the "id" in kvs, since that is the one produced by the docx -- reader. @@ -1275,87 +1280,103 @@ inlineToOpenXML' opts (Link _ txt (src,_)) = do return i return [ mknode "w:hyperlink" [("r:id",id')] contents ] inlineToOpenXML' opts (Image attr alt (src, title)) = do - -- first, check to see if we've already done this image pageWidth <- asks envPrintWidth imgs <- gets stImages - case M.lookup src imgs of - Just (_,_,_,elt,_) -> return [elt] - Nothing -> - catchError - (do (img, mt) <- P.fetchItem src - ident <- ("rId"++) `fmap` getUniqueId - let (xpt,ypt) = desiredSizeInPoints opts attr - (either (const def) id (imageSize opts img)) - -- 12700 emu = 1 pt - let (xemu,yemu) = fitToPage (xpt * 12700, ypt * 12700) - (pageWidth * 12700) - let cNvPicPr = mknode "pic:cNvPicPr" [] $ - mknode "a:picLocks" [("noChangeArrowheads","1") - ,("noChangeAspect","1")] () - let nvPicPr = mknode "pic:nvPicPr" [] - [ mknode "pic:cNvPr" - [("descr",src),("id","0"),("name","Picture")] () - , cNvPicPr ] - let blipFill = mknode "pic:blipFill" [] - [ mknode "a:blip" [("r:embed",ident)] () - , mknode "a:stretch" [] $ - mknode "a:fillRect" [] () ] - let xfrm = mknode "a:xfrm" [] - [ mknode "a:off" [("x","0"),("y","0")] () - , mknode "a:ext" [("cx",show xemu) - ,("cy",show yemu)] () ] - let prstGeom = mknode "a:prstGeom" [("prst","rect")] $ - mknode "a:avLst" [] () - let ln = mknode "a:ln" [("w","9525")] - [ mknode "a:noFill" [] () - , mknode "a:headEnd" [] () - , mknode "a:tailEnd" [] () ] - let spPr = mknode "pic:spPr" [("bwMode","auto")] - [xfrm, prstGeom, mknode "a:noFill" [] (), ln] - let graphic = mknode "a:graphic" [] $ - mknode "a:graphicData" - [("uri","http://schemas.openxmlformats.org/drawingml/2006/picture")] - [ mknode "pic:pic" [] - [ nvPicPr - , blipFill - , spPr ] ] - let imgElt = mknode "w:r" [] $ - mknode "w:drawing" [] $ - mknode "wp:inline" [] - [ mknode "wp:extent" [("cx",show xemu),("cy",show yemu)] () - , mknode "wp:effectExtent" - [("b","0"),("l","0"),("r","0"),("t","0")] () - , mknode "wp:docPr" [("descr",stringify alt) - ,("title", title) - ,("id","1") - ,("name","Picture")] () - , graphic ] - let imgext = case mt >>= extensionFromMimeType of - Just x -> '.':x - Nothing -> case imageType img of - Just Png -> ".png" - Just Jpeg -> ".jpeg" - Just Gif -> ".gif" - Just Pdf -> ".pdf" - Just Eps -> ".eps" - Just Svg -> ".svg" - Just Emf -> ".emf" - Nothing -> "" - if null imgext - then -- without an extension there is no rule for content type - inlinesToOpenXML opts alt -- return alt to avoid corrupted docx - else do - let imgpath = "media/" ++ ident ++ imgext - let mbMimeType = mt <|> getMimeType imgpath - -- insert mime type to use in constructing [Content_Types].xml - modify $ \st -> st{ stImages = - M.insert src (ident, imgpath, mbMimeType, imgElt, img) - $ stImages st } - return [imgElt]) - (\e -> do - report $ CouldNotFetchResource src (show e) - -- emit alt text - inlinesToOpenXML opts alt) + let + stImage = M.lookup src imgs + generateImgElt (ident, _, _, img) = + let + (xpt,ypt) = desiredSizeInPoints opts attr + (either (const def) id (imageSize opts img)) + -- 12700 emu = 1 pt + (xemu,yemu) = fitToPage (xpt * 12700, ypt * 12700) + (pageWidth * 12700) + cNvPicPr = mknode "pic:cNvPicPr" [] $ + mknode "a:picLocks" [("noChangeArrowheads","1") + ,("noChangeAspect","1")] () + nvPicPr = mknode "pic:nvPicPr" [] + [ mknode "pic:cNvPr" + [("descr",src),("id","0"),("name","Picture")] () + , cNvPicPr ] + blipFill = mknode "pic:blipFill" [] + [ mknode "a:blip" [("r:embed",ident)] () + , mknode "a:stretch" [] $ + mknode "a:fillRect" [] () + ] + xfrm = mknode "a:xfrm" [] + [ mknode "a:off" [("x","0"),("y","0")] () + , mknode "a:ext" [("cx",show xemu) + ,("cy",show yemu)] () ] + prstGeom = mknode "a:prstGeom" [("prst","rect")] $ + mknode "a:avLst" [] () + ln = mknode "a:ln" [("w","9525")] + [ mknode "a:noFill" [] () + , mknode "a:headEnd" [] () + , mknode "a:tailEnd" [] () ] + spPr = mknode "pic:spPr" [("bwMode","auto")] + [xfrm, prstGeom, mknode "a:noFill" [] (), ln] + graphic = mknode "a:graphic" [] $ + mknode "a:graphicData" + [("uri","http://schemas.openxmlformats.org/drawingml/2006/picture")] + [ mknode "pic:pic" [] + [ nvPicPr + , blipFill + , spPr + ] + ] + imgElt = mknode "w:r" [] $ + mknode "w:drawing" [] $ + mknode "wp:inline" [] + [ mknode "wp:extent" [("cx",show xemu),("cy",show yemu)] () + , mknode "wp:effectExtent" + [("b","0"),("l","0"),("r","0"),("t","0")] () + , mknode "wp:docPr" + [ ("descr", stringify alt) + , ("title", title) + , ("id","1") + , ("name","Picture") + ] () + , graphic + ] + in + imgElt + + case stImage of + Just imgData -> return [generateImgElt imgData] + Nothing -> ( do --try + (img, mt) <- P.fetchItem src + ident <- ("rId"++) `fmap` getUniqueId + + let + imgext = case mt >>= extensionFromMimeType of + Just x -> '.':x + Nothing -> case imageType img of + Just Png -> ".png" + Just Jpeg -> ".jpeg" + Just Gif -> ".gif" + Just Pdf -> ".pdf" + Just Eps -> ".eps" + Just Svg -> ".svg" + Just Emf -> ".emf" + Nothing -> "" + imgpath = "media/" ++ ident ++ imgext + mbMimeType = mt <|> getMimeType imgpath + + imgData = (ident, imgpath, mbMimeType, img) + + if null imgext + then -- without an extension there is no rule for content type + inlinesToOpenXML opts alt -- return alt to avoid corrupted docx + else do + -- insert mime type to use in constructing [Content_Types].xml + modify $ \st -> st { stImages = M.insert src imgData $ stImages st } + return [generateImgElt imgData] + ) + `catchError` ( \e -> do + report $ CouldNotFetchResource src (show e) + -- emit alt text + inlinesToOpenXML opts alt + ) br :: Element br = breakElement "textWrapping" @@ -1370,12 +1391,12 @@ breakElement kind = mknode "w:r" [] [mknode "w:br" [("w:type",kind)] () ] defaultFootnotes :: [Element] defaultFootnotes = [ mknode "w:footnote" [("w:type", "separator"), ("w:id", "-1")] - [ mknode "w:p" [] $ + [ mknode "w:p" [] [mknode "w:r" [] $ [ mknode "w:separator" [] ()]]] , mknode "w:footnote" [("w:type", "continuationSeparator"), ("w:id", "0")] - [ mknode "w:p" [] $ + [ mknode "w:p" [] [ mknode "w:r" [] $ [ mknode "w:continuationSeparator" [] ()]]]] diff --git a/src/Text/Pandoc/Writers/DokuWiki.hs b/src/Text/Pandoc/Writers/DokuWiki.hs index dda21d23d..189bf138e 100644 --- a/src/Text/Pandoc/Writers/DokuWiki.hs +++ b/src/Text/Pandoc/Writers/DokuWiki.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2008-2018 John MacFarlane <jgm@berkeley.edu> @@ -39,6 +40,7 @@ DokuWiki: <https://www.dokuwiki.org/dokuwiki> -} module Text.Pandoc.Writers.DokuWiki ( writeDokuWiki ) where +import Prelude import Control.Monad (zipWithM) import Control.Monad.Reader (ReaderT, ask, local, runReaderT) import Control.Monad.State.Strict (StateT, evalStateT) @@ -366,12 +368,16 @@ isSimpleBlockQuote bs = all isPlainOrPara bs 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 +-- | For each string in the input list, convert all newlines to +-- dokuwiki escaped newlines. Then concat the list using double linebreaks. +backSlashLineBreaks :: [String] -> String +backSlashLineBreaks ls = vcatBackSlash $ map escape ls + where + vcatBackSlash = intercalate "\\\\ \\\\ " -- simulate paragraphs. + escape ['\n'] = "" -- remove trailing newlines + escape ('\n':cs) = "\\\\ " ++ escape cs + escape (c:cs) = c : escape cs + escape [] = [] -- Auxiliary functions for tables: @@ -400,7 +406,7 @@ blockListToDokuWiki opts blocks = do backSlash <- stBackSlashLB <$> ask let blocks' = consolidateRawBlocks blocks if backSlash - then (backSlashLineBreaks . vcat) <$> mapM (blockToDokuWiki opts) blocks' + then backSlashLineBreaks <$> mapM (blockToDokuWiki opts) blocks' else vcat <$> mapM (blockToDokuWiki opts) blocks' consolidateRawBlocks :: [Block] -> [Block] @@ -479,7 +485,11 @@ inlineToDokuWiki _ il@(RawInline f str) | f == Format "html" = return $ "<html>" ++ str ++ "</html>" | otherwise = "" <$ report (InlineNotRendered il) -inlineToDokuWiki _ LineBreak = return "\\\\\n" +inlineToDokuWiki _ LineBreak = do + backSlash <- stBackSlashLB <$> ask + return $ if backSlash + then "\n" + else "\\\\\n" inlineToDokuWiki opts SoftBreak = case writerWrapText opts of diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs index 7b4853a24..f1ff8b482 100644 --- a/src/Text/Pandoc/Writers/EPUB.hs +++ b/src/Text/Pandoc/Writers/EPUB.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternGuards #-} @@ -32,6 +33,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to EPUB. -} module Text.Pandoc.Writers.EPUB ( writeEPUB2, writeEPUB3 ) where +import Prelude import Codec.Archive.Zip (Entry, addEntryToArchive, eRelativePath, emptyArchive, fromArchive, fromEntry, toEntry) import Control.Monad (mplus, unless, when, zipWithM) @@ -53,7 +55,7 @@ import Text.HTML.TagSoup (Tag (TagOpen), fromAttrib, parseTags) import Text.Pandoc.Builder (fromList, setMeta) import Text.Pandoc.Class (PandocMonad, report) import qualified Text.Pandoc.Class as P -import Text.Pandoc.Compat.Time +import Data.Time import Text.Pandoc.Definition import Text.Pandoc.Error import Text.Pandoc.Logging @@ -401,6 +403,12 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do writeHtmlStringForEPUB version o metadata <- getEPUBMetadata opts meta + let plainTitle = case docTitle' meta of + [] -> case epubTitle metadata of + [] -> "UNTITLED" + (x:_) -> titleText x + x -> stringify x + -- stylesheet stylesheets <- case epubStylesheets metadata of [] -> (\x -> [B.fromChunks [x]]) <$> @@ -438,6 +446,7 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do cpContent <- lift $ writeHtml opts'{ writerVariables = ("coverpage","true"): + ("pagetitle",plainTitle): cssvars True ++ vars } (Pandoc meta [RawBlock (Format "html") $ "<div id=\"cover-image\">\n<img src=\"../media/" ++ coverImage ++ "\" alt=\"cover image\" />\n</div>"]) imgContent <- lift $ P.readFileLazy img @@ -450,6 +459,7 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do -- title page tpContent <- lift $ writeHtml opts'{ writerVariables = ("titlepage","true"): + ("pagetitle",plainTitle): cssvars True ++ vars } (Pandoc meta []) tpEntry <- mkEntry "text/title_page.xhtml" tpContent @@ -458,7 +468,7 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do -- mediaRef <- P.newIORef [] Pandoc _ blocks <- walkM (transformInline opts') doc >>= walkM transformBlock - picEntries <- (mapMaybe (snd . snd)) <$> gets stMediaPaths + picEntries <- mapMaybe (snd . snd) <$> gets stMediaPaths -- handle fonts let matchingGlob f = do xs <- lift $ P.glob f @@ -602,11 +612,6 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do $ eRelativePath ent), ("media-type", fromMaybe "" $ getMimeType $ eRelativePath ent)] $ () - let plainTitle = case docTitle' meta of - [] -> case epubTitle metadata of - [] -> "UNTITLED" - (x:_) -> titleText x - x -> stringify x let tocTitle = fromMaybe plainTitle $ metaValueToString <$> lookupMeta "toc-title" meta @@ -747,14 +752,18 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do where titElements = parseXML titRendered titRendered = case P.runPure (writeHtmlStringForEPUB version - opts{ writerTemplate = Nothing } + opts{ writerTemplate = Nothing + , writerVariables = + ("pagetitle",plainTitle): + writerVariables opts} (Pandoc nullMeta - [Plain $ walk delink tit])) of + [Plain $ walk clean tit])) of Left _ -> TS.pack $ stringify tit Right x -> x - -- can't have a element inside a... - delink (Link _ ils _) = Span ("", [], []) ils - delink x = x + -- can't have <a> elements inside generated links... + clean (Link _ ils _) = Span ("", [], []) ils + clean (Note _) = Str "" + clean x = x let navtag = if epub3 then "nav" else "div" tocBlocks <- lift $ evalStateT (mapM (navPointNode navXhtmlFormatter) secs) 1 @@ -872,7 +881,7 @@ metadataElement version md currentTime = dcTag' n s = [dcTag n s] toIdentifierNode id' (Identifier txt scheme) | version == EPUB2 = [dcNode "identifier" ! - ([("id",id')] ++ maybe [] (\x -> [("opf:scheme", x)]) scheme) $ + (("id",id') : maybe [] (\x -> [("opf:scheme", x)]) scheme) $ txt] | otherwise = [dcNode "identifier" ! [("id",id')] $ txt] ++ maybe [] (\x -> [unode "meta" ! diff --git a/src/Text/Pandoc/Writers/FB2.hs b/src/Text/Pandoc/Writers/FB2.hs index e322c7d98..a46011a8f 100644 --- a/src/Text/Pandoc/Writers/FB2.hs +++ b/src/Text/Pandoc/Writers/FB2.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PatternGuards #-} {- @@ -37,6 +38,7 @@ FictionBook is an XML-based e-book format. For more information see: -} module Text.Pandoc.Writers.FB2 (writeFB2) where +import Prelude import Control.Monad (zipWithM) import Control.Monad.Except (catchError) import Control.Monad.State.Strict (StateT, evalStateT, get, lift, liftM, modify) @@ -44,7 +46,7 @@ import Data.ByteString.Base64 (encode) import qualified Data.ByteString.Char8 as B8 import Data.Char (isAscii, isControl, isSpace, toLower) import Data.Either (lefts, rights) -import Data.List (intercalate, intersperse, isPrefixOf, stripPrefix) +import Data.List (intercalate, isPrefixOf, stripPrefix) import Data.Text (Text, pack) import Network.HTTP (urlEncode) import Text.XML.Light @@ -116,6 +118,9 @@ description meta' = do bt <- booktitle meta' let as = authors meta' dd <- docdate meta' + annotation <- case lookupMeta "abstract" meta' of + Just (MetaBlocks bs) -> (list . el "annotation") <$> cMapM blockToXml bs + _ -> pure mempty let lang = case lookupMeta "lang" meta' of Just (MetaInlines [Str s]) -> [el "lang" $ iso639 s] Just (MetaString s) -> [el "lang" $ iso639 s] @@ -130,7 +135,7 @@ description meta' = do Just (MetaString s) -> coverimage s _ -> return [] return $ el "description" - [ el "title-info" (genre : (bt ++ as ++ dd ++ lang)) + [ el "title-info" (genre : (bt ++ annotation ++ as ++ dd ++ lang)) , el "document-info" (el "program-used" "pandoc" : coverpage) ] @@ -178,7 +183,7 @@ renderSection :: PandocMonad m => Int -> ([Inline], [Block]) -> FBM m Content renderSection level (ttl, body) = do title <- if null ttl then return [] - else return . list . el "title" . formatTitle $ ttl + else list . el "title" <$> formatTitle ttl content <- if hasSubsections body then renderSections (level + 1) body else cMapM blockToXml body @@ -187,11 +192,9 @@ renderSection level (ttl, body) = do hasSubsections = any isHeaderBlock -- | Only <p> and <empty-line> are allowed within <title> in FB2. -formatTitle :: [Inline] -> [Content] +formatTitle :: PandocMonad m => [Inline] -> FBM m [Content] formatTitle inlines = - let lns = split isLineBreak inlines - lns' = map (el "p" . cMap plain) lns - in intersperse (el "empty-line" ()) lns' + cMapM (blockToXml . Para) $ split (== LineBreak) inlines split :: (a -> Bool) -> [a] -> [[a]] split _ [] = [] @@ -311,9 +314,6 @@ isMimeType s = footnoteID :: Int -> String footnoteID i = "n" ++ show i -linkID :: Int -> String -linkID i = "l" ++ show i - -- | Convert a block-level Pandoc's element to FictionBook XML representation. blockToXml :: PandocMonad m => Block -> FBM m [Content] blockToXml (Plain ss) = cMapM toXml ss -- FIXME: can lead to malformed FB2 @@ -365,10 +365,7 @@ blockToXml h@Header{} = do -- should not occur after hierarchicalize, except inside lists/blockquotes report $ BlockNotRendered h return [] -blockToXml HorizontalRule = return - [ el "empty-line" () - , el "p" (txt (replicate 10 '—')) - , el "empty-line" () ] +blockToXml HorizontalRule = return [ el "empty-line" () ] blockToXml (Table caption aligns _ headers rows) = do hd <- mkrow "th" headers aligns bd <- mapM (\r -> mkrow "td" r aligns) rows @@ -398,7 +395,7 @@ plainToPara [] = [] plainToPara (Plain inlines : rest) = Para inlines : plainToPara rest plainToPara (Para inlines : rest) = - Para inlines : Plain [LineBreak] : plainToPara rest + Para inlines : HorizontalRule : plainToPara rest -- HorizontalRule will be converted to <empty-line /> plainToPara (p:rest) = p : plainToPara rest -- Simulate increased indentation level. Will not really work @@ -449,29 +446,15 @@ toXml (Quoted DoubleQuote ss) = do toXml (Cite _ ss) = cMapM toXml ss -- FIXME: support citation styles toXml (Code _ s) = return [el "code" s] toXml Space = return [txt " "] -toXml SoftBreak = return [txt " "] -toXml LineBreak = return [el "empty-line" ()] +toXml SoftBreak = return [txt "\n"] +toXml LineBreak = return [txt "\n"] toXml (Math _ formula) = insertMath InlineImage formula toXml il@(RawInline _ _) = do report $ InlineNotRendered il return [] -- raw TeX and raw HTML are suppressed -toXml (Link _ text (url,ttl)) = do - fns <- footnotes `liftM` get - let n = 1 + length fns - let ln_id = linkID n - let ln_ref = list . el "sup" . txt $ "[" ++ show n ++ "]" +toXml (Link _ text (url,_)) = do ln_text <- cMapM toXml text - let ln_desc = - let ttl' = dropWhile isSpace ttl - in if null ttl' - then list . el "p" $ el "code" url - else list . el "p" $ [ txt (ttl' ++ ": "), el "code" url ] - modify (\s -> s { footnotes = (n, ln_id, ln_desc) : fns }) - return $ ln_text ++ - [ el "a" - ( [ attr ("l","href") ('#':ln_id) - , uattr "type" "note" ] - , ln_ref) ] + return [ el "a" ( [ attr ("l","href") url ], ln_text) ] toXml img@Image{} = insertImage InlineImage img toXml (Note bs) = do fns <- footnotes `liftM` get diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs index 1647df7ea..646168c72 100644 --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -45,11 +46,11 @@ module Text.Pandoc.Writers.HTML ( writeRevealJs, tagWithAttributes ) where +import Prelude import Control.Monad.State.Strict import Data.Char (ord, toLower) import Data.List (intercalate, intersperse, isPrefixOf, partition) import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) -import Data.Monoid ((<>)) import qualified Data.Set as Set import Data.String (fromString) import Data.Text (Text) @@ -259,10 +260,6 @@ pandocToHtml opts (Pandoc meta blocks) = do notes <- footnoteSection opts (reverse (stNotes st)) let thebody = blocks' >> notes let math = case writerHTMLMathMethod opts of - LaTeXMathML (Just url) -> - H.script ! A.src (toValue url) - ! A.type_ "text/javascript" - $ mempty MathJax url | slideVariant /= RevealJsSlides -> -- mathjax is handled via a special plugin in revealjs @@ -273,21 +270,15 @@ pandocToHtml opts (Pandoc meta blocks) = do preEscapedString "MathJax.Hub.Queue([\"Typeset\",MathJax.Hub]);" _ -> mempty - JsMath (Just url) -> - H.script ! A.src (toValue url) - ! A.type_ "text/javascript" - $ mempty - KaTeX url -> - (H.script ! - A.src (toValue $ url ++ "katex.min.js") $ mempty) <> - (H.script ! - A.src (toValue $ url ++ "contrib/auto-render.min.js") - $ mempty) <> - ( - H.script - "document.addEventListener(\"DOMContentLoaded\", function() {\n renderMathInElement(document.body);\n});") <> - (H.link ! A.rel "stylesheet" ! - A.href (toValue $ url ++ "katex.min.css")) + KaTeX url -> do + H.script ! + A.src (toValue $ url ++ "katex.min.js") $ mempty + H.script ! + A.src (toValue $ url ++ "contrib/auto-render.min.js") $ mempty + H.script + "document.addEventListener(\"DOMContentLoaded\", function() {\n renderMathInElement(document.body);\n});" + H.link ! A.rel "stylesheet" ! + A.href (toValue $ url ++ "katex.min.css") _ -> case lookup "mathml-script" (writerVariables opts) of Just s | not (stHtml5 st) -> @@ -363,7 +354,8 @@ defList :: PandocMonad m defList opts items = toList H.dl opts (items ++ [nl opts]) -- | Construct table of contents from list of elements. -tableOfContents :: PandocMonad m => WriterOptions -> [Element] -> StateT WriterState m (Maybe Html) +tableOfContents :: PandocMonad m => WriterOptions -> [Element] + -> StateT WriterState m (Maybe Html) tableOfContents _ [] = return Nothing tableOfContents opts sects = do contents <- mapM (elementToListItem opts) sects @@ -378,7 +370,8 @@ showSecNum = intercalate "." . map show -- | Converts an Element to a list item for a table of contents, -- retrieving the appropriate identifier from state. -elementToListItem :: PandocMonad m => WriterOptions -> Element -> StateT WriterState m (Maybe Html) +elementToListItem :: PandocMonad m => WriterOptions -> Element + -> StateT WriterState m (Maybe Html) -- Don't include the empty headers created in slide shows -- shows when an hrule is used to separate slides without a new title: elementToListItem _ (Sec _ _ _ [Str "\0"] _) = return Nothing @@ -390,7 +383,8 @@ elementToListItem opts (Sec lev num (id',classes,_) headerText subsecs) then (H.span ! A.class_ "toc-section-number" $ toHtml $ showSecNum num') >> preEscapedString " " else mempty - txt <- liftM (sectnum >>) $ inlineListToHtml opts $ walk deNote headerText + txt <- liftM (sectnum >>) $ + inlineListToHtml opts $ walk (deLink . deNote) headerText subHeads <- mapM (elementToListItem opts) subsecs >>= return . catMaybes subList <- if null subHeads then return mempty @@ -406,8 +400,13 @@ elementToListItem opts (Sec lev num (id',classes,_) headerText subsecs) $ toHtml txt) >> subList elementToListItem _ _ = return Nothing +deLink :: Inline -> Inline +deLink (Link _ ils _) = Span nullAttr ils +deLink x = x + -- | Convert an Element to Html. -elementToHtml :: PandocMonad m => Int -> WriterOptions -> Element -> StateT WriterState m Html +elementToHtml :: PandocMonad m => Int -> WriterOptions -> Element + -> StateT WriterState m Html elementToHtml _slideLevel opts (Blk block) = blockToHtml opts block elementToHtml slideLevel opts (Sec level num (id',classes,keyvals) title' elements) = do slideVariant <- gets stSlideVariant @@ -479,7 +478,12 @@ footnoteSection opts notes = do html5 <- gets stHtml5 slideVariant <- gets stSlideVariant let hrtag = if html5 then H5.hr else H.hr + epubVersion <- gets stEPUBVersion let container x + | html5 + , epubVersion == Just EPUB3 + = H5.section ! A.class_ "footnotes" + ! customAttribute "epub:type" "footnotes" $ x | html5 = H5.section ! A.class_ "footnotes" $ x | slideVariant /= NoSlides = H.div ! A.class_ "footnotes slide" $ x | otherwise = H.div ! A.class_ "footnotes" $ x @@ -962,8 +966,9 @@ inlineToHtml opts inline = do WrapNone -> preEscapedString " " WrapAuto -> preEscapedString " " WrapPreserve -> preEscapedString "\n" - LineBreak -> return $ (if html5 then H5.br else H.br) - <> strToHtml "\n" + LineBreak -> return $ do + if html5 then H5.br else H.br + strToHtml "\n" (Span (id',classes,kvs) ils) -> inlineListToHtml opts ils >>= addAttrs opts attr' . H.span @@ -1019,19 +1024,6 @@ inlineToHtml opts inline = do let mathClass = toValue $ ("math " :: String) ++ if t == InlineMath then "inline" else "display" case writerHTMLMathMethod opts of - LaTeXMathML _ -> - -- putting LaTeXMathML in container with class "LaTeX" prevents - -- non-math elements on the page from being treated as math by - -- the javascript - return $ H.span ! A.class_ "LaTeX" $ - case t of - InlineMath -> toHtml ("$" ++ str ++ "$") - DisplayMath -> toHtml ("$$" ++ str ++ "$$") - JsMath _ -> do - let m = preEscapedString str - return $ case t of - InlineMath -> H.span ! A.class_ mathClass $ m - DisplayMath -> H.div ! A.class_ mathClass $ m WebTeX url -> do let imtag = if html5 then H5.img else H.img let m = imtag ! A.style "vertical-align:middle" @@ -1042,10 +1034,6 @@ inlineToHtml opts inline = do return $ case t of InlineMath -> m DisplayMath -> brtag >> m >> brtag - GladTeX -> - return $ case t of - InlineMath -> preEscapedString $ "<EQ ENV=\"math\">" ++ str ++ "</EQ>" - DisplayMath -> preEscapedString $ "<EQ ENV=\"displaymath\">" ++ str ++ "</EQ>" MathML -> do let conf = useShortEmptyTags (const False) defaultConfigPP diff --git a/src/Text/Pandoc/Writers/Haddock.hs b/src/Text/Pandoc/Writers/Haddock.hs index 688c1f390..75b8c78dc 100644 --- a/src/Text/Pandoc/Writers/Haddock.hs +++ b/src/Text/Pandoc/Writers/Haddock.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} + {- Copyright (C) 2014-2015, 2017-2018 John MacFarlane <jgm@berkeley.edu> @@ -33,9 +34,9 @@ Conversion of 'Pandoc' documents to haddock markup. Haddock: <http://www.haskell.org/haddock/doc/html/> -} module Text.Pandoc.Writers.Haddock (writeHaddock) where +import Prelude import Control.Monad.State.Strict import Data.Default -import Data.List (intersperse, transpose) import Data.Text (Text) import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition @@ -136,29 +137,15 @@ blockToHaddock _ (CodeBlock (_,_,_) str) = -- Nothing in haddock corresponds to block quotes: blockToHaddock opts (BlockQuote blocks) = blockListToHaddock opts blocks --- Haddock doesn't have tables. Use haddock tables in code. blockToHaddock opts (Table caption aligns widths headers rows) = do caption' <- inlineListToHaddock opts caption let caption'' = if null caption then empty else blankline <> caption' <> blankline - rawHeaders <- mapM (blockListToHaddock opts) headers - rawRows <- mapM (mapM (blockListToHaddock opts)) rows - let isSimple = all (==0) widths - let isPlainBlock (Plain _) = True - isPlainBlock _ = False - let hasBlocks = not (all isPlainBlock $ concat . concat $ headers:rows) - (nst,tbl) <- case True of - _ | isSimple -> (nest 2,) <$> - pandocTable opts (all null headers) aligns widths - rawHeaders rawRows - | not hasBlocks -> (nest 2,) <$> - pandocTable opts (all null headers) aligns widths - rawHeaders rawRows - | otherwise -> (id,) <$> - gridTable opts blockListToHaddock - (all null headers) aligns widths headers rows - return $ prefixed "> " (nst $ tbl $$ blankline $$ caption'') $$ blankline + tbl <- gridTable opts blockListToHaddock + (all null headers) (map (const AlignDefault) aligns) + widths headers rows + return $ prefixed "> " (tbl $$ blankline $$ caption'') $$ blankline blockToHaddock opts (BulletList items) = do contents <- mapM (bulletListItemToHaddock opts) items return $ cat contents <> blankline @@ -174,46 +161,6 @@ blockToHaddock opts (DefinitionList items) = do contents <- mapM (definitionListItemToHaddock opts) items return $ cat contents <> blankline -pandocTable :: PandocMonad m - => WriterOptions -> Bool -> [Alignment] -> [Double] - -> [Doc] -> [[Doc]] -> StateT WriterState m Doc -pandocTable opts headless aligns widths rawHeaders rawRows = do - let isSimple = all (==0) widths - let alignHeader alignment = case alignment of - AlignLeft -> lblock - AlignCenter -> cblock - AlignRight -> rblock - AlignDefault -> lblock - let numChars = maximum . map offset - let widthsInChars = if isSimple - then map ((+2) . numChars) - $ transpose (rawHeaders : rawRows) - else map - (floor . (fromIntegral (writerColumns opts) *)) - widths - let makeRow = hcat . intersperse (lblock 1 (text " ")) . - zipWith3 alignHeader aligns widthsInChars - let rows' = map makeRow rawRows - let head' = makeRow rawHeaders - let maxRowHeight = maximum $ map height (head':rows') - let underline = cat $ intersperse (text " ") $ - map (\width -> text (replicate width '-')) widthsInChars - let border - | maxRowHeight > 1 = text (replicate (sum widthsInChars + - length widthsInChars - 1) '-') - | headless = underline - | otherwise = empty - let head'' = if headless - then empty - else border <> cr <> head' - let body = if maxRowHeight > 1 - then vsep rows' - else vcat rows' - let bottom = if headless - then underline - else border - return $ head'' $$ underline $$ body $$ bottom - -- | Convert bullet list item (list of blocks) to haddock bulletListItemToHaddock :: PandocMonad m => WriterOptions -> [Block] -> StateT WriterState m Doc diff --git a/src/Text/Pandoc/Writers/ICML.hs b/src/Text/Pandoc/Writers/ICML.hs index a5d851e40..266d58007 100644 --- a/src/Text/Pandoc/Writers/ICML.hs +++ b/src/Text/Pandoc/Writers/ICML.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- | @@ -16,6 +17,7 @@ InCopy is the companion word-processor to Adobe InDesign and ICML documents can into InDesign with File -> Place. -} module Text.Pandoc.Writers.ICML (writeICML) where +import Prelude import Control.Monad.Except (catchError) import Control.Monad.State.Strict import Data.List (intersperse, isInfixOf, isPrefixOf, stripPrefix) diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs index 639961acd..fb3236bd9 100644 --- a/src/Text/Pandoc/Writers/JATS.hs +++ b/src/Text/Pandoc/Writers/JATS.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- @@ -28,9 +29,10 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to JATS XML. Reference: -https://jats.nlm.nih.gov/publishing/tag-library/1.1d3/element/mml-math.html +https://jats.nlm.nih.gov/publishing/tag-library -} module Text.Pandoc.Writers.JATS ( writeJATS ) where +import Prelude import Control.Monad.Reader import Data.Char (toLower) import Data.Generics (everywhere, mkT) @@ -139,7 +141,7 @@ deflistItemToJATS opts term defs = do term' <- inlinesToJATS opts term def' <- blocksToJATS opts $ concatMap (map plainToPara) defs return $ inTagsIndented "def-item" $ - inTagsIndented "term" term' $$ + inTagsSimple "term" term' $$ inTagsIndented "def" def' -- | Convert a list of lists of blocks to a list of JATS list items. @@ -156,7 +158,7 @@ listItemToJATS :: PandocMonad m listItemToJATS opts mbmarker item = do contents <- blocksToJATS opts item return $ inTagsIndented "list-item" $ - maybe empty (\lbl -> inTagsIndented "label" (text lbl)) mbmarker + maybe empty (\lbl -> inTagsSimple "label" (text lbl)) mbmarker $$ contents imageMimeType :: String -> [(String, String)] -> (String, String) @@ -250,7 +252,7 @@ blockToJATS _ (Para [Image (ident,_,kvs) _ (src, tit)]) = do "xlink:type"]] return $ selfClosingTag "graphic" attr blockToJATS opts (Para lst) = - inTagsIndented "p" <$> inlinesToJATS opts lst + inTagsSimple "p" <$> inlinesToJATS opts lst blockToJATS opts (LineBlock lns) = blockToJATS opts $ linesToPara lns blockToJATS opts (BlockQuote blocks) = @@ -326,10 +328,10 @@ tableItemToJATS :: PandocMonad m -> [Block] -> JATS m Doc tableItemToJATS opts isHeader [Plain item] = - inTags True (if isHeader then "th" else "td") [] <$> + inTags False (if isHeader then "th" else "td") [] <$> inlinesToJATS opts item tableItemToJATS opts isHeader item = - (inTags True (if isHeader then "th" else "td") [] . vcat) <$> + (inTags False (if isHeader then "th" else "td") [] . vcat) <$> mapM (blockToJATS opts) item -- | Convert a list of inline elements to JATS. diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs index f61c878e5..2904bec06 100644 --- a/src/Text/Pandoc/Writers/LaTeX.hs +++ b/src/Text/Pandoc/Writers/LaTeX.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -34,6 +35,7 @@ module Text.Pandoc.Writers.LaTeX ( writeLaTeX , writeBeamer ) where +import Prelude import Control.Applicative ((<|>)) import Control.Monad.State.Strict import Data.Aeson (FromJSON, object, (.=)) @@ -411,15 +413,15 @@ elementToBeamer slideLevel (Sec lvl _num (ident,classes,kvs) tit elts) slideTitle <- if tit == [Str "\0"] -- marker for hrule then return [] - else - if null ident - then return $ latex "{" : tit ++ [latex "}"] - else do - ref <- toLabel ident - return $ latex ("{%\n\\protect\\hypertarget{" ++ - ref ++ "}{%\n") : tit ++ [latex "}}"] + else return $ latex "{" : tit ++ [latex "}"] + ref <- toLabel ident + let slideAnchor = if null ident + then [] + else [latex ("\n\\protect\\hypertarget{" ++ + ref ++ "}{}")] let slideStart = Para $ - RawInline "latex" ("\\begin{frame}" ++ options) : slideTitle + RawInline "latex" ("\\begin{frame}" ++ options) : + slideTitle ++ slideAnchor let slideEnd = RawBlock "latex" "\\end{frame}" -- now carve up slide into blocks if there are sections inside bs <- concat `fmap` mapM (elementToBeamer slideLevel) elts @@ -676,6 +678,7 @@ blockToLaTeX (OrderedList (start, numstyle, numdelim) lst) = do let enum = text $ "enum" ++ map toLower (toRomanNumeral oldlevel) let stylecommand | numstyle == DefaultStyle && numdelim == DefaultDelim = empty + | beamer && numstyle == Decimal && numdelim == Period = empty | beamer = brackets (todelim exemplar) | otherwise = "\\def" <> "\\label" <> enum <> braces (todelim $ tostyle enum) @@ -1033,7 +1036,7 @@ inlineToLaTeX (Code (_,classes,_) str) = do Nothing -> "" inNote <- gets stInNote when inNote $ modify $ \s -> s{ stVerbInNote = True } - let chr = case "!\"&'()*,-./:;?@_" \\ str of + let chr = case "!\"'()*,-./:;?@" \\ str of (c:_) -> c [] -> '!' let str' = escapeStringUsing (backslashEscapes "\\{}%~_&") str diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs index 1be955fe3..912231a88 100644 --- a/src/Text/Pandoc/Writers/Man.hs +++ b/src/Text/Pandoc/Writers/Man.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2007-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of 'Pandoc' documents to groff man page format. -} module Text.Pandoc.Writers.Man ( writeMan) where +import Prelude import Control.Monad.State.Strict import Data.List (intercalate, intersperse, sort, stripPrefix) import qualified Data.Map as Map diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs index cdd8f3b66..075858e5e 100644 --- a/src/Text/Pandoc/Writers/Markdown.hs +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -34,6 +35,7 @@ Conversion of 'Pandoc' documents to markdown-formatted plain text. Markdown: <http://daringfireball.net/projects/markdown/> -} module Text.Pandoc.Writers.Markdown (writeMarkdown, writePlain) where +import Prelude import Control.Monad.Reader import Control.Monad.State.Strict import Data.Char (chr, isPunctuation, isSpace, ord, isAlphaNum) @@ -730,7 +732,10 @@ pandocTable opts multiline headless aligns widths rawHeaders rawRows = do then empty else border <> cr <> head' let body = if multiline - then vsep rows' + then vsep rows' $$ + if length rows' < 2 + then blankline -- #4578 + else empty else vcat rows' let bottom = if headless then underline diff --git a/src/Text/Pandoc/Writers/Math.hs b/src/Text/Pandoc/Writers/Math.hs index 477f5a0b1..99d17d594 100644 --- a/src/Text/Pandoc/Writers/Math.hs +++ b/src/Text/Pandoc/Writers/Math.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Text.Pandoc.Writers.Math ( texMathToInlines , convertMath @@ -6,6 +7,7 @@ module Text.Pandoc.Writers.Math ) where +import Prelude import Text.Pandoc.Class import Text.Pandoc.Definition import Text.Pandoc.Logging diff --git a/src/Text/Pandoc/Writers/MediaWiki.hs b/src/Text/Pandoc/Writers/MediaWiki.hs index 2470d9200..df50028a0 100644 --- a/src/Text/Pandoc/Writers/MediaWiki.hs +++ b/src/Text/Pandoc/Writers/MediaWiki.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2008-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of 'Pandoc' documents to MediaWiki markup. MediaWiki: <http://www.mediawiki.org/wiki/MediaWiki> -} module Text.Pandoc.Writers.MediaWiki ( writeMediaWiki ) where +import Prelude import Control.Monad.Reader import Control.Monad.State.Strict import Data.List (intercalate) diff --git a/src/Text/Pandoc/Writers/Ms.hs b/src/Text/Pandoc/Writers/Ms.hs index 83d80cd4a..16a66c85b 100644 --- a/src/Text/Pandoc/Writers/Ms.hs +++ b/src/Text/Pandoc/Writers/Ms.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2007-2018 John MacFarlane <jgm@berkeley.edu> @@ -36,9 +37,10 @@ TODO: -} module Text.Pandoc.Writers.Ms ( writeMs ) where +import Prelude import Control.Monad.State.Strict -import Data.Char (isLower, isUpper, toUpper) -import Data.List (intercalate, intersperse, sort) +import Data.Char (isLower, isUpper, toUpper, ord) +import Data.List (intercalate, intersperse) import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text) @@ -46,6 +48,7 @@ import qualified Data.Text as T import Network.URI (escapeURIString, isAllowedInURI) import Skylighting import System.FilePath (takeExtension) +import Text.Pandoc.Asciify (toAsciiChar) import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Highlighting @@ -65,6 +68,7 @@ data WriterState = WriterState { stHasInlineMath :: Bool , stNotes :: [Note] , stSmallCaps :: Bool , stHighlighting :: Bool + , stInHeader :: Bool , stFontFeatures :: Map.Map Char Bool } @@ -74,6 +78,7 @@ defaultWriterState = WriterState{ stHasInlineMath = False , stNotes = [] , stSmallCaps = False , stHighlighting = False + , stInHeader = False , stFontFeatures = Map.fromList [ ('I',False) , ('B',False) @@ -132,14 +137,12 @@ msEscapes = Map.fromList [ ('\160', "\\~") , ('\'', "\\[aq]") , ('`', "\\`") - , ('\8217', "'") , ('"', "\\[dq]") , ('\x2014', "\\[em]") , ('\x2013', "\\[en]") , ('\x2026', "\\&...") , ('~', "\\[ti]") , ('^', "\\[ha]") - , ('-', "\\-") , ('@', "\\@") , ('\\', "\\\\") ] @@ -216,11 +219,16 @@ blockToMs :: PandocMonad m -> Block -- ^ Block element -> MS m Doc blockToMs _ Null = return empty -blockToMs opts (Div _ bs) = do +blockToMs opts (Div (ident,_,_) bs) = do + let anchor = if null ident + then empty + else nowrap $ + text ".pdfhref M " + <> doubleQuotes (text (toAscii ident)) setFirstPara res <- blockListToMs opts bs setFirstPara - return res + return $ anchor $$ res blockToMs opts (Plain inlines) = liftM vcat $ mapM (inlineListToMs' opts) $ splitSentences inlines blockToMs opts (Para [Image attr alt (src,_tit)]) @@ -258,7 +266,9 @@ blockToMs _ HorizontalRule = do return $ text ".HLINE" blockToMs opts (Header level (ident,classes,_) inlines) = do setFirstPara + modify $ \st -> st{ stInHeader = True } contents <- inlineListToMs' opts $ map breakToSpace inlines + modify $ \st -> st{ stInHeader = False } let (heading, secnum) = if writerNumberSections opts && "unnumbered" `notElem` classes then (".NH", "\\*[SN]") @@ -266,7 +276,8 @@ blockToMs opts (Header level (ident,classes,_) inlines) = do let anchor = if null ident then empty else nowrap $ - text ".pdfhref M " <> doubleQuotes (text ident) + text ".pdfhref M " + <> doubleQuotes (text (toAscii ident)) let bookmark = text ".pdfhref O " <> text (show level ++ " ") <> doubleQuotes (text $ secnum ++ (if null secnum @@ -274,7 +285,7 @@ blockToMs opts (Header level (ident,classes,_) inlines) = do else " ") ++ escapeString (stringify inlines)) let backlink = nowrap (text ".pdfhref L -D " <> - doubleQuotes (text ident) <> space <> text "\\") <> cr <> + doubleQuotes (text (toAscii ident)) <> space <> text "\\") <> cr <> text " -- " let tocEntry = if writerTableOfContents opts && level <= writerTOCDepth opts @@ -513,7 +524,7 @@ inlineToMs opts (Link _ txt ('#':ident, _)) = do -- internal link contents <- inlineListToMs' opts $ map breakToSpace txt return $ text "\\c" <> cr <> nowrap (text ".pdfhref L -D " <> - doubleQuotes (text ident) <> text " -A " <> + doubleQuotes (text (toAscii ident)) <> text " -A " <> doubleQuotes (text "\\c") <> space <> text "\\") <> cr <> text " -- " <> doubleQuotes (nowrap contents) <> cr <> text "\\&" inlineToMs opts (Link _ txt (src, _)) = do @@ -552,8 +563,15 @@ handleNote opts bs = do fontChange :: PandocMonad m => MS m Doc fontChange = do features <- gets stFontFeatures - let filling = sort [c | (c,True) <- Map.toList features] - return $ text $ "\\f[" ++ filling ++ "]" + inHeader <- gets stInHeader + let filling = ['C' | fromMaybe False $ Map.lookup 'C' features] ++ + ['B' | inHeader || + fromMaybe False (Map.lookup 'B' features)] ++ + ['I' | fromMaybe False $ Map.lookup 'I' features] + return $ + if null filling + then text "\\f[R]" + else text $ "\\f[" ++ filling ++ "]" withFontFeature :: PandocMonad m => Char -> MS m Doc -> MS m Doc withFontFeature c action = do @@ -637,3 +655,11 @@ highlightCode opts attr str = Right h -> do modify (\st -> st{ stHighlighting = True }) return h + +-- This is used for PDF anchors. +toAscii :: String -> String +toAscii = concatMap + (\c -> case toAsciiChar c of + Nothing -> '_':'u':show (ord c) ++ "_" + Just '/' -> '_':'u':show (ord c) ++ "_" -- see #4515 + Just c' -> [c']) diff --git a/src/Text/Pandoc/Writers/Muse.hs b/src/Text/Pandoc/Writers/Muse.hs index 7f53e202d..3681fcc0d 100644 --- a/src/Text/Pandoc/Writers/Muse.hs +++ b/src/Text/Pandoc/Writers/Muse.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2017-2018 Alexander Krotov <ilabdsf@gmail.com> @@ -42,7 +43,11 @@ However, @\<literal style="html">@ tag is used for HTML raw blocks even though it is supported only in Emacs Muse. -} module Text.Pandoc.Writers.Muse (writeMuse) where +import Prelude +import Control.Monad.Reader import Control.Monad.State.Strict +import Data.Char (isSpace, isDigit, isAsciiUpper, isAsciiLower) +import Data.Default import Data.Text (Text) import Data.List (intersperse, transpose, isInfixOf) import System.FilePath (takeExtension) @@ -58,34 +63,54 @@ import Text.Pandoc.Writers.Shared import qualified Data.Set as Set type Notes = [[Block]] + +type Muse m = ReaderT WriterEnv (StateT WriterState m) + +data WriterEnv = + WriterEnv { envOptions :: WriterOptions + , envTopLevel :: Bool + , envInsideBlock :: Bool + , envInlineStart :: Bool + , envInsideLinkDescription :: Bool -- ^ Escape ] if True + , envAfterSpace :: Bool + , envOneLine :: Bool -- ^ True if newlines are not allowed + } + data WriterState = WriterState { stNotes :: Notes - , stOptions :: WriterOptions - , stTopLevel :: Bool - , stInsideBlock :: Bool , stIds :: Set.Set String } +instance Default WriterState + where def = WriterState { stNotes = [] + , stIds = Set.empty + } + +evalMuse :: PandocMonad m => Muse m a -> WriterEnv -> WriterState -> m a +evalMuse document env = evalStateT $ runReaderT document env + -- | Convert Pandoc to Muse. writeMuse :: PandocMonad m => WriterOptions -> Pandoc -> m Text writeMuse opts document = - let st = WriterState { stNotes = [] - , stOptions = opts - , stTopLevel = True - , stInsideBlock = False - , stIds = Set.empty - } - in evalStateT (pandocToMuse document) st + evalMuse (pandocToMuse document) env def + where env = WriterEnv { envOptions = opts + , envTopLevel = True + , envInsideBlock = False + , envInlineStart = True + , envInsideLinkDescription = False + , envAfterSpace = False + , envOneLine = False + } -- | Return Muse representation of document. pandocToMuse :: PandocMonad m => Pandoc - -> StateT WriterState m Text + -> Muse m Text pandocToMuse (Pandoc meta blocks) = do - opts <- gets stOptions + opts <- asks envOptions let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing @@ -96,7 +121,7 @@ pandocToMuse (Pandoc meta blocks) = do (fmap render' . inlineListToMuse) meta body <- blockListToMuse blocks - notes <- liftM (reverse . stNotes) get >>= notesToMuse + notes <- fmap (reverse . stNotes) get >>= notesToMuse let main = render colwidth $ body $+$ notes let context = defField "body" main metadata case writerTemplate opts of @@ -108,7 +133,7 @@ pandocToMuse (Pandoc meta blocks) = do catWithBlankLines :: PandocMonad m => [Block] -- ^ List of block elements -> Int -- ^ Number of blank lines - -> StateT WriterState m Doc + -> Muse m Doc catWithBlankLines (b : bs) n = do b' <- blockToMuse b bs' <- flatBlockListToMuse bs @@ -116,10 +141,10 @@ catWithBlankLines (b : bs) n = do catWithBlankLines _ _ = error "Expected at least one block" -- | Convert list of Pandoc block elements to Muse --- | without setting stTopLevel. +-- | without setting envTopLevel. flatBlockListToMuse :: PandocMonad m => [Block] -- ^ List of block elements - -> StateT WriterState m Doc + -> Muse m Doc flatBlockListToMuse bs@(BulletList _ : BulletList _ : _) = catWithBlankLines bs 2 flatBlockListToMuse bs@(OrderedList (_, style1, _) _ : OrderedList (_, style2, _) _ : _) = catWithBlankLines bs (if style1' == style2' then 2 else 0) @@ -135,36 +160,23 @@ flatBlockListToMuse [] = return mempty -- | Convert list of Pandoc block elements to Muse. blockListToMuse :: PandocMonad m => [Block] -- ^ List of block elements - -> StateT WriterState m Doc -blockListToMuse blocks = do - oldState <- get - modify $ \s -> s { stTopLevel = not $ stInsideBlock s - , stInsideBlock = True - } - result <- flatBlockListToMuse blocks - modify $ \s -> s { stTopLevel = stTopLevel oldState - , stInsideBlock = stInsideBlock oldState - } - return result + -> Muse m Doc +blockListToMuse = + local (\env -> env { envTopLevel = not (envInsideBlock env) + , envInsideBlock = True + }) . flatBlockListToMuse -- | Convert Pandoc block element to Muse. blockToMuse :: PandocMonad m => Block -- ^ Block element - -> StateT WriterState m Doc -blockToMuse (Plain inlines) = inlineListToMuse inlines + -> Muse m Doc +blockToMuse (Plain inlines) = inlineListToMuse' inlines blockToMuse (Para inlines) = do - contents <- inlineListToMuse inlines + contents <- inlineListToMuse' inlines return $ contents <> blankline blockToMuse (LineBlock lns) = do - let splitStanza [] = [] - splitStanza xs = case break (== mempty) xs of - (l, []) -> [l] - (l, _:r) -> l : splitStanza r - let joinWithLinefeeds = nowrap . mconcat . intersperse cr - let joinWithBlankLines = mconcat . intersperse blankline - let prettyfyStanza ls = joinWithLinefeeds <$> mapM inlineListToMuse ls - contents <- joinWithBlankLines <$> mapM prettyfyStanza (splitStanza lns) - return $ blankline $$ "<verse>" $$ contents $$ "</verse>" <> blankline + lns' <- local (\env -> env { envOneLine = True }) $ mapM inlineListToMuse lns + return $ nowrap $ vcat (map (text "> " <>) lns') <> blankline blockToMuse (CodeBlock (_,_,_) str) = return $ "<example>" $$ text str $$ "</example>" $$ blankline blockToMuse (RawBlock (Format format) str) = @@ -180,50 +192,48 @@ blockToMuse (BlockQuote blocks) = do blockToMuse (OrderedList (start, style, _) items) = do let markers = take (length items) $ orderedListMarkers (start, style, Period) - let maxMarkerLength = maximum $ map length markers - let markers' = map (\m -> let s = maxMarkerLength - length m - in m ++ replicate s ' ') markers - contents <- zipWithM orderedListItemToMuse markers' items + contents <- zipWithM orderedListItemToMuse markers items -- ensure that sublists have preceding blank line - topLevel <- gets stTopLevel + topLevel <- asks envTopLevel return $ cr $$ (if topLevel then nest 1 else id) (vcat contents) $$ blankline where orderedListItemToMuse :: PandocMonad m => String -- ^ marker for list item -> [Block] -- ^ list item (list of blocks) - -> StateT WriterState m Doc + -> Muse m Doc orderedListItemToMuse marker item = do - contents <- blockListToMuse item - return $ hang (length marker + 1) (text marker <> space) contents + contents <- blockListToMuse item + return $ hang (length marker + 1) (text marker <> space) contents blockToMuse (BulletList items) = do contents <- mapM bulletListItemToMuse items -- ensure that sublists have preceding blank line - topLevel <- gets stTopLevel + topLevel <- asks envTopLevel return $ cr $$ (if topLevel then nest 1 else id) (vcat contents) $$ blankline where bulletListItemToMuse :: PandocMonad m => [Block] - -> StateT WriterState m Doc + -> Muse m Doc bulletListItemToMuse item = do contents <- blockListToMuse item return $ hang 2 "- " contents blockToMuse (DefinitionList items) = do contents <- mapM definitionListItemToMuse items - return $ cr $$ nest 1 (vcat contents) $$ blankline + -- ensure that sublists have preceding blank line + topLevel <- asks envTopLevel + return $ cr $$ (if topLevel then nest 1 else id) (vcat contents) $$ blankline where definitionListItemToMuse :: PandocMonad m => ([Inline], [[Block]]) - -> StateT WriterState m Doc + -> Muse m Doc definitionListItemToMuse (label, defs) = do - label' <- inlineListToMuse label - contents <- liftM vcat $ mapM descriptionToMuse defs + label' <- local (\env -> env { envOneLine = True, envAfterSpace = True }) $ inlineListToMuse' label + contents <- vcat <$> mapM descriptionToMuse defs let ind = offset label' return $ hang ind label' contents descriptionToMuse :: PandocMonad m => [Block] - -> StateT WriterState m Doc + -> Muse m Doc descriptionToMuse desc = hang 4 " :: " <$> blockListToMuse desc blockToMuse (Header level (ident,_,_) inlines) = do - opts <- gets stOptions - contents <- inlineListToMuse inlines - + opts <- asks envOptions + contents <- local (\env -> env { envOneLine = True }) $ inlineListToMuse' inlines ids <- gets stIds let autoId = uniqueIdent inlines ids modify $ \st -> st{ stIds = Set.insert autoId ids } @@ -232,8 +242,7 @@ blockToMuse (Header level (ident,_,_) inlines) = do then empty else "#" <> text ident <> cr let header' = text $ replicate level '*' - return $ blankline <> nowrap (header' <> space <> contents) - $$ attr' <> blankline + return $ blankline <> attr' $$ nowrap (header' <> space <> contents) <> blankline -- https://www.gnu.org/software/emacs-muse/manual/muse.html#Horizontal-Rules-and-Anchors blockToMuse HorizontalRule = return $ blankline $$ "----" $$ blankline blockToMuse (Table caption _ _ headers rows) = do @@ -266,18 +275,18 @@ blockToMuse Null = return empty -- | Return Muse representation of notes. notesToMuse :: PandocMonad m => Notes - -> StateT WriterState m Doc -notesToMuse notes = liftM vsep (zipWithM noteToMuse [1 ..] notes) + -> Muse m Doc +notesToMuse notes = vsep <$> zipWithM noteToMuse [1 ..] notes -- | Return Muse representation of a note. noteToMuse :: PandocMonad m => Int -> [Block] - -> StateT WriterState m Doc -noteToMuse num note = do - contents <- blockListToMuse note - let marker = "[" ++ show num ++ "] " - return $ hang (length marker) (text marker) contents + -> Muse m Doc +noteToMuse num note = + hang (length marker) (text marker) <$> blockListToMuse note + where + marker = "[" ++ show num ++ "] " -- | Escape special characters for Muse. escapeString :: String -> String @@ -286,17 +295,74 @@ escapeString s = substitute "</verbatim>" "<</verbatim><verbatim>/verbatim>" s ++ "</verbatim>" +startsWithMarker :: (Char -> Bool) -> String -> Bool +startsWithMarker f (' ':xs) = startsWithMarker f xs +startsWithMarker f (x:xs) = + f x && (startsWithMarker f xs || startsWithDot xs) + where + startsWithDot ['.'] = True + startsWithDot ('.':c:_) = isSpace c + startsWithDot _ = False +startsWithMarker _ [] = False + -- | Escape special characters for Muse if needed. -conditionalEscapeString :: String -> String -conditionalEscapeString s = - if any (`elem` ("#*<=>[]|" :: String)) s || +containsFootnotes :: String -> Bool +containsFootnotes = p + where p ('[':xs) = q xs || p xs + p (_:xs) = p xs + p "" = False + q (x:xs) + | x `elem` ("123456789"::String) = r xs || p xs + | otherwise = p xs + q [] = False + r ('0':xs) = r xs || p xs + r xs = s xs || q xs || p xs + s (']':_) = True + s (_:xs) = p xs + s [] = False + +conditionalEscapeString :: Bool -> String -> String +conditionalEscapeString isInsideLinkDescription s = + if any (`elem` ("#*<=|" :: String)) s || "::" `isInfixOf` s || - "----" `isInfixOf` s || - "~~" `isInfixOf` s + "~~" `isInfixOf` s || + "[[" `isInfixOf` s || + ("]" `isInfixOf` s && isInsideLinkDescription) || + containsFootnotes s then escapeString s else s +-- Expand Math and Cite before normalizing inline list +preprocessInlineList :: PandocMonad m + => [Inline] + -> m [Inline] +preprocessInlineList (Math t str:xs) = (++) <$> texMathToInlines t str <*> preprocessInlineList xs +-- Amusewiki does not support <cite> tag, +-- and Emacs Muse citation support is limited +-- (https://www.gnu.org/software/emacs-muse/manual/html_node/Citations.html#Citation) +-- so just fallback to expanding inlines. +preprocessInlineList (Cite _ lst:xs) = (lst ++) <$> preprocessInlineList xs +preprocessInlineList (x:xs) = (x:) <$> preprocessInlineList xs +preprocessInlineList [] = return [] + +replaceSmallCaps :: Inline -> Inline +replaceSmallCaps (SmallCaps lst) = Emph lst +replaceSmallCaps x = x + +removeKeyValues :: Inline -> Inline +removeKeyValues (Code (i, cls, _) xs) = Code (i, cls, []) xs +-- Do not remove attributes from Link +-- Do not remove attributes, such as "width", from Image +removeKeyValues (Span (i, cls, _) xs) = Span (i, cls, []) xs +removeKeyValues x = x + normalizeInlineList :: [Inline] -> [Inline] +normalizeInlineList (Str "" : xs) + = normalizeInlineList xs +normalizeInlineList (x : Str "" : xs) + = normalizeInlineList (x:xs) +normalizeInlineList (Str x1 : Str x2 : xs) + = normalizeInlineList $ Str (x1 ++ x2) : xs normalizeInlineList (Emph x1 : Emph x2 : ils) = normalizeInlineList $ Emph (x1 ++ x2) : ils normalizeInlineList (Strong x1 : Strong x2 : ils) @@ -313,8 +379,7 @@ normalizeInlineList (Code _ x1 : Code _ x2 : ils) = normalizeInlineList $ Code nullAttr (x1 ++ x2) : ils normalizeInlineList (RawInline f1 x1 : RawInline f2 x2 : ils) | f1 == f2 = normalizeInlineList $ RawInline f1 (x1 ++ x2) : ils -normalizeInlineList (Span a1 x1 : Span a2 x2 : ils) | a1 == a2 - = normalizeInlineList $ Span a1 (x1 ++ x2) : ils +-- Do not join Span's during normalization normalizeInlineList (x:xs) = x : normalizeInlineList xs normalizeInlineList [] = [] @@ -324,17 +389,77 @@ fixNotes (Space : n@Note{} : rest) = Str " " : n : fixNotes rest fixNotes (SoftBreak : n@Note{} : rest) = Str " " : n : fixNotes rest fixNotes (x:xs) = x : fixNotes xs --- | Convert list of Pandoc inline elements to Muse. -inlineListToMuse :: PandocMonad m +urlEscapeBrackets :: String -> String +urlEscapeBrackets (']':xs) = '%':'5':'D':urlEscapeBrackets xs +urlEscapeBrackets (x:xs) = x:urlEscapeBrackets xs +urlEscapeBrackets [] = [] + +isHorizontalRule :: String -> Bool +isHorizontalRule s = length s >= 4 && all (== '-') s + +startsWithSpace :: String -> Bool +startsWithSpace (x:_) = isSpace x +startsWithSpace [] = False + +fixOrEscape :: Bool -> Inline -> Bool +fixOrEscape sp (Str "-") = sp +fixOrEscape sp (Str ";") = not sp +fixOrEscape _ (Str ">") = True +fixOrEscape sp (Str s) = (sp && (startsWithMarker isDigit s || + startsWithMarker isAsciiLower s || + startsWithMarker isAsciiUpper s)) + || isHorizontalRule s || startsWithSpace s +fixOrEscape _ Space = True +fixOrEscape _ SoftBreak = True +fixOrEscape _ _ = False + +-- | Convert list of Pandoc inline elements to Muse +renderInlineList :: PandocMonad m => [Inline] - -> StateT WriterState m Doc -inlineListToMuse lst = hcat <$> mapM inlineToMuse (fixNotes $ normalizeInlineList lst) + -> Muse m Doc +renderInlineList [] = do + start <- asks envInlineStart + pure $ if start then "<verbatim></verbatim>" else "" +renderInlineList (x:xs) = do + start <- asks envInlineStart + afterSpace <- asks envAfterSpace + topLevel <- asks envTopLevel + r <- inlineToMuse x + opts <- asks envOptions + let isNewline = (x == SoftBreak && writerWrapText opts == WrapPreserve) || x == LineBreak + lst' <- local (\env -> env { envInlineStart = isNewline + , envAfterSpace = x == Space || (not topLevel && isNewline) + }) $ renderInlineList xs + if start && fixOrEscape afterSpace x + then pure (text "<verbatim></verbatim>" <> r <> lst') + else pure (r <> lst') + +-- | Normalize and convert list of Pandoc inline elements to Muse. +inlineListToMuse'' :: PandocMonad m + => Bool + -> [Inline] + -> Muse m Doc +inlineListToMuse'' start lst = do + lst' <- (normalizeInlineList . fixNotes) <$> preprocessInlineList (map (removeKeyValues . replaceSmallCaps) lst) + topLevel <- asks envTopLevel + afterSpace <- asks envAfterSpace + local (\env -> env { envInlineStart = start + , envAfterSpace = afterSpace || (start && not topLevel) + }) $ renderInlineList lst' + +inlineListToMuse' :: PandocMonad m => [Inline] -> Muse m Doc +inlineListToMuse' = inlineListToMuse'' True + +inlineListToMuse :: PandocMonad m => [Inline] -> Muse m Doc +inlineListToMuse = inlineListToMuse'' False -- | Convert Pandoc inline element to Muse. inlineToMuse :: PandocMonad m => Inline - -> StateT WriterState m Doc -inlineToMuse (Str str) = return $ text $ conditionalEscapeString str + -> Muse m Doc +inlineToMuse (Str str) = do + insideLink <- asks envInsideLinkDescription + return $ text $ conditionalEscapeString insideLink str inlineToMuse (Emph lst) = do contents <- inlineListToMuse lst return $ "<em>" <> contents <> "</em>" @@ -350,60 +475,73 @@ inlineToMuse (Superscript lst) = do inlineToMuse (Subscript lst) = do contents <- inlineListToMuse lst return $ "<sub>" <> contents <> "</sub>" -inlineToMuse (SmallCaps lst) = inlineListToMuse lst +inlineToMuse SmallCaps {} = + fail "SmallCaps should be expanded before normalization" inlineToMuse (Quoted SingleQuote lst) = do contents <- inlineListToMuse lst return $ "‘" <> contents <> "’" inlineToMuse (Quoted DoubleQuote lst) = do contents <- inlineListToMuse lst return $ "“" <> contents <> "”" --- Amusewiki does not support <cite> tag, --- and Emacs Muse citation support is limited --- (https://www.gnu.org/software/emacs-muse/manual/html_node/Citations.html#Citation) --- so just fallback to expanding inlines. -inlineToMuse (Cite _ lst) = inlineListToMuse lst +inlineToMuse Cite {} = + fail "Citations should be expanded before normalization" inlineToMuse (Code _ str) = return $ "<code>" <> text (substitute "</code>" "<</code><code>/code>" str) <> "</code>" -inlineToMuse (Math t str) = - lift (texMathToInlines t str) >>= inlineListToMuse +inlineToMuse Math{} = + fail "Math should be expanded before normalization" inlineToMuse (RawInline (Format f) str) = return $ "<literal style=\"" <> text f <> "\">" <> text str <> "</literal>" -inlineToMuse LineBreak = return $ "<br>" <> cr +inlineToMuse LineBreak = do + oneline <- asks envOneLine + return $ if oneline then "<br>" else "<br>" <> cr inlineToMuse Space = return space inlineToMuse SoftBreak = do - wrapText <- gets $ writerWrapText . stOptions - return $ if wrapText == WrapPreserve then cr else space + oneline <- asks envOneLine + wrapText <- asks $ writerWrapText . envOptions + return $ if not oneline && wrapText == WrapPreserve then cr else space inlineToMuse (Link _ txt (src, _)) = case txt of [Str x] | escapeURI x == src -> return $ "[[" <> text (escapeLink x) <> "]]" - _ -> do contents <- inlineListToMuse txt + _ -> do contents <- local (\env -> env { envInsideLinkDescription = True }) $ inlineListToMuse txt return $ "[[" <> text (escapeLink src) <> "][" <> contents <> "]]" - where escapeLink lnk = if isImageUrl lnk then "URL:" ++ lnk else lnk + where escapeLink lnk = if isImageUrl lnk then "URL:" ++ urlEscapeBrackets lnk else urlEscapeBrackets lnk -- Taken from muse-image-regexp defined in Emacs Muse file lisp/muse-regexps.el imageExtensions = [".eps", ".gif", ".jpg", ".jpeg", ".pbm", ".png", ".tiff", ".xbm", ".xpm"] isImageUrl = (`elem` imageExtensions) . takeExtension inlineToMuse (Image attr alt (source,'f':'i':'g':':':title)) = inlineToMuse (Image attr alt (source,title)) -inlineToMuse (Image attr inlines (source, title)) = do - opts <- gets stOptions - alt <- inlineListToMuse inlines +inlineToMuse (Image attr@(_, classes, _) inlines (source, title)) = do + opts <- asks envOptions + alt <- local (\env -> env { envInsideLinkDescription = True }) $ inlineListToMuse inlines let title' = if null title then if null inlines then "" else "[" <> alt <> "]" - else "[" <> text title <> "]" + else "[" <> text (conditionalEscapeString True title) <> "]" let width = case dimension Width attr of Just (Percent x) | isEnabled Ext_amuse opts -> " " ++ show (round x :: Integer) _ -> "" - return $ "[[" <> text (source ++ width) <> "]" <> title' <> "]" + let leftalign = if "align-left" `elem` classes + then " l" + else "" + let rightalign = if "align-right" `elem` classes + then " r" + else "" + return $ "[[" <> text (urlEscapeBrackets source ++ width ++ leftalign ++ rightalign) <> "]" <> title' <> "]" inlineToMuse (Note contents) = do -- add to notes in state notes <- gets stNotes modify $ \st -> st { stNotes = contents:notes } let ref = show $ length notes + 1 return $ "[" <> text ref <> "]" -inlineToMuse (Span (_,name:_,_) inlines) = do +inlineToMuse (Span (anchor,names,_) inlines) = do contents <- inlineListToMuse inlines - return $ "<class name=\"" <> text name <> "\">" <> contents <> "</class>" -inlineToMuse (Span _ lst) = inlineListToMuse lst + let anchorDoc = if null anchor + then mempty + else text ('#':anchor) <> space + return $ anchorDoc <> (if null inlines && not (null anchor) + then mempty + else (if null names + then "<class>" + else "<class name=\"" <> text (head names) <> "\">") <> contents <> "</class>") diff --git a/src/Text/Pandoc/Writers/Native.hs b/src/Text/Pandoc/Writers/Native.hs index f852bad96..730e3800a 100644 --- a/src/Text/Pandoc/Writers/Native.hs +++ b/src/Text/Pandoc/Writers/Native.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of a 'Pandoc' document to a string representation. -} module Text.Pandoc.Writers.Native ( writeNative ) where +import Prelude import Data.List (intersperse) import Data.Text (Text) import Text.Pandoc.Class (PandocMonad) diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs index 63a3f915a..7aecb3da5 100644 --- a/src/Text/Pandoc/Writers/ODT.hs +++ b/src/Text/Pandoc/Writers/ODT.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {- Copyright (C) 2008-2018 John MacFarlane <jgm@berkeley.edu> @@ -29,6 +30,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to ODT. -} module Text.Pandoc.Writers.ODT ( writeODT ) where +import Prelude import Codec.Archive.Zip import Control.Monad.Except (catchError) import Control.Monad.State.Strict diff --git a/src/Text/Pandoc/Writers/OOXML.hs b/src/Text/Pandoc/Writers/OOXML.hs index 30d8d72dd..9e1c81964 100644 --- a/src/Text/Pandoc/Writers/OOXML.hs +++ b/src/Text/Pandoc/Writers/OOXML.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> @@ -39,13 +40,13 @@ module Text.Pandoc.Writers.OOXML ( mknode , fitToPage ) where +import Prelude import Codec.Archive.Zip import Control.Monad.Reader 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 Data.Monoid ((<>)) import Text.Pandoc.Class (PandocMonad) import qualified Text.Pandoc.UTF8 as UTF8 import Text.XML.Light as XML diff --git a/src/Text/Pandoc/Writers/OPML.hs b/src/Text/Pandoc/Writers/OPML.hs index 29e1bc80c..6c48046a2 100644 --- a/src/Text/Pandoc/Writers/OPML.hs +++ b/src/Text/Pandoc/Writers/OPML.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {- Copyright (C) 2013-2018 John MacFarlane <jgm@berkeley.edu> @@ -29,12 +30,13 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to OPML XML. -} module Text.Pandoc.Writers.OPML ( writeOPML) where +import Prelude import Control.Monad.Except (throwError) import Data.Text (Text, unpack) import qualified Data.Text as T import qualified Text.Pandoc.Builder as B import Text.Pandoc.Class (PandocMonad) -import Text.Pandoc.Compat.Time +import Data.Time import Text.Pandoc.Definition import Text.Pandoc.Error import Text.Pandoc.Options @@ -75,12 +77,7 @@ showDateTimeRFC822 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" convertDate :: [Inline] -> String convertDate ils = maybe "" showDateTimeRFC822 $ -#if MIN_VERSION_time(1,5,0) - parseTimeM True -#else - parseTime -#endif - defaultTimeLocale "%F" =<< normalizeDate (stringify ils) + parseTimeM True defaultTimeLocale "%F" =<< normalizeDate (stringify ils) -- | Convert an Element to OPML. elementToOPML :: PandocMonad m => WriterOptions -> Element -> m Doc diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs index 17edc0cbd..514327e9a 100644 --- a/src/Text/Pandoc/Writers/OpenDocument.hs +++ b/src/Text/Pandoc/Writers/OpenDocument.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} @@ -32,6 +33,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to OpenDocument XML. -} module Text.Pandoc.Writers.OpenDocument ( writeOpenDocument ) where +import Prelude import Control.Arrow ((***), (>>>)) import Control.Monad.State.Strict hiding (when) import Data.Char (chr) diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs index 72def8e48..a71775e13 100644 --- a/src/Text/Pandoc/Writers/Org.hs +++ b/src/Text/Pandoc/Writers/Org.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2010-2015 Puneeth Chaganti <punchagan@gmail.com> @@ -35,6 +36,7 @@ Conversion of 'Pandoc' documents to Emacs Org-Mode. Org-Mode: <http://orgmode.org> -} module Text.Pandoc.Writers.Org (writeOrg) where +import Prelude import Control.Monad.State.Strict import Data.Char (isAlphaNum, toLower) import Data.List (intersect, intersperse, isPrefixOf, partition, transpose) @@ -166,8 +168,8 @@ blockToOrg (LineBlock lns) = do (l, _:r) -> l : splitStanza r let joinWithLinefeeds = nowrap . mconcat . intersperse cr let joinWithBlankLines = mconcat . intersperse blankline - let prettyfyStanza ls = joinWithLinefeeds <$> mapM inlineListToOrg ls - contents <- joinWithBlankLines <$> mapM prettyfyStanza (splitStanza lns) + let prettifyStanza ls = joinWithLinefeeds <$> mapM inlineListToOrg ls + contents <- joinWithBlankLines <$> mapM prettifyStanza (splitStanza lns) return $ blankline $$ "#+BEGIN_VERSE" $$ nest 2 contents $$ "#+END_VERSE" <> blankline blockToOrg (RawBlock "html" str) = diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs index 645a4cb86..665fd3f57 100644 --- a/src/Text/Pandoc/Writers/Powerpoint.hs +++ b/src/Text/Pandoc/Writers/Powerpoint.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- @@ -41,6 +42,7 @@ This is a wrapper around two modules: module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where +import Prelude import Codec.Archive.Zip import Text.Pandoc.Definition import Text.Pandoc.Walk diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs index b5138b514..865ef1efc 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PatternGuards #-} {- @@ -34,6 +35,7 @@ Text.Pandoc.Writers.Powerpoint.Presentation) to a zip archive. module Text.Pandoc.Writers.Powerpoint.Output ( presentationToArchive ) where +import Prelude import Control.Monad.Except (throwError, catchError) import Control.Monad.Reader import Control.Monad.State @@ -41,7 +43,7 @@ import Codec.Archive.Zip import Data.Char (toUpper) import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf, intersperse) import Data.Default -import Text.Pandoc.Compat.Time (formatTime, defaultTimeLocale) +import Data.Time (formatTime, defaultTimeLocale) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension) @@ -56,7 +58,7 @@ import Text.Pandoc.MIME import qualified Data.ByteString.Lazy as BL import Text.Pandoc.Writers.OOXML import qualified Data.Map as M -import Data.Maybe (mapMaybe, listToMaybe, fromMaybe, isJust, maybeToList, catMaybes) +import Data.Maybe (mapMaybe, listToMaybe, fromMaybe, maybeToList, catMaybes) import Text.Pandoc.ImageSize import Control.Applicative ((<|>)) import System.FilePath.Glob @@ -281,8 +283,9 @@ makeSlideIdMap (Presentation _ slides) = makeSpeakerNotesMap :: Presentation -> M.Map Int Int makeSpeakerNotesMap (Presentation _ slides) = M.fromList $ (mapMaybe f $ slides `zip` [1..]) `zip` [1..] - where f (Slide _ _ Nothing, _) = Nothing - f (Slide _ _ (Just _), n) = Just n + where f (Slide _ _ notes, n) = if notes == mempty + then Nothing + else Just n presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive presentationToArchive opts pres = do @@ -322,13 +325,11 @@ presentationToArchive opts pres = do -- Check to see if the presentation has speaker notes. This will -- influence whether we import the notesMaster template. presHasSpeakerNotes :: Presentation -> Bool -presHasSpeakerNotes (Presentation _ slides) = any isJust $ map slideSpeakerNotes slides +presHasSpeakerNotes (Presentation _ slides) = not $ all (mempty ==) $ map slideSpeakerNotes slides curSlideHasSpeakerNotes :: PandocMonad m => P m Bool -curSlideHasSpeakerNotes = do - sldId <- asks envCurSlideId - notesIdMap <- asks envSpeakerNotesIdMap - return $ isJust $ M.lookup sldId notesIdMap +curSlideHasSpeakerNotes = + M.member <$> asks envCurSlideId <*> asks envSpeakerNotesIdMap -------------------------------------------------- @@ -339,17 +340,9 @@ getLayout layout = do (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml" (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml" (TwoColumnSlide _ _ _) -> "ppt/slideLayouts/slideLayout4.xml" + refArchive <- asks envRefArchive distArchive <- asks envDistArchive - root <- case findEntryByPath layoutpath distArchive of - Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of - Just element -> return $ element - Nothing -> throwError $ - PandocSomeError $ - layoutpath ++ " corrupt in reference file" - Nothing -> throwError $ - PandocSomeError $ - layoutpath ++ " missing in reference file" - return root + parseXml refArchive distArchive layoutpath shapeHasId :: NameSpaces -> String -> Element -> Bool shapeHasId ns ident element @@ -930,6 +923,13 @@ graphicFrameToElements layout tbls caption = do return [graphicFrameElts, capElt] else return [graphicFrameElts] +getDefaultTableStyle :: PandocMonad m => P m (Maybe String) +getDefaultTableStyle = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + tblStyleLst <- parseXml refArchive distArchive "ppt/tableStyles.xml" + return $ findAttr (QName "def" Nothing Nothing) tblStyleLst + graphicToElement :: PandocMonad m => Integer -> Graphic -> P m Element graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do let colWidths = if null hdrCells @@ -967,12 +967,19 @@ graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do let mkgridcol w = mknode "a:gridCol" [("w", show ((12700 * w) :: Integer))] () let hasHeader = not (all null hdrCells) + + mbDefTblStyle <- getDefaultTableStyle + let tblPrElt = mknode "a:tblPr" + [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0") + , ("bandRow", if tblPrBandRow tblPr then "1" else "0") + ] (case mbDefTblStyle of + Nothing -> [] + Just sty -> [mknode "a:tableStyleId" [] sty]) + return $ mknode "a:graphic" [] $ [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $ [mknode "a:tbl" [] $ - [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0") - , ("bandRow", if tblPrBandRow tblPr then "1" else "0") - ] () + [ tblPrElt , mknode "a:tblGrid" [] (if all (==0) colWidths then [] else map mkgridcol colWidths) @@ -994,6 +1001,14 @@ getShapeByPlaceHolderType ns spTreeElem phType filterChild findPhType spTreeElem | otherwise = Nothing +-- Like the above, but it tries a number of different placeholder types +getShapeByPlaceHolderTypes :: NameSpaces -> Element -> [String] -> Maybe Element +getShapeByPlaceHolderTypes _ _ [] = Nothing +getShapeByPlaceHolderTypes ns spTreeElem (s:ss) = + case getShapeByPlaceHolderType ns spTreeElem s of + Just element -> Just element + Nothing -> getShapeByPlaceHolderTypes ns spTreeElem ss + getShapeByPlaceHolderIndex :: NameSpaces -> Element -> String -> Maybe Element getShapeByPlaceHolderIndex ns spTreeElem phIdx | isElem ns "p" "spTree" spTreeElem = @@ -1008,12 +1023,12 @@ getShapeByPlaceHolderIndex ns spTreeElem phIdx | otherwise = Nothing -nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element -nonBodyTextToElement layout phType paraElements +nonBodyTextToElement :: PandocMonad m => Element -> [String] -> [ParaElem] -> P m Element +nonBodyTextToElement layout phTypes paraElements | ns <- elemToNameSpaces layout , Just cSld <- findChild (elemName ns "p" "cSld") layout , Just spTree <- findChild (elemName ns "p" "spTree") cSld - , Just sp <- getShapeByPlaceHolderType ns spTree phType = do + , Just sp <- getShapeByPlaceHolderTypes ns spTree phTypes = do let hdrPara = Paragraph def paraElements element <- paragraphToElement hdrPara let txBody = mknode "p:txBody" [] $ @@ -1028,7 +1043,7 @@ contentToElement layout hdrShape shapes | ns <- elemToNameSpaces layout , Just cSld <- findChild (elemName ns "p" "cSld") layout , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do - element <- nonBodyTextToElement layout "title" hdrShape + element <- nonBodyTextToElement layout ["title"] hdrShape let hdrShapeElements = if null hdrShape then [] else [element] @@ -1046,7 +1061,7 @@ twoColumnToElement layout hdrShape shapesL shapesR | ns <- elemToNameSpaces layout , Just cSld <- findChild (elemName ns "p" "cSld") layout , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do - element <- nonBodyTextToElement layout "title" hdrShape + element <- nonBodyTextToElement layout ["title"] hdrShape let hdrShapeElements = if null hdrShape then [] else [element] @@ -1070,7 +1085,7 @@ titleToElement layout titleElems | ns <- elemToNameSpaces layout , Just cSld <- findChild (elemName ns "p" "cSld") layout , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do - element <- nonBodyTextToElement layout "title" titleElems + element <- nonBodyTextToElement layout ["title", "ctrTitle"] titleElems let titleShapeElements = if null titleElems then [] else [element] @@ -1084,15 +1099,15 @@ metadataToElement layout titleElems subtitleElems authorsElems dateElems , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do titleShapeElements <- if null titleElems then return [] - else sequence [nonBodyTextToElement layout "ctrTitle" titleElems] + else sequence [nonBodyTextToElement layout ["ctrTitle"] titleElems] let combinedAuthorElems = intercalate [Break] authorsElems subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems] subtitleShapeElements <- if null subtitleAndAuthorElems then return [] - else sequence [nonBodyTextToElement layout "subTitle" subtitleAndAuthorElems] + else sequence [nonBodyTextToElement layout ["subTitle"] subtitleAndAuthorElems] dateShapeElements <- if null dateElems then return [] - else sequence [nonBodyTextToElement layout "dt" dateElems] + else sequence [nonBodyTextToElement layout ["dt"] dateElems] return $ replaceNamedChildren ns "p" "sp" (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements) spTree @@ -1144,18 +1159,9 @@ slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems da getNotesMaster :: PandocMonad m => P m Element getNotesMaster = do - let notesMasterPath = "ppt/notesMasters/notesMaster1.xml" + refArchive <- asks envRefArchive distArchive <- asks envDistArchive - root <- case findEntryByPath notesMasterPath distArchive of - Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of - Just element -> return $ element - Nothing -> throwError $ - PandocSomeError $ - notesMasterPath ++ " corrupt in reference file" - Nothing -> throwError $ - PandocSomeError $ - notesMasterPath ++ " missing in reference file" - return root + parseXml refArchive distArchive "ppt/notesMasters/notesMaster1.xml" getSlideNumberFieldId :: PandocMonad m => Element -> P m String getSlideNumberFieldId notesMaster @@ -1256,42 +1262,40 @@ speakerNotesSlideNumber pgNum fieldId = ] slideToSpeakerNotesElement :: PandocMonad m => Slide -> P m (Maybe Element) -slideToSpeakerNotesElement slide - | Slide _ _ mbNotes <- slide - , Just (SpeakerNotes paras) <- mbNotes = do - master <- getNotesMaster - fieldId <- getSlideNumberFieldId master - num <- slideNum slide - let imgShape = speakerNotesSlideImage - sldNumShape = speakerNotesSlideNumber num fieldId - bodyShape <- speakerNotesBody paras - return $ Just $ - mknode "p:notes" - [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main") - , ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") - , ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") - ] [ mknode "p:cSld" [] - [ mknode "p:spTree" [] - [ mknode "p:nvGrpSpPr" [] - [ mknode "p:cNvPr" [("id", "1"), ("name", "")] () - , mknode "p:cNvGrpSpPr" [] () - , mknode "p:nvPr" [] () - ] - , mknode "p:grpSpPr" [] - [ mknode "a:xfrm" [] - [ mknode "a:off" [("x", "0"), ("y", "0")] () - , mknode "a:ext" [("cx", "0"), ("cy", "0")] () - , mknode "a:chOff" [("x", "0"), ("y", "0")] () - , mknode "a:chExt" [("cx", "0"), ("cy", "0")] () - ] - ] - , imgShape - , bodyShape - , sldNumShape +slideToSpeakerNotesElement (Slide _ _ (SpeakerNotes [])) = return Nothing +slideToSpeakerNotesElement slide@(Slide _ _ (SpeakerNotes paras)) = do + master <- getNotesMaster + fieldId <- getSlideNumberFieldId master + num <- slideNum slide + let imgShape = speakerNotesSlideImage + sldNumShape = speakerNotesSlideNumber num fieldId + bodyShape <- speakerNotesBody paras + return $ Just $ + mknode "p:notes" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main") + , ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") + , ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [ mknode "p:cSld" [] + [ mknode "p:spTree" [] + [ mknode "p:nvGrpSpPr" [] + [ mknode "p:cNvPr" [("id", "1"), ("name", "")] () + , mknode "p:cNvGrpSpPr" [] () + , mknode "p:nvPr" [] () ] + , mknode "p:grpSpPr" [] + [ mknode "a:xfrm" [] + [ mknode "a:off" [("x", "0"), ("y", "0")] () + , mknode "a:ext" [("cx", "0"), ("cy", "0")] () + , mknode "a:chOff" [("x", "0"), ("y", "0")] () + , mknode "a:chExt" [("cx", "0"), ("cy", "0")] () + ] ] + , imgShape + , bodyShape + , sldNumShape ] -slideToSpeakerNotesElement _ = return Nothing + ] + ] ----------------------------------------------------------------------- @@ -1466,23 +1470,22 @@ slideToSpeakerNotesEntry slide = do _ -> return Nothing slideToSpeakerNotesRelElement :: PandocMonad m => Slide -> P m (Maybe Element) -slideToSpeakerNotesRelElement slide - | Slide _ _ mbNotes <- slide - , Just _ <- mbNotes = do - idNum <- slideNum slide - return $ Just $ - mknode "Relationships" - [("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") - ] () - , mknode "Relationship" [ ("Id", "rId1") - , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster") - , ("Target", "../notesMasters/notesMaster1.xml") - ] () - ] -slideToSpeakerNotesRelElement _ = return Nothing +slideToSpeakerNotesRelElement (Slide _ _ (SpeakerNotes [])) = return Nothing +slideToSpeakerNotesRelElement slide@(Slide _ _ _) = do + idNum <- slideNum slide + return $ Just $ + mknode "Relationships" + [("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") + ] () + , mknode "Relationship" [ ("Id", "rId1") + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster") + , ("Target", "../notesMasters/notesMaster1.xml") + ] () + ] + slideToSpeakerNotesRelEntry :: PandocMonad m => Slide -> P m (Maybe Entry) slideToSpeakerNotesRelEntry slide = do diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs index ac7c86945..e14476b16 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {- Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu> @@ -57,6 +59,7 @@ module Text.Pandoc.Writers.Powerpoint.Presentation ( documentToPresentation ) where +import Prelude import Control.Monad.Reader import Control.Monad.State import Data.List (intercalate) @@ -67,7 +70,7 @@ import Text.Pandoc.Slides (getSlideLevel) import Text.Pandoc.Options import Text.Pandoc.Logging import Text.Pandoc.Walk -import Text.Pandoc.Compat.Time (UTCTime) +import Data.Time (UTCTime) import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element" import Text.Pandoc.Writers.Shared (metaValueToInlines) import qualified Data.Map as M @@ -110,7 +113,7 @@ data WriterState = WriterState { stNoteIds :: M.Map Int [Block] , stAnchorMap :: M.Map String SlideId , stSlideIdSet :: S.Set SlideId , stLog :: [LogMessage] - , stSpeakerNotesMap :: M.Map SlideId [[Paragraph]] + , stSpeakerNotes :: SpeakerNotes } deriving (Show, Eq) instance Default WriterState where @@ -119,7 +122,7 @@ instance Default WriterState where -- we reserve this s , stSlideIdSet = reservedSlideIds , stLog = [] - , stSpeakerNotesMap = mempty + , stSpeakerNotes = mempty } metadataSlideId :: SlideId @@ -183,7 +186,7 @@ data DocProps = DocProps { dcTitle :: Maybe String data Slide = Slide { slideId :: SlideId , slideLayout :: Layout - , slideSpeakerNotes :: Maybe SpeakerNotes + , slideSpeakerNotes :: SpeakerNotes } deriving (Show, Eq) newtype SlideId = SlideId String @@ -193,7 +196,7 @@ newtype SlideId = SlideId String -- designed mainly for one textbox, so we'll just put in the contents -- of that textbox, to avoid other shapes that won't work as well. newtype SpeakerNotes = SpeakerNotes {fromSpeakerNotes :: [Paragraph]} - deriving (Show, Eq) + deriving (Show, Eq, Monoid, Semigroup) data Layout = MetadataSlide { metadataSlideTitle :: [ParaElem] , metadataSlideSubtitle :: [ParaElem] @@ -229,7 +232,6 @@ data Paragraph = Paragraph { paraProps :: ParaProps , paraElems :: [ParaElem] } deriving (Show, Eq) - data BulletType = Bullet | AutoNumbering ListAttributes deriving (Show, Eq) @@ -374,9 +376,20 @@ inlineToParElems (Note blks) = do modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes } local (\env -> env{envRunProps = (envRunProps env){rLink = Just $ InternalTarget endNotesSlideId}}) $ inlineToParElems $ Superscript [Str $ show curNoteId] -inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils +inlineToParElems (Span _ ils) = inlinesToParElems ils +inlineToParElems (Quoted quoteType ils) = + inlinesToParElems $ [Str open] ++ ils ++ [Str close] + where (open, close) = case quoteType of + SingleQuote -> ("\x2018", "\x2019") + DoubleQuote -> ("\x201C", "\x201D") inlineToParElems (RawInline _ _) = return [] -inlineToParElems _ = return [] +inlineToParElems (Cite _ ils) = inlinesToParElems ils +-- Note: we shouldn't reach this, because images should be handled at +-- the shape level, but should that change in the future, we render +-- the alt text. +inlineToParElems (Image _ alt _) = inlinesToParElems alt + + isListType :: Block -> Bool isListType (OrderedList _ _) = True @@ -399,10 +412,7 @@ noteSize :: Pixels noteSize = 18 blockToParagraphs :: Block -> Pres [Paragraph] -blockToParagraphs (Plain ils) = do - parElems <- inlinesToParElems ils - pProps <- asks envParaProps - return [Paragraph pProps parElems] +blockToParagraphs (Plain ils) = blockToParagraphs (Para ils) blockToParagraphs (Para ils) = do parElems <- inlinesToParElems ils pProps <- asks envParaProps @@ -475,16 +485,6 @@ blockToParagraphs (DefinitionList entries) = do definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst return $ term ++ definition concatMapM go entries -blockToParagraphs (Div (_, "notes" : [], _) blks) = - local (\env -> env{envInSpeakerNotes=True}) $ do - sldId <- asks envCurSlideId - spkNotesMap <- gets stSpeakerNotesMap - paras <- concatMapM blockToParagraphs blks - let spkNotesMap' = case M.lookup sldId spkNotesMap of - Just lst -> M.insert sldId (paras : lst) spkNotesMap - Nothing -> M.insert sldId [paras] spkNotesMap - modify $ \st -> st{stSpeakerNotesMap = spkNotesMap'} - return [] blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks blockToParagraphs blk = do addLogMessage $ BlockNotRendered blk @@ -527,14 +527,9 @@ withAttr attr (Pic picPr url caption) = withAttr _ sp = sp blockToShape :: Block -> Pres Shape -blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il = - (withAttr attr . Pic def url) <$> inlinesToParElems ils +blockToShape (Plain ils) = blockToShape (Para ils) blockToShape (Para (il:_)) | Image attr ils (url, _) <- il = (withAttr attr . Pic def url) <$> inlinesToParElems ils -blockToShape (Plain (il:_)) | Link _ (il':_) target <- il - , Image attr ils (url, _) <- il' = - (withAttr attr . Pic def {picPropLink = Just $ ExternalTarget target} url) <$> - inlinesToParElems ils blockToShape (Para (il:_)) | Link _ (il':_) target <- il , Image attr ils (url, _) <- il' = (withAttr attr . Pic def{picPropLink = Just $ ExternalTarget target} url) <$> @@ -558,20 +553,23 @@ blockToShape blk = do paras <- blockToParagraphs blk combineShapes :: [Shape] -> [Shape] combineShapes [] = [] -combineShapes[s] = [s] -combineShapes (pic@(Pic{}) : ss) = pic : combineShapes ss +combineShapes (pic@Pic{} : ss) = pic : combineShapes ss combineShapes (TextBox [] : ss) = combineShapes ss combineShapes (s : TextBox [] : ss) = combineShapes (s : ss) combineShapes (TextBox (p:ps) : TextBox (p':ps') : ss) = combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss combineShapes (s:ss) = s : combineShapes ss +isNotesDiv :: Block -> Bool +isNotesDiv (Div (_, ["notes"], _) _) = True +isNotesDiv _ = False + blocksToShapes :: [Block] -> Pres [Shape] blocksToShapes blks = combineShapes <$> mapM blockToShape blks isImage :: Inline -> Bool -isImage (Image{}) = True -isImage (Link _ (Image _ _ _ : _) _) = True +isImage Image{} = True +isImage (Link _ (Image{} : _) _) = True isImage _ = False splitBlocks' :: [Block] -> [[Block]] -> [Block] -> Pres [[Block]] @@ -589,64 +587,60 @@ splitBlocks' cur acc (h@(Header n _ _) : blks) = do splitBlocks' cur acc (Plain ils : blks) = splitBlocks' cur acc (Para ils : blks) splitBlocks' cur acc (Para (il:ils) : blks) | isImage il = do slideLevel <- asks envSlideLevel + let (nts, blks') = if null ils + then span isNotesDiv blks + else ([], blks) case cur of - [(Header n _ _)] | n == slideLevel -> + [Header n _ _] | n == slideLevel -> splitBlocks' [] - (acc ++ [cur ++ [Para [il]]]) - (if null ils then blks else Para ils : blks) + (acc ++ [cur ++ [Para [il]] ++ nts]) + (if null ils then blks' else Para ils : blks') _ -> splitBlocks' [] - (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]]]) - (if null ils then blks else Para ils : blks) -splitBlocks' cur acc (tbl@(Table{}) : blks) = do + (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]] ++ nts]) + (if null ils then blks' else Para ils : blks') +splitBlocks' cur acc (tbl@Table{} : blks) = do slideLevel <- asks envSlideLevel + let (nts, blks') = span isNotesDiv blks case cur of - [(Header n _ _)] | n == slideLevel -> - splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks - _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks + [Header n _ _] | n == slideLevel -> + splitBlocks' [] (acc ++ [cur ++ [tbl] ++ nts]) blks' + _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl] ++ nts]) blks' splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes = do slideLevel <- asks envSlideLevel + let (nts, blks') = span isNotesDiv blks case cur of - [(Header n _ _)] | n == slideLevel -> - splitBlocks' [] (acc ++ [cur ++ [d]]) blks - _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) blks + [Header n _ _] | n == slideLevel -> + splitBlocks' [] (acc ++ [cur ++ [d] ++ nts]) blks' + _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d] ++ nts]) blks' splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks splitBlocks :: [Block] -> Pres [[Block]] splitBlocks = splitBlocks' [] [] -getSpeakerNotes :: Pres (Maybe SpeakerNotes) -getSpeakerNotes = do - sldId <- asks envCurSlideId - spkNtsMap <- gets stSpeakerNotesMap - return $ (SpeakerNotes . concat . reverse) <$> (M.lookup sldId spkNtsMap) - -blocksToSlide' :: Int -> [Block] -> Pres Slide -blocksToSlide' lvl (Header n (ident, _, _) ils : blks) +blocksToSlide' :: Int -> [Block] -> SpeakerNotes -> Pres Slide +blocksToSlide' lvl (Header n (ident, _, _) ils : blks) spkNotes | n < lvl = do registerAnchorId ident sldId <- asks envCurSlideId hdr <- inlinesToParElems ils - return $ Slide sldId TitleSlide {titleSlideHeader = hdr} Nothing + return $ Slide sldId TitleSlide {titleSlideHeader = hdr} spkNotes | n == lvl = do registerAnchorId ident hdr <- inlinesToParElems ils -- Now get the slide without the header, and then add the header -- in. - slide <- blocksToSlide' lvl blks + slide <- blocksToSlide' lvl blks spkNotes let layout = case slideLayout slide of ContentSlide _ cont -> ContentSlide hdr cont TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR layout' -> layout' return $ slide{slideLayout = layout} -blocksToSlide' _ (blk : blks) +blocksToSlide' _ (blk : blks) spkNotes | Div (_, classes, _) divBlks <- blk , "columns" `elem` classes , Div (_, clsL, _) blksL : Div (_, clsR, _) blksR : remaining <- divBlks , "column" `elem` clsL, "column" `elem` clsR = do - unless (null blks) - (mapM (addLogMessage . BlockNotRendered) blks >> return ()) - unless (null remaining) - (mapM (addLogMessage . BlockNotRendered) remaining >> return ()) + mapM_ (addLogMessage . BlockNotRendered) (blks ++ remaining) mbSplitBlksL <- splitBlocks blksL mbSplitBlksR <- splitBlocks blksR let blksL' = case mbSplitBlksL of @@ -664,8 +658,8 @@ blocksToSlide' _ (blk : blks) , twoColumnSlideLeft = shapesL , twoColumnSlideRight = shapesR } - Nothing -blocksToSlide' _ (blk : blks) = do + spkNotes +blocksToSlide' _ (blk : blks) spkNotes = do inNoteSlide <- asks envInNoteSlide shapes <- if inNoteSlide then forceFontSize noteSize $ blocksToShapes (blk : blks) @@ -677,8 +671,8 @@ blocksToSlide' _ (blk : blks) = do ContentSlide { contentSlideHeader = [] , contentSlideContent = shapes } - Nothing -blocksToSlide' _ [] = do + spkNotes +blocksToSlide' _ [] spkNotes = do sldId <- asks envCurSlideId return $ Slide @@ -686,14 +680,32 @@ blocksToSlide' _ [] = do ContentSlide { contentSlideHeader = [] , contentSlideContent = [] } - Nothing + spkNotes + +handleNotes :: Block -> Pres () +handleNotes (Div (_, ["notes"], _) blks) = + local (\env -> env{envInSpeakerNotes=True}) $ do + spNotes <- SpeakerNotes <$> concatMapM blockToParagraphs blks + modify $ \st -> st{stSpeakerNotes = (stSpeakerNotes st) <> spNotes} +handleNotes _ = return () + +handleAndFilterNotes' :: [Block] -> Pres [Block] +handleAndFilterNotes' blks = do + mapM_ handleNotes blks + return $ filter (not . isNotesDiv) blks + +handleAndFilterNotes :: [Block] -> Pres ([Block], SpeakerNotes) +handleAndFilterNotes blks = do + modify $ \st -> st{stSpeakerNotes = mempty} + blks' <- walkM handleAndFilterNotes' blks + spkNotes <- gets stSpeakerNotes + return (blks', spkNotes) blocksToSlide :: [Block] -> Pres Slide blocksToSlide blks = do + (blks', spkNotes) <- handleAndFilterNotes blks slideLevel <- asks envSlideLevel - sld <- blocksToSlide' slideLevel blks - spkNotes <- getSpeakerNotes - return $ sld{slideSpeakerNotes = spkNotes} + blocksToSlide' slideLevel blks' spkNotes makeNoteEntry :: Int -> [Block] -> [Block] makeNoteEntry n blks = @@ -719,15 +731,14 @@ makeEndNotesSlideBlocks = do anchorSet <- M.keysSet <$> gets stAnchorMap if M.null noteIds then return [] - else do let title = case lookupMeta "notes-title" meta of - Just val -> metaValueToInlines val - Nothing -> [Str "Notes"] - ident = Shared.uniqueIdent title anchorSet - hdr = Header slideLevel (ident, [], []) title - blks <- return $ - concatMap (\(n, bs) -> makeNoteEntry n bs) $ + else let title = case lookupMeta "notes-title" meta of + Just val -> metaValueToInlines val + Nothing -> [Str "Notes"] + ident = Shared.uniqueIdent title anchorSet + hdr = Header slideLevel (ident, [], []) title + blks = concatMap (\(n, bs) -> makeNoteEntry n bs) $ M.toList noteIds - return $ hdr : blks + in return $ hdr : blks getMetaSlide :: Pres (Maybe Slide) getMetaSlide = do @@ -753,7 +764,7 @@ getMetaSlide = do , metadataSlideAuthors = authors , metadataSlideDate = date } - Nothing + mempty -- adapted from the markdown writer elementToListItem :: Shared.Element -> Pres [Block] @@ -778,8 +789,7 @@ makeTOCSlide blks = local (\env -> env{envCurSlideId = tocSlideId}) $ do Just val -> metaValueToInlines val Nothing -> [Str "Table of Contents"] hdr = Header slideLevel nullAttr tocTitle - sld <- blocksToSlide [hdr, contents] - return sld + blocksToSlide [hdr, contents] combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem] combineParaElems' mbPElem [] = maybeToList mbPElem @@ -802,15 +812,9 @@ applyToParagraph f para = do return $ para {paraElems = paraElems'} applyToShape :: Monad m => (ParaElem -> m ParaElem) -> Shape -> m Shape -applyToShape f (Pic pPr fp pes) = do - pes' <- mapM f pes - return $ Pic pPr fp pes' -applyToShape f (GraphicFrame gfx pes) = do - pes' <- mapM f pes - return $ GraphicFrame gfx pes' -applyToShape f (TextBox paras) = do - paras' <- mapM (applyToParagraph f) paras - return $ TextBox paras' +applyToShape f (Pic pPr fp pes) = Pic pPr fp <$> mapM f pes +applyToShape f (GraphicFrame gfx pes) = GraphicFrame gfx <$> mapM f pes +applyToShape f (TextBox paras) = TextBox <$> mapM (applyToParagraph f) paras applyToLayout :: Monad m => (ParaElem -> m ParaElem) -> Layout -> m Layout applyToLayout f (MetadataSlide title subtitle authors date) = do @@ -819,9 +823,7 @@ applyToLayout f (MetadataSlide title subtitle authors date) = do authors' <- mapM (mapM f) authors date' <- mapM f date return $ MetadataSlide title' subtitle' authors' date' -applyToLayout f (TitleSlide title) = do - title' <- mapM f title - return $ TitleSlide title' +applyToLayout f (TitleSlide title) = TitleSlide <$> mapM f title applyToLayout f (ContentSlide hdr content) = do hdr' <- mapM f hdr content' <- mapM (applyToShape f) content @@ -835,11 +837,9 @@ applyToLayout f (TwoColumnSlide hdr contentL contentR) = do applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide applyToSlide f slide = do layout' <- applyToLayout f $ slideLayout slide - mbNotes' <- case slideSpeakerNotes slide of - Just (SpeakerNotes notes) -> (Just . SpeakerNotes) <$> - mapM (applyToParagraph f) notes - Nothing -> return Nothing - return slide{slideLayout = layout', slideSpeakerNotes = mbNotes'} + let paras = fromSpeakerNotes $ slideSpeakerNotes slide + notes' <- SpeakerNotes <$> mapM (applyToParagraph f) paras + return slide{slideLayout = layout', slideSpeakerNotes = notes'} replaceAnchor :: ParaElem -> Pres ParaElem replaceAnchor (Run rProps s) @@ -853,6 +853,40 @@ replaceAnchor (Run rProps s) return $ Run rProps' s replaceAnchor pe = return pe +emptyParaElem :: ParaElem -> Bool +emptyParaElem (Run _ s) = + null $ Shared.trim s +emptyParaElem (MathElem _ ts) = + null $ Shared.trim $ unTeXString ts +emptyParaElem _ = False + +emptyParagraph :: Paragraph -> Bool +emptyParagraph para = all emptyParaElem $ paraElems para + + +emptyShape :: Shape -> Bool +emptyShape (TextBox paras) = all emptyParagraph paras +emptyShape _ = False + +emptyLayout :: Layout -> Bool +emptyLayout layout = case layout of + MetadataSlide title subtitle authors date -> + all emptyParaElem title && + all emptyParaElem subtitle && + all (all emptyParaElem) authors && + all emptyParaElem date + TitleSlide hdr -> all emptyParaElem hdr + ContentSlide hdr shapes -> + all emptyParaElem hdr && + all emptyShape shapes + TwoColumnSlide hdr shapes1 shapes2 -> + all emptyParaElem hdr && + all emptyShape shapes1 && + all emptyShape shapes2 + +emptySlide :: Slide -> Bool +emptySlide (Slide _ layout notes) = (notes == mempty) && (emptyLayout layout) + blocksToPresentationSlides :: [Block] -> Pres [Slide] blocksToPresentationSlides blks = do opts <- asks envOpts @@ -893,7 +927,8 @@ blocksToPresentationSlides blks = do return [endNotesSlide] let slides = metadataslides ++ tocSlides ++ bodyslides ++ endNotesSlides - mapM (applyToSlide replaceAnchor) slides + slides' = filter (not . emptySlide) slides + mapM (applyToSlide replaceAnchor) slides' metaToDocProps :: Meta -> DocProps metaToDocProps meta = diff --git a/src/Text/Pandoc/Writers/RST.hs b/src/Text/Pandoc/Writers/RST.hs index 95cb46643..f82597c55 100644 --- a/src/Text/Pandoc/Writers/RST.hs +++ b/src/Text/Pandoc/Writers/RST.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,7 +31,8 @@ Conversion of 'Pandoc' documents to reStructuredText. reStructuredText: <http://docutils.sourceforge.net/rst.html> -} -module Text.Pandoc.Writers.RST ( writeRST ) where +module Text.Pandoc.Writers.RST ( writeRST, flatten ) where +import Prelude import Control.Monad.State.Strict import Data.Char (isSpace, toLower) import Data.List (isPrefixOf, stripPrefix) @@ -46,6 +48,7 @@ import Text.Pandoc.Pretty import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate') import Text.Pandoc.Writers.Shared +import Text.Pandoc.Walk type Refs = [([Inline], Target)] @@ -260,7 +263,6 @@ blockToRST (Header level (name,classes,_) inlines) = do return $ nowrap $ hang 3 ".. " (rub $$ name' $$ cls) $$ blankline blockToRST (CodeBlock (_,classes,kvs) str) = do opts <- gets stOptions - let tabstop = writerTabStop opts let startnum = maybe "" (\x -> " " <> text x) $ lookup "startFrom" kvs let numberlines = if "numberLines" `elem` classes then " :number-lines:" <> startnum @@ -273,11 +275,10 @@ blockToRST (CodeBlock (_,classes,kvs) str) = do c `notElem` ["sourceCode","literate","numberLines"]] of [] -> "::" (lang:_) -> (".. code:: " <> text lang) $$ numberlines) - $+$ nest tabstop (text str) $$ blankline + $+$ nest 3 (text str) $$ blankline blockToRST (BlockQuote blocks) = do - tabstop <- gets $ writerTabStop . stOptions contents <- blockListToRST blocks - return $ nest tabstop contents <> blankline + return $ nest 3 contents <> blankline blockToRST (Table caption aligns widths headers rows) = do caption' <- inlineListToRST caption let blocksToDoc opts bs = do @@ -335,8 +336,7 @@ definitionListItemToRST :: PandocMonad m => ([Inline], [[Block]]) -> RST m Doc definitionListItemToRST (label, defs) = do label' <- inlineListToRST label contents <- liftM vcat $ mapM blockListToRST defs - tabstop <- gets $ writerTabStop . stOptions - return $ nowrap label' $$ nest tabstop (nestle contents <> cr) + return $ nowrap label' $$ nest 3 (nestle contents <> cr) -- | Format a list of lines as line block. linesToLineBlock :: PandocMonad m => [[Inline]] -> RST m Doc @@ -376,12 +376,27 @@ blockListToRST :: PandocMonad m -> RST m Doc blockListToRST = blockListToRST' False --- | Convert list of Pandoc inline elements to RST. -inlineListToRST :: PandocMonad m => [Inline] -> RST m Doc -inlineListToRST lst = - mapM inlineToRST (removeSpaceAfterDisplayMath $ insertBS lst) >>= - return . hcat - where -- remove spaces after displaymath, as they screw up indentation: +transformInlines :: [Inline] -> [Inline] +transformInlines = insertBS . + filter hasContents . + removeSpaceAfterDisplayMath . + concatMap (transformNested . flatten) + where -- empty inlines are not valid RST syntax + hasContents :: Inline -> Bool + hasContents (Str "") = False + hasContents (Emph []) = False + hasContents (Strong []) = False + hasContents (Strikeout []) = False + hasContents (Superscript []) = False + hasContents (Subscript []) = False + hasContents (SmallCaps []) = False + hasContents (Quoted _ []) = False + hasContents (Cite _ []) = False + hasContents (Span _ []) = False + hasContents (Link _ [] ("", "")) = False + hasContents (Image _ [] ("", "")) = False + hasContents _ = True + -- remove spaces after displaymath, as they screw up indentation: removeSpaceAfterDisplayMath (Math DisplayMath x : zs) = Math DisplayMath x : dropWhile (==Space) zs removeSpaceAfterDisplayMath (x:xs) = x : removeSpaceAfterDisplayMath xs @@ -399,6 +414,8 @@ inlineListToRST lst = x : insertBS (y : zs) insertBS (x:ys) = x : insertBS ys insertBS [] = [] + transformNested :: [Inline] -> [Inline] + transformNested = map (mapNested stripLeadingTrailingSpace) surroundComplex :: Inline -> Inline -> Bool surroundComplex (Str s@(_:_)) (Str s'@(_:_)) = case (last s, head s') of @@ -436,44 +453,122 @@ inlineListToRST lst = isComplex (Span _ (x:_)) = isComplex x isComplex _ = False +-- | Flattens nested inlines. Extracts nested inlines and goes through +-- them either collapsing them in the outer inline container or +-- pulling them out of it +flatten :: Inline -> [Inline] +flatten outer + | null contents = [outer] + | otherwise = combineAll contents + where contents = dropInlineParent outer + combineAll = foldl combine [] + + combine :: [Inline] -> Inline -> [Inline] + combine f i = + case (outer, i) of + -- quotes are not rendered using RST inlines, so we can keep + -- them and they will be readable and parsable + (Quoted _ _, _) -> keep f i + (_, Quoted _ _) -> keep f i + -- parent inlines would prevent links from being correctly + -- parsed, in this case we prioritise the content over the + -- style + (_, Link _ _ _) -> emerge f i + -- always give priority to strong text over emphasis + (Emph _, Strong _) -> emerge f i + -- drop all other nested styles + (_, _) -> collapse f i + + emerge f i = f <> [i] + keep f i = appendToLast f [i] + collapse f i = appendToLast f $ dropInlineParent i + + appendToLast :: [Inline] -> [Inline] -> [Inline] + appendToLast [] toAppend = [setInlineChildren outer toAppend] + appendToLast flattened toAppend + | isOuter lastFlat = init flattened <> [appendTo lastFlat toAppend] + | otherwise = flattened <> [setInlineChildren outer toAppend] + where lastFlat = last flattened + appendTo o i = mapNested (<> i) o + isOuter i = emptyParent i == emptyParent outer + emptyParent i = setInlineChildren i [] + +mapNested :: ([Inline] -> [Inline]) -> Inline -> Inline +mapNested f i = setInlineChildren i (f (dropInlineParent i)) + +dropInlineParent :: Inline -> [Inline] +dropInlineParent (Link _ i _) = i +dropInlineParent (Emph i) = i +dropInlineParent (Strong i) = i +dropInlineParent (Strikeout i) = i +dropInlineParent (Superscript i) = i +dropInlineParent (Subscript i) = i +dropInlineParent (SmallCaps i) = i +dropInlineParent (Cite _ i) = i +dropInlineParent (Image _ i _) = i +dropInlineParent (Span _ i) = i +dropInlineParent (Quoted _ i) = i +dropInlineParent i = [i] -- not a parent, like Str or Space + +setInlineChildren :: Inline -> [Inline] -> Inline +setInlineChildren (Link a _ t) i = Link a i t +setInlineChildren (Emph _) i = Emph i +setInlineChildren (Strong _) i = Strong i +setInlineChildren (Strikeout _) i = Strikeout i +setInlineChildren (Superscript _) i = Superscript i +setInlineChildren (Subscript _) i = Subscript i +setInlineChildren (SmallCaps _) i = SmallCaps i +setInlineChildren (Quoted q _) i = Quoted q i +setInlineChildren (Cite c _) i = Cite c i +setInlineChildren (Image a _ t) i = Image a i t +setInlineChildren (Span a _) i = Span a i +setInlineChildren leaf _ = leaf + +inlineListToRST :: PandocMonad m => [Inline] -> RST m Doc +inlineListToRST = writeInlines . walk transformInlines + +-- | Convert list of Pandoc inline elements to RST. +writeInlines :: PandocMonad m => [Inline] -> RST m Doc +writeInlines lst = mapM inlineToRST lst >>= return . hcat + -- | Convert Pandoc inline element to RST. inlineToRST :: PandocMonad m => Inline -> RST m Doc inlineToRST (Span (_,_,kvs) ils) = do - contents <- inlineListToRST ils + contents <- writeInlines ils return $ case lookup "role" kvs of Just role -> ":" <> text role <> ":`" <> contents <> "`" Nothing -> contents inlineToRST (Emph lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst return $ "*" <> contents <> "*" inlineToRST (Strong lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst return $ "**" <> contents <> "**" inlineToRST (Strikeout lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst return $ "[STRIKEOUT:" <> contents <> "]" inlineToRST (Superscript lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst return $ ":sup:`" <> contents <> "`" inlineToRST (Subscript lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst return $ ":sub:`" <> contents <> "`" -inlineToRST (SmallCaps lst) = inlineListToRST lst +inlineToRST (SmallCaps lst) = writeInlines lst inlineToRST (Quoted SingleQuote lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst opts <- gets stOptions if isEnabled Ext_smart opts then return $ "'" <> contents <> "'" else return $ "‘" <> contents <> "’" inlineToRST (Quoted DoubleQuote lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst opts <- gets stOptions if isEnabled Ext_smart opts then return $ "\"" <> contents <> "\"" else return $ "“" <> contents <> "”" inlineToRST (Cite _ lst) = - inlineListToRST lst + writeInlines lst inlineToRST (Code _ str) = do opts <- gets stOptions -- we trim the string because the delimiters must adjoin a @@ -524,7 +619,7 @@ inlineToRST (Link _ [Image attr alt (imgsrc,imgtit)] (src, _tit)) = do return $ "|" <> label <> "|" inlineToRST (Link _ txt (src, tit)) = do useReferenceLinks <- gets $ writerReferenceLinks . stOptions - linktext <- inlineListToRST $ B.toList . B.trimInlines . B.fromList $ txt + linktext <- writeInlines $ B.toList . B.trimInlines . B.fromList $ txt if useReferenceLinks then do refs <- gets stLinks case lookup txt refs of diff --git a/src/Text/Pandoc/Writers/RTF.hs b/src/Text/Pandoc/Writers/RTF.hs index 7006b58d1..3045c1c10 100644 --- a/src/Text/Pandoc/Writers/RTF.hs +++ b/src/Text/Pandoc/Writers/RTF.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of 'Pandoc' documents to RTF (rich text format). -} module Text.Pandoc.Writers.RTF ( writeRTF ) where +import Prelude import Control.Monad.Except (catchError, throwError) import Control.Monad import qualified Data.ByteString as B diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs index ae4cc5cc5..2edce7deb 100644 --- a/src/Text/Pandoc/Writers/Shared.hs +++ b/src/Text/Pandoc/Writers/Shared.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2013-2018 John MacFarlane <jgm@berkeley.edu> @@ -41,8 +42,10 @@ module Text.Pandoc.Writers.Shared ( , unsmartify , gridTable , metaValueToInlines + , stripLeadingTrailingSpace ) where +import Prelude import Control.Monad (zipWithM) import Data.Aeson (FromJSON (..), Result (..), ToJSON (..), Value (Object), encode, fromJSON) @@ -240,40 +243,58 @@ gridTable :: Monad m -> [[[Block]]] -> m Doc gridTable opts blocksToDoc headless aligns widths headers rows = do + -- the number of columns will be used in case of even widths let numcols = maximum (length aligns : length widths : map length (headers:rows)) + -- handleGivenWidths wraps the given blocks in order for them to fit + -- in cells with given widths. the returned content can be + -- concatenated with borders and frames let handleGivenWidths widths' = do let widthsInChars' = map ( (\x -> if x < 1 then 1 else x) . (\x -> x - 3) . floor . (fromIntegral (writerColumns opts) *) ) widths' - rawHeaders' <- zipWithM blocksToDoc - (map (\w -> opts{writerColumns = - min (w - 2) (writerColumns opts)}) widthsInChars') - headers + -- replace page width (in columns) in the options with a + -- given width if smaller (adjusting by two) + useWidth w = opts{writerColumns = min (w - 2) (writerColumns opts)} + -- prepare options to use with header and row cells + columnOptions = map useWidth widthsInChars' + rawHeaders' <- zipWithM blocksToDoc columnOptions headers rawRows' <- mapM - (\cs -> zipWithM blocksToDoc - (map (\w -> opts{writerColumns = - min (w - 2) (writerColumns opts)}) widthsInChars') - cs) + (\cs -> zipWithM blocksToDoc columnOptions cs) rows return (widthsInChars', rawHeaders', rawRows') - let handleZeroWidths = do + -- handleFullWidths tries to wrap cells to the page width or even + -- more in cases where `--wrap=none`. thus the content here is left + -- as wide as possible + let handleFullWidths = do rawHeaders' <- mapM (blocksToDoc opts) headers rawRows' <- mapM (mapM (blocksToDoc opts)) rows let numChars [] = 0 numChars xs = maximum . map offset $ xs let widthsInChars' = map numChars $ transpose (rawHeaders' : rawRows') + return (widthsInChars', rawHeaders', rawRows') + -- handleZeroWidths calls handleFullWidths to check whether a wide + -- table would fit in the page. if the produced table is too wide, + -- it calculates even widths and passes the content to + -- handleGivenWidths + let handleZeroWidths = do + (widthsInChars', rawHeaders', rawRows') <- handleFullWidths if sum widthsInChars' > writerColumns opts then -- use even widths handleGivenWidths (replicate numcols (1.0 / fromIntegral numcols) :: [Double]) else return (widthsInChars', rawHeaders', rawRows') - (widthsInChars, rawHeaders, rawRows) <- if all (== 0) widths - then handleZeroWidths - else handleGivenWidths widths + -- render the contents of header and row cells differently depending + -- on command line options, widths given in this specific table, and + -- cells' contents + let handleWidths + | writerWrapText opts == WrapNone = handleFullWidths + | all (== 0) widths = handleZeroWidths + | otherwise = handleGivenWidths widths + (widthsInChars, rawHeaders, rawRows) <- handleWidths let hpipeBlocks blocks = hcat [beg, middle, end] where h = maximum (1 : map height blocks) sep' = lblock 3 $ vcat (replicate h (text " | ")) diff --git a/src/Text/Pandoc/Writers/TEI.hs b/src/Text/Pandoc/Writers/TEI.hs index 4936c743e..e461f5715 100644 --- a/src/Text/Pandoc/Writers/TEI.hs +++ b/src/Text/Pandoc/Writers/TEI.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {- @@ -30,6 +31,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to Docbook XML. -} module Text.Pandoc.Writers.TEI (writeTEI) where +import Prelude import Data.Char (toLower) import Data.List (isPrefixOf, stripPrefix) import Data.Text (Text) diff --git a/src/Text/Pandoc/Writers/Texinfo.hs b/src/Text/Pandoc/Writers/Texinfo.hs index bf434642e..305b41206 100644 --- a/src/Text/Pandoc/Writers/Texinfo.hs +++ b/src/Text/Pandoc/Writers/Texinfo.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2008-2018 John MacFarlane @@ -31,6 +32,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' format into Texinfo. -} module Text.Pandoc.Writers.Texinfo ( writeTexinfo ) where +import Prelude import Control.Monad.Except (throwError) import Control.Monad.State.Strict import Data.Char (chr, ord) diff --git a/src/Text/Pandoc/Writers/Textile.hs b/src/Text/Pandoc/Writers/Textile.hs index f46eb43bc..0ed79d2df 100644 --- a/src/Text/Pandoc/Writers/Textile.hs +++ b/src/Text/Pandoc/Writers/Textile.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2010-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of 'Pandoc' documents to Textile markup. Textile: <http://thresholdstate.com/articles/4312/the-textile-reference-manual> -} module Text.Pandoc.Writers.Textile ( writeTextile ) where +import Prelude import Control.Monad.State.Strict import Data.Char (isSpace) import Data.List (intercalate) diff --git a/src/Text/Pandoc/Writers/ZimWiki.hs b/src/Text/Pandoc/Writers/ZimWiki.hs index dec1f9d4a..a583b07b1 100644 --- a/src/Text/Pandoc/Writers/ZimWiki.hs +++ b/src/Text/Pandoc/Writers/ZimWiki.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2008-2018 John MacFarlane <jgm@berkeley.edu> 2017-2018 Alex Ivkin @@ -32,6 +33,7 @@ http://zim-wiki.org/manual/Help/Wiki_Syntax.html -} module Text.Pandoc.Writers.ZimWiki ( writeZimWiki ) where +import Prelude import Control.Monad (zipWithM) import Control.Monad.State.Strict (StateT, evalStateT, gets, modify) import Data.Default (Default (..)) |