diff options
Diffstat (limited to 'src/Text/Pandoc/Writers')
37 files changed, 2637 insertions, 1027 deletions
diff --git a/src/Text/Pandoc/Writers/AsciiDoc.hs b/src/Text/Pandoc/Writers/AsciiDoc.hs index ab7e5f1a9..24438370a 100644 --- a/src/Text/Pandoc/Writers/AsciiDoc.hs +++ b/src/Text/Pandoc/Writers/AsciiDoc.hs @@ -21,7 +21,7 @@ AsciiDoc: <http://www.methods.co.nz/asciidoc/> module Text.Pandoc.Writers.AsciiDoc (writeAsciiDoc, writeAsciiDoctor) where import Control.Monad.State.Strict import Data.Char (isPunctuation, isSpace) -import Data.List (intercalate, intersperse) +import Data.List (delete, intercalate, intersperse) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe, isJust) import qualified Data.Set as Set @@ -149,9 +149,8 @@ blockToAsciiDoc opts (Div (id',"section":_,_) blockToAsciiDoc opts (Plain inlines) = do contents <- inlineListToAsciiDoc opts inlines return $ contents <> blankline -blockToAsciiDoc opts (Para [Image attr alternate (src,tgt)]) +blockToAsciiDoc opts (SimpleFigure attr alternate (src, tit)) -- image::images/logo.png[Company logo, title="blah"] - | Just tit <- T.stripPrefix "fig:" tgt = (\args -> "image::" <> args <> blankline) <$> imageArguments opts attr alternate src tit blockToAsciiDoc opts (Para inlines) = do @@ -193,7 +192,10 @@ blockToAsciiDoc _ (CodeBlock (_,classes,_) str) = return $ flush ( then "...." $$ literal str $$ "...." else attrs $$ "----" $$ literal str $$ "----") <> blankline - where attrs = "[" <> literal (T.intercalate "," ("source" : classes)) <> "]" + where attrs = "[" <> literal (T.intercalate "," classes') <> "]" + classes' = if "numberLines" `elem` classes + then "source%linesnum" : delete "numberLines" classes + else "source" : classes blockToAsciiDoc opts (BlockQuote blocks) = do contents <- blockListToAsciiDoc opts blocks let isBlock (BlockQuote _) = True @@ -546,6 +548,7 @@ inlineToAsciiDoc opts (Link _ txt (src, _tit)) = do -- or my@email.com[email john] linktext <- inlineListToAsciiDoc opts txt let isRelative = T.all (/= ':') src + let needsPassthrough = "--" `T.isInfixOf` src let prefix = if isRelative then text "link:" else empty @@ -553,9 +556,16 @@ inlineToAsciiDoc opts (Link _ txt (src, _tit)) = do let useAuto = case txt of [Str s] | escapeURI s == srcSuffix -> True _ -> False - return $ if useAuto - then literal srcSuffix - else prefix <> literal src <> "[" <> linktext <> "]" + return $ + if needsPassthrough + then + if useAuto + then "link:++" <> literal srcSuffix <> "++[]" + else "link:++" <> literal src <> "++[" <> linktext <> "]" + else + if useAuto + then literal srcSuffix + else prefix <> literal src <> "[" <> linktext <> "]" inlineToAsciiDoc opts (Image attr alternate (src, tit)) = ("image:" <>) <$> imageArguments opts attr alternate src tit inlineToAsciiDoc opts (Note [Para inlines]) = diff --git a/src/Text/Pandoc/Writers/Blaze.hs b/src/Text/Pandoc/Writers/Blaze.hs new file mode 100644 index 000000000..0e3bd0f98 --- /dev/null +++ b/src/Text/Pandoc/Writers/Blaze.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.Writers.Shared + Copyright : Copyright (C) 2021 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Render blaze-html Html to DocLayout document (so it can be wrapped). +-} +module Text.Pandoc.Writers.Blaze ( layoutMarkup ) +where +import Text.Blaze +import qualified Data.ByteString as S +import Data.List (isInfixOf) +import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text as T +import Data.Text (Text) +import Text.DocLayout hiding (Text, Empty) +import Text.Blaze.Internal (ChoiceString(..), getText, MarkupM(..)) + +layoutMarkup :: Markup -> Doc T.Text +layoutMarkup = go True mempty + where + go :: Bool -> Doc T.Text -> MarkupM b -> Doc T.Text + go wrap attrs (Parent _ open close content) = + let open' = getText open + in literal open' + <> attrs + <> char '>' + <> (if allowsWrap open' + then go wrap mempty content + else flush $ go False mempty content) + <> literal (getText close) + go wrap attrs (CustomParent tag content) = + char '<' + <> fromChoiceString wrap tag + <> attrs + <> char '>' + <> go wrap mempty content + <> literal "</" + <> fromChoiceString wrap tag + <> char '>' + go _wrap attrs (Leaf _ begin end _) = + literal (getText begin) + <> attrs + <> literal (getText end) + go wrap attrs (CustomLeaf tag close _) = + char '<' + <> fromChoiceString wrap tag + <> attrs + <> (if close then literal " />" else char '>') + go wrap attrs (AddAttribute rawkey _ value h) = + go wrap + (space' wrap + <> literal (getText rawkey) + <> char '=' + <> doubleQuotes (fromChoiceString wrap value) + <> attrs) h + go wrap attrs (AddCustomAttribute key value h) = + go wrap + (space' wrap + <> fromChoiceString wrap key + <> char '=' + <> doubleQuotes (fromChoiceString wrap value) + <> attrs) h + go wrap _ (Content content _) = fromChoiceString wrap content + go wrap _ (Comment comment _) = + literal "<!--" + <> space' wrap + <> fromChoiceString wrap comment + <> space' wrap + <> "-->" + go wrap attrs (Append h1 h2) = go wrap attrs h1 <> go wrap attrs h2 + go _ _ (Empty _) = mempty + space' wrap = if wrap then space else char ' ' + +allowsWrap :: T.Text -> Bool +allowsWrap t = + not (t == "<pre" || t == "<style" || t == "<script" || t == "<textarea") + +fromChoiceString :: Bool -- ^ Allow wrapping + -> ChoiceString -- ^ String to render + -> Doc Text -- ^ Resulting builder +fromChoiceString wrap (Static s) = withWrap wrap $ getText s +fromChoiceString wrap (String s) = withWrap wrap $ + escapeMarkupEntities $ T.pack s +fromChoiceString wrap (Text s) = withWrap wrap $ escapeMarkupEntities s +fromChoiceString wrap (ByteString s) = withWrap wrap $ decodeUtf8 s +fromChoiceString _wrap (PreEscaped x) = -- don't wrap! + case x of + String s -> literal $ T.pack s + Text s -> literal s + s -> fromChoiceString False s +fromChoiceString wrap (External x) = case x of + -- Check that the sequence "</" is *not* in the external data. + String s -> if "</" `isInfixOf` s then mempty else withWrap wrap (T.pack s) + Text s -> if "</" `T.isInfixOf` s then mempty else withWrap wrap s + ByteString s -> if "</" `S.isInfixOf` s then mempty else withWrap wrap (decodeUtf8 s) + s -> fromChoiceString wrap s +fromChoiceString wrap (AppendChoiceString x y) = + fromChoiceString wrap x <> fromChoiceString wrap y +fromChoiceString _ EmptyChoiceString = mempty + +withWrap :: Bool -> Text -> Doc Text +withWrap wrap + | wrap = mconcat . toChunks + | otherwise = literal + +toChunks :: Text -> [Doc Text] +toChunks = map toDoc . T.groupBy sameStatus + where + toDoc t = + if T.any (== ' ') t + then space + else if T.any (== '\n') t + then cr + else literal t + sameStatus c d = + (c == ' ' && d == ' ') || + (c == '\n' && d == '\n') || + (c /= ' ' && d /= ' ' && c /= '\n' && d /= '\n') + + +-- | Escape predefined XML entities in a text value +-- +escapeMarkupEntities :: Text -- ^ Text to escape + -> Text -- ^ Resulting Doc +escapeMarkupEntities = T.concatMap escape + where + escape :: Char -> Text + escape '<' = "<" + escape '>' = ">" + escape '&' = "&" + escape '"' = """ + escape '\'' = "'" + escape x = T.singleton x diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs index 3cafcefba..13970cbc3 100644 --- a/src/Text/Pandoc/Writers/ConTeXt.hs +++ b/src/Text/Pandoc/Writers/ConTeXt.hs @@ -162,10 +162,7 @@ blockToConTeXt (Div attr@(_,"section":_,_) innerContents <- blockListToConTeXt xs return $ header' $$ innerContents $$ footer' blockToConTeXt (Plain lst) = inlineListToConTeXt lst --- title beginning with fig: indicates that the image is a figure -blockToConTeXt (Para [Image attr txt (src,tgt)]) - | Just _ <- T.stripPrefix "fig:" tgt - = do +blockToConTeXt (SimpleFigure attr txt (src, _)) = do capt <- inlineListToConTeXt txt img <- inlineToConTeXt (Image attr txt (src, "")) let (ident, _, _) = attr diff --git a/src/Text/Pandoc/Writers/Custom.hs b/src/Text/Pandoc/Writers/Custom.hs index 58c4bb5be..da212ab4e 100644 --- a/src/Text/Pandoc/Writers/Custom.hs +++ b/src/Text/Pandoc/Writers/Custom.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Writers.Custom Copyright : Copyright (C) 2012-2021 John MacFarlane @@ -10,7 +13,7 @@ Portability : portable Conversion of 'Pandoc' documents to custom markup using -a lua writer. +a Lua writer. -} module Text.Pandoc.Writers.Custom ( writeCustom ) where import Control.Arrow ((***)) @@ -20,49 +23,51 @@ import Data.List (intersperse) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text, pack) -import Foreign.Lua (Lua, Pushable) +import HsLua as Lua hiding (Operation (Div), render) +import HsLua.Class.Peekable (PeekError) import Text.DocLayout (render, literal) -import Text.Pandoc.Class.PandocIO (PandocIO) +import Control.Monad.IO.Class (MonadIO) import Text.Pandoc.Definition import Text.Pandoc.Lua (Global (..), runLua, setGlobals) import Text.Pandoc.Lua.Util (addField, dofileWithTraceback) import Text.Pandoc.Options +import Text.Pandoc.Class (PandocMonad) import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared -import qualified Foreign.Lua as Lua - attrToMap :: Attr -> M.Map T.Text T.Text attrToMap (id',classes,keyvals) = M.fromList $ ("id", id') : ("class", T.unwords classes) : keyvals -newtype Stringify a = Stringify a +newtype Stringify e a = Stringify a -instance Pushable (Stringify Format) where +instance Pushable (Stringify e Format) where push (Stringify (Format f)) = Lua.push (T.toLower f) -instance Pushable (Stringify [Inline]) where - push (Stringify ils) = Lua.push =<< inlineListToCustom ils +instance PeekError e => Pushable (Stringify e [Inline]) where + push (Stringify ils) = Lua.push =<< + changeErrorType ((inlineListToCustom @e) ils) -instance Pushable (Stringify [Block]) where - push (Stringify blks) = Lua.push =<< blockListToCustom blks +instance PeekError e => Pushable (Stringify e [Block]) where + push (Stringify blks) = Lua.push =<< + changeErrorType ((blockListToCustom @e) blks) -instance Pushable (Stringify MetaValue) where - push (Stringify (MetaMap m)) = Lua.push (fmap Stringify m) - push (Stringify (MetaList xs)) = Lua.push (map Stringify xs) +instance PeekError e => Pushable (Stringify e MetaValue) where + push (Stringify (MetaMap m)) = Lua.push (fmap (Stringify @e) m) + push (Stringify (MetaList xs)) = Lua.push (map (Stringify @e) xs) push (Stringify (MetaBool x)) = Lua.push x push (Stringify (MetaString s)) = Lua.push s - push (Stringify (MetaInlines ils)) = Lua.push (Stringify ils) - push (Stringify (MetaBlocks bs)) = Lua.push (Stringify bs) + push (Stringify (MetaInlines ils)) = Lua.push (Stringify @e ils) + push (Stringify (MetaBlocks bs)) = Lua.push (Stringify @e bs) -instance Pushable (Stringify Citation) where +instance PeekError e => Pushable (Stringify e Citation) where push (Stringify cit) = do Lua.createtable 6 0 addField "citationId" $ citationId cit - addField "citationPrefix" . Stringify $ citationPrefix cit - addField "citationSuffix" . Stringify $ citationSuffix cit + addField "citationPrefix" . Stringify @e $ citationPrefix cit + addField "citationSuffix" . Stringify @e $ citationSuffix cit addField "citationMode" $ show (citationMode cit) addField "citationNoteNum" $ citationNoteNum cit addField "citationHash" $ citationHash cit @@ -76,10 +81,11 @@ instance (Pushable a, Pushable b) => Pushable (KeyValue a b) where Lua.newtable Lua.push k Lua.push v - Lua.rawset (Lua.nthFromTop 3) + Lua.rawset (Lua.nth 3) -- | Convert Pandoc to custom markup. -writeCustom :: FilePath -> WriterOptions -> Pandoc -> PandocIO Text +writeCustom :: (PandocMonad m, MonadIO m) + => FilePath -> WriterOptions -> Pandoc -> m Text writeCustom luaFile opts doc@(Pandoc meta _) = do let globals = [ PANDOC_DOCUMENT doc , PANDOC_SCRIPT_FILE luaFile @@ -90,7 +96,7 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do -- check for error in lua script (later we'll change the return type -- to handle this more gracefully): when (stat /= Lua.OK) - Lua.throwTopMessage + Lua.throwErrorAsException rendered <- docToCustom opts doc context <- metaToContext opts (fmap (literal . pack) . blockListToCustom) @@ -105,126 +111,132 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do Just tpl -> render Nothing $ renderTemplate tpl $ setField "body" body context -docToCustom :: WriterOptions -> Pandoc -> Lua String +docToCustom :: forall e. PeekError e + => WriterOptions -> Pandoc -> LuaE e String docToCustom opts (Pandoc (Meta metamap) blocks) = do body <- blockListToCustom blocks - Lua.callFunc "Doc" body (fmap Stringify metamap) (writerVariables opts) + invoke @e "Doc" body (fmap (Stringify @e) metamap) (writerVariables opts) -- | Convert Pandoc block element to Custom. -blockToCustom :: Block -- ^ Block element - -> Lua String +blockToCustom :: forall e. PeekError e + => Block -- ^ Block element + -> LuaE e String blockToCustom Null = return "" -blockToCustom (Plain inlines) = Lua.callFunc "Plain" (Stringify inlines) +blockToCustom (Plain inlines) = invoke @e "Plain" (Stringify @e inlines) blockToCustom (Para [Image attr txt (src,tit)]) = - Lua.callFunc "CaptionedImage" src tit (Stringify txt) (attrToMap attr) + invoke @e "CaptionedImage" src tit (Stringify @e txt) (attrToMap attr) -blockToCustom (Para inlines) = Lua.callFunc "Para" (Stringify inlines) +blockToCustom (Para inlines) = invoke @e "Para" (Stringify @e inlines) blockToCustom (LineBlock linesList) = - Lua.callFunc "LineBlock" (map Stringify linesList) + invoke @e "LineBlock" (map (Stringify @e) linesList) blockToCustom (RawBlock format str) = - Lua.callFunc "RawBlock" (Stringify format) str + invoke @e "RawBlock" (Stringify @e format) str -blockToCustom HorizontalRule = Lua.callFunc "HorizontalRule" +blockToCustom HorizontalRule = invoke @e "HorizontalRule" blockToCustom (Header level attr inlines) = - Lua.callFunc "Header" level (Stringify inlines) (attrToMap attr) + invoke @e "Header" level (Stringify @e inlines) (attrToMap attr) blockToCustom (CodeBlock attr str) = - Lua.callFunc "CodeBlock" str (attrToMap attr) + invoke @e "CodeBlock" str (attrToMap attr) blockToCustom (BlockQuote blocks) = - Lua.callFunc "BlockQuote" (Stringify blocks) + invoke @e "BlockQuote" (Stringify @e blocks) blockToCustom (Table _ blkCapt specs thead tbody tfoot) = let (capt, aligns, widths, headers, rows) = toLegacyTable blkCapt specs thead tbody tfoot aligns' = map show aligns - capt' = Stringify capt - headers' = map Stringify headers - rows' = map (map Stringify) rows - in Lua.callFunc "Table" capt' aligns' widths headers' rows' + capt' = Stringify @e capt + headers' = map (Stringify @e) headers + rows' = map (map (Stringify @e)) rows + in invoke @e "Table" capt' aligns' widths headers' rows' blockToCustom (BulletList items) = - Lua.callFunc "BulletList" (map Stringify items) + invoke @e "BulletList" (map (Stringify @e) items) blockToCustom (OrderedList (num,sty,delim) items) = - Lua.callFunc "OrderedList" (map Stringify items) num (show sty) (show delim) + invoke @e "OrderedList" (map (Stringify @e) items) num (show sty) (show delim) blockToCustom (DefinitionList items) = - Lua.callFunc "DefinitionList" - (map (KeyValue . (Stringify *** map Stringify)) items) + invoke @e "DefinitionList" + (map (KeyValue . (Stringify @e *** map (Stringify @e))) items) blockToCustom (Div attr items) = - Lua.callFunc "Div" (Stringify items) (attrToMap attr) + invoke @e "Div" (Stringify @e items) (attrToMap attr) -- | Convert list of Pandoc block elements to Custom. -blockListToCustom :: [Block] -- ^ List of block elements - -> Lua String +blockListToCustom :: forall e. PeekError e + => [Block] -- ^ List of block elements + -> LuaE e String blockListToCustom xs = do - blocksep <- Lua.callFunc "Blocksep" + blocksep <- invoke @e "Blocksep" bs <- mapM blockToCustom xs return $ mconcat $ intersperse blocksep bs -- | Convert list of Pandoc inline elements to Custom. -inlineListToCustom :: [Inline] -> Lua String +inlineListToCustom :: forall e. PeekError e => [Inline] -> LuaE e String inlineListToCustom lst = do - xs <- mapM inlineToCustom lst + xs <- mapM (inlineToCustom @e) lst return $ mconcat xs -- | Convert Pandoc inline element to Custom. -inlineToCustom :: Inline -> Lua String +inlineToCustom :: forall e. PeekError e => Inline -> LuaE e String -inlineToCustom (Str str) = Lua.callFunc "Str" str +inlineToCustom (Str str) = invoke @e "Str" str -inlineToCustom Space = Lua.callFunc "Space" +inlineToCustom Space = invoke @e "Space" -inlineToCustom SoftBreak = Lua.callFunc "SoftBreak" +inlineToCustom SoftBreak = invoke @e "SoftBreak" -inlineToCustom (Emph lst) = Lua.callFunc "Emph" (Stringify lst) +inlineToCustom (Emph lst) = invoke @e "Emph" (Stringify @e lst) -inlineToCustom (Underline lst) = Lua.callFunc "Underline" (Stringify lst) +inlineToCustom (Underline lst) = invoke @e "Underline" (Stringify @e lst) -inlineToCustom (Strong lst) = Lua.callFunc "Strong" (Stringify lst) +inlineToCustom (Strong lst) = invoke @e "Strong" (Stringify @e lst) -inlineToCustom (Strikeout lst) = Lua.callFunc "Strikeout" (Stringify lst) +inlineToCustom (Strikeout lst) = invoke @e "Strikeout" (Stringify @e lst) -inlineToCustom (Superscript lst) = Lua.callFunc "Superscript" (Stringify lst) +inlineToCustom (Superscript lst) = invoke @e "Superscript" (Stringify @e lst) -inlineToCustom (Subscript lst) = Lua.callFunc "Subscript" (Stringify lst) +inlineToCustom (Subscript lst) = invoke @e "Subscript" (Stringify @e lst) -inlineToCustom (SmallCaps lst) = Lua.callFunc "SmallCaps" (Stringify lst) +inlineToCustom (SmallCaps lst) = invoke @e "SmallCaps" (Stringify @e lst) -inlineToCustom (Quoted SingleQuote lst) = Lua.callFunc "SingleQuoted" (Stringify lst) +inlineToCustom (Quoted SingleQuote lst) = + invoke @e "SingleQuoted" (Stringify @e lst) -inlineToCustom (Quoted DoubleQuote lst) = Lua.callFunc "DoubleQuoted" (Stringify lst) +inlineToCustom (Quoted DoubleQuote lst) = + invoke @e "DoubleQuoted" (Stringify @e lst) -inlineToCustom (Cite cs lst) = Lua.callFunc "Cite" (Stringify lst) (map Stringify cs) +inlineToCustom (Cite cs lst) = + invoke @e "Cite" (Stringify @e lst) (map (Stringify @e) cs) inlineToCustom (Code attr str) = - Lua.callFunc "Code" str (attrToMap attr) + invoke @e "Code" str (attrToMap attr) inlineToCustom (Math DisplayMath str) = - Lua.callFunc "DisplayMath" str + invoke @e "DisplayMath" str inlineToCustom (Math InlineMath str) = - Lua.callFunc "InlineMath" str + invoke @e "InlineMath" str inlineToCustom (RawInline format str) = - Lua.callFunc "RawInline" (Stringify format) str + invoke @e "RawInline" (Stringify @e format) str -inlineToCustom LineBreak = Lua.callFunc "LineBreak" +inlineToCustom LineBreak = invoke @e "LineBreak" inlineToCustom (Link attr txt (src,tit)) = - Lua.callFunc "Link" (Stringify txt) src tit (attrToMap attr) + invoke @e "Link" (Stringify @e txt) src tit (attrToMap attr) inlineToCustom (Image attr alt (src,tit)) = - Lua.callFunc "Image" (Stringify alt) src tit (attrToMap attr) + invoke @e "Image" (Stringify @e alt) src tit (attrToMap attr) -inlineToCustom (Note contents) = Lua.callFunc "Note" (Stringify contents) +inlineToCustom (Note contents) = invoke @e "Note" (Stringify @e contents) inlineToCustom (Span attr items) = - Lua.callFunc "Span" (Stringify items) (attrToMap attr) + invoke @e "Span" (Stringify @e items) (attrToMap attr) diff --git a/src/Text/Pandoc/Writers/Docbook.hs b/src/Text/Pandoc/Writers/Docbook.hs index 33a6f5f0c..c9e49517f 100644 --- a/src/Text/Pandoc/Writers/Docbook.hs +++ b/src/Text/Pandoc/Writers/Docbook.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.Docbook Copyright : Copyright (C) 2006-2021 John MacFarlane @@ -188,7 +187,7 @@ blockToDocbook opts (Div (id',"section":_,_) (Header lvl (_,_,attrs) ils : xs)) -- standalone documents will include them in the template. then [("xmlns", "http://docbook.org/ns/docbook"),("xmlns:xlink", "http://www.w3.org/1999/xlink")] else [] - + -- Populate miscAttr with Header.Attr.attributes, filtering out non-valid DocBook section attributes, id, and xml:id miscAttr = filter (isSectionAttr version) attrs attribs = nsAttr <> idAttr <> miscAttr @@ -233,7 +232,7 @@ blockToDocbook _ h@Header{} = do return empty blockToDocbook opts (Plain lst) = inlinesToDocbook opts lst -- title beginning with fig: indicates that the image is a figure -blockToDocbook opts (Para [Image attr txt (src,T.stripPrefix "fig:" -> Just _)]) = do +blockToDocbook opts (SimpleFigure attr txt (src, _)) = do alt <- inlinesToDocbook opts txt let capt = if null txt then empty diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index a3c4b6be1..ce7133f33 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -36,7 +36,9 @@ import Data.Time.Clock.POSIX import Data.Digest.Pure.SHA (sha1, showDigest) import Skylighting import Text.Collate.Lang (renderLang) -import Text.Pandoc.Class.PandocMonad (PandocMonad, report, toLang, translateTerm) +import Text.Pandoc.Class (PandocMonad, report, toLang, translateTerm, + getMediaBag) +import Text.Pandoc.MediaBag (lookupMedia, MediaItem(..)) import qualified Text.Pandoc.Translations as Term import qualified Text.Pandoc.Class.PandocMonad as P import Data.Time @@ -175,6 +177,7 @@ writeDocx opts doc = do let initialSt = defaultWriterState { stStyleMaps = styleMaps , stTocTitle = tocTitle + , stCurId = 20 } let isRTLmeta = case lookupMeta "dir" meta of @@ -783,8 +786,6 @@ rStyleM styleName = do return $ mknode "w:rStyle" [("w:val", fromStyleId sty')] () getUniqueId :: (PandocMonad m) => WS m Text --- the + 20 is to ensure that there are no clashes with the rIds --- already in word/document.xml.rel getUniqueId = do n <- gets stCurId modify $ \st -> st{stCurId = n + 1} @@ -853,11 +854,13 @@ blockToOpenXML' opts (Plain lst) = do then withParaProp prop block else block -- title beginning with fig: indicates that the image is a figure -blockToOpenXML' opts (Para [Image attr alt (src,T.stripPrefix "fig:" -> Just tit)]) = do +blockToOpenXML' opts (SimpleFigure attr@(imgident, _, _) alt (src, tit)) = do setFirstPara fignum <- gets stNextFigureNum unless (null alt) $ modify $ \st -> st{ stNextFigureNum = fignum + 1 } - let figid = "fig" <> tshow fignum + let refid = if T.null imgident + then "ref_fig" <> tshow fignum + else "ref_" <> imgident figname <- translateTerm Term.Figure prop <- pStyleM $ if null alt @@ -869,14 +872,16 @@ blockToOpenXML' opts (Para [Image attr alt (src,T.stripPrefix "fig:" -> Just tit then return [] else withParaPropM (pStyleM "Image Caption") $ blockToOpenXML opts - (Para $ Span (figid,[],[]) - [Str (figname <> "\160"), - RawInline (Format "openxml") - ("<w:fldSimple w:instr=\"SEQ Figure" - <> " \\* ARABIC \"><w:r><w:t>" - <> tshow fignum - <> "</w:t></w:r></w:fldSimple>"), - Str ":", Space] : alt) + $ Para + $ if isEnabled Ext_native_numbering opts + then Span (refid,[],[]) + [Str (figname <> "\160"), + RawInline (Format "openxml") + ("<w:fldSimple w:instr=\"SEQ Figure" + <> " \\* ARABIC \"><w:r><w:t>" + <> tshow fignum + <> "</w:t></w:r></w:fldSimple>")] : Str ": " : alt + else alt return $ Elem (mknode "w:p" [] (map Elem paraProps ++ contents)) : captionNode @@ -922,7 +927,8 @@ blockToOpenXML' _ HorizontalRule = do ("o:hralign","center"), ("o:hrstd","t"),("o:hr","t")] () ] blockToOpenXML' opts (Table attr caption colspecs thead tbodies tfoot) = - tableToOpenXML (blocksToOpenXML opts) + tableToOpenXML opts + (blocksToOpenXML opts) (Grid.toTable attr caption colspecs thead tbodies tfoot) blockToOpenXML' opts el | BulletList lst <- el = addOpenXMLList BulletMarker lst @@ -1230,7 +1236,42 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do imgs <- gets stImages let stImage = M.lookup (T.unpack src) imgs - generateImgElt (ident, _, _, img) = + generateImgElt (ident, _fp, mt, img) = do + docprid <- getUniqueId + nvpicprid <- getUniqueId + (blipAttrs, blipContents) <- + case T.takeWhile (/=';') <$> mt of + Just "image/svg+xml" -> do + -- get fallback png + mediabag <- getMediaBag + mbFallback <- + case lookupMedia (T.unpack (src <> ".png")) mediabag of + Just item -> do + id' <- T.unpack . ("rId" <>) <$> getUniqueId + let fp' = "media/" <> id' <> ".png" + let imgdata = (id', + fp', + Just (mediaMimeType item), + BL.toStrict $ mediaContents item) + modify $ \st -> st { stImages = + M.insert fp' imgdata $ stImages st } + return $ Just id' + Nothing -> return Nothing + let extLst = mknode "a:extLst" [] + [ mknode "a:ext" + [("uri","{28A0092B-C50C-407E-A947-70E740481C1C}")] + [ mknode "a14:useLocalDpi" + [("xmlns:a14","http://schemas.microsoft.com/office/drawing/2010/main"), + ("val","0")] () ] + , mknode "a:ext" + [("uri","{96DAC541-7B7A-43D3-8B79-37D633B846F1}")] + [ mknode "asvg:svgBlip" + [("xmlns:asvg", "http://schemas.microsoft.com/office/drawing/2016/SVG/main"), + ("r:embed",T.pack ident)] () ] + ] + return (maybe [] (\id'' -> [("r:embed", T.pack id'')]) mbFallback, + [extLst]) + _ -> return ([("r:embed", T.pack ident)], []) let (xpt,ypt) = desiredSizeInPoints opts attr (either (const def) id (imageSize opts img)) @@ -1242,10 +1283,12 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do ,("noChangeAspect","1")] () nvPicPr = mknode "pic:nvPicPr" [] [ mknode "pic:cNvPr" - [("descr",src),("id","0"),("name","Picture")] () + [("descr",src) + ,("id", nvpicprid) + ,("name","Picture")] () , cNvPicPr ] blipFill = mknode "pic:blipFill" [] - [ mknode "a:blip" [("r:embed",T.pack ident)] () + [ mknode "a:blip" blipAttrs blipContents , mknode "a:stretch" [] $ mknode "a:fillRect" [] () ] @@ -1279,16 +1322,15 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do , mknode "wp:docPr" [ ("descr", stringify alt) , ("title", title) - , ("id","1") + , ("id", docprid) , ("name","Picture") ] () , graphic ] - in - imgElt + return [Elem imgElt] wrapBookmark imgident =<< case stImage of - Just imgData -> return [Elem $ generateImgElt imgData] + Just imgData -> generateImgElt imgData Nothing -> ( do --try (img, mt) <- P.fetchItem src ident <- ("rId" <>) <$> getUniqueId @@ -1317,7 +1359,7 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do else do -- insert mime type to use in constructing [Content_Types].xml modify $ \st -> st { stImages = M.insert (T.unpack src) imgData $ stImages st } - return [Elem $ generateImgElt imgData] + generateImgElt imgData ) `catchError` ( \e -> do report $ CouldNotFetchResource src $ T.pack (show e) diff --git a/src/Text/Pandoc/Writers/Docx/Table.hs b/src/Text/Pandoc/Writers/Docx/Table.hs index 7a84c5278..4dc4ad6a2 100644 --- a/src/Text/Pandoc/Writers/Docx/Table.hs +++ b/src/Text/Pandoc/Writers/Docx/Table.hs @@ -20,6 +20,8 @@ import Text.Pandoc.Definition import Text.Pandoc.Class.PandocMonad (PandocMonad, translateTerm) import Text.Pandoc.Writers.Docx.Types import Text.Pandoc.Shared +import Text.Pandoc.Options (WriterOptions, isEnabled) +import Text.Pandoc.Extensions (Extension(Ext_native_numbering)) import Text.Printf (printf) import Text.Pandoc.Writers.GridTable hiding (Table) import Text.Pandoc.Writers.OOXML @@ -29,10 +31,11 @@ import qualified Text.Pandoc.Translations as Term import qualified Text.Pandoc.Writers.GridTable as Grid tableToOpenXML :: PandocMonad m - => ([Block] -> WS m [Content]) + => WriterOptions + -> ([Block] -> WS m [Content]) -> Grid.Table -> WS m [Content] -tableToOpenXML blocksToOpenXML gridTable = do +tableToOpenXML opts blocksToOpenXML gridTable = do setFirstPara let (Grid.Table (ident,_,_) caption colspecs _rowheads thead tbodies tfoot) = gridTable @@ -50,7 +53,9 @@ tableToOpenXML blocksToOpenXML gridTable = do then return [] else withParaPropM (pStyleM "Table Caption") $ blocksToOpenXML - $ addLabel tableid tablename tablenum captionBlocks + $ if isEnabled Ext_native_numbering opts + then addLabel tableid tablename tablenum captionBlocks + else captionBlocks -- We set "in table" after processing the caption, because we don't -- want the "Table Caption" style to be overwritten with "Compact". modify $ \s -> s { stInTable = True } @@ -93,8 +98,8 @@ tableToOpenXML blocksToOpenXML gridTable = do addLabel :: Text -> Text -> Int -> [Block] -> [Block] addLabel tableid tablename tablenum bs = case bs of - (Para ils : rest) -> Para (label : Space : ils) : rest - (Plain ils : rest) -> Plain (label : Space : ils) : rest + (Para ils : rest) -> Para (label : Str ": " : ils) : rest + (Plain ils : rest) -> Plain (label : Str ": " : ils) : rest _ -> Para [label] : bs where label = Span (tableid,[],[]) @@ -103,8 +108,7 @@ addLabel tableid tablename tablenum bs = ("<w:fldSimple w:instr=\"SEQ Table" <> " \\* ARABIC \"><w:r><w:t>" <> tshow tablenum - <> "</w:t></w:r></w:fldSimple>"), - Str ":"] + <> "</w:t></w:r></w:fldSimple>")] -- | Parts of a table data RowType = HeadRow | BodyRow | FootRow diff --git a/src/Text/Pandoc/Writers/DokuWiki.hs b/src/Text/Pandoc/Writers/DokuWiki.hs index 602c70ebe..c77f20ec1 100644 --- a/src/Text/Pandoc/Writers/DokuWiki.hs +++ b/src/Text/Pandoc/Writers/DokuWiki.hs @@ -109,9 +109,7 @@ blockToDokuWiki opts (Plain inlines) = -- title beginning with fig: indicates that the image is a figure -- dokuwiki doesn't support captions - so combine together alt and caption into alt -blockToDokuWiki opts (Para [Image attr txt (src,tgt)]) - | Just tit <- T.stripPrefix "fig:" tgt - = do +blockToDokuWiki opts (SimpleFigure attr txt (src, tit)) = do capt <- if null txt then return "" else (" " <>) `fmap` inlineListToDokuWiki opts txt diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs index 508fb6a98..d1417ff48 100644 --- a/src/Text/Pandoc/Writers/EPUB.hs +++ b/src/Text/Pandoc/Writers/EPUB.hs @@ -32,7 +32,6 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Text (Text) import qualified Data.Text.Lazy as TL -import Network.HTTP (urlEncode) import System.FilePath (takeExtension, takeFileName, makeRelative) import Text.HTML.TagSoup (Tag (TagOpen), fromAttrib, parseTags) import Text.Pandoc.Builder (fromList, setMeta) @@ -45,6 +44,7 @@ import Text.Pandoc.Error import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.MIME (MimeType, extensionFromMimeType, getMimeType) +import Text.Pandoc.Network.HTTP (urlEncode) import Text.Pandoc.Options (EPUBVersion (..), HTMLMathMethod (..), ObfuscationMethod (NoObfuscation), WrapOption (..), WriterOptions (..)) @@ -79,7 +79,7 @@ data EPUBMetadata = EPUBMetadata{ , epubLanguage :: Text , epubCreator :: [Creator] , epubContributor :: [Creator] - , epubSubject :: [Text] + , epubSubject :: [Subject] , epubDescription :: Maybe Text , epubType :: Maybe Text , epubFormat :: Maybe Text @@ -121,6 +121,12 @@ data Title = Title{ data ProgressionDirection = LTR | RTL deriving Show +data Subject = Subject{ + subjectText :: Text + , subjectAuthority :: Maybe Text + , subjectTerm :: Maybe Text + } deriving Show + dcName :: Text -> QName dcName n = QName n Nothing (Just "dc") @@ -232,7 +238,11 @@ addMetadataFromXML e@(Element (QName name _ (Just "dc")) attrs _ _) md , creatorRole = getAttr "role" , creatorFileAs = getAttr "file-as" } : epubContributor md } - | name == "subject" = md{ epubSubject = strContent e : epubSubject md } + | name == "subject" = md{ epubSubject = + Subject { subjectText = strContent e + , subjectAuthority = getAttr "authority" + , subjectTerm = getAttr "term" + } : epubSubject md } | name == "description" = md { epubDescription = Just $ strContent e } | name == "type" = md { epubType = Just $ strContent e } | name == "format" = md { epubFormat = Just $ strContent e } @@ -313,12 +323,13 @@ getDate s meta = getList s meta handleMetaValue handleMetaValue mv = Date { dateText = fromMaybe "" $ normalizeDate' $ metaValueToString mv , dateEvent = Nothing } -simpleList :: T.Text -> Meta -> [Text] -simpleList s meta = - case lookupMeta s meta of - Just (MetaList xs) -> map metaValueToString xs - Just x -> [metaValueToString x] - Nothing -> [] +getSubject :: T.Text -> Meta -> [Subject] +getSubject s meta = getList s meta handleMetaValue + where handleMetaValue (MetaMap m) = + Subject{ subjectText = maybe "" metaValueToString $ M.lookup "text" m + , subjectAuthority = metaValueToString <$> M.lookup "authority" m + , subjectTerm = metaValueToString <$> M.lookup "term" m } + handleMetaValue mv = Subject (metaValueToString mv) Nothing Nothing metadataFromMeta :: WriterOptions -> Meta -> EPUBMetadata metadataFromMeta opts meta = EPUBMetadata{ @@ -352,7 +363,7 @@ metadataFromMeta opts meta = EPUBMetadata{ lookupMeta "language" meta `mplus` lookupMeta "lang" meta creators = getCreator "creator" meta contributors = getCreator "contributor" meta - subjects = simpleList "subject" meta + subjects = getSubject "subject" meta description = metaValueToString <$> lookupMeta "description" meta epubtype = metaValueToString <$> lookupMeta "type" meta format = metaValueToString <$> lookupMeta "format" meta @@ -659,7 +670,7 @@ pandocToEPUB version opts doc = do "contributors", "other-credits", "errata", "revision-history", "titlepage", "halftitlepage", "seriespage", - "foreword", "preface", + "foreword", "preface", "frontispiece", "seriespage", "titlepage"] backMatterTypes = ["appendix", "colophon", "bibliography", "index"] @@ -974,7 +985,7 @@ metadataElement version md currentTime = epubCreator md contributorNodes = withIds "epub-contributor" (toCreatorNode "contributor") $ epubContributor md - subjectNodes = map (dcTag "subject") $ epubSubject md + subjectNodes = withIds "subject" toSubjectNode $ epubSubject md descriptionNodes = maybe [] (dcTag' "description") $ epubDescription md typeNodes = maybe [] (dcTag' "type") $ epubType md formatNodes = maybe [] (dcTag' "format") $ epubFormat md @@ -1046,6 +1057,16 @@ metadataElement version md currentTime = (("id",id') : maybe [] (\x -> [("opf:event",x)]) (dateEvent date)) $ dateText date] + toSubjectNode id' subject + | version == EPUB2 = [dcNode "subject" ! + [("id",id')] $ subjectText subject] + | otherwise = (dcNode "subject" ! [("id",id')] $ subjectText subject) + : maybe [] (\x -> (unode "meta" ! + [("refines", "#" <> id'),("property","authority")] $ x) : + maybe [] (\y -> [unode "meta" ! + [("refines", "#" <> id'),("property","term")] $ y]) + (subjectTerm subject)) + (subjectAuthority subject) schemeToOnix :: Text -> Text schemeToOnix "ISBN-10" = "02" schemeToOnix "GTIN-13" = "03" @@ -1137,7 +1158,7 @@ transformInline _opts (Image attr@(_,_,kvs) lab (src,tit)) return $ Image attr lab ("../" <> newsrc, tit) transformInline opts x@(Math t m) | WebTeX url <- writerHTMLMathMethod opts = do - newsrc <- modifyMediaRef (T.unpack url <> urlEncode (T.unpack m)) + newsrc <- modifyMediaRef (T.unpack (url <> urlEncode m)) let mathclass = if t == DisplayMath then "display" else "inline" return $ Span ("",["math",mathclass],[]) [Image nullAttr [x] ("../" <> newsrc, "")] diff --git a/src/Text/Pandoc/Writers/FB2.hs b/src/Text/Pandoc/Writers/FB2.hs index 3b5d04427..ce3fe25a9 100644 --- a/src/Text/Pandoc/Writers/FB2.hs +++ b/src/Text/Pandoc/Writers/FB2.hs @@ -29,7 +29,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as TE -import Network.HTTP (urlEncode) +import Text.Pandoc.Network.HTTP (urlEncode) import Text.Pandoc.XML.Light as X import Text.Pandoc.Class.PandocMonad (PandocMonad, report) @@ -299,9 +299,8 @@ blockToXml :: PandocMonad m => Block -> FBM m [Content] blockToXml (Plain ss) = cMapM toXml ss -- FIXME: can lead to malformed FB2 blockToXml (Para [Math DisplayMath formula]) = insertMath NormalImage formula -- title beginning with fig: indicates that the image is a figure -blockToXml (Para [Image atr alt (src,tgt)]) - | Just tit <- T.stripPrefix "fig:" tgt - = insertImage NormalImage (Image atr alt (src,tit)) +blockToXml (SimpleFigure atr alt (src, tit)) = + insertImage NormalImage (Image atr alt (src,tit)) blockToXml (Para ss) = list . el "p" <$> cMapM toXml ss blockToXml (CodeBlock _ s) = return . spaceBeforeAfter . map (el "p" . el "code") . T.lines $ s @@ -451,7 +450,7 @@ insertMath immode formula = do case htmlMath of WebTeX url -> do let alt = [Code nullAttr formula] - let imgurl = url <> T.pack (urlEncode $ T.unpack formula) + let imgurl = url <> urlEncode formula let img = Image nullAttr alt (imgurl, "") insertImage immode img _ -> return [el "code" formula] diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs index 6f91d1965..8c5548196 100644 --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -28,7 +28,6 @@ module Text.Pandoc.Writers.HTML ( writeRevealJs, tagWithAttributes ) where -import Control.Monad.Identity (runIdentity) import Control.Monad.State.Strict import Data.Char (ord) import Data.List (intercalate, intersperse, partition, delete, (\\), foldl') @@ -38,10 +37,9 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import Network.HTTP (urlEncode) import Network.URI (URI (..), parseURIReference) import Numeric (showHex) -import Text.DocLayout (render, literal) +import Text.DocLayout (render, literal, Doc) import Text.Blaze.Internal (MarkupM (Empty), customLeaf, customParent) import Text.DocTemplates (FromContext (lookupContext), Context (..)) import Text.Blaze.Html hiding (contents) @@ -52,11 +50,12 @@ import Text.Pandoc.ImageSize import Text.Pandoc.Options import Text.Pandoc.Shared import Text.Pandoc.Slides -import Text.Pandoc.Templates (Template, compileTemplate, renderTemplate) +import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Walk import Text.Pandoc.Writers.Math import Text.Pandoc.Writers.Shared import qualified Text.Pandoc.Writers.AnnotatedTable as Ann +import Text.Pandoc.Network.HTTP (urlEncode) import Text.Pandoc.XML (escapeStringForXML, fromEntities, toEntities, html5Attributes, html4Attributes, rdfaAttributes) import qualified Text.Blaze.XHtml5 as H5 @@ -71,13 +70,16 @@ import Text.Pandoc.Class.PandocPure (runPure) import Text.Pandoc.Error import Text.Pandoc.Logging import Text.Pandoc.MIME (mediaCategory) +import Text.Pandoc.Writers.Blaze (layoutMarkup) import Text.TeXMath import Text.XML.Light (elChildren, unode, unqual) import qualified Text.XML.Light as XML import Text.XML.Light.Output +import Data.String (fromString) data WriterState = WriterState { stNotes :: [Html] -- ^ List of notes + , stEmittedNotes :: Int -- ^ How many notes we've already pushed out to the HTML , stMath :: Bool -- ^ Math is used in document , stQuotes :: Bool -- ^ <q> tag is used , stHighlighting :: Bool -- ^ Syntax highlighting is used @@ -89,10 +91,11 @@ data WriterState = WriterState , stCodeBlockNum :: Int -- ^ Number of code block , stCsl :: Bool -- ^ Has CSL references , stCslEntrySpacing :: Maybe Int -- ^ CSL entry spacing + , stBlockLevel :: Int -- ^ Current block depth, excluding section divs } defaultWriterState :: WriterState -defaultWriterState = WriterState {stNotes= [], stMath = False, stQuotes = False, +defaultWriterState = WriterState {stNotes= [], stEmittedNotes = 0, stMath = False, stQuotes = False, stHighlighting = False, stHtml5 = False, stEPUBVersion = Nothing, @@ -101,7 +104,8 @@ defaultWriterState = WriterState {stNotes= [], stMath = False, stQuotes = False, stInSection = False, stCodeBlockNum = 0, stCsl = False, - stCslEntrySpacing = Nothing} + stCslEntrySpacing = Nothing, + stBlockLevel = 0} -- Helpers to render HTML with the appropriate function. @@ -128,10 +132,8 @@ needsVariationSelector '↔' = True needsVariationSelector _ = False -- | Hard linebreak. -nl :: WriterOptions -> Html -nl opts = if writerWrapText opts == WrapNone - then mempty - else preEscapedString "\n" +nl :: Html +nl = preEscapedString "\n" -- | Convert Pandoc document to Html 5 string. writeHtml5String :: PandocMonad m => WriterOptions -> Pandoc -> m Text @@ -157,7 +159,8 @@ writeHtmlStringForEPUB :: PandocMonad m -> m Text writeHtmlStringForEPUB version o = writeHtmlString' defaultWriterState{ stHtml5 = version == EPUB3, - stEPUBVersion = Just version } o + stEPUBVersion = Just version } + o{ writerWrapText = WrapNone } -- | Convert Pandoc document to Reveal JS HTML slide show. writeRevealJs :: PandocMonad m @@ -204,20 +207,23 @@ writeHtmlString' :: PandocMonad m => WriterState -> WriterOptions -> Pandoc -> m Text writeHtmlString' st opts d = do (body, context) <- evalStateT (pandocToHtml opts d) st - let defaultTemplate = fmap (const tocTemplate) (getField "table-of-contents" context :: Maybe Text) - let template = msum [ writerTemplate opts - , defaultTemplate ] + let colwidth = case writerWrapText opts of + WrapAuto -> Just (writerColumns opts) + _ -> Nothing (if writerPreferAscii opts then toEntities else id) <$> - case template of - Nothing -> return $ renderHtml' body + case writerTemplate opts of + Nothing -> return $ + case colwidth of + Nothing -> renderHtml' body -- optimization, skip layout + Just cols -> render (Just cols) $ layoutMarkup body Just tpl -> do -- warn if empty lang when (isNothing (getField "lang" context :: Maybe Text)) $ report NoLangSpecified -- check for empty pagetitle - context' <- + (context' :: Context Text) <- case getField "pagetitle" context of Just (s :: Text) | not (T.null s) -> return context _ -> do @@ -228,9 +234,9 @@ writeHtmlString' st opts d = do Just [] -> "Untitled" Just (x:_) -> takeBaseName $ T.unpack x report $ NoTitleElement fallback - return $ resetField "pagetitle" fallback context - return $ render Nothing $ renderTemplate tpl - (defField "body" (renderHtml' body) context') + return $ resetField "pagetitle" (literal fallback) context + return $ render colwidth $ renderTemplate tpl + (defField "body" (layoutMarkup body) context') writeHtml' :: PandocMonad m => WriterState -> WriterOptions -> Pandoc -> m Html writeHtml' st opts d = @@ -243,13 +249,6 @@ writeHtml' st opts d = (body, _) <- evalStateT (pandocToHtml opts d) st return body -wantTOC :: Meta -> Maybe Bool -wantTOC = fmap (== MetaBool True) . lookupMeta "tableOfContents" - -tocTemplate :: Template Text -tocTemplate = either error id . runIdentity . compileTemplate "" $ - "<div class=\"toc\"><h1></h1>$table-of-contents$</div>$body$" - -- result is (title, authors, date, toc, body, new variables) pandocToHtml :: PandocMonad m => WriterOptions @@ -259,13 +258,13 @@ pandocToHtml opts (Pandoc meta blocks) = do let slideLevel = fromMaybe (getSlideLevel blocks) $ writerSlideLevel opts modify $ \st -> st{ stSlideLevel = slideLevel } metadata <- metaToContext opts - (fmap (literal . renderHtml') . blockListToHtml opts) - (fmap (literal . renderHtml') . inlineListToHtml opts) + (fmap layoutMarkup . blockListToHtml opts) + (fmap layoutMarkup . inlineListToHtml opts) meta let stringifyHTML = escapeStringForXML . stringify - let authsMeta = map stringifyHTML $ docAuthors meta + let authsMeta = map (literal . stringifyHTML) $ docAuthors meta let dateMeta = stringifyHTML $ docDate meta - let descriptionMeta = escapeStringForXML $ + let descriptionMeta = literal $ escapeStringForXML $ lookupMetaString "description" meta slideVariant <- gets stSlideVariant let sects = adjustNumbers opts $ @@ -273,15 +272,22 @@ pandocToHtml opts (Pandoc meta blocks) = do if slideVariant == NoSlides then blocks else prepSlides slideLevel blocks - let withTOC = fromMaybe (writerTableOfContents opts) (wantTOC meta) - toc <- if withTOC && slideVariant /= S5Slides - then fmap renderHtml' <$> tableOfContents opts sects + toc <- if writerTableOfContents opts && slideVariant /= S5Slides + then fmap layoutMarkup <$> tableOfContents opts sects else return Nothing blocks' <- blockListToHtml opts sects + notes <- do + -- make the st private just to be safe, since we modify it right afterwards + st <- get + if null (stNotes st) + then return mempty + else do + notes <- footnoteSection EndOfDocument (stEmittedNotes st + 1) (reverse (stNotes st)) + modify (\st' -> st'{ stNotes = mempty, stEmittedNotes = stEmittedNotes st' + length (stNotes st') }) + return notes st <- get - notes <- footnoteSection opts (reverse (stNotes st)) let thebody = blocks' >> notes - let math = case writerHTMLMathMethod opts of + let math = layoutMarkup $ case writerHTMLMathMethod opts of MathJax url | slideVariant /= RevealJsSlides -> -- mathjax is handled via a special plugin in revealjs @@ -295,10 +301,10 @@ pandocToHtml opts (Pandoc meta blocks) = do KaTeX url -> do H.script ! A.src (toValue $ url <> "katex.min.js") $ mempty - nl opts + nl let katexFlushLeft = case lookupContext "classoption" metadata of - Just clsops | "fleqn" `elem` (clsops :: [Text]) -> "true" + Just clsops | "fleqn" `elem` (clsops :: [Doc Text]) -> "true" _ -> "false" H.script $ text $ T.unlines [ "document.addEventListener(\"DOMContentLoaded\", function () {" @@ -315,7 +321,7 @@ pandocToHtml opts (Pandoc meta blocks) = do , " });" , "}}});" ] - nl opts + nl H.link ! A.rel "stylesheet" ! A.href (toValue $ url <> "katex.min.css") @@ -324,15 +330,16 @@ pandocToHtml opts (Pandoc meta blocks) = do Just s | not (stHtml5 st) -> H.script ! A.type_ "text/javascript" $ preEscapedString - ("/*<![CDATA[*/\n" ++ T.unpack s ++ + ("/*<![CDATA[*/\n" <> T.unpack s <> "/*]]>*/\n") | otherwise -> mempty Nothing -> mempty let mCss :: Maybe [Text] = lookupContext "css" metadata - let context = (if stHighlighting st + let context :: Context Text + context = (if stHighlighting st then case writerHighlightStyle opts of Just sty -> defField "highlighting-css" - (T.pack $ styleToCss sty) + (literal $ T.pack $ styleToCss sty) Nothing -> id else id) . (if stCsl st @@ -342,15 +349,15 @@ pandocToHtml opts (Pandoc meta blocks) = do Just 0 -> id Just n -> defField "csl-entry-spacing" - (tshow n <> "em")) + (literal $ tshow n <> "em")) else id) . (if stMath st - then defField "math" (renderHtml' math) + then defField "math" math else id) . (case writerHTMLMathMethod opts of MathJax u -> defField "mathjax" True . defField "mathjaxurl" - (T.takeWhile (/='?') u) + (literal $ T.takeWhile (/='?') u) _ -> defField "mathjax" False) . (case writerHTMLMathMethod opts of PlainMath -> defField "displaymath-css" True @@ -361,13 +368,14 @@ pandocToHtml opts (Pandoc meta blocks) = do -- template can't distinguish False/undefined defField "controls" True . defField "controlsTutorial" True . - defField "controlsLayout" ("bottom-right" :: Text) . - defField "controlsBackArrows" ("faded" :: Text) . + defField "controlsLayout" + ("bottom-right" :: Doc Text) . + defField "controlsBackArrows" ("faded" :: Doc Text) . defField "progress" True . defField "slideNumber" False . - defField "showSlideNumber" ("all" :: Text) . + defField "showSlideNumber" ("all" :: Doc Text) . defField "hashOneBasedIndex" False . - defField "hash" False . + defField "hash" True . defField "respondToHashChanges" True . defField "history" False . defField "keyboard" True . @@ -377,7 +385,7 @@ pandocToHtml opts (Pandoc meta blocks) = do defField "touch" True . defField "loop" False . defField "rtl" False . - defField "navigationMode" ("default" :: Text) . + defField "navigationMode" ("default" :: Doc Text) . defField "shuffle" False . defField "fragments" True . defField "fragmentInURL" True . @@ -385,22 +393,22 @@ pandocToHtml opts (Pandoc meta blocks) = do defField "help" True . defField "pause" True . defField "showNotes" False . - defField "autoPlayMedia" ("null" :: Text) . - defField "preloadIframes" ("null" :: Text) . - defField "autoSlide" ("0" :: Text) . + defField "autoPlayMedia" ("null" :: Doc Text) . + defField "preloadIframes" ("null" :: Doc Text) . + defField "autoSlide" ("0" :: Doc Text) . defField "autoSlideStoppable" True . - defField "autoSlideMethod" ("null" :: Text) . - defField "defaultTiming" ("null" :: Text) . + defField "autoSlideMethod" ("null" :: Doc Text) . + defField "defaultTiming" ("null" :: Doc Text) . defField "mouseWheel" False . - defField "display" ("block" :: Text) . + defField "display" ("block" :: Doc Text) . defField "hideInactiveCursor" True . - defField "hideCursorTime" ("5000" :: Text) . + defField "hideCursorTime" ("5000" :: Doc Text) . defField "previewLinks" False . - defField "transition" ("slide" :: Text) . - defField "transitionSpeed" ("default" :: Text) . - defField "backgroundTransition" ("fade" :: Text) . - defField "viewDistance" ("3" :: Text) . - defField "mobileViewDistance" ("2" :: Text) + defField "transition" ("slide" :: Doc Text) . + defField "transitionSpeed" ("default" :: Doc Text) . + defField "backgroundTransition" ("fade" :: Doc Text) . + defField "viewDistance" ("3" :: Doc Text) . + defField "mobileViewDistance" ("2" :: Doc Text) else id) . defField "document-css" (isNothing mCss && slideVariant == NoSlides) . defField "quotes" (stQuotes st) . @@ -410,18 +418,18 @@ pandocToHtml opts (Pandoc meta blocks) = do maybe id (defField "toc") toc . maybe id (defField "table-of-contents") toc . defField "author-meta" authsMeta . - maybe id (defField "date-meta") + maybe id (defField "date-meta" . literal) (normalizeDate dateMeta) . defField "description-meta" descriptionMeta . defField "pagetitle" - (stringifyHTML . docTitle $ meta) . - defField "idprefix" (writerIdentifierPrefix opts) . + (literal . stringifyHTML . docTitle $ meta) . + defField "idprefix" (literal $ writerIdentifierPrefix opts) . -- these should maybe be set in pandoc.hs defField "slidy-url" - ("https://www.w3.org/Talks/Tools/Slidy2" :: Text) . - defField "slideous-url" ("slideous" :: Text) . - defField "revealjs-url" ("https://unpkg.com/reveal.js@^4/" :: Text) $ - defField "s5-url" ("s5/default" :: Text) . + ("https://www.w3.org/Talks/Tools/Slidy2" :: Doc Text) . + defField "slideous-url" ("slideous" :: Doc Text) . + defField "revealjs-url" ("https://unpkg.com/reveal.js@^4/" :: Doc Text) $ + defField "s5-url" ("s5/default" :: Doc Text) . defField "html5" (stHtml5 st) $ metadata return (thebody, context) @@ -449,15 +457,15 @@ toList listop opts items = do unordList :: PandocMonad m => WriterOptions -> [Html] -> StateT WriterState m Html -unordList opts = toList H.ul opts . toListItems opts +unordList opts = toList H.ul opts . toListItems ordList :: PandocMonad m => WriterOptions -> [Html] -> StateT WriterState m Html -ordList opts = toList H.ol opts . toListItems opts +ordList opts = toList H.ol opts . toListItems defList :: PandocMonad m => WriterOptions -> [Html] -> StateT WriterState m Html -defList opts items = toList H.dl opts (items ++ [nl opts]) +defList opts items = toList H.dl opts (items ++ [nl]) isTaskListItem :: [Block] -> Bool isTaskListItem (Plain (Str "☐":Space:_):_) = True @@ -479,7 +487,7 @@ listItemToHtml opts bls let checkbox = if checked then checkbox' ! A.checked "" else checkbox' - checkbox' = H.input ! A.type_ "checkbox" ! A.disabled "" >> nl opts + checkbox' = H.input ! A.type_ "checkbox" ! A.disabled "" >> nl isContents <- inlineListToHtml opts is bsContents <- blockListToHtml opts bs return $ constr (checkbox >> isContents) >> bsContents @@ -502,28 +510,45 @@ tableOfContents opts sects = do -- | Convert list of Note blocks to a footnote <div>. -- Assumes notes are sorted. -footnoteSection :: PandocMonad m - => WriterOptions -> [Html] -> StateT WriterState m Html -footnoteSection opts notes = do +footnoteSection :: + PandocMonad m => ReferenceLocation -> Int -> [Html] -> StateT WriterState m Html +footnoteSection refLocation startCounter notes = do html5 <- gets stHtml5 slideVariant <- gets stSlideVariant - let hrtag = if html5 then H5.hr else H.hr + let hrtag = if refLocation /= EndOfBlock + then (if html5 then H5.hr else H.hr) <> nl + else mempty + let additionalClassName = case refLocation of + EndOfBlock -> "footnotes-end-of-block" + EndOfDocument -> "footnotes-end-of-document" + EndOfSection -> "footnotes-end-of-section" + let className = "footnotes " <> additionalClassName epubVersion <- gets stEPUBVersion let container x | html5 , epubVersion == Just EPUB3 - = H5.section ! A.class_ "footnotes" + = H5.section ! A.class_ className ! customAttribute "epub:type" "footnotes" $ x - | html5 = H5.section ! A.class_ "footnotes" + | html5 = H5.section ! A.class_ className ! customAttribute "role" "doc-endnotes" $ x | slideVariant /= NoSlides = H.div ! A.class_ "footnotes slide" $ x - | otherwise = H.div ! A.class_ "footnotes" $ x + | otherwise = H.div ! A.class_ className $ x return $ if null notes then mempty - else nl opts >> container (nl opts >> hrtag >> nl opts >> - H.ol (mconcat notes >> nl opts) >> nl opts) + else do + nl + container $ do + nl + hrtag + -- Keep the previous output exactly the same if we don't + -- have multiple notes sections + if startCounter == 1 + then H.ol $ mconcat notes >> nl + else H.ol ! A.start (fromString (show startCounter)) $ + mconcat notes >> nl + nl -- | Parse a mailto link; return Just (name, domain) or Nothing. parseMailto :: Text -> Maybe (Text, Text) @@ -618,6 +643,7 @@ toAttrs kvs = do return (keys, attrs) else return (Set.insert k keys, addAttr html5 mbEpubVersion k v attrs) addAttr html5 mbEpubVersion x y + | T.null x = id -- see #7546 | html5 = if x `Set.member` (html5Attributes <> rdfaAttributes) || T.any (== ':') x -- e.g. epub: namespace @@ -689,12 +715,11 @@ figure opts attr@(_, _, attrList) txt (s,tit) = do img <- inlineToHtml opts (Image attr alt (s,tit)) capt <- if null txt then return mempty - else tocapt `fmap` inlineListToHtml opts txt + else (nl <>) . tocapt <$> inlineListToHtml opts txt + let inner = mconcat [nl, img, capt, nl] return $ if html5 - then H5.figure $ mconcat - [nl opts, img, capt, nl opts] - else H.div ! A.class_ "figure" $ mconcat - [nl opts, img, nl opts, capt, nl opts] + then H5.figure inner + else H.div ! A.class_ "figure" $ inner adjustNumbers :: WriterOptions -> [Block] -> [Block] @@ -714,11 +739,10 @@ adjustNumbers opts doc = fixnum x = x showSecNum = T.intercalate "." . map tshow --- | Convert Pandoc block element to HTML. -blockToHtml :: PandocMonad m => WriterOptions -> Block -> StateT WriterState m Html -blockToHtml _ Null = return mempty -blockToHtml opts (Plain lst) = inlineListToHtml opts lst -blockToHtml opts (Para [Image attr@(_,classes,_) txt (src,tit)]) +blockToHtmlInner :: PandocMonad m => WriterOptions -> Block -> StateT WriterState m Html +blockToHtmlInner _ Null = return mempty +blockToHtmlInner opts (Plain lst) = inlineListToHtml opts lst +blockToHtmlInner opts (Para [Image attr@(_,classes,_) txt (src,tit)]) | "stretch" `elem` classes = do slideVariant <- gets stSlideVariant case slideVariant of @@ -728,20 +752,20 @@ blockToHtml opts (Para [Image attr@(_,classes,_) txt (src,tit)]) inlineToHtml opts (Image attr txt (src, tit)) _ -> figure opts attr txt (src, tit) -- title beginning with fig: indicates that the image is a figure -blockToHtml opts (Para [Image attr txt (s,T.stripPrefix "fig:" -> Just tit)]) = - figure opts attr txt (s,tit) -blockToHtml opts (Para lst) = do +blockToHtmlInner opts (SimpleFigure attr caption (src, title)) = + figure opts attr caption (src, title) +blockToHtmlInner opts (Para lst) = do contents <- inlineListToHtml opts lst case contents of Empty _ | not (isEnabled Ext_empty_paragraphs opts) -> return mempty _ -> return $ H.p contents -blockToHtml opts (LineBlock lns) = +blockToHtmlInner opts (LineBlock lns) = if writerWrapText opts == WrapNone then blockToHtml opts $ linesToPara lns else do htmlLines <- inlineListToHtml opts $ intercalate [LineBreak] lns return $ H.div ! A.class_ "line-block" $ htmlLines -blockToHtml opts (Div (ident, "section":dclasses, dkvs) +blockToHtmlInner opts (Div (ident, "section":dclasses, dkvs) (Header level hattr@(hident,hclasses,hkvs) ils : xs)) = do slideVariant <- gets stSlideVariant @@ -796,33 +820,33 @@ blockToHtml opts (Div (ident, "section":dclasses, dkvs) if titleSlide then do t <- addAttrs opts attr $ - secttag $ nl opts <> header' <> nl opts <> titleContents <> nl opts + secttag $ nl <> header' <> nl <> titleContents <> nl -- ensure 2D nesting for revealjs, but only for one level; -- revealjs doesn't like more than one level of nesting return $ if slideVariant == RevealJsSlides && not inSection && not (null innerSecs) - then H5.section (nl opts <> t <> nl opts <> innerContents) - else t <> nl opts <> if null innerSecs + then H5.section (nl <> t <> nl <> innerContents) + else t <> nl <> if null innerSecs then mempty - else innerContents <> nl opts + else innerContents <> nl else if writerSectionDivs opts || slide || (hident /= ident && not (T.null hident || T.null ident)) || (hclasses /= dclasses) || (hkvs /= dkvs) then addAttrs opts attr $ secttag - $ nl opts <> header' <> nl opts <> + $ nl <> header' <> nl <> if null innerSecs then mempty - else innerContents <> nl opts + else innerContents <> nl else do let attr' = (ident, classes' \\ hclasses, dkvs \\ hkvs) t <- addAttrs opts attr' header' return $ t <> if null innerSecs then mempty - else nl opts <> innerContents -blockToHtml opts (Div attr@(ident, classes, kvs') bs) = do + else nl <> innerContents +blockToHtmlInner opts (Div attr@(ident, classes, kvs') bs) = do html5 <- gets stHtml5 slideVariant <- gets stSlideVariant let isCslBibBody = ident == "refs" || "csl-bib-body" `elem` classes @@ -859,7 +883,7 @@ blockToHtml opts (Div attr@(ident, classes, kvs') bs) = do -- off widths! see #4028 mconcat <$> mapM (blockToHtml opts) bs' else blockListToHtml opts' bs' - let contents' = nl opts >> contents >> nl opts + let contents' = nl >> contents >> nl let (divtag, classes'') = if html5 && "section" `elem` classes' then (H5.section, filter (/= "section") classes') else (H.div, classes') @@ -876,7 +900,7 @@ blockToHtml opts (Div attr@(ident, classes, kvs') bs) = do _ -> return mempty else addAttrs opts (ident, classes'', kvs) $ divtag contents' -blockToHtml opts (RawBlock f str) = do +blockToHtmlInner opts (RawBlock f str) = do ishtml <- isRawHtml f if ishtml then return $ preEscapedText str @@ -887,10 +911,10 @@ blockToHtml opts (RawBlock f str) = do else do report $ BlockNotRendered (RawBlock f str) return mempty -blockToHtml _ HorizontalRule = do +blockToHtmlInner _ HorizontalRule = do html5 <- gets stHtml5 return $ if html5 then H5.hr else H.hr -blockToHtml opts (CodeBlock (id',classes,keyvals) rawCode) = do +blockToHtmlInner opts (CodeBlock (id',classes,keyvals) rawCode) = do id'' <- if T.null id' then do modify $ \st -> st{ stCodeBlockNum = stCodeBlockNum st + 1 } @@ -922,7 +946,7 @@ blockToHtml opts (CodeBlock (id',classes,keyvals) rawCode) = do -- we set writerIdentifierPrefix to "" since id'' already -- includes it: addAttrs opts{writerIdentifierPrefix = ""} (id'',[],keyvals) h -blockToHtml opts (BlockQuote blocks) = do +blockToHtmlInner opts (BlockQuote blocks) = do -- in S5, treat list in blockquote specially -- if default is incremental, make it nonincremental; -- otherwise incremental @@ -940,11 +964,11 @@ blockToHtml opts (BlockQuote blocks) = do (DefinitionList lst) _ -> do contents <- blockListToHtml opts blocks return $ H.blockquote - $ nl opts >> contents >> nl opts + $ nl >> contents >> nl else do contents <- blockListToHtml opts blocks - return $ H.blockquote $ nl opts >> contents >> nl opts -blockToHtml opts (Header level (ident,classes,kvs) lst) = do + return $ H.blockquote $ nl >> contents >> nl +blockToHtmlInner opts (Header level (ident,classes,kvs) lst) = do contents <- inlineListToHtml opts lst let secnum = fromMaybe mempty $ lookup "number" kvs let contents' = if writerNumberSections opts && not (T.null secnum) @@ -967,12 +991,12 @@ blockToHtml opts (Header level (ident,classes,kvs) lst) = do 5 -> H.h5 contents' 6 -> H.h6 contents' _ -> H.p ! A.class_ "heading" $ contents' -blockToHtml opts (BulletList lst) = do +blockToHtmlInner opts (BulletList lst) = do contents <- mapM (listItemToHtml opts) lst let isTaskList = not (null lst) && all isTaskListItem lst (if isTaskList then (! A.class_ "task-list") else id) <$> unordList opts contents -blockToHtml opts (OrderedList (startnum, numstyle, _) lst) = do +blockToHtmlInner opts (OrderedList (startnum, numstyle, _) lst) = do contents <- mapM (listItemToHtml opts) lst html5 <- gets stHtml5 let numstyle' = case numstyle of @@ -995,17 +1019,47 @@ blockToHtml opts (OrderedList (startnum, numstyle, _) lst) = do else []) l <- ordList opts contents return $ foldl' (!) l attribs -blockToHtml opts (DefinitionList lst) = do +blockToHtmlInner opts (DefinitionList lst) = do contents <- mapM (\(term, defs) -> do term' <- liftM H.dt $ inlineListToHtml opts term - defs' <- mapM (liftM (\x -> H.dd (x >> nl opts)) . + defs' <- mapM (liftM (\x -> H.dd (nl >> x >> nl)) . blockListToHtml opts) defs - return $ mconcat $ nl opts : term' : nl opts : - intersperse (nl opts) defs') lst + return $ mconcat $ nl : term' : nl : + intersperse (nl) defs') lst defList opts contents -blockToHtml opts (Table attr caption colspecs thead tbody tfoot) = +blockToHtmlInner opts (Table attr caption colspecs thead tbody tfoot) = tableToHtml opts (Ann.toTable attr caption colspecs thead tbody tfoot) +-- | Convert Pandoc block element to HTML. All the legwork is done by +-- 'blockToHtmlInner', this just takes care of emitting the notes after +-- the block if necessary. +blockToHtml :: PandocMonad m => WriterOptions -> Block -> StateT WriterState m Html +blockToHtml opts block = do + -- Ignore inserted section divs -- they are not blocks as they came from + -- the document itself (at least not when coming from markdown) + let isSection = case block of + Div (_, classes, _) _ | "section" `elem` classes -> True + _ -> False + let increaseLevel = not isSection + when increaseLevel $ + modify (\st -> st{ stBlockLevel = stBlockLevel st + 1 }) + doc <- blockToHtmlInner opts block + st <- get + let emitNotes = + (writerReferenceLocation opts == EndOfBlock && stBlockLevel st == 1) || + (writerReferenceLocation opts == EndOfSection && isSection) + res <- if emitNotes + then do + notes <- if null (stNotes st) + then return mempty + else footnoteSection (writerReferenceLocation opts) (stEmittedNotes st + 1) (reverse (stNotes st)) + modify (\st' -> st'{ stNotes = mempty, stEmittedNotes = stEmittedNotes st' + length (stNotes st') }) + return (doc <> notes) + else return doc + when increaseLevel $ + modify (\st' -> st'{ stBlockLevel = stBlockLevel st' - 1 }) + return res + tableToHtml :: PandocMonad m => WriterOptions -> Ann.Table @@ -1017,10 +1071,10 @@ tableToHtml opts (Ann.Table attr caption colspecs thead tbodies tfoot) = do cs <- blockListToHtml opts longCapt return $ do H.caption cs - nl opts - coltags <- colSpecListToHtml opts colspecs + nl + coltags <- colSpecListToHtml colspecs head' <- tableHeadToHtml opts thead - bodies <- intersperse (nl opts) <$> mapM (tableBodyToHtml opts) tbodies + bodies <- intersperse (nl) <$> mapM (tableBodyToHtml opts) tbodies foot' <- tableFootToHtml opts tfoot let (ident,classes,kvs) = attr -- When widths of columns are < 100%, we need to set width for the whole @@ -1037,13 +1091,13 @@ tableToHtml opts (Ann.Table attr caption colspecs thead tbodies tfoot) = do <> "%;"):kvs) _ -> attr addAttrs opts attr' $ H.table $ do - nl opts + nl captionDoc coltags head' mconcat bodies foot' - nl opts + nl tableBodyToHtml :: PandocMonad m => WriterOptions @@ -1090,7 +1144,7 @@ tablePartToHtml opts tblpart attr rows = tablePartElement <- addAttrs opts attr $ tag' contents return $ do tablePartElement - nl opts + nl where isEmptyRow (Ann.HeaderRow _attr _rownum cells) = all isEmptyCell cells isEmptyCell (Ann.Cell _colspecs _colnum cell) = @@ -1131,14 +1185,13 @@ rowListToHtml :: PandocMonad m -> [TableRow] -> StateT WriterState m Html rowListToHtml opts rows = - (\x -> nl opts *> mconcat x) <$> + (\x -> nl *> mconcat x) <$> mapM (tableRowToHtml opts) rows colSpecListToHtml :: PandocMonad m - => WriterOptions - -> [ColSpec] + => [ColSpec] -> StateT WriterState m Html -colSpecListToHtml opts colspecs = do +colSpecListToHtml colspecs = do html5 <- gets stHtml5 let hasDefaultWidth (_, ColWidthDefault) = True hasDefaultWidth _ = False @@ -1152,16 +1205,16 @@ colSpecListToHtml opts colspecs = do ColWidth w -> if html5 then A.style (toValue $ "width: " <> percent w) else A.width (toValue $ percent w) - nl opts + nl return $ if all hasDefaultWidth colspecs then mempty else do H.colgroup $ do - nl opts + nl mapM_ (col . snd) colspecs - nl opts + nl tableRowToHtml :: PandocMonad m => WriterOptions @@ -1180,12 +1233,12 @@ tableRowToHtml opts (TableRow tblpart attr rownum rowhead rowbody) = do headcells <- mapM (cellToHtml opts HeaderCell) rowhead bodycells <- mapM (cellToHtml opts celltype) rowbody rowHtml <- addAttrs opts attr' $ H.tr $ do - nl opts + nl mconcat headcells mconcat bodycells return $ do rowHtml - nl opts + nl alignmentToString :: Alignment -> Maybe Text alignmentToString = \case @@ -1243,18 +1296,18 @@ tableCellToHtml opts ctype colAlign (Cell attr align rowspan colspan item) = do : otherAttribs return $ do tag' ! attribs $ contents - nl opts + nl -toListItems :: WriterOptions -> [Html] -> [Html] -toListItems opts items = map (toListItem opts) items ++ [nl opts] +toListItems :: [Html] -> [Html] +toListItems items = map toListItem items ++ [nl] -toListItem :: WriterOptions -> Html -> Html -toListItem opts item = nl opts *> H.li item +toListItem :: Html -> Html +toListItem item = nl *> H.li item blockListToHtml :: PandocMonad m => WriterOptions -> [Block] -> StateT WriterState m Html blockListToHtml opts lst = - mconcat . intersperse (nl opts) . filter nonempty + mconcat . intersperse (nl) . filter nonempty <$> mapM (blockToHtml opts) lst where nonempty (Empty _) = False nonempty _ = True @@ -1286,9 +1339,9 @@ inlineToHtml opts inline = do (Str str) -> return $ strToHtml str Space -> return $ strToHtml " " SoftBreak -> return $ case writerWrapText opts of - WrapNone -> preEscapedText " " - WrapAuto -> preEscapedText " " - WrapPreserve -> preEscapedText "\n" + WrapNone -> " " + WrapAuto -> " " + WrapPreserve -> nl LineBreak -> return $ do if html5 then H5.br else H.br strToHtml "\n" @@ -1389,7 +1442,7 @@ inlineToHtml opts inline = do InlineMath -> "\\textstyle " DisplayMath -> "\\displaystyle " return $ imtag ! A.style "vertical-align:middle" - ! A.src (toValue $ url <> T.pack (urlEncode (T.unpack $ s <> str))) + ! A.src (toValue . (url <>) . urlEncode $ s <> str) ! A.alt (toValue str) ! A.title (toValue str) ! A.class_ mathClass @@ -1424,13 +1477,17 @@ inlineToHtml opts inline = do ishtml <- isRawHtml f if ishtml then return $ preEscapedText str - else if (f == Format "latex" || f == Format "tex") && - allowsMathEnvironments (writerHTMLMathMethod opts) && - isMathEnvironment str - then inlineToHtml opts $ Math DisplayMath str - else do - report $ InlineNotRendered inline - return mempty + else do + let istex = f == Format "latex" || f == Format "tex" + let mm = writerHTMLMathMethod opts + case istex of + True + | allowsMathEnvironments mm && isMathEnvironment str + -> inlineToHtml opts $ Math DisplayMath str + | allowsRef mm && isRef str + -> inlineToHtml opts $ Math InlineMath str + _ -> do report $ InlineNotRendered inline + return mempty (Link attr txt (s,_)) | "mailto:" `T.isPrefixOf` s -> do linkText <- inlineListToHtml opts txt obfuscateLink opts attr linkText s @@ -1480,7 +1537,8 @@ inlineToHtml opts inline = do -- note: null title included, as in Markdown.pl (Note contents) -> do notes <- gets stNotes - let number = length notes + 1 + emittedNotes <- gets stEmittedNotes + let number = emittedNotes + length notes + 1 let ref = tshow number htmlContents <- blockListToNote opts ref contents epubVersion <- gets stEPUBVersion @@ -1548,7 +1606,7 @@ blockListToNote opts ref blocks = do _ | html5 -> noteItem ! customAttribute "role" "doc-endnote" _ -> noteItem - return $ nl opts >> noteItem' + return $ nl >> noteItem' inDiv :: PandocMonad m=> Text -> Html -> StateT WriterState m Html inDiv cls x = do @@ -1557,6 +1615,9 @@ inDiv cls x = do (if html5 then H5.div else H.div) x ! A.class_ (toValue cls) +isRef :: Text -> Bool +isRef t = "\\ref{" `T.isPrefixOf` t || "\\eqref{" `T.isPrefixOf` t + isMathEnvironment :: Text -> Bool isMathEnvironment s = "\\begin{" `T.isPrefixOf` s && envName `elem` mathmlenvs @@ -1591,10 +1652,15 @@ isMathEnvironment s = "\\begin{" `T.isPrefixOf` s && allowsMathEnvironments :: HTMLMathMethod -> Bool allowsMathEnvironments (MathJax _) = True +allowsMathEnvironments (KaTeX _) = True allowsMathEnvironments MathML = True allowsMathEnvironments (WebTeX _) = True allowsMathEnvironments _ = False +allowsRef :: HTMLMathMethod -> Bool +allowsRef (MathJax _) = True +allowsRef _ = False + -- | List of intrinsic event attributes allowed on all elements in HTML4. intrinsicEventsHTML4 :: [Text] intrinsicEventsHTML4 = diff --git a/src/Text/Pandoc/Writers/Haddock.hs b/src/Text/Pandoc/Writers/Haddock.hs index 75e14714b..dfd89bc54 100644 --- a/src/Text/Pandoc/Writers/Haddock.hs +++ b/src/Text/Pandoc/Writers/Haddock.hs @@ -98,8 +98,7 @@ blockToHaddock opts (Plain inlines) = do contents <- inlineListToHaddock opts inlines return $ contents <> cr -- title beginning with fig: indicates figure -blockToHaddock opts (Para [Image attr alt (src,tgt)]) - | Just tit <- T.stripPrefix "fig:" tgt +blockToHaddock opts (SimpleFigure attr alt (src, tit)) = blockToHaddock opts (Para [Image attr alt (src,tit)]) blockToHaddock opts (Para inlines) = -- TODO: if it contains linebreaks, we need to use a @...@ block diff --git a/src/Text/Pandoc/Writers/ICML.hs b/src/Text/Pandoc/Writers/ICML.hs index c254fbc58..ea6009fd1 100644 --- a/src/Text/Pandoc/Writers/ICML.hs +++ b/src/Text/Pandoc/Writers/ICML.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.ICML @@ -309,9 +308,8 @@ blocksToICML opts style lst = do -- | Convert a Pandoc block element to ICML. blockToICML :: PandocMonad m => WriterOptions -> Style -> Block -> WS m (Doc Text) blockToICML opts style (Plain lst) = parStyle opts style "" lst --- title beginning with fig: indicates that the image is a figure -blockToICML opts style (Para img@[Image _ txt (_,Text.stripPrefix "fig:" -> Just _)]) = do - figure <- parStyle opts (figureName:style) "" img +blockToICML opts style (SimpleFigure attr txt (src, tit)) = do + figure <- parStyle opts (figureName:style) "" [Image attr txt (src, tit)] caption <- parStyle opts (imgCaptionName:style) "" txt return $ intersperseBrs [figure, caption] blockToICML opts style (Para lst) = parStyle opts (paragraphName:style) "" lst diff --git a/src/Text/Pandoc/Writers/Ipynb.hs b/src/Text/Pandoc/Writers/Ipynb.hs index 2613851c5..47c6e6966 100644 --- a/src/Text/Pandoc/Writers/Ipynb.hs +++ b/src/Text/Pandoc/Writers/Ipynb.hs @@ -37,6 +37,8 @@ import qualified Data.ByteString.Lazy as BL import Data.Aeson.Encode.Pretty (Config(..), defConfig, encodePretty', keyOrder, Indent(Spaces)) import Text.DocLayout (literal) +import Text.Pandoc.UUID (getRandomUUID) +import Data.Char (isAscii, isAlphaNum) writeIpynb :: PandocMonad m => WriterOptions -> Pandoc -> m Text writeIpynb opts d = do @@ -49,7 +51,7 @@ writeIpynb opts d = do "cell_type", "output_type", "execution_count", "metadata", "outputs", "source", - "data", "name", "text" ] } + "data", "name", "text" ] <> compare } $ notebook pandocToNotebook :: PandocMonad m @@ -79,7 +81,7 @@ pandocToNotebook opts (Pandoc meta blocks) = do let metadata = case fromJSON metadata' of Error _ -> mempty -- TODO warning here? shouldn't happen Success x -> x - cells <- extractCells opts blocks + cells <- extractCells nbformat opts blocks return $ Notebook{ notebookMetadata = metadata , notebookFormat = nbformat @@ -97,23 +99,26 @@ addAttachment (Image attr lab (src,tit)) return $ Image attr lab ("attachment:" <> src, tit) addAttachment x = return x -extractCells :: PandocMonad m => WriterOptions -> [Block] -> m [Ipynb.Cell a] -extractCells _ [] = return [] -extractCells opts (Div (_id,classes,kvs) xs : bs) +extractCells :: PandocMonad m + => (Int, Int) -> WriterOptions -> [Block] -> m [Ipynb.Cell a] +extractCells _ _ [] = return [] +extractCells nbformat opts (Div (ident,classes,kvs) xs : bs) | "cell" `elem` classes , "markdown" `elem` classes = do let meta = pairsToJSONMeta kvs (newdoc, attachments) <- runStateT (walkM addAttachment (Pandoc nullMeta xs)) mempty source <- writeMarkdown opts{ writerTemplate = Nothing } newdoc + uuid <- uuidFrom nbformat ident (Ipynb.Cell{ cellType = Markdown + , cellId = uuid , cellSource = Source $ breakLines $ T.stripEnd source , cellMetadata = meta , cellAttachments = if M.null attachments then Nothing - else Just attachments } :) - <$> extractCells opts bs + else Just $ MimeAttachments attachments } :) + <$> extractCells nbformat opts bs | "cell" `elem` classes , "code" `elem` classes = do let (codeContent, rest) = @@ -123,14 +128,16 @@ extractCells opts (Div (_id,classes,kvs) xs : bs) let meta = pairsToJSONMeta kvs outputs <- catMaybes <$> mapM blockToOutput rest let exeCount = lookup "execution_count" kvs >>= safeRead + uuid <- uuidFrom nbformat ident (Ipynb.Cell{ cellType = Ipynb.Code { codeExecutionCount = exeCount , codeOutputs = outputs } + , cellId = uuid , cellSource = Source $ breakLines codeContent , cellMetadata = meta - , cellAttachments = Nothing } :) <$> extractCells opts bs + , cellAttachments = Nothing } :) <$> extractCells nbformat opts bs | "cell" `elem` classes , "raw" `elem` classes = case consolidateAdjacentRawBlocks xs of @@ -138,38 +145,66 @@ extractCells opts (Div (_id,classes,kvs) xs : bs) let format' = case T.toLower f of "html" -> "text/html" + "html4" -> "text/html" + "html5" -> "text/html" + "s5" -> "text/html" + "slidy" -> "text/html" + "slideous" -> "text/html" + "dzslides" -> "text/html" "revealjs" -> "text/html" "latex" -> "text/latex" "markdown" -> "text/markdown" - "rst" -> "text/x-rst" + "rst" -> "text/restructuredtext" + "asciidoc" -> "text/asciidoc" _ -> f + uuid <- uuidFrom nbformat ident (Ipynb.Cell{ cellType = Raw + , cellId = uuid , cellSource = Source $ breakLines raw , cellMetadata = if format' == "ipynb" -- means no format given then mempty - else M.insert "format" + else JSONMeta $ M.insert "raw_mimetype" (Aeson.String format') mempty - , cellAttachments = Nothing } :) <$> extractCells opts bs - _ -> extractCells opts bs -extractCells opts (CodeBlock (_id,classes,kvs) raw : bs) + , cellAttachments = Nothing } :) <$> extractCells nbformat opts bs + _ -> extractCells nbformat opts bs +extractCells nbformat opts (CodeBlock (ident,classes,kvs) raw : bs) | "code" `elem` classes = do let meta = pairsToJSONMeta kvs let exeCount = lookup "execution_count" kvs >>= safeRead + uuid <- uuidFrom nbformat ident (Ipynb.Cell{ cellType = Ipynb.Code { codeExecutionCount = exeCount , codeOutputs = [] } + , cellId = uuid , cellSource = Source $ breakLines raw , cellMetadata = meta - , cellAttachments = Nothing } :) <$> extractCells opts bs -extractCells opts (b:bs) = do + , cellAttachments = Nothing } :) <$> extractCells nbformat opts bs +extractCells nbformat opts (b:bs) = do let isCodeOrDiv (CodeBlock (_,cl,_) _) = "code" `elem` cl isCodeOrDiv (Div (_,cl,_) _) = "cell" `elem` cl isCodeOrDiv _ = False let (mds, rest) = break isCodeOrDiv bs - extractCells opts (Div ("",["cell","markdown"],[]) (b:mds) : rest) + extractCells nbformat opts + (Div ("",["cell","markdown"],[]) (b:mds) : rest) + +-- Return Nothing if nbformat < 4.5. +-- Otherwise construct a UUID, using the existing identifier +-- if it is a valid UUID, otherwise constructing a new one. +uuidFrom :: PandocMonad m => (Int, Int) -> Text -> m (Maybe Text) +uuidFrom nbformat ident = + if nbformat >= (4,5) + then + if isValidUUID ident + then return $ Just ident + else Just . T.pack . drop 9 . show <$> getRandomUUID + else return Nothing + where + isValidUUID t = not (T.null t) && T.length t <= 64 && + T.all isValidUUIDChar t + isValidUUIDChar c = isAscii c && (isAlphaNum c || c == '-' || c == '_') blockToOutput :: PandocMonad m => Block -> m (Maybe (Output a)) blockToOutput (Div (_,["output","stream",sname],_) (CodeBlock _ t:_)) = @@ -218,11 +253,13 @@ extractData bs = do return (M.insert "text/html" (TextualData raw) mmap, meta) go (mmap, meta) (RawBlock (Format "latex") raw) = return (M.insert "text/latex" (TextualData raw) mmap, meta) + go (mmap, meta) (RawBlock (Format "markdown") raw) = + return (M.insert "text/markdown" (TextualData raw) mmap, meta) go (mmap, meta) (Div _ bs') = foldM go (mmap, meta) bs' go (mmap, meta) b = (mmap, meta) <$ report (BlockNotRendered b) pairsToJSONMeta :: [(Text, Text)] -> JSONMeta -pairsToJSONMeta kvs = +pairsToJSONMeta kvs = JSONMeta $ M.fromList [(k, case Aeson.decode (UTF8.fromTextLazy $ TL.fromStrict v) of Just val -> val Nothing -> String v) diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs index 9db8723d1..799fe29fa 100644 --- a/src/Text/Pandoc/Writers/JATS.hs +++ b/src/Text/Pandoc/Writers/JATS.hs @@ -291,9 +291,7 @@ blockToJATS opts (Header _ _ title) = do return $ inTagsSimple "title" title' -- No Plain, everything needs to be in a block-level tag blockToJATS opts (Plain lst) = blockToJATS opts (Para lst) --- title beginning with fig: indicates that the image is a figure -blockToJATS opts (Para [Image (ident,_,kvs) txt - (src,T.stripPrefix "fig:" -> Just tit)]) = do +blockToJATS opts (SimpleFigure (ident, _, kvs) txt (src, tit)) = do alt <- inlinesToJATS opts txt let (maintype, subtype) = imageMimeType src kvs let capt = if null txt @@ -553,6 +551,7 @@ inlineToJATS _ (Image (ident,_,kvs) _ (src, tit)) = do return $ selfClosingTag "inline-graphic" attr isParaOrList :: Block -> Bool +isParaOrList SimpleFigure{} = False -- implicit figures are not paragraphs isParaOrList Para{} = True isParaOrList Plain{} = True isParaOrList BulletList{} = True diff --git a/src/Text/Pandoc/Writers/JATS/References.hs b/src/Text/Pandoc/Writers/JATS/References.hs index 5b19fd034..b00875a7c 100644 --- a/src/Text/Pandoc/Writers/JATS/References.hs +++ b/src/Text/Pandoc/Writers/JATS/References.hs @@ -70,6 +70,7 @@ referenceToJATS _opts ref = do , "pages" `varInTag` "page-range" , "ISBN" `varInTag` "isbn" , "ISSN" `varInTag` "issn" + , "URL" `varInTag` "uri" , varInTagWith "doi" "pub-id" [("pub-id-type", "doi")] , varInTagWith "pmid" "pub-id" [("pub-id-type", "pmid")] ] diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs index 063e347fb..f8847aa08 100644 --- a/src/Text/Pandoc/Writers/LaTeX.hs +++ b/src/Text/Pandoc/Writers/LaTeX.hs @@ -21,15 +21,13 @@ module Text.Pandoc.Writers.LaTeX ( ) where import Control.Monad.State.Strict import Data.Char (isDigit) -import Data.List (intersperse, nubBy, (\\)) +import Data.List (intersperse, (\\)) import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe, isNothing) -import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T import Network.URI (unEscapeString) -import Text.DocTemplates (FromContext(lookupContext), renderTemplate, - Val(..), Context(..)) -import Text.Collate.Lang (Lang (..), renderLang) +import Text.DocTemplates (FromContext(lookupContext), renderTemplate) +import Text.Collate.Lang (renderLang) import Text.Pandoc.Class.PandocMonad (PandocMonad, report, toLang) import Text.Pandoc.Definition import Text.Pandoc.Highlighting (formatLaTeXBlock, formatLaTeXInline, highlight, @@ -46,7 +44,7 @@ import Text.Pandoc.Writers.LaTeX.Table (tableToLaTeX) import Text.Pandoc.Writers.LaTeX.Citation (citationsToNatbib, citationsToBiblatex) import Text.Pandoc.Writers.LaTeX.Types (LW, WriterState (..), startingState) -import Text.Pandoc.Writers.LaTeX.Lang (toPolyglossia, toBabel) +import Text.Pandoc.Writers.LaTeX.Lang (toBabel) import Text.Pandoc.Writers.LaTeX.Util (stringToLaTeX, StringContext(..), toLabel, inCmd, wrapDiv, hypertarget, labelFor, @@ -132,12 +130,6 @@ pandocToLaTeX options (Pandoc meta blocks) = do ,("tmargin","margin-top") ,("bmargin","margin-bottom") ] - let toPolyObj :: Lang -> Val Text - toPolyObj lang = MapVal $ Context $ - M.fromList [ ("name" , SimpleVal $ literal name) - , ("options" , SimpleVal $ literal opts) ] - where - (name, opts) = toPolyglossia lang mblang <- toLang $ case getLang options meta of Just l -> Just l Nothing | null docLangs -> Nothing @@ -216,36 +208,7 @@ pandocToLaTeX options (Pandoc meta blocks) = do (literal $ toBabel l)) mblang $ defField "babel-otherlangs" (map (literal . toBabel) docLangs) - $ defField "babel-newcommands" (vcat $ - map (\(poly, babel) -> literal $ - -- \textspanish and \textgalician are already used by babel - -- save them as \oritext... and let babel use that - if poly `elem` ["spanish", "galician"] - then "\\let\\oritext" <> poly <> "\\text" <> poly <> "\n" <> - "\\AddBabelHook{" <> poly <> "}{beforeextras}" <> - "{\\renewcommand{\\text" <> poly <> "}{\\oritext" - <> poly <> "}}\n" <> - "\\AddBabelHook{" <> poly <> "}{afterextras}" <> - "{\\renewcommand{\\text" <> poly <> "}[2][]{\\foreignlanguage{" - <> poly <> "}{##2}}}" - else (if poly == "latin" -- see #4161 - then "\\providecommand{\\textlatin}{}\n\\renewcommand" - else "\\newcommand") <> "{\\text" <> poly <> - "}[2][]{\\foreignlanguage{" <> babel <> "}{#2}}\n" <> - "\\newenvironment{" <> poly <> - "}[2][]{\\begin{otherlanguage}{" <> - babel <> "}}{\\end{otherlanguage}}" - ) - -- eliminate duplicates that have same polyglossia name - $ nubBy (\a b -> fst a == fst b) - -- find polyglossia and babel names of languages used in the document - $ map (\l -> (fst $ toPolyglossia l, toBabel l)) docLangs - ) - $ maybe id (defField "polyglossia-lang" . toPolyObj) mblang - $ defField "polyglossia-otherlangs" - (ListVal (map toPolyObj docLangs :: [Val Text])) - $ - defField "latex-dir-rtl" + $ defField "latex-dir-rtl" ((render Nothing <$> getField "dir" context) == Just ("rtl" :: Text)) context return $ render colwidth $ @@ -383,10 +346,7 @@ blockToLaTeX (Div (identifier,classes,kvs) bs) = do wrapNotes <$> wrapDiv (identifier,classes,kvs) result blockToLaTeX (Plain lst) = inlineListToLaTeX lst --- title beginning with fig: indicates that the image is a figure -blockToLaTeX (Para [Image attr@(ident, _, _) txt (src,tgt)]) - | Just tit <- T.stripPrefix "fig:" tgt - = do +blockToLaTeX (SimpleFigure attr@(ident, _, _) txt (src, tit)) = do (capt, captForLof, footnotes) <- getCaption inlineListToLaTeX True txt lab <- labelFor ident let caption = "\\caption" <> captForLof <> braces capt <> lab @@ -429,6 +389,7 @@ blockToLaTeX (BlockQuote lst) = do blockToLaTeX (CodeBlock (identifier,classes,keyvalAttr) str) = do opts <- gets stOptions lab <- labelFor identifier + inNote <- stInNote <$> get linkAnchor' <- hypertarget True identifier lab let linkAnchor = if isEmpty linkAnchor' then empty @@ -438,8 +399,7 @@ blockToLaTeX (CodeBlock (identifier,classes,keyvalAttr) str) = do return $ flush (linkAnchor $$ "\\begin{code}" $$ literal str $$ "\\end{code}") $$ cr let rawCodeBlock = do - st <- get - env <- if stInNote st + env <- if inNote then modify (\s -> s{ stVerbInNote = True }) >> return "Verbatim" else return "verbatim" @@ -475,14 +435,13 @@ blockToLaTeX (CodeBlock (identifier,classes,keyvalAttr) str) = do "\\end{lstlisting}") $$ cr let highlightedCodeBlock = case highlight (writerSyntaxMap opts) - formatLaTeXBlock ("",classes,keyvalAttr) str of + formatLaTeXBlock ("",classes ++ ["default"],keyvalAttr) str of Left msg -> do unless (T.null msg) $ report $ CouldNotHighlight msg rawCodeBlock Right h -> do - st <- get - when (stInNote st) $ modify (\s -> s{ stVerbInNote = True }) + when inNote $ modify (\s -> s{ stVerbInNote = True }) modify (\s -> s{ stHighlighting = True }) return (flush $ linkAnchor $$ text (T.unpack h)) case () of @@ -491,6 +450,12 @@ blockToLaTeX (CodeBlock (identifier,classes,keyvalAttr) str) = do | writerListings opts -> listingsCodeBlock | not (null classes) && isJust (writerHighlightStyle opts) -> highlightedCodeBlock + -- we don't want to use \begin{verbatim} if our code + -- contains \end{verbatim}: + | inNote + , "\\end{Verbatim}" `T.isInfixOf` str -> highlightedCodeBlock + | not inNote + , "\\end{verbatim}" `T.isInfixOf` str -> highlightedCodeBlock | otherwise -> rawCodeBlock blockToLaTeX b@(RawBlock f x) = do beamer <- gets stBeamer @@ -766,9 +731,8 @@ inlineToLaTeX (Span (id',classes,kvs) ils) = do kvToCmd _ = Nothing langCmds = case lang of - Just lng -> let (l, o) = toPolyglossia lng - ops = if T.null o then "" else "[" <> o <> "]" - in ["text" <> l <> ops] + Just lng -> let l = toBabel lng + in ["foreignlanguage{" <> l <> "}"] Nothing -> [] let cmds = mapMaybe classToCmd classes ++ mapMaybe kvToCmd kvs ++ langCmds contents <- inlineListToLaTeX ils @@ -786,7 +750,9 @@ inlineToLaTeX (Span (id',classes,kvs) ils) = do then braces contents else foldr inCmd contents cmds) inlineToLaTeX (Emph lst) = inCmd "emph" <$> inlineListToLaTeX lst -inlineToLaTeX (Underline lst) = inCmd "underline" <$> inlineListToLaTeX lst +inlineToLaTeX (Underline lst) = do + modify $ \st -> st{ stStrikeout = True } -- this gives us the ulem package + inCmd "uline" <$> inlineListToLaTeX lst inlineToLaTeX (Strong lst) = inCmd "textbf" <$> inlineListToLaTeX lst inlineToLaTeX (Strikeout lst) = do -- we need to protect VERB in an mbox or we get an error diff --git a/src/Text/Pandoc/Writers/LaTeX/Lang.hs b/src/Text/Pandoc/Writers/LaTeX/Lang.hs index 0ba68b74e..3fdbdc5af 100644 --- a/src/Text/Pandoc/Writers/LaTeX/Lang.hs +++ b/src/Text/Pandoc/Writers/LaTeX/Lang.hs @@ -10,61 +10,12 @@ Portability : portable -} module Text.Pandoc.Writers.LaTeX.Lang - ( toPolyglossiaEnv, - toPolyglossia, - toBabel + ( toBabel ) where import Data.Text (Text) import Text.Collate.Lang (Lang(..)) --- In environments \Arabic instead of \arabic is used -toPolyglossiaEnv :: Lang -> (Text, Text) -toPolyglossiaEnv l = - case toPolyglossia l of - ("arabic", o) -> ("Arabic", o) - x -> x - --- Takes a list of the constituents of a BCP47 language code and --- converts it to a Polyglossia (language, options) tuple --- http://mirrors.ctan.org/macros/latex/contrib/polyglossia/polyglossia.pdf -toPolyglossia :: Lang -> (Text, Text) -toPolyglossia (Lang "ar" _ (Just "DZ") _ _ _) = ("arabic", "locale=algeria") -toPolyglossia (Lang "ar" _ (Just "IQ") _ _ _) = ("arabic", "locale=mashriq") -toPolyglossia (Lang "ar" _ (Just "JO") _ _ _) = ("arabic", "locale=mashriq") -toPolyglossia (Lang "ar" _ (Just "LB") _ _ _) = ("arabic", "locale=mashriq") -toPolyglossia (Lang "ar" _ (Just "LY") _ _ _) = ("arabic", "locale=libya") -toPolyglossia (Lang "ar" _ (Just "MA") _ _ _) = ("arabic", "locale=morocco") -toPolyglossia (Lang "ar" _ (Just "MR") _ _ _) = ("arabic", "locale=mauritania") -toPolyglossia (Lang "ar" _ (Just "PS") _ _ _) = ("arabic", "locale=mashriq") -toPolyglossia (Lang "ar" _ (Just "SY") _ _ _) = ("arabic", "locale=mashriq") -toPolyglossia (Lang "ar" _ (Just "TN") _ _ _) = ("arabic", "locale=tunisia") -toPolyglossia (Lang "de" _ _ vars _ _) - | "1901" `elem` vars = ("german", "spelling=old") -toPolyglossia (Lang "de" _ (Just "AT") vars _ _) - | "1901" `elem` vars = ("german", "variant=austrian, spelling=old") -toPolyglossia (Lang "de" _ (Just "AT") _ _ _) = ("german", "variant=austrian") -toPolyglossia (Lang "de" _ (Just "CH") vars _ _) - | "1901" `elem` vars = ("german", "variant=swiss, spelling=old") -toPolyglossia (Lang "de" _ (Just "CH") _ _ _) = ("german", "variant=swiss") -toPolyglossia (Lang "de" _ _ _ _ _) = ("german", "") -toPolyglossia (Lang "dsb" _ _ _ _ _) = ("lsorbian", "") -toPolyglossia (Lang "el" _ _ vars _ _) - | "polyton" `elem` vars = ("greek", "variant=poly") -toPolyglossia (Lang "en" _ (Just "AU") _ _ _) = ("english", "variant=australian") -toPolyglossia (Lang "en" _ (Just "CA") _ _ _) = ("english", "variant=canadian") -toPolyglossia (Lang "en" _ (Just "GB") _ _ _) = ("english", "variant=british") -toPolyglossia (Lang "en" _ (Just "NZ") _ _ _) = ("english", "variant=newzealand") -toPolyglossia (Lang "en" _ (Just "UK") _ _ _) = ("english", "variant=british") -toPolyglossia (Lang "en" _ (Just "US") _ _ _) = ("english", "variant=american") -toPolyglossia (Lang "grc" _ _ _ _ _) = ("greek", "variant=ancient") -toPolyglossia (Lang "hsb" _ _ _ _ _) = ("usorbian", "") -toPolyglossia (Lang "la" _ _ vars _ _) - | "x-classic" `elem` vars = ("latin", "variant=classic") -toPolyglossia (Lang "pt" _ (Just "BR") _ _ _) = ("portuguese", "variant=brazilian") -toPolyglossia (Lang "sl" _ _ _ _ _) = ("slovenian", "") -toPolyglossia x = (commonFromBcp47 x, "") - -- Takes a list of the constituents of a BCP47 language code and -- converts it to a Babel language string. -- http://mirrors.ctan.org/macros/latex/required/babel/base/babel.pdf @@ -92,7 +43,7 @@ toBabel (Lang "en" _ (Just "US") _ _ _) = "american" toBabel (Lang "fr" _ (Just "CA") _ _ _) = "canadien" toBabel (Lang "fra" _ _ vars _ _) | "aca" `elem` vars = "acadian" -toBabel (Lang "grc" _ _ _ _ _) = "polutonikogreek" +toBabel (Lang "grc" _ _ _ _ _) = "ancientgreek" toBabel (Lang "hsb" _ _ _ _ _) = "uppersorbian" toBabel (Lang "la" _ _ vars _ _) | "x-classic" `elem` vars = "classiclatin" diff --git a/src/Text/Pandoc/Writers/LaTeX/Table.hs b/src/Text/Pandoc/Writers/LaTeX/Table.hs index 27a8a0257..9471c171c 100644 --- a/src/Text/Pandoc/Writers/LaTeX/Table.hs +++ b/src/Text/Pandoc/Writers/LaTeX/Table.hs @@ -102,7 +102,7 @@ colDescriptors (Ann.Table _attr _caption specs thead tbodies tfoot) = toColDescriptor :: Int -> Alignment -> Double -> Text toColDescriptor numcols align width = T.pack $ printf - ">{%s\\arraybackslash}p{(\\columnwidth - %d\\tabcolsep) * \\real{%0.2f}}" + ">{%s\\arraybackslash}p{(\\columnwidth - %d\\tabcolsep) * \\real{%0.4f}}" (T.unpack (alignCommand align)) ((numcols - 1) * 2) width diff --git a/src/Text/Pandoc/Writers/LaTeX/Util.hs b/src/Text/Pandoc/Writers/LaTeX/Util.hs index c34338121..916ca1a99 100644 --- a/src/Text/Pandoc/Writers/LaTeX/Util.hs +++ b/src/Text/Pandoc/Writers/LaTeX/Util.hs @@ -26,7 +26,7 @@ import Control.Monad (when) import Text.Pandoc.Class (PandocMonad, toLang) import Text.Pandoc.Options (WriterOptions(..), isEnabled) import Text.Pandoc.Writers.LaTeX.Types (LW, WriterState(..)) -import Text.Pandoc.Writers.LaTeX.Lang (toPolyglossiaEnv) +import Text.Pandoc.Writers.LaTeX.Lang (toBabel) import Text.Pandoc.Highlighting (toListingsLanguage) import Text.DocLayout import Text.Pandoc.Definition @@ -124,7 +124,7 @@ stringToLaTeX context zs = do '\160' -> emits "~" '\x200B' -> emits "\\hspace{0pt}" -- zero-width space '\x202F' -> emits "\\," - '\x2026' -> emitcseq "\\ldots" + '\x2026' | ligatures -> emitcseq "\\ldots" '\x2018' | ligatures -> emitquote "`" '\x2019' | ligatures -> emitquote "'" '\x201C' | ligatures -> emitquote "``" @@ -238,13 +238,11 @@ wrapDiv (_,classes,kvs) t = do Just "ltr" -> align "LTR" _ -> id wrapLang txt = case lang of - Just lng -> let (l, o) = toPolyglossiaEnv lng - ops = if T.null o - then "" - else brackets $ literal o - in inCmd "begin" (literal l) <> ops + Just lng -> let l = toBabel lng + in inCmd "begin" "otherlanguage" + <> (braces (literal l)) $$ blankline <> txt <> blankline - $$ inCmd "end" (literal l) + $$ inCmd "end" "otherlanguage" Nothing -> txt return $ wrapColumns . wrapColumn . wrapDir . wrapLang $ t diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs index 87b2d8d21..8a34bf47f 100644 --- a/src/Text/Pandoc/Writers/Man.hs +++ b/src/Text/Pandoc/Writers/Man.hs @@ -109,11 +109,10 @@ blockToMan :: PandocMonad m blockToMan _ Null = return empty blockToMan opts (Div _ bs) = blockListToMan opts bs blockToMan opts (Plain inlines) = - liftM vcat $ mapM (inlineListToMan opts) $ splitSentences inlines + splitSentences <$> inlineListToMan opts inlines blockToMan opts (Para inlines) = do - contents <- liftM vcat $ mapM (inlineListToMan opts) $ - splitSentences inlines - return $ text ".PP" $$ contents + contents <- inlineListToMan opts inlines + return $ text ".PP" $$ splitSentences contents blockToMan opts (LineBlock lns) = blockToMan opts $ linesToPara lns blockToMan _ b@(RawBlock f str) diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs index fda2bbcef..bb68d9fee 100644 --- a/src/Text/Pandoc/Writers/Markdown.hs +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -2,7 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.Markdown Copyright : Copyright (C) 2006-2021 John MacFarlane @@ -19,6 +18,7 @@ Markdown: <https://daringfireball.net/projects/markdown/> module Text.Pandoc.Writers.Markdown ( writeMarkdown, writeCommonMark, + writeMarkua, writePlain) where import Control.Monad.Reader import Control.Monad.State.Strict @@ -43,7 +43,10 @@ import Text.Pandoc.Templates (renderTemplate) import Text.DocTemplates (Val(..), Context(..), FromContext(..)) import Text.Pandoc.Walk import Text.Pandoc.Writers.HTML (writeHtml5String) -import Text.Pandoc.Writers.Markdown.Inline (inlineListToMarkdown, linkAttributes, attrsToMarkdown) +import Text.Pandoc.Writers.Markdown.Inline (inlineListToMarkdown, + linkAttributes, + attrsToMarkdown, + attrsToMarkua) import Text.Pandoc.Writers.Markdown.Types (MarkdownVariant(..), WriterState(..), WriterEnv(..), @@ -78,6 +81,26 @@ writeCommonMark opts document = enableExtension Ext_intraword_underscores $ writerExtensions opts } +-- | Convert Pandoc to Markua. +writeMarkua :: PandocMonad m => WriterOptions -> Pandoc -> m Text +writeMarkua opts document = + evalMD (pandocToMarkdown opts' document) def{ envVariant = Markua } def + where + opts' = opts{ writerExtensions = + enableExtension Ext_hard_line_breaks $ + enableExtension Ext_pipe_tables $ + -- required for fancy list enumerators + enableExtension Ext_fancy_lists $ + enableExtension Ext_startnum $ + enableExtension Ext_strikeout $ + enableExtension Ext_subscript $ + enableExtension Ext_superscript $ + enableExtension Ext_definition_lists $ + enableExtension Ext_smart $ + enableExtension Ext_footnotes + mempty } + + pandocTitleBlock :: Doc Text -> [Doc Text] -> Doc Text -> Doc Text pandocTitleBlock tit auths dat = hang 2 (text "% ") tit <> cr <> @@ -141,10 +164,20 @@ valToYaml (SimpleVal x) | otherwise = if hasNewlines x then hang 0 ("|" <> cr) x - else if isNothing $ foldM needsDoubleQuotes True x - then "\"" <> fmap escapeInDoubleQuotes x <> "\"" - else x + else case x of + Text _ t | isSpecialString t -> + "\"" <> fmap escapeInDoubleQuotes x <> "\"" + _ | isNothing (foldM needsDoubleQuotes True x) -> + "\"" <> fmap escapeInDoubleQuotes x <> "\"" + | otherwise -> x where + isSpecialString t = Set.member t specialStrings + specialStrings = Set.fromList + ["y", "Y", "yes", "Yes", "YES", "n", "N", + "no", "No", "NO", "true", "True", "TRUE", + "false", "False", "FALSE", "on", "On", "ON", + "off", "Off", "OFF", "null", "Null", + "NULL", "~", "*"] needsDoubleQuotes isFirst t = if T.any isBadAnywhere t || (isFirst && T.any isYamlPunct (T.take 1 t)) @@ -318,8 +351,15 @@ blockToMarkdown' opts (Div attrs ils) = do contents <- blockListToMarkdown opts ils variant <- asks envVariant return $ - case () of - _ | isEnabled Ext_fenced_divs opts && + case () of + _ | variant == Markua -> + case () of + () | "blurb" `elem` classes' -> prefixed "B> " contents <> blankline + | "aside" `elem` classes' -> prefixed "A> " contents <> blankline + -- | necessary to enable option to create a bibliography + | (take 3 (T.unpack id')) == "ref" -> contents <> blankline + | otherwise -> contents <> blankline + | isEnabled Ext_fenced_divs opts && attrs /= nullAttr -> let attrsToMd = if variant == Commonmark then attrsToMarkdown @@ -365,14 +405,13 @@ blockToMarkdown' opts (Plain inlines) = do _ -> inlines contents <- inlineListToMarkdown opts inlines' return $ contents <> cr --- title beginning with fig: indicates figure -blockToMarkdown' opts (Para [Image attr alt (src,tgt@(T.stripPrefix "fig:" -> Just tit))]) +blockToMarkdown' opts (SimpleFigure attr alt (src, tit)) | isEnabled Ext_raw_html opts && not (isEnabled Ext_link_attributes opts || isEnabled Ext_attributes opts) && attr /= nullAttr = -- use raw HTML (<> blankline) . literal . T.strip <$> writeHtml5String opts{ writerTemplate = Nothing } - (Pandoc nullMeta [Para [Image attr alt (src,tgt)]]) + (Pandoc nullMeta [SimpleFigure attr alt (src, tit)]) | otherwise = blockToMarkdown opts (Para [Image attr alt (src,tit)]) blockToMarkdown' opts (Para inlines) = (<> blankline) `fmap` blockToMarkdown opts (Plain inlines) @@ -391,7 +430,8 @@ blockToMarkdown' opts b@(RawBlock f str) = do (literal "```" <> literal "\n") let renderEmpty = mempty <$ report (BlockNotRendered b) case variant of - PlainText -> renderEmpty + PlainText + | f == "plain" -> return $ literal str <> literal "\n" Commonmark | f `elem` ["gfm", "commonmark", "commonmark_x", "markdown"] -> return $ literal str <> literal "\n" @@ -399,6 +439,7 @@ blockToMarkdown' opts b@(RawBlock f str) = do | f `elem` ["markdown", "markdown_github", "markdown_phpextra", "markdown_mmd", "markdown_strict"] -> return $ literal str <> literal "\n" + Markua -> renderEmpty _ | isEnabled Ext_raw_attribute opts -> rawAttribBlock | f `elem` ["html", "html5", "html4"] , isEnabled Ext_markdown_attribute opts @@ -410,17 +451,19 @@ blockToMarkdown' opts b@(RawBlock f str) = do , isEnabled Ext_raw_tex opts -> return $ literal str <> literal "\n" _ -> renderEmpty -blockToMarkdown' opts HorizontalRule = - return $ blankline <> literal (T.replicate (writerColumns opts) "-") <> blankline +blockToMarkdown' opts HorizontalRule = do + variant <- asks envVariant + let indicator = case variant of + Markua -> "* * *" + _ -> T.replicate (writerColumns opts) "-" + return $ blankline <> literal indicator <> blankline blockToMarkdown' opts (Header level attr inlines) = do - -- first, if we're putting references at the end of a section, we -- put them here. blkLevel <- asks envBlockLevel refs <- if writerReferenceLocation opts == EndOfSection && blkLevel == 1 then notesAndRefs opts else return empty - variant <- asks envVariant -- we calculate the id that would be used by auto_identifiers -- so we know whether to print an explicit identifier @@ -433,7 +476,8 @@ blockToMarkdown' opts (Header level attr inlines) = do && id' == autoId -> empty (id',_,_) | isEnabled Ext_mmd_header_identifiers opts -> space <> brackets (literal id') - _ | isEnabled Ext_header_attributes opts || + _ | variant == Markua -> attrsToMarkua attr + | isEnabled Ext_header_attributes opts || isEnabled Ext_attributes opts -> space <> attrsToMarkdown attr | otherwise -> empty @@ -467,6 +511,8 @@ blockToMarkdown' opts (Header level attr inlines) = do -- ghc interprets '#' characters in column 1 as linenum specifiers. _ | variant == PlainText || isEnabled Ext_literate_haskell opts -> contents <> blankline + _ | variant == Markua -> attr' <> cr <> literal (T.replicate level "#") + <> space <> contents <> blankline _ -> literal (T.replicate level "#") <> space <> contents <> attr' <> blankline return $ refs <> hdr @@ -483,9 +529,11 @@ blockToMarkdown' opts (CodeBlock attribs str) = do backticks <> attrs <> cr <> literal str <> cr <> backticks <> blankline | isEnabled Ext_fenced_code_blocks opts -> tildes <> attrs <> cr <> literal str <> cr <> tildes <> blankline - _ -> nest (writerTabStop opts) (literal str) <> blankline + _ | variant == Markua -> blankline <> attrsToMarkua attribs <> cr <> backticks <> cr <> + literal str <> cr <> backticks <> cr <> blankline + | otherwise -> nest (writerTabStop opts) (literal str) <> blankline where - endlineLen c = maybe 3 ((+1) . maximum) $ nonEmpty $ + endlineLen c = maybe 3 ((+1) . maximum) $ nonEmpty [T.length ln | ln <- map trim (T.lines str) , T.pack [c,c,c] `T.isPrefixOf` ln @@ -572,19 +620,29 @@ blockToMarkdown' opts t@(Table _ blkCapt specs thead tbody tfoot) = do return $ nst (tbl $$ caption'') $$ blankline blockToMarkdown' opts (BulletList items) = do contents <- inList $ mapM (bulletListItemToMarkdown opts) items - return $ (if isTightList items then vcat else vsep) contents <> blankline + return $ (if isTightList items then vcat else vsep) + contents <> blankline blockToMarkdown' opts (OrderedList (start,sty,delim) items) = do variant <- asks envVariant let start' = if variant == Commonmark || isEnabled Ext_startnum opts then start else 1 let sty' = if isEnabled Ext_fancy_lists opts then sty else DefaultStyle - let delim' = if isEnabled Ext_fancy_lists opts then delim else DefaultDelim + let delim' | isEnabled Ext_fancy_lists opts = + case variant of + -- Markua supports 'fancy' enumerators, but no TwoParens + Markua -> if delim == TwoParens then OneParen else delim + _ -> delim + | variant == Commonmark && --commonmark only supports one paren + (delim == OneParen || delim == TwoParens) = OneParen + | otherwise = DefaultDelim let attribs = (start', sty', delim') let markers = orderedListMarkers attribs - let markers' = map (\m -> if T.length m < 3 - then m <> T.replicate (3 - T.length m) " " - else m) markers + let markers' = case variant of + Markua -> markers + _ -> map (\m -> if T.length m < 3 + then m <> T.replicate (3 - T.length m) " " + else m) markers contents <- inList $ zipWithM (orderedListItemToMarkdown opts) markers' items return $ (if isTightList items then vcat else vsep) contents <> blankline @@ -698,10 +756,13 @@ itemEndsWithTightList bs = -- | Convert bullet list item (list of blocks) to markdown. bulletListItemToMarkdown :: PandocMonad m => WriterOptions -> [Block] -> MD m (Doc Text) bulletListItemToMarkdown opts bs = do + variant <- asks envVariant let exts = writerExtensions opts contents <- blockListToMarkdown opts $ taskListItemToAscii exts bs let sps = T.replicate (writerTabStop opts - 2) " " - let start = literal $ "- " <> sps + let start = case variant of + Markua -> literal "* " + _ -> literal $ "- " <> sps -- remove trailing blank line if item ends with a tight list let contents' = if itemEndsWithTightList bs then chomp contents <> cr @@ -711,19 +772,22 @@ bulletListItemToMarkdown opts bs = do -- | Convert ordered list item (a list of blocks) to markdown. orderedListItemToMarkdown :: PandocMonad m => WriterOptions -- ^ options - -> Text -- ^ list item marker + -> Text -- ^ list item marker -> [Block] -- ^ list item (list of blocks) -> MD m (Doc Text) orderedListItemToMarkdown opts marker bs = do let exts = writerExtensions opts contents <- blockListToMarkdown opts $ taskListItemToAscii exts bs + variant <- asks envVariant let sps = case writerTabStop opts - T.length marker of n | n > 0 -> literal $ T.replicate n " " _ -> literal " " let ind = if isEnabled Ext_four_space_rule opts then writerTabStop opts else max (writerTabStop opts) (T.length marker + 1) - let start = literal marker <> sps + let start = case variant of + Markua -> literal marker <> " " + _ -> literal marker <> sps -- remove trailing blank line if item ends with a tight list let contents' = if itemEndsWithTightList bs then chomp contents <> cr @@ -742,7 +806,10 @@ definitionListItemToMarkdown opts (label, defs) = do then do let tabStop = writerTabStop opts variant <- asks envVariant - let leader = if variant == PlainText then " " else ": " + let leader = case variant of + PlainText -> " " + Markua -> ":" + _ -> ": " let sps = case writerTabStop opts - 3 of n | n > 0 -> literal $ T.replicate n " " _ -> literal " " @@ -813,6 +880,7 @@ blockListToMarkdown opts blocks = do isListBlock _ = False commentSep | variant == PlainText = Null + | variant == Markua = Null | isEnabled Ext_raw_html opts = RawBlock "html" "<!-- -->\n" | otherwise = RawBlock "markdown" " \n" mconcat <$> mapM (blockToMarkdown opts) (fixBlocks blocks) diff --git a/src/Text/Pandoc/Writers/Markdown/Inline.hs b/src/Text/Pandoc/Writers/Markdown/Inline.hs index cd5f5b896..0bf70e80e 100644 --- a/src/Text/Pandoc/Writers/Markdown/Inline.hs +++ b/src/Text/Pandoc/Writers/Markdown/Inline.hs @@ -13,7 +13,8 @@ module Text.Pandoc.Writers.Markdown.Inline ( inlineListToMarkdown, linkAttributes, - attrsToMarkdown + attrsToMarkdown, + attrsToMarkua ) where import Control.Monad.Reader import Control.Monad.State.Strict @@ -24,7 +25,6 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T -import Network.HTTP (urlEncode) import Text.Pandoc.Class.PandocMonad (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Logging @@ -32,6 +32,7 @@ import Text.Pandoc.Options import Text.Pandoc.Parsing hiding (blankline, blanklines, char, space) import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.Network.HTTP (urlEncode) import Text.Pandoc.Writers.Shared import Text.Pandoc.Walk import Text.Pandoc.Writers.HTML (writeHtml5String) @@ -44,32 +45,35 @@ import Text.Pandoc.Writers.Markdown.Types (MarkdownVariant(..), -- | Escape special characters for Markdown. escapeText :: WriterOptions -> Text -> Text -escapeText opts = T.pack . go . T.unpack +escapeText opts = T.pack . go' . T.unpack where startsWithSpace (' ':_) = True startsWithSpace ('\t':_) = True startsWithSpace [] = True startsWithSpace _ = False + go' ('#':cs) + | isEnabled Ext_space_in_atx_header opts + = if startsWithSpace (dropWhile (=='#') cs) + then '\\':'#':go cs + else '#':go cs + | otherwise = '\\':'#':go cs + go' ('@':cs) + | isEnabled Ext_citations opts = + case cs of + (d:_) + | isAlphaNum d || d == '_' || d == '{' + -> '\\':'@':go cs + _ -> '@':go cs + go' cs = go cs go [] = [] go (c:cs) = case c of - '<' | isEnabled Ext_all_symbols_escapable opts -> - '\\' : '<' : go cs - | otherwise -> "<" ++ go cs - '>' | isEnabled Ext_all_symbols_escapable opts -> - '\\' : '>' : go cs - | otherwise -> ">" ++ go cs - '@' | isEnabled Ext_citations opts -> - case cs of - (d:_) - | isAlphaNum d || d == '_' || d == '{' - -> '\\':'@':go cs - _ -> '@':go cs - '#' | isEnabled Ext_space_in_atx_header opts - , startsWithSpace cs - -> '\\':'#':go cs _ | c `elem` ['\\','`','*','_','[',']'] -> '\\':c:go cs + '>' | isEnabled Ext_all_symbols_escapable opts -> '\\':'>':go cs + | otherwise -> ">" ++ go cs + '<' | isEnabled Ext_all_symbols_escapable opts -> '\\':'<':go cs + | otherwise -> "<" ++ go cs '|' | isEnabled Ext_pipe_tables opts -> '\\':'|':go cs '^' | isEnabled Ext_superscript opts -> '\\':'^':go cs '~' | isEnabled Ext_subscript opts || @@ -90,10 +94,13 @@ escapeText opts = T.pack . go . T.unpack | isEnabled Ext_intraword_underscores opts , isAlphaNum c , isAlphaNum x -> c : '_' : x : go xs - '#':xs -> c : '#' : go xs - '>':xs -> c : '>' : go xs _ -> c : go cs +-- Escape the escape character, as well as formatting pairs +escapeMarkuaString :: Text -> Text +escapeMarkuaString s = foldr (uncurry T.replace) s [("--","~-~-"), + ("**","~*~*"),("//","~/~/"),("^^","~^~^"),(",,","~,~,")] + attrsToMarkdown :: Attr -> Doc Text attrsToMarkdown attribs = braces $ hsep [attribId, attribClasses, attribKeys] where attribId = case attribs of @@ -115,9 +122,56 @@ attrsToMarkdown attribs = braces $ hsep [attribId, attribClasses, attribKeys] escAttrChar '\\' = literal "\\\\" escAttrChar c = literal $ T.singleton c +attrsToMarkua:: Attr -> Doc Text +attrsToMarkua attributes + | null list = empty + | otherwise = braces $ intercalateDocText list + where attrId = case attributes of + ("",_,_) -> [] + (i,_,_) -> [literal $ "id: " <> i] + -- all non explicit (key,value) attributes besides id are getting + -- a default class key to be Markua conform + attrClasses = case attributes of + (_,[],_) -> [] + (_,classes,_) -> map (escAttr . ("class: " <>)) + classes + attrKeyValues = case attributes of + (_,_,[]) -> [] + (_,_,keyvalues) -> map ((\(k,v) -> escAttr k + <> ": " <> escAttr v) . + preprocessKeyValues) keyvalues + escAttr = mconcat . map escAttrChar . T.unpack + escAttrChar '"' = literal "\"" + escAttrChar c = literal $ T.singleton c + + list = concat [attrId, attrClasses, attrKeyValues] + + -- if attribute key is alt, caption, title then content + -- gets wrapped inside quotes + -- attribute gets removed + preprocessKeyValues :: (Text, Text) -> (Text, Text) + preprocessKeyValues (key,value) + | key == "alt" || + key == "caption" || + key == "title" = (key, inquotes value) + | otherwise = (key,value) + intercalateDocText :: [Doc Text] -> Doc Text + intercalateDocText [] = empty + intercalateDocText [x] = x + intercalateDocText (x:xs) = x <> ", " <> (intercalateDocText xs) + +-- | Add a (key, value) pair to Pandoc attr type +addKeyValueToAttr :: Attr -> (Text,Text) -> Attr +addKeyValueToAttr (ident,classes,kvs) (key,value) + | not (T.null key) && not (T.null value) = (ident, + classes, + (key,value): kvs) + | otherwise = (ident,classes,kvs) + linkAttributes :: WriterOptions -> Attr -> Doc Text linkAttributes opts attr = - if (isEnabled Ext_link_attributes opts || isEnabled Ext_attributes opts) && attr /= nullAttr + if (isEnabled Ext_link_attributes opts || + isEnabled Ext_attributes opts) && attr /= nullAttr then attrsToMarkdown attr else empty @@ -190,11 +244,13 @@ getReference attr label target = do (stKeys s) }) return lab' + + -- | Convert list of Pandoc inline elements to markdown. inlineListToMarkdown :: PandocMonad m => WriterOptions -> [Inline] -> MD m (Doc Text) -inlineListToMarkdown opts lst = do - inlist <- asks envInList - go (if inlist then avoidBadWrapsInList lst else lst) +inlineListToMarkdown opts ils = do + inlist <- asks envInList + avoidBadWraps inlist <$> go ils where go [] = return empty go (x@Math{}:y@(Str t):zs) | T.all isDigit (T.take 1 t) -- starts with digit -- see #7058 @@ -235,26 +291,25 @@ inlineListToMarkdown opts lst = do fmap (iMark <>) (go is) thead = fmap fst . T.uncons -isSp :: Inline -> Bool -isSp Space = True -isSp SoftBreak = True -isSp _ = False +-- Remove breaking spaces that might cause bad wraps. +avoidBadWraps :: Bool -> Doc Text -> Doc Text +avoidBadWraps inListItem = go . toList + where + go [] = mempty + go (BreakingSpace : Text len t : BreakingSpace : xs) + = case T.uncons t of + Just (c,t') + | c == '>' + || ((c == '-' || c == '*' || c == '+') && T.null t') + || (inListItem && isOrderedListMarker t) + || (t == "1." || t == "1)") + -> Text (len + 1) (" " <> t) <> go (BreakingSpace : xs) + _ -> BreakingSpace <> Text len t <> go (BreakingSpace : xs) + go (x:xs) = x <> go xs -avoidBadWrapsInList :: [Inline] -> [Inline] -avoidBadWrapsInList [] = [] -avoidBadWrapsInList (s:Str (T.uncons -> Just ('>',cs)):xs) | isSp s = - Str (" >" <> cs) : avoidBadWrapsInList xs -avoidBadWrapsInList [s, Str (T.uncons -> Just (c, cs))] - | T.null cs && isSp s && c `elem` ['-','*','+'] = [Str $ T.pack [' ', c]] -avoidBadWrapsInList (s:Str (T.uncons -> Just (c, cs)):Space:xs) - | T.null cs && isSp s && c `elem` ['-','*','+'] = - Str (T.pack [' ', c]) : Space : avoidBadWrapsInList xs -avoidBadWrapsInList (s:Str cs:Space:xs) - | isSp s && isOrderedListMarker cs = - Str (" " <> cs) : Space : avoidBadWrapsInList xs -avoidBadWrapsInList [s, Str cs] - | isSp s && isOrderedListMarker cs = [Str $ " " <> cs] -avoidBadWrapsInList (x:xs) = x : avoidBadWrapsInList xs + toList (Concat (Concat a b) c) = toList (Concat a (Concat b c)) + toList (Concat a b) = a : toList b + toList x = [x] isOrderedListMarker :: Text -> Bool isOrderedListMarker xs = not (T.null xs) && (T.last xs `elem` ['.',')']) && @@ -281,6 +336,7 @@ inlineToMarkdown opts (Span attrs ils) = do _ -> id $ case variant of PlainText -> contents + Markua -> "`" <> contents <> "`" <> attrsToMarkua attrs _ | attrs == nullAttr -> contents | isEnabled Ext_bracketed_spans opts -> let attrs' = if attrs /= nullAttr @@ -307,7 +363,7 @@ inlineToMarkdown opts (Underline lst) = do case variant of PlainText -> return contents _ | isEnabled Ext_bracketed_spans opts -> - return $ "[" <> contents <> "]" <> "{.ul}" + return $ "[" <> contents <> "]" <> "{.underline}" | isEnabled Ext_native_spans opts -> return $ tagWithAttrs "span" ("", ["underline"], []) <> contents @@ -394,60 +450,75 @@ inlineToMarkdown opts (Quoted DoubleQuote lst) = do then "“" <> contents <> "”" else "“" <> contents <> "”" inlineToMarkdown opts (Code attr str) = do + variant <- asks envVariant let tickGroups = filter (T.any (== '`')) $ T.group str let longest = maybe 0 maximum $ nonEmpty $ map T.length tickGroups let marker = T.replicate (longest + 1) "`" let spacer = if longest == 0 then "" else " " let attrsEnabled = isEnabled Ext_inline_code_attributes opts || isEnabled Ext_attributes opts - let attrs = if attrsEnabled && attr /= nullAttr - then attrsToMarkdown attr - else empty - variant <- asks envVariant + let attrs = case variant of + Markua -> attrsToMarkua attr + _ -> if attrsEnabled && attr /= nullAttr + then attrsToMarkdown attr + else empty case variant of PlainText -> return $ literal str _ -> return $ literal (marker <> spacer <> str <> spacer <> marker) <> attrs inlineToMarkdown opts (Str str) = do variant <- asks envVariant - let str' = (if writerPreferAscii opts - then toHtml5Entities - else id) . - (if isEnabled Ext_smart opts - then unsmartify opts - else id) . - (if variant == PlainText - then id - else escapeText opts) $ str + let str' = case variant of + Markua -> escapeMarkuaString str + _ -> (if writerPreferAscii opts + then toHtml5Entities + else id) . + (if isEnabled Ext_smart opts + then unsmartify opts + else id) . + (if variant == PlainText + then id + else escapeText opts) $ str return $ literal str' -inlineToMarkdown opts (Math InlineMath str) = - case writerHTMLMathMethod opts of - WebTeX url -> inlineToMarkdown opts - (Image nullAttr [Str str] (url <> T.pack (urlEncode $ T.unpack str), str)) - _ | isEnabled Ext_tex_math_dollars opts -> - return $ "$" <> literal str <> "$" - | isEnabled Ext_tex_math_single_backslash opts -> - return $ "\\(" <> literal str <> "\\)" - | isEnabled Ext_tex_math_double_backslash opts -> - return $ "\\\\(" <> literal str <> "\\\\)" - | otherwise -> do - variant <- asks envVariant - texMathToInlines InlineMath str >>= - inlineListToMarkdown opts . - (if variant == PlainText then makeMathPlainer else id) -inlineToMarkdown opts (Math DisplayMath str) = - case writerHTMLMathMethod opts of - WebTeX url -> (\x -> blankline <> x <> blankline) `fmap` - inlineToMarkdown opts (Image nullAttr [Str str] - (url <> T.pack (urlEncode $ T.unpack str), str)) - _ | isEnabled Ext_tex_math_dollars opts -> - return $ "$$" <> literal str <> "$$" - | isEnabled Ext_tex_math_single_backslash opts -> - return $ "\\[" <> literal str <> "\\]" - | isEnabled Ext_tex_math_double_backslash opts -> - return $ "\\\\[" <> literal str <> "\\\\]" - | otherwise -> (\x -> cr <> x <> cr) `fmap` - (texMathToInlines DisplayMath str >>= inlineListToMarkdown opts) +inlineToMarkdown opts (Math InlineMath str) = do + variant <- asks envVariant + case () of + _ | variant == Markua -> return $ "`" <> literal str <> "`" <> "$" + | otherwise -> case writerHTMLMathMethod opts of + WebTeX url -> inlineToMarkdown opts + (Image nullAttr [Str str] (url <> urlEncode str, str)) + _ | isEnabled Ext_tex_math_dollars opts -> + return $ "$" <> literal str <> "$" + | isEnabled Ext_tex_math_single_backslash opts -> + return $ "\\(" <> literal str <> "\\)" + | isEnabled Ext_tex_math_double_backslash opts -> + return $ "\\\\(" <> literal str <> "\\\\)" + | otherwise -> + texMathToInlines InlineMath str >>= + inlineListToMarkdown opts . + (if variant == PlainText then makeMathPlainer else id) + +inlineToMarkdown opts (Math DisplayMath str) = do + variant <- asks envVariant + case () of + _ | variant == Markua -> do + let attributes = attrsToMarkua (addKeyValueToAttr ("",[],[]) + ("format", "latex")) + return $ blankline <> attributes <> cr <> literal "```" <> cr + <> literal str <> cr <> literal "```" <> blankline + | otherwise -> case writerHTMLMathMethod opts of + WebTeX url -> (\x -> blankline <> x <> blankline) `fmap` + inlineToMarkdown opts (Image nullAttr [Str str] + (url <> urlEncode str, str)) + _ | isEnabled Ext_tex_math_dollars opts -> + return $ "$$" <> literal str <> "$$" + | isEnabled Ext_tex_math_single_backslash opts -> + return $ "\\[" <> literal str <> "\\]" + | isEnabled Ext_tex_math_double_backslash opts -> + return $ "\\\\[" <> literal str <> "\\\\]" + | otherwise -> (\x -> cr <> x <> cr) `fmap` + (texMathToInlines DisplayMath str >>= inlineListToMarkdown opts) + inlineToMarkdown opts il@(RawInline f str) = do let tickGroups = filter (T.any (== '`')) $ T.group str let numticks = 1 + maybe 0 maximum (nonEmpty (map T.length tickGroups)) @@ -458,7 +529,8 @@ inlineToMarkdown opts il@(RawInline f str) = do literal (T.replicate numticks "`") <> literal "{=" <> literal fmt <> literal "}" let renderEmpty = mempty <$ report (InlineNotRendered il) case variant of - PlainText -> renderEmpty + PlainText + | f == "plain" -> return $ literal str Commonmark | f `elem` ["gfm", "commonmark", "commonmark_x", "markdown"] -> return $ literal str @@ -466,6 +538,7 @@ inlineToMarkdown opts il@(RawInline f str) = do | f `elem` ["markdown", "markdown_github", "markdown_phpextra", "markdown_mmd", "markdown_strict"] -> return $ literal str + Markua -> renderEmpty _ | isEnabled Ext_raw_attribute opts -> rawAttribInline | f `elem` ["html", "html5", "html4"] , isEnabled Ext_raw_html opts @@ -502,7 +575,11 @@ inlineToMarkdown opts (Cite (c:cs) lst) then do suffs <- inlineListToMarkdown opts $ citationSuffix c rest <- mapM convertOne cs - let inbr = suffs <+> joincits rest + let inbr = suffs <> + (if not (null (citationSuffix c)) && not (null rest) + then text ";" + else mempty) + <+> joincits rest br = if isEmpty inbr then empty else char '[' <> inbr <> char ']' return $ literal ("@" <> maybeInBraces (citationId c)) <+> br else do @@ -524,12 +601,14 @@ inlineToMarkdown opts (Cite (c:cs) lst) sdoc <- inlineListToMarkdown opts sinlines let k' = literal (modekey m <> "@" <> maybeInBraces k) r = case sinlines of - Str (T.uncons -> Just (y,_)):_ | y `elem` (",;]@" :: String) -> k' <> sdoc - _ -> k' <+> sdoc + Str (T.uncons -> Just (y,_)):_ + | y `elem` (",;]@" :: String) -> k' <> sdoc + Space:_ -> k' <> sdoc + _ -> k' <+> sdoc return $ pdoc <+> r modekey SuppressAuthor = "-" modekey _ = "" -inlineToMarkdown opts lnk@(Link attr txt (src, tit)) = do +inlineToMarkdown opts lnk@(Link attr@(ident,classes,kvs) txt (src, tit)) = do variant <- asks envVariant linktext <- inlineListToMarkdown opts txt let linktitle = if T.null tit @@ -537,6 +616,9 @@ inlineToMarkdown opts lnk@(Link attr txt (src, tit)) = do else literal $ " \"" <> tit <> "\"" let srcSuffix = fromMaybe src (T.stripPrefix "mailto:" src) let useAuto = isURI src && + T.null ident && + null kvs && + (null classes || classes == ["uri"] || classes == ["email"]) && case txt of [Str s] | escapeURI s == srcSuffix -> True _ -> False @@ -551,6 +633,11 @@ inlineToMarkdown opts lnk@(Link attr txt (src, tit)) = do PlainText | useAuto -> return $ literal srcSuffix | otherwise -> return linktext + Markua + | T.null tit -> return $ result <> attrsToMarkua attr + | otherwise -> return $ result <> attrsToMarkua attributes + where result = "[" <> linktext <> "](" <> (literal src) <> ")" + attributes = addKeyValueToAttr attr ("title", tit) _ | useAuto -> return $ "<" <> literal srcSuffix <> ">" | useRefLinks -> let first = "[" <> linktext <> "]" @@ -582,9 +669,16 @@ inlineToMarkdown opts img@(Image attr alternate (source, tit)) then [Str ""] else alternate linkPart <- inlineToMarkdown opts (Link attr txt (source, tit)) + alt <- inlineListToMarkdown opts alternate + let attributes | variant == Markua = attrsToMarkua $ + addKeyValueToAttr (addKeyValueToAttr attr ("title", tit)) + ("alt", render (Just (writerColumns opts)) alt) + | otherwise = empty return $ case variant of - PlainText -> "[" <> linkPart <> "]" - _ -> "!" <> linkPart + PlainText -> "[" <> linkPart <> "]" + Markua -> cr <> attributes <> cr <> literal "![](" <> + literal source <> ")" <> cr + _ -> "!" <> linkPart inlineToMarkdown opts (Note contents) = do modify (\st -> st{ stNotes = contents : stNotes st }) st <- get diff --git a/src/Text/Pandoc/Writers/Markdown/Types.hs b/src/Text/Pandoc/Writers/Markdown/Types.hs index a1d0d14e4..060446811 100644 --- a/src/Text/Pandoc/Writers/Markdown/Types.hs +++ b/src/Text/Pandoc/Writers/Markdown/Types.hs @@ -45,7 +45,8 @@ data WriterEnv = WriterEnv { envInList :: Bool } data MarkdownVariant = - PlainText + Markua + | PlainText | Commonmark | Markdown deriving (Show, Eq) diff --git a/src/Text/Pandoc/Writers/MediaWiki.hs b/src/Text/Pandoc/Writers/MediaWiki.hs index 5029be69f..f047baf1c 100644 --- a/src/Text/Pandoc/Writers/MediaWiki.hs +++ b/src/Text/Pandoc/Writers/MediaWiki.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.MediaWiki Copyright : Copyright (C) 2008-2021 John MacFarlane @@ -91,8 +90,7 @@ blockToMediaWiki (Div attrs bs) = do blockToMediaWiki (Plain inlines) = inlineListToMediaWiki inlines --- title beginning with fig: indicates that the image is a figure -blockToMediaWiki (Para [Image attr txt (src,T.stripPrefix "fig:" -> Just tit)]) = do +blockToMediaWiki (SimpleFigure attr txt (src, tit)) = do capt <- inlineListToMediaWiki txt img <- imageToMediaWiki attr let opt = if T.null tit @@ -130,10 +128,15 @@ blockToMediaWiki b@(RawBlock f str) blockToMediaWiki HorizontalRule = return "\n-----\n" -blockToMediaWiki (Header level _ inlines) = do +blockToMediaWiki (Header level (ident,_,_) inlines) = do + let autoId = T.replace " " "_" $ stringify inlines contents <- inlineListToMediaWiki inlines let eqs = T.replicate level "=" - return $ eqs <> " " <> contents <> " " <> eqs <> "\n" + return $ + (if T.null ident || autoId == ident + then "" + else "<span id=\"" <> ident <> "\"></span>\n") + <> eqs <> " " <> contents <> " " <> eqs <> "\n" blockToMediaWiki (CodeBlock (_,classes,keyvals) str) = do let at = Set.fromList classes `Set.intersection` highlightingLangs diff --git a/src/Text/Pandoc/Writers/Ms.hs b/src/Text/Pandoc/Writers/Ms.hs index 97c23f24d..53763a609 100644 --- a/src/Text/Pandoc/Writers/Ms.hs +++ b/src/Text/Pandoc/Writers/Ms.hs @@ -21,7 +21,7 @@ TODO: module Text.Pandoc.Writers.Ms ( writeMs ) where import Control.Monad.State.Strict -import Data.Char (isLower, isUpper, ord) +import Data.Char (isAscii, isLower, isUpper, ord) import Data.List (intercalate, intersperse) import Data.List.NonEmpty (nonEmpty) import qualified Data.Map as Map @@ -46,6 +46,8 @@ import Text.Pandoc.Writers.Shared import Text.Pandoc.Writers.Roff import Text.Printf (printf) import Text.TeXMath (writeEqn) +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString as B -- | Convert Pandoc to Ms. writeMs :: PandocMonad m => WriterOptions -> Pandoc -> m Text @@ -88,6 +90,21 @@ escapeStr :: WriterOptions -> Text -> Text escapeStr opts = escapeString (if writerPreferAscii opts then AsciiOnly else AllowUTF8) +-- In PDFs we need to escape parentheses and backslash. +-- In PDF we need to encode as UTF-16 BE. +escapePDFString :: Text -> Text +escapePDFString t + | T.all isAscii t = + T.replace "(" "\\(" . T.replace ")" "\\)" . T.replace "\\" "\\\\" $ t + | otherwise = ("\\376\\377" <>) . -- add bom + mconcat . map encodeChar . T.unpack $ t + where + encodeChar c = + if isAscii c && c /= '\\' && c /= '(' && c /= ')' + then "\\000" <> T.singleton c + else mconcat . map toOctal . B.unpack . TE.encodeUtf16BE $ T.singleton c + toOctal n = "\\" <> T.pack (printf "%03o" n) + escapeUri :: Text -> Text escapeUri = T.pack . escapeURIString (\c -> c /= '@' && isAllowedInURI c) . T.unpack @@ -143,7 +160,7 @@ blockToMs opts (Div (ident,cls,kvs) bs) = do setFirstPara return $ anchor $$ res blockToMs opts (Plain inlines) = - liftM vcat $ mapM (inlineListToMs' opts) $ splitSentences inlines + splitSentences <$> inlineListToMs' opts inlines blockToMs opts (Para [Image attr alt (src,_tit)]) | let ext = takeExtension (T.unpack src) in (ext == ".ps" || ext == ".eps") = do let (mbW,mbH) = (inPoints opts <$> dimension Width attr, @@ -156,7 +173,7 @@ blockToMs opts (Para [Image attr alt (src,_tit)]) space <> doubleQuotes (literal (tshow (floor hp :: Int))) _ -> empty - capt <- inlineListToMs' opts alt + capt <- splitSentences <$> inlineListToMs' opts alt return $ nowrap (literal ".PSPIC -C " <> doubleQuotes (literal (escapeStr opts src)) <> sizeAttrs) $$ @@ -166,9 +183,9 @@ blockToMs opts (Para [Image attr alt (src,_tit)]) blockToMs opts (Para inlines) = do firstPara <- gets stFirstPara resetFirstPara - contents <- liftM vcat $ mapM (inlineListToMs' opts) $ - splitSentences inlines - return $ literal (if firstPara then ".LP" else ".PP") $$ contents + contents <- inlineListToMs' opts inlines + return $ literal (if firstPara then ".LP" else ".PP") $$ + splitSentences contents blockToMs _ b@(RawBlock f str) | f == Format "ms" = return $ literal str | otherwise = do @@ -196,7 +213,7 @@ blockToMs opts (Header level (ident,classes,_) inlines) = do (if T.null secnum then "" else " ") <> - escapeStr opts (stringify inlines)) + escapePDFString (stringify inlines)) let backlink = nowrap (literal ".pdfhref L -D " <> doubleQuotes (literal (toAscii ident)) <> space <> literal "\\") <> cr <> literal " -- " diff --git a/src/Text/Pandoc/Writers/Native.hs b/src/Text/Pandoc/Writers/Native.hs index 9c2ce805d..264b9c498 100644 --- a/src/Text/Pandoc/Writers/Native.hs +++ b/src/Text/Pandoc/Writers/Native.hs @@ -12,82 +12,20 @@ Conversion of a 'Pandoc' document to a string representation. -} module Text.Pandoc.Writers.Native ( writeNative ) where -import Data.List (intersperse) import Data.Text (Text) +import qualified Data.Text as T import Text.Pandoc.Class.PandocMonad (PandocMonad) import Text.Pandoc.Definition -import Text.Pandoc.Options (WrapOption (..), WriterOptions (..)) -import Text.DocLayout - -prettyList :: [Doc Text] -> Doc Text -prettyList ds = - "[" <> - mconcat (intersperse (cr <> ",") $ map (nest 1) ds) <> "]" - --- | Prettyprint Pandoc block element. -prettyBlock :: Block -> Doc Text -prettyBlock (LineBlock lines') = - "LineBlock" $$ prettyList (map (text . show) lines') -prettyBlock (BlockQuote blocks) = - "BlockQuote" $$ prettyList (map prettyBlock blocks) -prettyBlock (OrderedList attribs blockLists) = - "OrderedList" <> space <> text (show attribs) $$ - prettyList (map (prettyList . map prettyBlock) blockLists) -prettyBlock (BulletList blockLists) = - "BulletList" $$ - prettyList (map (prettyList . map prettyBlock) blockLists) -prettyBlock (DefinitionList items) = "DefinitionList" $$ - prettyList (map deflistitem items) - where deflistitem (term, defs) = "(" <> text (show term) <> "," <> cr <> - nest 1 (prettyList $ map (prettyList . map prettyBlock) defs) <> ")" -prettyBlock (Table attr blkCapt specs thead tbody tfoot) = - mconcat [ "Table " - , text (show attr) - , " " - , prettyCaption blkCapt ] $$ - prettyList (map (text . show) specs) $$ - prettyHead thead $$ - prettyBodies tbody $$ - prettyFoot tfoot - where prettyRows = prettyList . map prettyRow - prettyRow (Row a body) = - text ("Row " <> show a) $$ prettyList (map prettyCell body) - prettyCell (Cell a ma h w b) = - mconcat [ "Cell " - , text (show a) - , " " - , text (show ma) - , " (" - , text (show h) - , ") (" - , text (show w) - , ")" ] $$ - prettyList (map prettyBlock b) - prettyCaption (Caption mshort body) = - "(Caption " <> text (showsPrec 11 mshort "") $$ prettyList (map prettyBlock body) <> ")" - prettyHead (TableHead thattr body) - = "(TableHead " <> text (show thattr) $$ prettyRows body <> ")" - prettyBody (TableBody tbattr rhc hd bd) - = mconcat [ "(TableBody " - , text (show tbattr) - , " (" - , text (show rhc) - , ")" ] $$ prettyRows hd $$ prettyRows bd <> ")" - prettyBodies = prettyList . map prettyBody - prettyFoot (TableFoot tfattr body) - = "(TableFoot " <> text (show tfattr) $$ prettyRows body <> ")" -prettyBlock (Div attr blocks) = - text ("Div " <> show attr) $$ prettyList (map prettyBlock blocks) -prettyBlock block = text $ show block +import Text.Pandoc.Options (WriterOptions (..)) +import Text.Show.Pretty (ppDoc) +import Text.PrettyPrint (renderStyle, Style(..), style, char) -- | Prettyprint Pandoc document. writeNative :: PandocMonad m => WriterOptions -> Pandoc -> m Text -writeNative opts (Pandoc meta blocks) = return $ - let colwidth = if writerWrapText opts == WrapAuto - then Just $ writerColumns opts - else Nothing - withHead = case writerTemplate opts of - Just _ -> \bs -> text ("Pandoc (" ++ show meta ++ ")") $$ - bs $$ cr - Nothing -> id - in render colwidth $ withHead $ prettyList $ map prettyBlock blocks +writeNative opts (Pandoc meta blocks) = do + let style' = style{ lineLength = writerColumns opts, + ribbonsPerLine = 1.2 } + return $ T.pack $ renderStyle style' $ + case writerTemplate opts of + Just _ -> ppDoc (Pandoc meta blocks) <> char '\n' + Nothing -> ppDoc blocks diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs index 5f3224c2f..8af64969b 100644 --- a/src/Text/Pandoc/Writers/OpenDocument.hs +++ b/src/Text/Pandoc/Writers/OpenDocument.hs @@ -2,7 +2,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.OpenDocument Copyright : Copyright (C) 2008-2020 Andrea Rossato and John MacFarlane @@ -193,7 +192,7 @@ formulaStyle mt = inTags False "style:style" ,("style:vertical-rel", "text")] else [("style:vertical-pos", "middle") - ,("style:vertical-rel", "paragraph-content") + ,("style:vertical-rel", "text") ,("style:horizontal-pos", "center") ,("style:horizontal-rel", "paragraph-content") ,("style:wrap", "none")] @@ -377,7 +376,7 @@ blockToOpenDocument o = \case Plain b -> if null b then return empty else inParagraphTags =<< inlinesToOpenDocument o b - Para [Image attr c (s,T.stripPrefix "fig:" -> Just t)] -> figure attr c s t + SimpleFigure attr c (s, t) -> figure attr c s t Para b -> if null b && not (isEnabled Ext_empty_paragraphs o) then return empty diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs index d404f1c8d..d2a383212 100644 --- a/src/Text/Pandoc/Writers/Org.hs +++ b/src/Text/Pandoc/Writers/Org.hs @@ -22,6 +22,7 @@ import Data.List (intersect, intersperse, partition, transpose) import Data.List.NonEmpty (nonEmpty) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Map as M import Text.Pandoc.Class.PandocMonad (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Logging @@ -29,6 +30,7 @@ import Text.Pandoc.Options import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) +import Text.Pandoc.Citeproc.Locator (parseLocator, LocatorMap(..), LocatorInfo(..)) import Text.Pandoc.Writers.Shared data WriterState = @@ -103,11 +105,14 @@ blockToOrg :: PandocMonad m => Block -- ^ Block element -> Org m (Doc Text) blockToOrg Null = return empty -blockToOrg (Div attr bs) = divToOrg attr bs +blockToOrg (Div attr@(ident,_,_) bs) = do + opts <- gets stOptions + -- Strip off bibliography if citations enabled + if ident == "refs" && isEnabled Ext_citations opts + then return mempty + else divToOrg attr bs blockToOrg (Plain inlines) = inlineListToOrg inlines --- title beginning with fig: indicates that the image is a figure -blockToOrg (Para [Image attr txt (src,tgt)]) - | Just tit <- T.stripPrefix "fig:" tgt = do +blockToOrg (SimpleFigure attr txt (src, tit)) = do capt <- if null txt then return empty else ("#+caption: " <>) `fmap` inlineListToOrg txt @@ -154,7 +159,7 @@ blockToOrg (CodeBlock (_,classes,kvs) str) = do let (beg, end) = case at of [] -> ("#+begin_example" <> numberlines, "#+end_example") (x:_) -> ("#+begin_src " <> x <> numberlines, "#+end_src") - return $ literal beg $$ nest 2 (literal str) $$ text end $$ blankline + return $ literal beg $$ literal str $$ text end $$ blankline blockToOrg (BlockQuote blocks) = do contents <- blockListToOrg blocks return $ blankline $$ "#+begin_quote" $$ @@ -398,7 +403,35 @@ inlineToOrg (Quoted SingleQuote lst) = do inlineToOrg (Quoted DoubleQuote lst) = do contents <- inlineListToOrg lst return $ "\"" <> contents <> "\"" -inlineToOrg (Cite _ lst) = inlineListToOrg lst +inlineToOrg (Cite cs lst) = do + opts <- gets stOptions + if isEnabled Ext_citations opts + then do + let renderCiteItem c = do + citePref <- inlineListToOrg (citationPrefix c) + let (locinfo, suffix) = parseLocator locmap (citationSuffix c) + citeSuff <- inlineListToOrg suffix + let locator = case locinfo of + Just info -> literal $ + T.replace "\160" " " $ + T.replace "{" "" $ + T.replace "}" "" $ locatorRaw info + Nothing -> mempty + return $ hsep [ citePref + , ("@" <> literal (citationId c)) + , locator + , citeSuff ] + citeItems <- mconcat . intersperse "; " <$> mapM renderCiteItem cs + let sty = case cs of + (d:_) + | citationMode d == AuthorInText + -> literal "/t" + [d] + | citationMode d == SuppressAuthor + -> literal "/na" + _ -> mempty + return $ "[cite" <> sty <> ":" <> citeItems <> "]" + else inlineListToOrg lst inlineToOrg (Code _ str) = return $ "=" <> literal str <> "=" inlineToOrg (Str str) = return . literal $ escapeString str inlineToOrg (Math t str) = do @@ -461,20 +494,109 @@ pandocLangToOrg cs = "c" -> "C" "commonlisp" -> "lisp" "r" -> "R" - "bash" -> "shell" - "lillypond" -> "ly" + "bash" -> "sh" _ -> cs -- | List of language identifiers recognized by org-mode. +-- See <https://orgmode.org/manual/Languages.html>. orgLangIdentifiers :: [Text] orgLangIdentifiers = - [ "abc", "asymptote", "awk", "axiom", "C", "cpp", "calc", "clojure","comint" - , "coq", "css", "D", "ditaa", "dot", "ebnf", "elixir", "eukleides", "fomus" - , "forth", "F90", "gnuplot", "Translate", "groovy", "haskell" , "browser" - , "request", "io", "ipython", "J", "java", "js", "julia", "kotlin", "latex" - , "ledger", "ly", "lisp", "Flavored", "makefile", "mathematica", "mathomatic" - , "matlab", "max", "mongo", "mscgen", "cypher", "Caml", "octave" , "org", "oz" - , "perl", "picolisp", "plantuml", "processing", "prolog", "python" , "R" - , "rec", "ruby", "sass", "scala", "scheme", "screen", "sed", "shell", "shen" - , "sql", "sqlite", "stan", "ML", "stata", "tcl", "typescript", "vala" - ] + [ "asymptote" + , "lisp" + , "awk" + , "lua" + , "C" + , "matlab" + , "C++" + , "mscgen" + , "clojure" + , "ocaml" + , "css" + , "octave" + , "D" + , "org" + , "ditaa" + , "oz" + , "calc" + , "perl" + , "emacs-lisp" + , "plantuml" + , "eshell" + , "processing" + , "fortran" + , "python" + , "gnuplot" + , "R" + , "screen" + , "ruby" + , "dot" + , "sass" + , "haskell" + , "scheme" + , "java" + , "sed" + , "js" + , "sh" + , "latex" + , "sql" + , "ledger" + , "sqlite" + , "lilypond" + , "vala" ] + +-- taken from oc-csl.el in the org source tree: +locmap :: LocatorMap +locmap = LocatorMap $ M.fromList + [ ("bk." , "book") + , ("bks." , "book") + , ("book" , "book") + , ("chap." , "chapter") + , ("chaps." , "chapter") + , ("chapter" , "chapter") + , ("col." , "column") + , ("cols." , "column") + , ("column" , "column") + , ("figure" , "figure") + , ("fig." , "figure") + , ("figs." , "figure") + , ("folio" , "folio") + , ("fol." , "folio") + , ("fols." , "folio") + , ("number" , "number") + , ("no." , "number") + , ("nos." , "number") + , ("line" , "line") + , ("l." , "line") + , ("ll." , "line") + , ("note" , "note") + , ("n." , "note") + , ("nn." , "note") + , ("opus" , "opus") + , ("op." , "opus") + , ("opp." , "opus") + , ("page" , "page") + , ("p" , "page") + , ("p." , "page") + , ("pp." , "page") + , ("paragraph" , "paragraph") + , ("para." , "paragraph") + , ("paras." , "paragraph") + , ("¶" , "paragraph") + , ("¶¶" , "paragraph") + , ("part" , "part") + , ("pt." , "part") + , ("pts." , "part") + , ("§" , "section") + , ("§§" , "section") + , ("section" , "section") + , ("sec." , "section") + , ("secs." , "section") + , ("sub verbo" , "sub verbo") + , ("s.v." , "sub verbo") + , ("s.vv." , "sub verbo") + , ("verse" , "verse") + , ("v." , "verse") + , ("vv." , "verse") + , ("volume" , "volume") + , ("vol." , "volume") + , ("vols." , "volume") ] diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs index 157810216..e799297de 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -1,5 +1,10 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {- | Module : Text.Pandoc.Writers.Powerpoint.Output Copyright : Copyright (C) 2017-2020 Jesse Rosenthal @@ -21,14 +26,21 @@ import Control.Monad.Reader import Control.Monad.State import Codec.Archive.Zip import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf, intersperse) +import Data.Bifunctor (bimap) +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI import Data.Default +import Data.Foldable (toList) +import Data.List.NonEmpty (nonEmpty, NonEmpty ((:|))) +import Data.Ratio ((%), Ratio) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Read +import Data.Text.Read (decimal) import Data.Time (formatTime, defaultTimeLocale) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) -import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension) +import Data.Traversable (for) +import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension, takeFileName) import Text.Pandoc.XML.Light as XML import Text.Pandoc.Definition import qualified Text.Pandoc.UTF8 as UTF8 @@ -48,11 +60,11 @@ import System.FilePath.Glob import Text.DocTemplates (FromContext(lookupContext), Context) import Text.DocLayout (literal) import Text.TeXMath +import Text.Pandoc.Logging (LogMessage(PowerpointTemplateWarning)) import Text.Pandoc.Writers.Math (convertMath) import Text.Pandoc.Writers.Powerpoint.Presentation import Text.Pandoc.Shared (tshow, stringify) import Skylighting (fromColor) -import Data.List.NonEmpty (nonEmpty) -- |The 'EMU' type is used to specify sizes in English Metric Units. type EMU = Integer @@ -105,11 +117,7 @@ data WriterEnv = WriterEnv { envRefArchive :: Archive , envInList :: Bool , envInNoteSlide :: Bool , envCurSlideId :: Int - -- the difference between the number at - -- the end of the slide file name and - -- the rId number - , envSlideIdOffset :: Int - , envContentType :: ContentType + , envPlaceholder :: Placeholder , envSlideIdMap :: M.Map SlideId Int -- maps the slide number to the -- corresponding notes id number. If there @@ -117,6 +125,8 @@ data WriterEnv = WriterEnv { envRefArchive :: Archive -- no entry in the map for it. , envSpeakerNotesIdMap :: M.Map Int Int , envInSpeakerNotes :: Bool + , envSlideLayouts :: Maybe SlideLayouts + , envOtherStyleIndents :: Maybe Indents } deriving (Show) @@ -131,17 +141,82 @@ instance Default WriterEnv where , envInList = False , envInNoteSlide = False , envCurSlideId = 1 - , envSlideIdOffset = 1 - , envContentType = NormalContent + , envPlaceholder = Placeholder ObjType 0 , envSlideIdMap = mempty , envSpeakerNotesIdMap = mempty , envInSpeakerNotes = False + , envSlideLayouts = Nothing + , envOtherStyleIndents = Nothing } -data ContentType = NormalContent - | TwoColumnLeftContent - | TwoColumnRightContent - deriving (Show, Eq) +type SlideLayouts = SlideLayoutsOf SlideLayout + +data SlideLayoutsOf a = SlideLayouts + { metadata :: a + , title :: a + , content :: a + , twoColumn :: a + , comparison :: a + , contentWithCaption :: a + , blank :: a + } deriving (Show, Eq, Functor, Foldable, Traversable) + +data SlideLayout = SlideLayout + { slElement :: Element + , slInReferenceDoc :: Bool + -- ^ True if the layout is in the provided reference doc, False if it's in + -- the default reference doc. + , slPath :: FilePath + , slEntry :: Entry + } deriving (Show) + +getSlideLayouts :: PandocMonad m => P m SlideLayouts +getSlideLayouts = asks envSlideLayouts >>= maybe (throwError e) pure + where + e = PandocSomeError ("Slide layouts aren't defined, even though they should " + <> "always be. This is a bug in pandoc.") + +-- | A placeholder within a layout, identified by type and index. +-- +-- E.g., @Placeholder ObjType 2@ is the third placeholder of type 'ObjType' in +-- the layout. +data Placeholder = Placeholder + { placeholderType :: PHType + , index :: Int + } deriving (Show, Eq) + +-- | Paragraph indentation info. +data Indents = Indents + { level1 :: Maybe LevelIndents + , level2 :: Maybe LevelIndents + , level3 :: Maybe LevelIndents + , level4 :: Maybe LevelIndents + , level5 :: Maybe LevelIndents + , level6 :: Maybe LevelIndents + , level7 :: Maybe LevelIndents + , level8 :: Maybe LevelIndents + , level9 :: Maybe LevelIndents + } deriving (Show, Eq) + +levelIndent :: Indents -> Int -> Maybe LevelIndents +levelIndent is index = getter is + where + getter = case index of + 0 -> level1 + 1 -> level2 + 2 -> level3 + 3 -> level4 + 4 -> level5 + 5 -> level6 + 6 -> level7 + 7 -> level8 + 8 -> level9 + _ -> const Nothing + +data LevelIndents = LevelIndents + { marL :: EMU + , indent :: EMU + } deriving (Show, Eq) data MediaInfo = MediaInfo { mInfoFilePath :: FilePath , mInfoLocalId :: Int @@ -155,12 +230,14 @@ data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int LinkTarget) -- (FP, Local ID, Global ID, Maybe Mime) , stMediaIds :: M.Map Int [MediaInfo] , stMediaGlobalIds :: M.Map FilePath Int + , stFooterInfo :: Maybe FooterInfo } deriving (Show, Eq) instance Default WriterState where def = WriterState { stLinkIds = mempty , stMediaIds = mempty , stMediaGlobalIds = mempty + , stFooterInfo = Nothing } type P m = ReaderT WriterEnv (StateT WriterState m) @@ -199,11 +276,12 @@ alwaysInheritedPatterns = , "ppt/slideLayouts/_rels/slideLayout*.xml.rels" , "ppt/slideMasters/slideMaster1.xml" , "ppt/slideMasters/_rels/slideMaster1.xml.rels" - , "ppt/theme/theme1.xml" - , "ppt/theme/_rels/theme1.xml.rels" + , "ppt/theme/theme*.xml" + , "ppt/theme/_rels/theme*.xml.rels" , "ppt/presProps.xml" , "ppt/tableStyles.xml" , "ppt/media/image*" + , "ppt/fonts/*" ] -- We only look for these under special conditions @@ -212,8 +290,6 @@ contingentInheritedPatterns pres = [] <> if presHasSpeakerNotes pres then map compile [ "ppt/notesMasters/notesMaster*.xml" , "ppt/notesMasters/_rels/notesMaster*.xml.rels" - , "ppt/theme/theme2.xml" - , "ppt/theme/_rels/theme2.xml.rels" ] else [] @@ -264,7 +340,32 @@ presentationToArchiveP p@(Presentation docProps slides) = do T.unlines (map (T.pack . (" " <>)) missingFiles) ) - newArch' <- foldM copyFileToArchive emptyArchive filePaths + newArch <- foldM copyFileToArchive emptyArchive filePaths + + -- Add any layouts taken from the default archive, + -- overwriting any already added. + slideLayouts <- getSlideLayouts + let f layout = + if not (slInReferenceDoc layout) + then addEntryToArchive (slEntry layout) + else id + let newArch' = foldr f newArch slideLayouts + + master <- getMaster + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + presentationElement <- parseXml refArchive distArchive "ppt/presentation.xml" + modify (\s -> + s {stFooterInfo = + getFooterInfo (dcDate docProps) slideLayouts master presentationElement + }) + + -- Update the master to make sure it includes any layouts we've just added + masterRels <- getMasterRels + let (updatedMasterElem, updatedMasterRelElem) = updateMasterElems slideLayouts master masterRels + updatedMasterEntry <- elemToEntry "ppt/slideMasters/slideMaster1.xml" updatedMasterElem + updatedMasterRelEntry <- elemToEntry "ppt/slideMasters/_rels/slideMaster1.xml.rels" updatedMasterRelElem + -- we make a modified ppt/viewProps.xml out of the presentation viewProps viewPropsEntry <- makeViewPropsEntry -- we make a docProps/core.xml entry out of the presentation docprops @@ -274,10 +375,9 @@ presentationToArchiveP p@(Presentation docProps slides) = do -- we make this ourself in case there's something unexpected in the -- one in the reference doc. relsEntry <- topLevelRelsEntry - -- presentation entry and rels. We have to do the rels first to make - -- sure we know the correct offset for the rIds. - presEntry <- presentationToPresEntry p - presRelsEntry <- presentationToRelsEntry p + -- presentation entry and rels. + (presentationRIdUpdateData, presRelsEntry) <- presentationToRelsEntry p + presEntry <- presentationToPresEntry presentationRIdUpdateData p slideEntries <- mapM slideToEntry slides slideRelEntries <- mapM slideToSlideRelEntry slides spkNotesEntries <- catMaybes <$> mapM slideToSpeakerNotesEntry slides @@ -293,9 +393,169 @@ presentationToArchiveP p@(Presentation docProps slides) = do spkNotesEntries <> spkNotesRelEntries <> mediaEntries <> + [updatedMasterEntry, updatedMasterRelEntry] <> [contentTypesEntry, docPropsEntry, docCustomPropsEntry, relsEntry, presEntry, presRelsEntry, viewPropsEntry] +updateMasterElems :: SlideLayouts -> Element -> Element -> (Element, Element) +updateMasterElems layouts master masterRels = (updatedMaster, updatedMasterRels) + where + updatedMaster = master { elContent = updateSldLayoutIdLst <$> elContent master } + (updatedRelationshipIds, updatedMasterRels) = addLayoutRels masterRels + + updateSldLayoutIdLst :: Content -> Content + updateSldLayoutIdLst (Elem e) = case elName e of + (QName "sldLayoutIdLst" _ _) -> let + mkChild relationshipId (lastId, children) = let + thisId = lastId + 1 + newChild = Element + { elName = QName "sldLayoutId" Nothing (Just "p") + , elAttribs = + [ Attr (QName "id" Nothing Nothing) (T.pack (show thisId)) + , Attr (QName "id" Nothing (Just "r")) relationshipId + ] + , elContent = [] + , elLine = Nothing + } + in (thisId, Elem newChild : children) + newChildren = snd (foldr mkChild (maxIdNumber' e, []) updatedRelationshipIds) + in Elem e { elContent = elContent e <> newChildren } + _ -> Elem e + updateSldLayoutIdLst c = c + + addLayoutRels :: + Element -> + ([Text], Element) + addLayoutRels e = let + layoutsToAdd = filter (\l -> not (slInReferenceDoc l) && isNew e l) + (toList layouts) + newRelationships = snd (foldr mkRelationship (maxIdNumber e, []) layoutsToAdd) + newRelationshipIds = + mapMaybe (findElemAttr (QName "Id" Nothing Nothing)) newRelationships + mkRelationship layout (lastId, relationships) = let + thisId = lastId + 1 + slideLayoutPath = "../slideLayouts/" <> T.pack (takeFileName (slPath layout)) + newRelationship = Element + { elName = QName "Relationship" Nothing Nothing + , elAttribs = + [ Attr (QName "Id" Nothing Nothing) ("rId" <> T.pack (show thisId)) + , Attr (QName "Type" Nothing Nothing) "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout" + , Attr (QName "Target" Nothing Nothing) slideLayoutPath + ] + , elContent = [] + , elLine = Nothing + } + in (thisId, Elem newRelationship : relationships) + in (newRelationshipIds, e {elContent = elContent e <> newRelationships}) + + -- | Whether the layout needs to be added to the Relationships element. + isNew :: Element -> SlideLayout -> Bool + isNew relationships SlideLayout{..} = let + toDetails = fmap (takeFileName . T.unpack) + . findElemAttr (QName "Target" Nothing Nothing) + in takeFileName slPath `notElem` mapMaybe toDetails (elContent relationships) + + findElemAttr :: QName -> Content -> Maybe Text + findElemAttr attr (Elem e) = findAttr attr e + findElemAttr _ _ = Nothing + + maxIdNumber :: Element -> Integer + maxIdNumber relationships = maximum (0 : idNumbers) + where + idNumbers = mapMaybe (readTextAsInteger . T.drop 3) idAttributes + idAttributes = mapMaybe getIdAttribute (elContent relationships) + getIdAttribute (Elem e) = findAttr (QName "Id" Nothing Nothing) e + getIdAttribute _ = Nothing + + maxIdNumber' :: Element -> Integer + maxIdNumber' sldLayouts = maximum (0 : idNumbers) + where + idNumbers = mapMaybe readTextAsInteger idAttributes + idAttributes = mapMaybe getIdAttribute (elContent sldLayouts) + getIdAttribute (Elem e) = findAttr (QName "id" Nothing Nothing) e + getIdAttribute _ = Nothing + +data FooterInfo = FooterInfo + { fiDate :: SlideLayoutsOf (Maybe Element) + , fiFooter :: SlideLayoutsOf (Maybe Element) + , fiSlideNumber :: SlideLayoutsOf (Maybe Element) + , fiShowOnFirstSlide :: Bool + } deriving (Show, Eq) + +getFooterInfo :: Maybe Text -> SlideLayouts -> Element -> Element -> Maybe FooterInfo +getFooterInfo date layouts master presentation = do + let ns = elemToNameSpaces master + hf <- findChild (elemName ns "p" "hf") master + let fiDate = let + f layoutDate = + case date of + Nothing -> layoutDate + Just d -> + if dateIsAutomatic (elemToNameSpaces layoutDate) layoutDate + then layoutDate + else replaceDate d layoutDate + in fmap f . getShape "dt" hf . slElement <$> layouts + fiFooter = getShape "ftr" hf . slElement <$> layouts + fiSlideNumber = getShape "sldNum" hf . slElement <$> layouts + fiShowOnFirstSlide = + fromMaybe True + (getBooleanAttribute "showSpecialPlsOnTitleSld" presentation) + pure FooterInfo{..} + where + getShape t hf layout = + if fromMaybe True (getBooleanAttribute t hf) + then do + let ns = elemToNameSpaces layout + cSld <- findChild (elemName ns "p" "cSld") layout + spTree <- findChild (elemName ns "p" "spTree") cSld + let containsPlaceholder sp = fromMaybe False $ do + nvSpPr <- findChild (elemName ns "p" "nvSpPr") sp + nvPr <- findChild (elemName ns "p" "nvPr") nvSpPr + ph <- findChild (elemName ns "p" "ph") nvPr + placeholderType <- findAttr (QName "type" Nothing Nothing) ph + pure (placeholderType == t) + listToMaybe (filterChildren containsPlaceholder spTree) + else Nothing + + dateIsAutomatic :: NameSpaces -> Element -> Bool + dateIsAutomatic ns shape = isJust $ do + txBody <- findChild (elemName ns "p" "txBody") shape + p <- findChild (elemName ns "a" "p") txBody + findChild (elemName ns "a" "fld") p + + replaceDate :: Text -> Element -> Element + replaceDate newDate e = + e { elContent = + case (elName e) of + QName "t" _ (Just "a") -> + [ Text (CData { cdVerbatim = CDataText + , cdData = newDate + , cdLine = Nothing + }) + ] + _ -> ifElem (replaceDate newDate) <$> elContent e + } + + ifElem :: (Element -> Element) -> (Content -> Content) + ifElem f (Elem e) = Elem (f e) + ifElem _ c = c + + getBooleanAttribute t e = + (`elem` ["1", "true"]) <$> + (findAttr (QName t Nothing Nothing) e) + +footerElements :: + PandocMonad m => + (forall a. SlideLayoutsOf a -> a) -> + P m [Content] +footerElements layout = do + footerInfo <- gets stFooterInfo + pure + $ Elem <$> + (toList (footerInfo >>= layout . fiDate) + <> toList (footerInfo >>= layout . fiFooter) + <> toList (footerInfo >>= layout . fiSlideNumber)) + makeSlideIdMap :: Presentation -> M.Map SlideId Int makeSlideIdMap (Presentation _ slides) = M.fromList $ map slideId slides `zip` [1..] @@ -304,9 +564,9 @@ makeSpeakerNotesMap :: Presentation -> M.Map Int Int makeSpeakerNotesMap (Presentation _ slides) = M.fromList $ mapMaybe f (slides `zip` [1..]) `zip` [1..] - where f (Slide _ _ notes, n) = if notes == mempty - then Nothing - else Just n + where f (Slide _ _ notes _, n) = if notes == mempty + then Nothing + else Just n presentationToArchive :: PandocMonad m => WriterOptions -> Meta -> Presentation -> m Archive @@ -318,6 +578,71 @@ presentationToArchive opts meta pres = do Nothing -> toArchive . BL.fromStrict <$> P.readDataFile "reference.pptx" + let (referenceLayouts, defaultReferenceLayouts) = + (getLayoutsFromArchive refArchive, getLayoutsFromArchive distArchive) + let layoutTitles = SlideLayouts { metadata = "Title Slide" :: Text + , title = "Section Header" + , content = "Title and Content" + , twoColumn = "Two Content" + , comparison = "Comparison" + , contentWithCaption = "Content with Caption" + , blank = "Blank" + } + layouts <- for layoutTitles $ \layoutTitle -> do + let layout = M.lookup (CI.mk layoutTitle) referenceLayouts + let defaultLayout = M.lookup (CI.mk layoutTitle) defaultReferenceLayouts + case (layout, defaultLayout) of + (Nothing, Nothing) -> + throwError (PandocSomeError ("Couldn't find layout named \"" + <> layoutTitle <> "\" in the provided " + <> "reference doc or in the default " + <> "reference doc included with pandoc.")) + (Nothing, Just ((element, path, entry) :| _)) -> do + P.report (PowerpointTemplateWarning + ("Couldn't find layout named \"" + <> layoutTitle <> "\" in provided " + <> "reference doc. Falling back to " + <> "the default included with pandoc.")) + pure SlideLayout { slElement = element + , slPath = path + , slEntry = entry + , slInReferenceDoc = False + } + (Just ((element, path, entry) :| _), _ ) -> + pure SlideLayout { slElement = element + , slPath = path + , slEntry = entry + , slInReferenceDoc = True + } + + master <- getMaster' refArchive distArchive + + let otherStyleIndents = do + let ns = elemToNameSpaces master + txStyles <- findChild (elemName ns "p" "txStyles") master + otherStyle <- findChild (elemName ns "p" "otherStyle") txStyles + let makeLevelIndents name = do + e <- findChild (elemName ns "a" name) otherStyle + pure LevelIndents + { indent = fromMaybe (-342900) + (findAttr (QName "indent" Nothing Nothing) e + >>= readTextAsInteger) + , marL = fromMaybe 347663 + (findAttr (QName "marL" Nothing Nothing) e + >>= readTextAsInteger) + } + pure Indents + { level1 = makeLevelIndents "lvl1pPr" + , level2 = makeLevelIndents "lvl2pPr" + , level3 = makeLevelIndents "lvl3pPr" + , level4 = makeLevelIndents "lvl4pPr" + , level5 = makeLevelIndents "lvl5pPr" + , level6 = makeLevelIndents "lvl6pPr" + , level7 = makeLevelIndents "lvl7pPr" + , level8 = makeLevelIndents "lvl8pPr" + , level9 = makeLevelIndents "lvl9pPr" + } + utctime <- P.getTimestamp presSize <- case getPresentationSize refArchive distArchive of @@ -341,6 +666,8 @@ presentationToArchive opts meta pres = do , envPresentationSize = presSize , envSlideIdMap = makeSlideIdMap pres , envSpeakerNotesIdMap = makeSpeakerNotesMap pres + , envSlideLayouts = Just layouts + , envOtherStyleIndents = otherStyleIndents } let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive @@ -348,7 +675,30 @@ presentationToArchive opts meta pres = do runP env st $ presentationToArchiveP pres - +-- | Get all slide layouts from an archive, as a map where the layout's name +-- gives the map key. +-- +-- For each layout, the map contains its XML representation, its path within +-- the archive, and the archive entry. +getLayoutsFromArchive :: Archive -> M.Map (CI Text) (NonEmpty (Element, FilePath, Entry)) +getLayoutsFromArchive archive = + M.fromListWith (<>) ((\t@(e, _, _) -> (CI.mk (name e), pure t)) <$> layouts) + where + layouts :: [(Element, FilePath, Entry)] + layouts = mapMaybe findElementByPath paths + parseXml' entry = case parseXMLElement (UTF8.toTextLazy (fromEntry entry)) of + Left _ -> Nothing + Right element -> Just element + findElementByPath :: FilePath -> Maybe (Element, FilePath, Entry) + findElementByPath path = do + entry <- findEntryByPath path archive + element <- parseXml' entry + pure (element, path, entry) + paths = filter (match (compile "ppt/slideLayouts/slideLayout*.xml")) (filesInArchive archive) + name element = fromMaybe "Untitled layout" $ do + let ns = elemToNameSpaces element + cSld <- findChild (elemName ns "p" "cSld") element + findAttr (QName "name" Nothing Nothing) cSld -------------------------------------------------- @@ -365,38 +715,59 @@ curSlideHasSpeakerNotes = -------------------------------------------------- getLayout :: PandocMonad m => Layout -> P m Element -getLayout layout = do - let layoutpath = case layout of - MetadataSlide{} -> "ppt/slideLayouts/slideLayout1.xml" - TitleSlide{} -> "ppt/slideLayouts/slideLayout3.xml" - ContentSlide{} -> "ppt/slideLayouts/slideLayout2.xml" - TwoColumnSlide{} -> "ppt/slideLayouts/slideLayout4.xml" - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - parseXml refArchive distArchive layoutpath +getLayout layout = getElement <$> getSlideLayouts + where + getElement = + slElement . case layout of + MetadataSlide{} -> metadata + TitleSlide{} -> title + ContentSlide{} -> content + TwoColumnSlide{} -> twoColumn + ComparisonSlide{} -> comparison + ContentWithCaptionSlide{} -> contentWithCaption + BlankSlide{} -> blank shapeHasId :: NameSpaces -> T.Text -> Element -> Bool -shapeHasId ns ident element - | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element - , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr - , Just nm <- findAttr (QName "id" Nothing Nothing) cNvPr = - nm == ident - | otherwise = False +shapeHasId ns ident element = getShapeId ns element == Just ident -getContentShape :: PandocMonad m => NameSpaces -> Element -> P m Element +getShapeId :: NameSpaces -> Element -> Maybe Text +getShapeId ns element = do + nvSpPr <- findChild (elemName ns "p" "nvSpPr") element + cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr + findAttr (QName "id" Nothing Nothing) cNvPr + +type ShapeId = Integer + +getContentShape :: PandocMonad m => NameSpaces -> Element -> P m (Maybe ShapeId, Element) getContentShape ns spTreeElem | isElem ns "p" "spTree" spTreeElem = do - contentType <- asks envContentType - let contentShapes = getShapesByPlaceHolderType ns spTreeElem ObjType - case contentType of - NormalContent | (sp : _) <- contentShapes -> return sp - TwoColumnLeftContent | (sp : _) <- contentShapes -> return sp - TwoColumnRightContent | (_ : sp : _) <- contentShapes -> return sp - _ -> throwError $ PandocSomeError - "Could not find shape for Powerpoint content" + ph@Placeholder{index, placeholderType} <- asks envPlaceholder + case drop index (getShapesByPlaceHolderType ns spTreeElem placeholderType) of + sp : _ -> let + shapeId = getShapeId ns sp >>= readTextAsInteger + in return (shapeId, sp) + [] -> throwError $ PandocSomeError $ missingPlaceholderMessage ph getContentShape _ _ = throwError $ PandocSomeError "Attempted to find content on non shapeTree" +missingPlaceholderMessage :: Placeholder -> Text +missingPlaceholderMessage Placeholder{..} = + "Could not find a " <> ordinal + <> " placeholder of type " <> placeholderText + where + ordinal = T.pack (show index) <> + case (index `mod` 100, index `mod` 10) of + (11, _) -> "th" + (12, _) -> "th" + (13, _) -> "th" + (_, 1) -> "st" + (_, 2) -> "nd" + (_, 3) -> "rd" + _ -> "th" + placeholderText = case placeholderType of + ObjType -> "obj (or nothing)" + PHType t -> t + getShapeDimensions :: NameSpaces -> Element -> Maybe ((Integer, Integer), (Integer, Integer)) @@ -438,7 +809,7 @@ getContentShapeSize ns layout master | isElem ns "p" "sldLayout" layout , Just cSld <- findChild (elemName ns "p" "cSld") layout , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do - sp <- getContentShape ns spTree + (_, sp) <- getContentShape ns spTree case getShapeDimensions ns sp of Just sz -> return sz Nothing -> do let mbSz = @@ -602,8 +973,18 @@ getMaster :: PandocMonad m => P m Element getMaster = do refArchive <- asks envRefArchive distArchive <- asks envDistArchive + getMaster' refArchive distArchive + +getMaster' :: PandocMonad m => Archive -> Archive -> m Element +getMaster' refArchive distArchive = parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml" +getMasterRels :: PandocMonad m => P m Element +getMasterRels = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + parseXml refArchive distArchive "ppt/slideMasters/_rels/slideMaster1.xml.rels" + -- We want to get the header dimensions, so we can make sure that the -- image goes underneath it. We only use this in a content slide if it -- has a header. @@ -654,41 +1035,44 @@ captionHeight = 40 createCaption :: PandocMonad m => ((Integer, Integer), (Integer, Integer)) -> [ParaElem] - -> P m Element + -> P m (ShapeId, Element) createCaption contentShapeDimensions paraElements = do let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements elements <- mapM paragraphToElement [para] let ((x, y), (cx, cy)) = contentShapeDimensions let txBody = mknode "p:txBody" [] $ [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] <> elements - return $ - mknode "p:sp" [] [ mknode "p:nvSpPr" [] - [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] () - , mknode "p:cNvSpPr" [("txBox", "1")] () - , mknode "p:nvPr" [] () - ] - , mknode "p:spPr" [] - [ mknode "a:xfrm" [] - [ mknode "a:off" [("x", tshow $ 12700 * x), - ("y", tshow $ 12700 * (y + cy - captionHeight))] () - , mknode "a:ext" [("cx", tshow $ 12700 * cx), - ("cy", tshow $ 12700 * captionHeight)] () - ] - , mknode "a:prstGeom" [("prst", "rect")] - [ mknode "a:avLst" [] () - ] - , mknode "a:noFill" [] () - ] - , txBody - ] + return + ( 1 + , mknode "p:sp" [] [ mknode "p:nvSpPr" [] + [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] () + , mknode "p:cNvSpPr" [("txBox", "1")] () + , mknode "p:nvPr" [] () + ] + , mknode "p:spPr" [] + [ mknode "a:xfrm" [] + [ mknode "a:off" [("x", tshow $ 12700 * x), + ("y", tshow $ 12700 * (y + cy - captionHeight))] () + , mknode "a:ext" [("cx", tshow $ 12700 * cx), + ("cy", tshow $ 12700 * captionHeight)] () + ] + , mknode "a:prstGeom" [("prst", "rect")] + [ mknode "a:avLst" [] () + ] + , mknode "a:noFill" [] () + ] + , txBody + ] + ) makePicElements :: PandocMonad m => Element -> PicProps -> MediaInfo + -> Text -> [ParaElem] - -> P m [Element] -makePicElements layout picProps mInfo alt = do + -> P m [(ShapeId, Element)] +makePicElements layout picProps mInfo titleText alt = do opts <- asks envOpts (pageWidth, pageHeight) <- asks envPresentationSize -- hasHeader <- asks envSlideHasHeader @@ -721,7 +1105,11 @@ makePicElements layout picProps mInfo alt = do ,("noChangeAspect","1")] () -- cNvPr will contain the link information so we do that separately, -- and register the link if necessary. - let cNvPrAttr = [("descr", T.pack $ mInfoFilePath mInfo), + let description = (if T.null titleText + then "" + else titleText <> "\n\n") + <> T.pack (mInfoFilePath mInfo) + let cNvPrAttr = [("descr", description), ("id","0"), ("name","Picture 1")] cNvPr <- case picPropLink picProps of @@ -751,10 +1139,12 @@ makePicElements layout picProps mInfo alt = do let spPr = mknode "p:spPr" [("bwMode","auto")] [xfrm, prstGeom, mknode "a:noFill" [] (), ln] - let picShape = mknode "p:pic" [] - [ nvPicPr - , blipFill - , spPr ] + let picShape = ( 0 + , mknode "p:pic" [] + [ nvPicPr + , blipFill + , spPr ] + ) -- And now, maybe create the caption: if hasCaption @@ -762,6 +1152,12 @@ makePicElements layout picProps mInfo alt = do return [picShape, cap] else return [picShape] +consolidateRuns :: [ParaElem] -> [ParaElem] +consolidateRuns [] = [] +consolidateRuns (Run pr1 s1 : Run pr2 s2 : xs) + | pr1 == pr2 = consolidateRuns (Run pr1 (s1 <> s2) : xs) +consolidateRuns (x:xs) = x : consolidateRuns xs + paraElemToElements :: PandocMonad m => ParaElem -> P m [Content] paraElemToElements Break = return [Elem $ mknode "a:br" [] ()] @@ -867,15 +1263,32 @@ surroundWithMathAlternate element = paragraphToElement :: PandocMonad m => Paragraph -> P m Element paragraphToElement par = do + indents <- asks envOtherStyleIndents let - attrs = [("lvl", tshow $ pPropLevel $ paraProps par)] <> - (case pPropMarginLeft (paraProps par) of - Just px -> [("marL", tshow $ pixelsToEmu px)] - Nothing -> [] - ) <> - (case pPropIndent (paraProps par) of - Just px -> [("indent", tshow $ pixelsToEmu px)] - Nothing -> [] + lvl = pPropLevel (paraProps par) + attrs = [("lvl", tshow lvl)] <> + (case (pPropIndent (paraProps par), pPropMarginLeft (paraProps par)) of + (Just px1, Just px2) -> [ ("indent", tshow $ pixelsToEmu px1) + , ("marL", tshow $ pixelsToEmu px2) + ] + (Just px1, Nothing) -> [("indent", tshow $ pixelsToEmu px1)] + (Nothing, Just px2) -> [("marL", tshow $ pixelsToEmu px2)] + (Nothing, Nothing) -> fromMaybe [] $ do + indents' <- indents + thisLevel <- levelIndent indents' lvl + nextLevel <- levelIndent indents' (lvl + 1) + let (m, i) = + case pPropBullet (paraProps par) of + Nothing -> + (Just (marL thisLevel), Just 0) + Just (AutoNumbering _) -> + ( Just (marL nextLevel) + , Just (marL thisLevel - marL nextLevel) + ) + Just Bullet -> (Nothing, Nothing) + pure ( toList ((,) "indent" . tshow <$> i) + <> toList ((,) "marL" . tshow <$> m) + ) ) <> (case pPropAlign (paraProps par) of Just AlgnLeft -> [("algn", "l")] @@ -897,48 +1310,53 @@ paragraphToElement par = do [mknode "a:buAutoNum" (autoNumAttrs attrs') ()] Nothing -> [mknode "a:buNone" [] ()] ) - paras <- mapM paraElemToElements (paraElems par) - return $ mknode "a:p" [] $ - [Elem $ mknode "a:pPr" attrs props] <> concat paras + paras <- mconcat <$> mapM paraElemToElements (consolidateRuns (paraElems par)) + return $ mknode "a:p" [] $ [Elem $ mknode "a:pPr" attrs props] <> paras -shapeToElement :: PandocMonad m => Element -> Shape -> P m Element +shapeToElement :: PandocMonad m => Element -> Shape -> P m (Maybe ShapeId, Element) shapeToElement layout (TextBox paras) | ns <- elemToNameSpaces layout , Just cSld <- findChild (elemName ns "p" "cSld") layout , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do - sp <- getContentShape ns spTree + (shapeId, sp) <- getContentShape ns spTree elements <- mapM paragraphToElement paras let txBody = mknode "p:txBody" [] $ [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] <> elements emptySpPr = mknode "p:spPr" [] () return + . (shapeId,) . surroundWithMathAlternate . replaceNamedChildren ns "p" "txBody" [txBody] . replaceNamedChildren ns "p" "spPr" [emptySpPr] $ sp -- GraphicFrame and Pic should never reach this. -shapeToElement _ _ = return $ mknode "p:sp" [] () +shapeToElement _ _ = return (Nothing, mknode "p:sp" [] ()) -shapeToElements :: PandocMonad m => Element -> Shape -> P m [Content] -shapeToElements layout (Pic picProps fp alt) = do +shapeToElements :: PandocMonad m => Element -> Shape -> P m [(Maybe ShapeId, Content)] +shapeToElements layout (Pic picProps fp titleText alt) = do mInfo <- registerMedia fp alt case mInfoExt mInfo of - Just _ -> map Elem <$> - makePicElements layout picProps mInfo alt + Just _ -> map (bimap Just Elem) <$> + makePicElements layout picProps mInfo titleText alt Nothing -> shapeToElements layout $ TextBox [Paragraph def alt] -shapeToElements layout (GraphicFrame tbls cptn) = map Elem <$> +shapeToElements layout (GraphicFrame tbls cptn) = map (bimap Just Elem) <$> graphicFrameToElements layout tbls cptn shapeToElements _ (RawOOXMLShape str) = return - [Text (CData CDataRaw str Nothing)] + [(Nothing, Text (CData CDataRaw str Nothing))] shapeToElements layout shp = do - element <- shapeToElement layout shp - return [Elem element] + (shapeId, element) <- shapeToElement layout shp + return [(shapeId, Elem element)] -shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Content] +shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [(Maybe ShapeId, Content)] shapesToElements layout shps = concat <$> mapM (shapeToElements layout) shps -graphicFrameToElements :: PandocMonad m => Element -> [Graphic] -> [ParaElem] -> P m [Element] +graphicFrameToElements :: + PandocMonad m => + Element -> + [Graphic] -> + [ParaElem] -> + P m [(ShapeId, Element)] graphicFrameToElements layout tbls caption = do -- get the sizing master <- getMaster @@ -952,21 +1370,23 @@ graphicFrameToElements layout tbls caption = do elements <- mapM (graphicToElement cx) tbls let graphicFrameElts = - mknode "p:graphicFrame" [] $ - [ mknode "p:nvGraphicFramePr" [] - [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] () - , mknode "p:cNvGraphicFramePr" [] - [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()] - , mknode "p:nvPr" [] - [mknode "p:ph" [("idx", "1")] ()] - ] - , mknode "p:xfrm" [] - [ mknode "a:off" [("x", tshow $ 12700 * x), - ("y", tshow $ 12700 * y)] () - , mknode "a:ext" [("cx", tshow $ 12700 * cx), - ("cy", tshow $ 12700 * cy)] () - ] - ] <> elements + ( 6 + , mknode "p:graphicFrame" [] $ + [ mknode "p:nvGraphicFramePr" [] + [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] () + , mknode "p:cNvGraphicFramePr" [] + [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()] + , mknode "p:nvPr" [] + [mknode "p:ph" [("idx", "1")] ()] + ] + , mknode "p:xfrm" [] + [ mknode "a:off" [("x", tshow $ 12700 * x), + ("y", tshow $ 12700 * y)] () + , mknode "a:ext" [("cx", tshow $ 12700 * cx), + ("cy", tshow $ 12700 * cy)] () + ] + ] <> elements + ) if not $ null caption then do capElt <- createCaption ((x, y), (cx, cytmp)) caption @@ -1088,124 +1508,433 @@ getShapeByPlaceHolderTypes ns spTreeElem (s:ss) = Just element -> Just element Nothing -> getShapeByPlaceHolderTypes ns spTreeElem ss -nonBodyTextToElement :: PandocMonad m => Element -> [PHType] -> [ParaElem] -> P m Element +nonBodyTextToElement :: + PandocMonad m => + Element -> + [PHType] -> + [ParaElem] -> + P m (Maybe ShapeId, 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 <- getShapeByPlaceHolderTypes ns spTree phTypes = do + , Just sp <- getShapeByPlaceHolderTypes ns spTree phTypes + , Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") sp + , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr + , Just shapeId <- findAttr (nodename "id") cNvPr + , Right (shapeIdNum, _) <- decimal shapeId = do let hdrPara = Paragraph def paraElements element <- paragraphToElement hdrPara let txBody = mknode "p:txBody" [] $ [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] <> [element] - return $ replaceNamedChildren ns "p" "txBody" [txBody] sp + return (Just shapeIdNum, replaceNamedChildren ns "p" "txBody" [txBody] sp) -- XXX: TODO - | otherwise = return $ mknode "p:sp" [] () - -contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element + | otherwise = return (Nothing, mknode "p:sp" [] ()) + +data ContentShapeIds = ContentShapeIds + { contentHeaderId :: Maybe ShapeId + , contentContentIds :: [ShapeId] + } + +contentToElement :: + PandocMonad m => + Element -> + [ParaElem] -> + [Shape] -> + P m (Maybe ContentShapeIds, Element) 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 [PHType "title"] hdrShape + (shapeId, element) <- nonBodyTextToElement layout [PHType "title"] hdrShape let hdrShapeElements = [Elem element | not (null hdrShape)] - contentElements <- local - (\env -> env {envContentType = NormalContent}) + contentHeaderId = if null hdrShape then Nothing else shapeId + content' <- local + (\env -> env {envPlaceholder = Placeholder ObjType 0}) (shapesToElements layout shapes) - return $ buildSpTree ns spTree (hdrShapeElements <> contentElements) -contentToElement _ _ _ = return $ mknode "p:sp" [] () - -twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element + let contentContentIds = mapMaybe fst content' + contentElements = snd <$> content' + footer <- footerElements content + return ( Just ContentShapeIds{..} + , buildSpTree ns spTree (hdrShapeElements <> contentElements <> footer) + ) +contentToElement _ _ _ = return (Nothing, mknode "p:sp" [] ()) + +data TwoColumnShapeIds = TwoColumnShapeIds + { twoColumnHeaderId :: Maybe ShapeId + , twoColumnLeftIds :: [ShapeId] + , twoColumnRightIds :: [ShapeId] + } + +twoColumnToElement :: + PandocMonad m => + Element -> + [ParaElem] -> + [Shape] -> + [Shape] -> + P m (Maybe TwoColumnShapeIds, Element) 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 [PHType "title"] hdrShape + (headerId, element) <- nonBodyTextToElement layout [PHType "title"] hdrShape let hdrShapeElements = [Elem element | not (null hdrShape)] - contentElementsL <- local - (\env -> env {envContentType =TwoColumnLeftContent}) - (shapesToElements layout shapesL) - contentElementsR <- local - (\env -> env {envContentType =TwoColumnRightContent}) - (shapesToElements layout shapesR) + twoColumnHeaderId = if null hdrShape then Nothing else headerId + contentL <- local (\env -> env {envPlaceholder = Placeholder ObjType 0}) + (shapesToElements layout shapesL) + let twoColumnLeftIds = mapMaybe fst contentL + contentElementsL = snd <$> contentL + contentR <- local (\env -> env {envPlaceholder = Placeholder ObjType 1}) + (shapesToElements layout shapesR) + let (twoColumnRightIds) = (mapMaybe fst contentR) + contentElementsR = snd <$> contentR -- let contentElementsL' = map (setIdx ns "1") contentElementsL -- contentElementsR' = map (setIdx ns "2") contentElementsR - return $ buildSpTree ns spTree $ - hdrShapeElements <> contentElementsL <> contentElementsR -twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] () - - -titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element + footer <- footerElements twoColumn + return + $ (Just TwoColumnShapeIds{..}, ) + $ buildSpTree ns spTree + $ hdrShapeElements <> contentElementsL <> contentElementsR <> footer +twoColumnToElement _ _ _ _ = return (Nothing, mknode "p:sp" [] ()) + +data ComparisonShapeIds = ComparisonShapeIds + { comparisonHeaderId :: Maybe ShapeId + , comparisonLeftTextIds :: [ShapeId] + , comparisonLeftContentIds :: [ShapeId] + , comparisonRightTextIds :: [ShapeId] + , comparisonRightContentIds :: [ShapeId] + } + +comparisonToElement :: + PandocMonad m => + Element -> + [ParaElem] -> + ([Shape], [Shape]) -> + ([Shape], [Shape]) -> + P m (Maybe ComparisonShapeIds, Element) +comparisonToElement layout hdrShape (shapesL1, shapesL2) (shapesR1, shapesR2) + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + (headerShapeId, element) <- nonBodyTextToElement layout [PHType "title"] hdrShape + let hdrShapeElements = [Elem element | not (null hdrShape)] + comparisonHeaderId = if null hdrShape then Nothing else headerShapeId + contentL1 <- local (\env -> env {envPlaceholder = Placeholder (PHType "body") 0}) + (shapesToElements layout shapesL1) + let comparisonLeftTextIds = mapMaybe fst contentL1 + contentElementsL1 = snd <$> contentL1 + contentL2 <- local (\env -> env {envPlaceholder = Placeholder ObjType 0}) + (shapesToElements layout shapesL2) + let comparisonLeftContentIds = mapMaybe fst contentL2 + contentElementsL2 = snd <$> contentL2 + contentR1 <- local (\env -> env {envPlaceholder = Placeholder (PHType "body") 1}) + (shapesToElements layout shapesR1) + let comparisonRightTextIds = mapMaybe fst contentR1 + contentElementsR1 = snd <$> contentR1 + contentR2 <- local (\env -> env {envPlaceholder = Placeholder ObjType 1}) + (shapesToElements layout shapesR2) + let comparisonRightContentIds = mapMaybe fst contentR2 + contentElementsR2 = snd <$> contentR2 + footer <- footerElements comparison + return + $ (Just ComparisonShapeIds{..}, ) + $ buildSpTree ns spTree + $ mconcat [ hdrShapeElements + , contentElementsL1 + , contentElementsL2 + , contentElementsR1 + , contentElementsR2 + ] <> footer +comparisonToElement _ _ _ _= return (Nothing, mknode "p:sp" [] ()) + +data ContentWithCaptionShapeIds = ContentWithCaptionShapeIds + { contentWithCaptionHeaderId :: Maybe ShapeId + , contentWithCaptionCaptionIds :: [ShapeId] + , contentWithCaptionContentIds :: [ShapeId] + } + +contentWithCaptionToElement :: + PandocMonad m => + Element -> + [ParaElem] -> + [Shape] -> + [Shape] -> + P m (Maybe ContentWithCaptionShapeIds, Element) +contentWithCaptionToElement layout hdrShape textShapes contentShapes + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + (shapeId, element) <- nonBodyTextToElement layout [PHType "title"] hdrShape + let hdrShapeElements = [Elem element | not (null hdrShape)] + contentWithCaptionHeaderId = if null hdrShape then Nothing else shapeId + text <- local (\env -> env {envPlaceholder = Placeholder (PHType "body") 0}) + (shapesToElements layout textShapes) + let contentWithCaptionCaptionIds = mapMaybe fst text + textElements = snd <$> text + content <- local (\env -> env {envPlaceholder = Placeholder ObjType 0}) + (shapesToElements layout contentShapes) + let contentWithCaptionContentIds = mapMaybe fst content + contentElements = snd <$> content + footer <- footerElements contentWithCaption + return + $ (Just ContentWithCaptionShapeIds{..}, ) + $ buildSpTree ns spTree + $ mconcat [ hdrShapeElements + , textElements + , contentElements + ] <> footer +contentWithCaptionToElement _ _ _ _ = return (Nothing, mknode "p:sp" [] ()) + +blankToElement :: + PandocMonad m => + Element -> + P m Element +blankToElement layout + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = + buildSpTree ns spTree <$> footerElements blank +blankToElement _ = return $ mknode "p:sp" [] () + +newtype TitleShapeIds = TitleShapeIds + { titleHeaderId :: Maybe ShapeId + } + +titleToElement :: + PandocMonad m => + Element -> + [ParaElem] -> + P m (Maybe TitleShapeIds, Element) 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 [PHType "title", PHType "ctrTitle"] titleElems + (shapeId, element) <- nonBodyTextToElement layout [PHType "title", PHType "ctrTitle"] titleElems let titleShapeElements = [Elem element | not (null titleElems)] - return $ buildSpTree ns spTree titleShapeElements -titleToElement _ _ = return $ mknode "p:sp" [] () - -metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element + titleHeaderId = if null titleElems then Nothing else shapeId + footer <- footerElements title + return + $ (Just TitleShapeIds{..}, ) + $ buildSpTree ns spTree (titleShapeElements <> footer) +titleToElement _ _ = return (Nothing, mknode "p:sp" [] ()) + +data MetadataShapeIds = MetadataShapeIds + { metadataTitleId :: Maybe ShapeId + , metadataSubtitleId :: Maybe ShapeId + , metadataDateId :: Maybe ShapeId + } + +metadataToElement :: + PandocMonad m => + Element -> + [ParaElem] -> + [ParaElem] -> + [[ParaElem]] -> + [ParaElem] -> + P m (Maybe MetadataShapeIds, Element) metadataToElement layout titleElems subtitleElems authorsElems dateElems | ns <- elemToNameSpaces layout , Just cSld <- findChild (elemName ns "p" "cSld") layout , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do - titleShapeElements <- if null titleElems - then return [] - else sequence [nonBodyTextToElement layout [PHType "ctrTitle"] titleElems] let combinedAuthorElems = intercalate [Break] authorsElems subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems] - subtitleShapeElements <- if null subtitleAndAuthorElems - then return [] - else sequence [nonBodyTextToElement layout [PHType "subTitle"] subtitleAndAuthorElems] - dateShapeElements <- if null dateElems - then return [] - else sequence [nonBodyTextToElement layout [PHType "dt"] dateElems] - return . buildSpTree ns spTree . map Elem $ - (titleShapeElements <> subtitleShapeElements <> dateShapeElements) -metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] () + (titleId, titleElement) <- nonBodyTextToElement layout [PHType "ctrTitle"] titleElems + (subtitleId, subtitleElement) <- nonBodyTextToElement layout [PHType "subTitle"] subtitleAndAuthorElems + (dateId, dateElement) <- nonBodyTextToElement layout [PHType "dt"] dateElems + let titleShapeElements = [titleElement | not (null titleElems)] + metadataTitleId = if null titleElems then Nothing else titleId + subtitleShapeElements = [subtitleElement | not (null subtitleAndAuthorElems)] + metadataSubtitleId = if null subtitleAndAuthorElems then Nothing else subtitleId + footerInfo <- gets stFooterInfo + footer <- (if maybe False fiShowOnFirstSlide footerInfo + then id + else const []) <$> footerElements metadata + let dateShapeElements = [dateElement + | not (null dateElems + || isJust (footerInfo >>= metadata . fiDate)) + ] + metadataDateId = if null dateElems then Nothing else dateId + return + $ (Just MetadataShapeIds{..}, ) + $ buildSpTree ns spTree + $ map Elem (titleShapeElements <> subtitleShapeElements <> dateShapeElements) + <> footer +metadataToElement _ _ _ _ _ = return (Nothing, mknode "p:sp" [] ()) slideToElement :: PandocMonad m => Slide -> P m Element -slideToElement (Slide _ l@(ContentSlide hdrElems shapes) _ )= do +slideToElement (Slide _ l@(ContentSlide hdrElems shapes) _ backgroundImage) = do + layout <- getLayout l + backgroundImageElement <- traverse backgroundImageToElement backgroundImage + (shapeIds, spTree) + <- local (\env -> if null hdrElems + then env + else env{envSlideHasHeader=True}) + (contentToElement layout hdrElems shapes) + let animations = case shapeIds of + Nothing -> [] + Just ContentShapeIds{..} -> + slideToIncrementalAnimations (zip contentContentIds shapes) + return $ mknode "p:sld" + [ ("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" [] (toList backgroundImageElement <> [spTree]) : animations) +slideToElement (Slide _ l@(TwoColumnSlide hdrElems shapesL shapesR) _ backgroundImage) = do layout <- getLayout l - spTree <- local (\env -> if null hdrElems + backgroundImageElement <- traverse backgroundImageToElement backgroundImage + (shapeIds, spTree) <- local (\env -> if null hdrElems then env else env{envSlideHasHeader=True}) $ - contentToElement layout hdrElems shapes + twoColumnToElement layout hdrElems shapesL shapesR + let animations = case shapeIds of + Nothing -> [] + Just TwoColumnShapeIds{..} -> + slideToIncrementalAnimations (zip twoColumnLeftIds shapesL + <> zip twoColumnRightIds shapesR) return $ mknode "p:sld" [ ("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" [] [spTree]] -slideToElement (Slide _ l@(TwoColumnSlide hdrElems shapesL shapesR) _) = do + ] (mknode "p:cSld" [] (toList backgroundImageElement <> [spTree]) : animations) +slideToElement (Slide _ l@(ComparisonSlide hdrElems shapesL shapesR) _ backgroundImage) = do layout <- getLayout l - spTree <- local (\env -> if null hdrElems + backgroundImageElement <- traverse backgroundImageToElement backgroundImage + (shapeIds, spTree) <- local (\env -> if null hdrElems then env else env{envSlideHasHeader=True}) $ - twoColumnToElement layout hdrElems shapesL shapesR + comparisonToElement layout hdrElems shapesL shapesR + let animations = case shapeIds of + Nothing -> [] + Just ComparisonShapeIds{..} -> + slideToIncrementalAnimations + (zip comparisonLeftTextIds (fst shapesL) + <> zip comparisonLeftContentIds (snd shapesL) + <> zip comparisonRightTextIds (fst shapesR) + <> zip comparisonRightContentIds (snd shapesR)) + return $ mknode "p:sld" + [ ("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" [] (toList backgroundImageElement <> [spTree]) : animations) +slideToElement (Slide _ l@(TitleSlide hdrElems) _ backgroundImage) = do + layout <- getLayout l + backgroundImageElement <- traverse backgroundImageToElement backgroundImage + (_, spTree) <- titleToElement layout hdrElems return $ mknode "p:sld" [ ("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" [] [spTree]] -slideToElement (Slide _ l@(TitleSlide hdrElems) _) = do + ] [mknode "p:cSld" [] (toList backgroundImageElement <> [spTree])] +slideToElement (Slide + _ + l@(MetadataSlide titleElems subtitleElems authorElems dateElems) + _ + backgroundImage) = do layout <- getLayout l - spTree <- titleToElement layout hdrElems + backgroundImageElement <- traverse backgroundImageToElement backgroundImage + (_, spTree) <- metadataToElement layout titleElems subtitleElems authorElems dateElems return $ mknode "p:sld" [ ("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" [] [spTree]] -slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems dateElems) _) = do + ] [mknode "p:cSld" [] (toList backgroundImageElement <> [spTree])] +slideToElement (Slide + _ + l@(ContentWithCaptionSlide hdrElems captionShapes contentShapes) + _ + backgroundImage) = do layout <- getLayout l - spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems + backgroundImageElement <- traverse backgroundImageToElement backgroundImage + (shapeIds, spTree) <- contentWithCaptionToElement layout hdrElems captionShapes contentShapes + let animations = case shapeIds of + Nothing -> [] + Just ContentWithCaptionShapeIds{..} -> + slideToIncrementalAnimations + (zip contentWithCaptionCaptionIds captionShapes + <> zip contentWithCaptionContentIds contentShapes) return $ mknode "p:sld" [ ("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" [] [spTree]] + ] (mknode "p:cSld" [] (toList backgroundImageElement <> [spTree]) : animations) +slideToElement (Slide _ BlankSlide _ backgroundImage) = do + layout <- getLayout BlankSlide + backgroundImageElement <- traverse backgroundImageToElement backgroundImage + spTree <- blankToElement layout + return $ mknode "p:sld" + [ ("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" [] (toList backgroundImageElement <> [spTree])] +backgroundImageToElement :: PandocMonad m => FilePath -> P m Element +backgroundImageToElement path = do + MediaInfo{mInfoLocalId, mInfoFilePath} <- registerMedia path [] + (imgBytes, _) <- P.fetchItem (T.pack mInfoFilePath) + opts <- asks envOpts + let imageDimensions = either (const Nothing) + (Just . sizeInPixels) + (imageSize opts imgBytes) + pageSize <- asks envPresentationSize + let fillRectAttributes = maybe [] (offsetAttributes pageSize) imageDimensions + let rId = "rId" <> T.pack (show mInfoLocalId) + return + $ mknode "p:bg" [] + $ mknode "p:bgPr" [] + [ mknode "a:blipFill" [("dpi", "0"), ("rotWithShape", "1")] + [ mknode "a:blip" [("r:embed", rId)] + $ mknode "a:lum" [] () + , mknode "a:srcRect" [] () + , mknode "a:stretch" [] + $ mknode "a:fillRect" fillRectAttributes () + ] + , mknode "a:effectsLst" [] () + ] + where + offsetAttributes :: (Integer, Integer) -> (Integer, Integer) -> [(Text, Text)] + offsetAttributes (pageWidth, pageHeight) (pictureWidth, pictureHeight) = let + widthRatio = pictureWidth % pageWidth + heightRatio = pictureHeight % pageHeight + getOffset :: Ratio Integer -> Text + getOffset proportion = let + percentageOffset = (proportion - 1) * (-100 % 2) + integerOffset = round percentageOffset * 1000 :: Integer + in T.pack (show integerOffset) + in case compare widthRatio heightRatio of + EQ -> [] + LT -> let + offset = getOffset ((pictureHeight % pageHeight) / widthRatio) + in [ ("t", offset) + , ("b", offset) + ] + GT -> let + offset = getOffset ((pictureWidth % pageWidth) / heightRatio) + in [ ("l", offset) + , ("r", offset) + ] + + +slideToIncrementalAnimations :: + [(ShapeId, Shape)] -> + [Element] +slideToIncrementalAnimations shapes = let + incrementals :: [(ShapeId, [Bool])] + incrementals = do + (shapeId, TextBox ps) <- shapes + pure . (shapeId,) $ do + Paragraph ParaProps{pPropIncremental} _ <- ps + pure pPropIncremental + toIndices :: [Bool] -> Maybe (NonEmpty (Integer, Integer)) + toIndices bs = do + let indexed = zip [0..] bs + ts <- nonEmpty (filter snd indexed) + pure (fmap (\(n, _) -> (n, n)) ts) + indices :: [(ShapeId, NonEmpty (Integer, Integer))] + indices = do + (shapeId, bs) <- incrementals + toList ((,) shapeId <$> toIndices bs) + in toList (incrementalAnimation <$> nonEmpty indices) -------------------------------------------------------------------- -- Notes: @@ -1316,8 +2045,8 @@ speakerNotesSlideNumber pgNum fieldId = ] slideToSpeakerNotesElement :: PandocMonad m => Slide -> P m (Maybe Element) -slideToSpeakerNotesElement (Slide _ _ (SpeakerNotes [])) = return Nothing -slideToSpeakerNotesElement slide@(Slide _ _ (SpeakerNotes paras)) = do +slideToSpeakerNotesElement (Slide _ _ (SpeakerNotes []) _) = return Nothing +slideToSpeakerNotesElement slide@(Slide _ _ (SpeakerNotes paras) _) = do master <- getNotesMaster fieldId <- getSlideNumberFieldId master num <- slideNum slide @@ -1373,11 +2102,14 @@ slideToFilePath slide = do idNum <- slideNum slide return $ "slide" <> show idNum <> ".xml" -slideToRelId :: PandocMonad m => Slide -> P m T.Text -slideToRelId slide = do +slideToRelId :: + PandocMonad m => + MinimumRId -> + Slide -> + P m T.Text +slideToRelId minSlideRId slide = do n <- slideNum slide - offset <- asks envSlideIdOffset - return $ "rId" <> tshow (n + offset) + return $ "rId" <> tshow (n + minSlideRId - 1) data Relationship = Relationship { relId :: Int @@ -1396,19 +2128,18 @@ elementToRel element return $ Relationship num type' (T.unpack target) | otherwise = Nothing -slideToPresRel :: PandocMonad m => Slide -> P m Relationship -slideToPresRel slide = do +slideToPresRel :: PandocMonad m => Int -> Slide -> P m Relationship +slideToPresRel minimumSlideRId slide = do idNum <- slideNum slide - n <- asks envSlideIdOffset - let rId = idNum + n + let rId = idNum + minimumSlideRId - 1 fp = "slides/" <> idNumToFilePath idNum return $ Relationship { relId = rId , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" , relTarget = fp } -getRels :: PandocMonad m => P m [Relationship] -getRels = do +getPresentationRels :: PandocMonad m => P m [Relationship] +getPresentationRels = do refArchive <- asks envRefArchive distArchive <- asks envDistArchive relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels" @@ -1416,42 +2147,77 @@ getRels = do let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem return $ mapMaybe elementToRel relElems -presentationToRels :: PandocMonad m => Presentation -> P m [Relationship] +-- | Info required to update a presentation rId from the reference doc for the +-- output. +type PresentationRIdUpdateData = (ReferenceMinRIdAfterSlides, NewRIdBounds) + +-- | The minimum and maximum rIds for presentation relationships created from +-- the presentation content (as opposed to from the reference doc). +-- +-- Relationships taken from the reference doc should have their rId number +-- adjusted to make sure it sits outside this range. +type NewRIdBounds = (MinimumRId, MaximumRId) + +-- | The minimum presentation rId from the reference doc which comes after the +-- first slide rId (in the reference doc). +type ReferenceMinRIdAfterSlides = Int +type MinimumRId = Int +type MaximumRId = Int + +-- | Given a presentation rId from the reference doc, return the value it should +-- have in the output. +updatePresentationRId :: PresentationRIdUpdateData -> Int -> Int +updatePresentationRId (minOverlappingRId, (minNewId, maxNewId)) n + | n < minNewId = n + | otherwise = n - minOverlappingRId + maxNewId + 1 + +presentationToRels :: + PandocMonad m => + Presentation -> + P m (PresentationRIdUpdateData, [Relationship]) presentationToRels pres@(Presentation _ slides) = do - mySlideRels <- mapM slideToPresRel slides - let notesMasterRels = - [Relationship { relId = length mySlideRels + 2 - , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster" - , relTarget = "notesMasters/notesMaster1.xml" - } | presHasSpeakerNotes pres] - insertedRels = mySlideRels <> notesMasterRels - rels <- getRels - -- we remove the slide rels and the notesmaster (if it's - -- there). We'll put these back in ourselves, if necessary. - let relsWeKeep = filter + rels <- getPresentationRels + + -- We want to make room for the slides in the id space. We'll assume the slide + -- masters come first (this seems to be what PowerPoint does by default, and + -- is true of the reference doc), and we'll put the slides next. So we find + -- the starting rId for the slides by finding the maximum rId for the masters + -- and adding 1. + -- + -- Then: + -- 1. We look to see what the minimum rId which is greater than or equal to + -- the minimum slide rId is, in the rels we're keeping from the reference + -- doc (i.e. the minimum rId which might overlap with the slides). + -- 2. We increase this minimum overlapping rId to 1 higher than the last slide + -- rId (or the notesMaster rel, if we're including one), and increase all + -- rIds higher than this minimum by the same amount. + + let masterRels = filter (T.isSuffixOf "slideMaster" . relType) rels + slideStartId = maybe 1 ((+ 1) . maximum . fmap relId) (nonEmpty masterRels) + -- we remove the slide rels and the notesmaster (if it's + -- there). We'll put these back in ourselves, if necessary. + relsWeKeep = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" && relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster") rels - -- We want to make room for the slides in the id space. The slides - -- will start at Id2 (since Id1 is for the slide master). There are - -- two slides in the data file, but that might change in the future, - -- so we will do this: - -- - -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is. - -- 2. We add the difference between this and the number of slides to - -- all relWithoutSlide rels (unless they're 1) - -- 3. If we have a notesmaster slide, we make space for that as well. + minOverlappingRel = maybe 0 minimum + (nonEmpty (filter (slideStartId <=) + (relId <$> relsWeKeep))) - let minRelNotOne = maybe 0 minimum $ nonEmpty - $ filter (1 <) $ map relId relsWeKeep + mySlideRels <- mapM (slideToPresRel slideStartId) slides - modifyRelNum :: Int -> Int - modifyRelNum 1 = 1 - modifyRelNum n = n - minRelNotOne + 2 + length insertedRels + let notesMasterRels = + [Relationship { relId = slideStartId + length mySlideRels + , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster" + , relTarget = "notesMasters/notesMaster1.xml" + } | presHasSpeakerNotes pres] + insertedRels = mySlideRels <> notesMasterRels + newRIdBounds = (slideStartId, slideStartId + length insertedRels - 1) + updateRId = updatePresentationRId (minOverlappingRel, newRIdBounds) - relsWeKeep' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWeKeep + relsWeKeep' = map (\r -> r{relId = updateRId $ relId r}) relsWeKeep - return $ insertedRels <> relsWeKeep' + return ((minOverlappingRel, newRIdBounds), insertedRels <> relsWeKeep') -- We make this ourselves, in case there's a thumbnail in the one from -- the template. @@ -1488,10 +2254,14 @@ relsToElement rels = mknode "Relationships" [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] (map relToElement rels) -presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry +presentationToRelsEntry :: + PandocMonad m => + Presentation -> + P m (PresentationRIdUpdateData, Entry) presentationToRelsEntry pres = do - rels <- presentationToRels pres - elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels + (presentationRIdUpdateData, rels) <- presentationToRels pres + element <- elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels + pure (presentationRIdUpdateData, element) elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry elemToEntry fp element = do @@ -1522,7 +2292,7 @@ slideToSpeakerNotesEntry slide = do _ -> return Nothing slideToSpeakerNotesRelElement :: PandocMonad m => Slide -> P m (Maybe Element) -slideToSpeakerNotesRelElement (Slide _ _ (SpeakerNotes [])) = return Nothing +slideToSpeakerNotesRelElement (Slide _ _ (SpeakerNotes []) _) = return Nothing slideToSpeakerNotesRelElement slide@Slide{} = do idNum <- slideNum slide return $ Just $ @@ -1606,11 +2376,16 @@ speakerNotesSlideRelElement slide = do slideToSlideRelElement :: PandocMonad m => Slide -> P m Element slideToSlideRelElement slide = do idNum <- slideNum slide - let target = case slide of - (Slide _ MetadataSlide{} _) -> "../slideLayouts/slideLayout1.xml" - (Slide _ TitleSlide{} _) -> "../slideLayouts/slideLayout3.xml" - (Slide _ ContentSlide{} _) -> "../slideLayouts/slideLayout2.xml" - (Slide _ TwoColumnSlide{} _) -> "../slideLayouts/slideLayout4.xml" + target <- flip fmap getSlideLayouts $ + T.pack . ("../slideLayouts/" <>) . takeFileName . + slPath . case slide of + (Slide _ MetadataSlide{} _ _) -> metadata + (Slide _ TitleSlide{} _ _) -> title + (Slide _ ContentSlide{} _ _) -> content + (Slide _ TwoColumnSlide{} _ _) -> twoColumn + (Slide _ ComparisonSlide{} _ _) -> comparison + (Slide _ ContentWithCaptionSlide{} _ _) -> contentWithCaption + (Slide _ BlankSlide _ _) -> blank speakerNotesRels <- maybeToList <$> speakerNotesSlideRelElement slide @@ -1632,24 +2407,37 @@ slideToSlideRelElement slide = do , ("Target", target)] () ] <> speakerNotesRels <> linkRels <> mediaRels) -slideToSldIdElement :: PandocMonad m => Slide -> P m Element -slideToSldIdElement slide = do +slideToSldIdElement :: + PandocMonad m => + MinimumRId -> + Slide -> + P m Element +slideToSldIdElement minimumSlideRId slide = do n <- slideNum slide let id' = tshow $ n + 255 - rId <- slideToRelId slide + rId <- slideToRelId minimumSlideRId slide return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] () -presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element -presentationToSldIdLst (Presentation _ slides) = do - ids <- mapM slideToSldIdElement slides +presentationToSldIdLst :: + PandocMonad m => + MinimumRId -> + Presentation -> + P m Element +presentationToSldIdLst minimumSlideRId (Presentation _ slides) = do + ids <- mapM (slideToSldIdElement minimumSlideRId) slides return $ mknode "p:sldIdLst" [] ids -presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element -presentationToPresentationElement pres@(Presentation _ slds) = do +presentationToPresentationElement :: + PandocMonad m => + PresentationRIdUpdateData -> + Presentation -> + P m Element +presentationToPresentationElement presentationUpdateRIdData pres = do + let (_, (minSlideRId, maxSlideRId)) = presentationUpdateRIdData refArchive <- asks envRefArchive distArchive <- asks envDistArchive element <- parseXml refArchive distArchive "ppt/presentation.xml" - sldIdLst <- presentationToSldIdLst pres + sldIdLst <- presentationToSldIdLst minSlideRId pres let modifySldIdLst :: Content -> Content modifySldIdLst (Elem e) = case elName e of @@ -1657,11 +2445,11 @@ presentationToPresentationElement pres@(Presentation _ slds) = do _ -> Elem e modifySldIdLst ct = ct - notesMasterRId = length slds + 2 + notesMasterRId = maxSlideRId notesMasterElem = mknode "p:notesMasterIdLst" [] [ mknode - "p:NotesMasterId" + "p:notesMasterId" [("r:id", "rId" <> tshow notesMasterRId)] () ] @@ -1692,16 +2480,34 @@ presentationToPresentationElement pres@(Presentation _ slds) = do then concatMap insertNotesMaster' else id + updateRIds :: Content -> Content + updateRIds (Elem el) = + Elem (el { elAttribs = fmap updateRIdAttribute (elAttribs el) + , elContent = fmap updateRIds (elContent el) + }) + updateRIds content = content + + updateRIdAttribute :: XML.Attr -> XML.Attr + updateRIdAttribute attr = fromMaybe attr $ do + oldValue <- case attrKey attr of + QName "id" _ (Just "r") -> + T.stripPrefix "rId" (attrVal attr) + >>= fmap fromIntegral . readTextAsInteger + _ -> Nothing + let newValue = updatePresentationRId presentationUpdateRIdData oldValue + pure attr {attrVal = "rId" <> T.pack (show newValue)} + newContent = insertNotesMaster $ removeUnwantedMaster $ - map modifySldIdLst $ + (modifySldIdLst . updateRIds) <$> elContent element return $ element{elContent = newContent} -presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry -presentationToPresEntry pres = presentationToPresentationElement pres >>= - elemToEntry "ppt/presentation.xml" +presentationToPresEntry :: PandocMonad m => PresentationRIdUpdateData -> Presentation -> P m Entry +presentationToPresEntry presentationRIdUpdateData pres = + presentationToPresentationElement presentationRIdUpdateData pres >>= + elemToEntry "ppt/presentation.xml" -- adapted from the Docx writer docPropsElement :: PandocMonad m => DocProps -> P m Element @@ -1920,3 +2726,102 @@ autoNumAttrs (startNum, numStyle, numDelim) = OneParen -> "ParenR" TwoParens -> "ParenBoth" _ -> "Period" + +-- | The XML required to insert an "appear" animation for each of the given +-- groups of paragraphs, identified by index. +incrementalAnimation :: + -- | (ShapeId, [(startParagraphIndex, endParagraphIndex)]) + NonEmpty (ShapeId, NonEmpty (Integer, Integer)) -> + Element +incrementalAnimation indices = mknode "p:timing" [] [tnLst, bldLst] + where + triples :: NonEmpty (ShapeId, Integer, Integer) + triples = do + (shapeId, paragraphIds) <- indices + (start, end) <- paragraphIds + pure (shapeId, start, end) + + tnLst = mknode "p:tnLst" [] + $ mknode "p:par" [] + $ mknode "p:cTn" [ ("id", "1") + , ("dur", "indefinite") + , ("restart", "never") + , ("nodeType", "tmRoot") + ] + $ mknode "p:childTnLst" [] + $ mknode "p:seq" [ ("concurrent", "1") + , ("nextAc", "seek") + ] + [ mknode "p:cTn" [ ("id", "2") + , ("dur", "indefinite") + , ("nodeType", "mainSeq") + ] + $ mknode "p:childTnLst" [] + $ zipWith makePar [3, 7 ..] (toList triples) + , mknode "p:prevCondLst" [] + $ mknode "p:cond" ([("evt", "onPrev"), ("delay", "0")]) + $ mknode "p:tgtEl" [] + $ mknode "p:sldTgt" [] () + , mknode "p:nextCondLst" [] + $ mknode "p:cond" ([("evt", "onNext"), ("delay", "0")]) + $ mknode "p:tgtEl" [] + $ mknode "p:sldTgt" [] () + ] + bldLst = mknode "p:bldLst" [] + [ mknode "p:bldP" [ ("spid", T.pack (show shapeId)) + , ("grpId", "0") + , ("uiExpand", "1") + , ("build", "p") + ] + () | (shapeId, _) <- toList indices + ] + + makePar :: Integer -> (ShapeId, Integer, Integer) -> Element + makePar nextId (shapeId, start, end) = + mknode "p:par" [] + $ mknode "p:cTn" [("id", T.pack (show nextId)), ("fill", "hold")] + [ mknode "p:stCondLst" [] + $ mknode "p:cond" [("delay", "indefinite")] () + , mknode "p:childTnLst" [] + $ mknode "p:par" [] + $ mknode "p:cTn" [ ("id", T.pack (show (nextId + 1))) + , ("fill", "hold") + ] + [ mknode "p:stCondLst" [] + $ mknode "p:cond" [("delay", "0")] () + , mknode "p:childTnLst" [] + $ mknode "p:par" [] + $ mknode "p:cTn" [ ("id", T.pack (show (nextId + 2))) + , ("presetID", "1") + , ("presetClass", "entr") + , ("presetSubtype", "0") + , ("fill", "hold") + , ("grpId", "0") + , ("nodeType", "clickEffect") + ] + [ mknode "p:stCondLst" [] + $ mknode "p:cond" [("delay", "0")] () + , mknode "p:childTnLst" [] + $ mknode "p:set" [] + [ mknode "p:cBhvr" [] + [ mknode "p:cTn" [ ("id", T.pack (show (nextId + 3))) + , ("dur", "1") + , ("fill", "hold") + ] + $ mknode "p:stCondLst" [] + $ mknode "p:cond" [("delay", "0")] () + , mknode "p:tgtEl" [] + $ mknode "p:spTgt" [("spid", T.pack (show shapeId))] + $ mknode "p:txEl" [] + $ mknode "p:pRg" [ ("st", T.pack (show start)) + , ("end", T.pack (show end))] + () + , mknode "p:attrNameLst" [] + $ mknode "p:attrName" [] ("style.visibility" :: Text) + ] + , mknode "p:to" [] + $ mknode "p:strVal" [("val", "visible")] () + ] + ] + ] + ] diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs index 9246a93e9..fd6b83120 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | Module : Text.Pandoc.Writers.Powerpoint.Presentation Copyright : Copyright (C) 2017-2020 Jesse Rosenthal @@ -53,7 +55,6 @@ import Text.Pandoc.Slides (getSlideLevel) import Text.Pandoc.Options import Text.Pandoc.Logging import Text.Pandoc.Walk -import Data.Time (UTCTime) import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element" import Text.Pandoc.Shared (tshow) import Text.Pandoc.Writers.Shared (lookupMetaInlines, lookupMetaBlocks @@ -61,11 +62,13 @@ import Text.Pandoc.Writers.Shared (lookupMetaInlines, lookupMetaBlocks , toLegacyTable) import qualified Data.Map as M import qualified Data.Set as S -import Data.Maybe (maybeToList, fromMaybe) +import Data.Maybe (maybeToList, fromMaybe, listToMaybe, isNothing) import Text.Pandoc.Highlighting import qualified Data.Text as T import Control.Applicative ((<|>)) import Skylighting +import Data.Bifunctor (bimap) +import Data.Char (isSpace) data WriterEnv = WriterEnv { envMetadata :: Meta , envRunProps :: RunProps @@ -77,6 +80,8 @@ data WriterEnv = WriterEnv { envMetadata :: Meta , envInNoteSlide :: Bool , envCurSlideId :: SlideId , envInSpeakerNotes :: Bool + , envInIncrementalDiv :: Maybe InIncrementalDiv + , envInListInBlockQuote :: Bool } deriving (Show) @@ -91,6 +96,8 @@ instance Default WriterEnv where , envInNoteSlide = False , envCurSlideId = SlideId "Default" , envInSpeakerNotes = False + , envInIncrementalDiv = Nothing + , envInListInBlockQuote = False } @@ -111,6 +118,23 @@ instance Default WriterState where , stSpeakerNotes = mempty } +data InIncrementalDiv + = InIncremental + -- ^ The current content is contained within an "incremental" div. + | InNonIncremental + -- ^ The current content is contained within a "nonincremental" div. + deriving (Show) + +listShouldBeIncremental :: Pres Bool +listShouldBeIncremental = do + incrementalOption <- asks (writerIncremental . envOpts) + inIncrementalDiv <- asks envInIncrementalDiv + inBlockQuote <- asks envInListInBlockQuote + let toBoolean = (\case InIncremental -> True + InNonIncremental -> False) + maybeInvert = if inBlockQuote then not else id + pure (maybeInvert (maybe incrementalOption toBoolean inIncrementalDiv)) + metadataSlideId :: SlideId metadataSlideId = SlideId "Metadata" @@ -168,7 +192,7 @@ data DocProps = DocProps { dcTitle :: Maybe T.Text , dcKeywords :: Maybe [T.Text] , dcDescription :: Maybe T.Text , cpCategory :: Maybe T.Text - , dcCreated :: Maybe UTCTime + , dcDate :: Maybe T.Text , customProperties :: Maybe [(T.Text, T.Text)] } deriving (Show, Eq) @@ -176,6 +200,7 @@ data DocProps = DocProps { dcTitle :: Maybe T.Text data Slide = Slide { slideId :: SlideId , slideLayout :: Layout , slideSpeakerNotes :: SpeakerNotes + , slideBackgroundImage :: Maybe FilePath } deriving (Show, Eq) newtype SlideId = SlideId T.Text @@ -195,9 +220,15 @@ data Layout = MetadataSlide [ParaElem] [ParaElem] [[ParaElem]] [ParaElem] -- heading content | TwoColumnSlide [ParaElem] [Shape] [Shape] -- heading left right + | ComparisonSlide [ParaElem] ([Shape], [Shape]) ([Shape], [Shape]) + -- heading left@(text, content) right@(text, content) + | ContentWithCaptionSlide [ParaElem] [Shape] [Shape] + -- heading text content + | BlankSlide deriving (Show, Eq) -data Shape = Pic PicProps FilePath [ParaElem] +data Shape = Pic PicProps FilePath T.Text [ParaElem] + -- title alt-text | GraphicFrame [Graphic] [ParaElem] | TextBox [Paragraph] | RawOOXMLShape T.Text @@ -218,7 +249,7 @@ data Graphic = Tbl TableProps [TableCell] [[TableCell]] data Paragraph = Paragraph { paraProps :: ParaProps - , paraElems :: [ParaElem] + , paraElems :: [ParaElem] } deriving (Show, Eq) data BulletType = Bullet @@ -235,6 +266,7 @@ data ParaProps = ParaProps { pPropMarginLeft :: Maybe Pixels , pPropAlign :: Maybe Algnment , pPropSpaceBefore :: Maybe Pixels , pPropIndent :: Maybe Pixels + , pPropIncremental :: Bool } deriving (Show, Eq) instance Default ParaProps where @@ -245,6 +277,7 @@ instance Default ParaProps where , pPropAlign = Nothing , pPropSpaceBefore = Nothing , pPropIndent = Just 0 + , pPropIncremental = False } newtype TeXString = TeXString {unTeXString :: T.Text} @@ -315,7 +348,7 @@ instance Default PicProps where -------------------------------------------------- inlinesToParElems :: [Inline] -> Pres [ParaElem] -inlinesToParElems ils = concatMapM inlineToParElems ils +inlinesToParElems = concatMapM inlineToParElems inlineToParElems :: Inline -> Pres [ParaElem] inlineToParElems (Str s) = do @@ -440,7 +473,8 @@ blockToParagraphs (CodeBlock attr str) = do -- (BlockQuote List) as a list to maintain compatibility with other -- formats. blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do - ps <- blockToParagraphs blk + ps <- local (\env -> env { envInListInBlockQuote = True }) + (blockToParagraphs blk) ps' <- blockToParagraphs $ BlockQuote blks return $ ps ++ ps' blockToParagraphs (BlockQuote blks) = @@ -465,25 +499,26 @@ blockToParagraphs (Header _ (ident, _, _) ils) = do return [Paragraph def{pPropSpaceBefore = Just 30} parElems] blockToParagraphs (BulletList blksLst) = do pProps <- asks envParaProps - let lvl = pPropLevel pProps + incremental <- listShouldBeIncremental local (\env -> env{ envInList = True - , envParaProps = pProps{ pPropLevel = lvl + 1 - , pPropBullet = Just Bullet + , envParaProps = pProps{ pPropBullet = Just Bullet , pPropMarginLeft = Nothing , pPropIndent = Nothing + , pPropIncremental = incremental }}) $ - concatMapM multiParBullet blksLst + concatMapM multiParList blksLst blockToParagraphs (OrderedList listAttr blksLst) = do pProps <- asks envParaProps - let lvl = pPropLevel pProps + incremental <- listShouldBeIncremental local (\env -> env{ envInList = True - , envParaProps = pProps{ pPropLevel = lvl + 1 - , pPropBullet = Just (AutoNumbering listAttr) + , envParaProps = pProps{ pPropBullet = Just (AutoNumbering listAttr) , pPropMarginLeft = Nothing , pPropIndent = Nothing + , pPropIncremental = incremental }}) $ - concatMapM multiParBullet blksLst + concatMapM multiParList blksLst blockToParagraphs (DefinitionList entries) = do + incremental <- listShouldBeIncremental let go :: ([Inline], [[Block]]) -> Pres [Paragraph] go (ils, blksLst) = do term <-blockToParagraphs $ Para [Strong ils] @@ -491,20 +526,35 @@ blockToParagraphs (DefinitionList entries) = do -- blockquote. We can extend this further later. definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst return $ term ++ definition - concatMapM go entries -blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks + local (\env -> env {envParaProps = + (envParaProps env) {pPropIncremental = incremental}}) + $ concatMapM go entries +blockToParagraphs (Div (_, classes, _) blks) = let + hasIncremental = "incremental" `elem` classes + hasNonIncremental = "nonincremental" `elem` classes + incremental = if | hasIncremental -> Just InIncremental + | hasNonIncremental -> Just InNonIncremental + | otherwise -> Nothing + addIncremental env = env { envInIncrementalDiv = incremental } + in local addIncremental (concatMapM blockToParagraphs blks) blockToParagraphs blk = do addLogMessage $ BlockNotRendered blk return [] --- Make sure the bullet env gets turned off after the first para. -multiParBullet :: [Block] -> Pres [Paragraph] -multiParBullet [] = return [] -multiParBullet (b:bs) = do +-- | Make sure the bullet env gets turned off after the first para. +multiParList :: [Block] -> Pres [Paragraph] +multiParList [] = return [] +multiParList (b:bs) = do pProps <- asks envParaProps p <- blockToParagraphs b - ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $ - concatMapM blockToParagraphs bs + let level = pPropLevel pProps + ps <- local (\env -> env + { envParaProps = pProps + { pPropBullet = Nothing + , pPropLevel = level + 1 + } + }) + $ concatMapM blockToParagraphs bs return $ p ++ ps cellToParagraphs :: Alignment -> SimpleCell -> Pres [Paragraph] @@ -525,21 +575,22 @@ rowToParagraphs algns tblCells = do mapM (uncurry cellToParagraphs) pairs withAttr :: Attr -> Shape -> Shape -withAttr attr (Pic picPr url caption) = +withAttr attr (Pic picPr url title caption) = let picPr' = picPr { picWidth = dimension Width attr , picHeight = dimension Height attr } in - Pic picPr' url caption + Pic picPr' url title caption withAttr _ sp = sp blockToShape :: Block -> Pres Shape blockToShape (Plain ils) = blockToShape (Para ils) -blockToShape (Para (il:_)) | Image attr ils (url, _) <- il = - withAttr attr . Pic def (T.unpack url) <$> inlinesToParElems ils +blockToShape (Para (il:_)) | Image attr ils (url, title) <- il = + withAttr attr . Pic def (T.unpack url) title <$> inlinesToParElems ils blockToShape (Para (il:_)) | Link _ (il':_) target <- il - , Image attr ils (url, _) <- il' = - withAttr attr . Pic def{picPropLink = Just $ ExternalTarget target} (T.unpack url) + , Image attr ils (url, title) <- il' = + withAttr attr . + Pic def{picPropLink = Just $ ExternalTarget target} (T.unpack url) title <$> inlinesToParElems ils blockToShape (Table _ blkCapt specs thead tbody tfoot) = do let (caption, algn, _, hdrCells, rows) = toLegacyTable blkCapt specs thead tbody tfoot @@ -582,7 +633,30 @@ isImage Image{} = True isImage (Link _ (Image{} : _) _) = True isImage _ = False -splitBlocks' :: [Block] -> [[Block]] -> [Block] -> Pres [[Block]] +plainOrPara :: Block -> Maybe [Inline] +plainOrPara (Plain ils) = Just ils +plainOrPara (Para ils) = Just ils +plainOrPara _ = Nothing + +notText :: Block -> Bool +notText block | startsWithImage block = True +notText Table{} = True +notText _ = False + +startsWithImage :: Block -> Bool +startsWithImage block = fromMaybe False $ do + inline <- plainOrPara block >>= listToMaybe + pure (isImage inline) + +-- | Group blocks into a number of "splits" +splitBlocks' :: + -- | Blocks so far in the current split + [Block] -> + -- | Splits so far + [[Block]] -> + -- | All remaining blocks + [Block] -> + Pres [[Block]] splitBlocks' cur acc [] = return $ acc ++ ([cur | not (null cur)]) splitBlocks' cur acc (HorizontalRule : blks) = splitBlocks' [] (acc ++ ([cur | not (null cur)])) blks @@ -602,25 +676,31 @@ splitBlocks' cur acc (Para (il:ils) : blks) | isImage il = do then span isNotesDiv blks else ([], blks) case cur of - [Header n _ _] | n == slideLevel -> + [Header n _ _] | n == slideLevel || slideLevel == 0 -> splitBlocks' [] (acc ++ [cur ++ [Para [il]] ++ nts]) (if null ils then blks' else Para ils : blks') _ -> splitBlocks' [] - (acc ++ ([cur | not (null cur)]) ++ [Para [il] : nts]) + (if any notText cur + then acc ++ ([cur | not (null cur)]) ++ [Para [il] : nts] + else acc ++ [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 -> + [Header n _ _] | n == slideLevel || slideLevel == 0 -> splitBlocks' [] (acc ++ [cur ++ [tbl] ++ nts]) blks' - _ -> splitBlocks' [] (acc ++ ([cur | not (null cur)]) ++ [tbl : nts]) blks' + _ -> splitBlocks' [] + (if any notText cur + then acc ++ ([cur | not (null cur)]) ++ [tbl : nts] + else acc ++ ([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 -> + [Header n _ _] | n == slideLevel || slideLevel == 0 -> splitBlocks' [] (acc ++ [cur ++ [d] ++ nts]) blks' _ -> splitBlocks' [] (acc ++ ([cur | not (null cur)]) ++ [d : nts]) blks' splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks @@ -628,63 +708,96 @@ splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks splitBlocks :: [Block] -> Pres [[Block]] splitBlocks = splitBlocks' [] [] +-- | Assuming the slide title is already handled, convert these blocks to the +-- body content for the slide. +bodyBlocksToSlide :: Int -> [Block] -> SpeakerNotes -> Pres Slide +bodyBlocksToSlide _ (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 + mapM_ (addLogMessage . BlockNotRendered) (blks ++ remaining) + let mkTwoColumn left right = do + blksL' <- join . take 1 <$> splitBlocks left + blksR' <- join . take 1 <$> splitBlocks right + shapesL <- blocksToShapes blksL' + shapesR <- blocksToShapes blksR' + sldId <- asks envCurSlideId + return $ Slide + sldId + (TwoColumnSlide [] shapesL shapesR) + spkNotes + Nothing + let mkComparison blksL1 blksL2 blksR1 blksR2 = do + shapesL1 <- blocksToShapes blksL1 + shapesL2 <- blocksToShapes blksL2 + shapesR1 <- blocksToShapes blksR1 + shapesR2 <- blocksToShapes blksR2 + sldId <- asks envCurSlideId + return $ Slide + sldId + (ComparisonSlide [] (shapesL1, shapesL2) (shapesR1, shapesR2)) + spkNotes + Nothing + let (blksL1, blksL2) = break notText blksL + (blksR1, blksR2) = break notText blksR + if (any null [blksL1, blksL2]) && (any null [blksR1, blksR2]) + then mkTwoColumn blksL blksR + else mkComparison blksL1 blksL2 blksR1 blksR2 +bodyBlocksToSlide _ (blk : blks) spkNotes = do + sldId <- asks envCurSlideId + inNoteSlide <- asks envInNoteSlide + let mkSlide s = + Slide sldId s spkNotes Nothing + if inNoteSlide + then mkSlide . ContentSlide [] <$> + forceFontSize noteSize (blocksToShapes (blk : blks)) + else let + contentOrBlankSlide = + if makesBlankSlide (blk : blks) + then pure (mkSlide BlankSlide) + else mkSlide . ContentSlide [] <$> blocksToShapes (blk : blks) + in case break notText (blk : blks) of + ([], _) -> contentOrBlankSlide + (_, []) -> contentOrBlankSlide + (textBlocks, contentBlocks) -> do + textShapes <- blocksToShapes textBlocks + contentShapes <- blocksToShapes contentBlocks + return (mkSlide (ContentWithCaptionSlide [] textShapes contentShapes)) +bodyBlocksToSlide _ [] spkNotes = do + sldId <- asks envCurSlideId + return $ + Slide + sldId + BlankSlide + spkNotes + Nothing + blocksToSlide' :: Int -> [Block] -> SpeakerNotes -> Pres Slide -blocksToSlide' lvl (Header n (ident, _, _) ils : blks) spkNotes +blocksToSlide' lvl (Header n (ident, _, attributes) ils : blks) spkNotes | n < lvl = do registerAnchorId ident sldId <- asks envCurSlideId hdr <- inlinesToParElems ils - return $ Slide sldId (TitleSlide hdr) spkNotes - | n == lvl = do + return $ Slide sldId (TitleSlide hdr) spkNotes backgroundImage + | n == lvl || lvl == 0 = do registerAnchorId ident hdr <- inlinesToParElems ils -- Now get the slide without the header, and then add the header -- in. - slide <- blocksToSlide' lvl blks spkNotes + slide <- bodyBlocksToSlide lvl blks spkNotes let layout = case slideLayout slide of ContentSlide _ cont -> ContentSlide hdr cont TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR + ComparisonSlide _ contL contR -> ComparisonSlide hdr contL contR + ContentWithCaptionSlide _ text content -> ContentWithCaptionSlide hdr text content + BlankSlide -> if all inlineIsBlank ils then BlankSlide else ContentSlide hdr [] layout' -> layout' - return $ slide{slideLayout = layout} -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 - mapM_ (addLogMessage . BlockNotRendered) (blks ++ remaining) - mbSplitBlksL <- splitBlocks blksL - mbSplitBlksR <- splitBlocks blksR - let blksL' = case mbSplitBlksL of - bs : _ -> bs - [] -> [] - let blksR' = case mbSplitBlksR of - bs : _ -> bs - [] -> [] - shapesL <- blocksToShapes blksL' - shapesR <- blocksToShapes blksR' - sldId <- asks envCurSlideId - return $ Slide - sldId - (TwoColumnSlide [] shapesL shapesR) - spkNotes -blocksToSlide' _ (blk : blks) spkNotes = do - inNoteSlide <- asks envInNoteSlide - shapes <- if inNoteSlide - then forceFontSize noteSize $ blocksToShapes (blk : blks) - else blocksToShapes (blk : blks) - sldId <- asks envCurSlideId - return $ - Slide - sldId - (ContentSlide [] shapes) - spkNotes -blocksToSlide' _ [] spkNotes = do - sldId <- asks envCurSlideId - return $ - Slide - sldId - (ContentSlide [] []) - spkNotes + return $ slide{slideLayout = layout, slideBackgroundImage = backgroundImage} + where + backgroundImage = T.unpack <$> (lookup "background-image" attributes + <|> lookup "data-background-image" attributes) +blocksToSlide' lvl blks spkNotes = bodyBlocksToSlide lvl blks spkNotes blockToSpeakerNotes :: Block -> Pres SpeakerNotes blockToSpeakerNotes (Div (_, ["notes"], _) blks) = @@ -764,12 +877,13 @@ getMetaSlide = do metadataSlideId (MetadataSlide title subtitle authors date) mempty + Nothing addSpeakerNotesToMetaSlide :: Slide -> [Block] -> Pres (Slide, [Block]) -addSpeakerNotesToMetaSlide (Slide sldId layout@MetadataSlide{} spkNotes) blks = +addSpeakerNotesToMetaSlide (Slide sldId layout@MetadataSlide{} spkNotes backgroundImage) blks = do let (ntsBlks, blks') = span isNotesDiv blks spkNotes' <- mconcat <$> mapM blockToSpeakerNotes ntsBlks - return (Slide sldId layout (spkNotes <> spkNotes'), blks') + return (Slide sldId layout (spkNotes <> spkNotes') backgroundImage, blks') addSpeakerNotesToMetaSlide sld blks = return (sld, blks) makeTOCSlide :: [Block] -> Pres Slide @@ -805,7 +919,7 @@ applyToParagraph f para = do return $ para {paraElems = paraElems'} applyToShape :: Monad m => (ParaElem -> m ParaElem) -> Shape -> m Shape -applyToShape f (Pic pPr fp pes) = Pic pPr fp <$> mapM f pes +applyToShape f (Pic pPr fp title pes) = Pic pPr fp title <$> mapM f pes applyToShape f (GraphicFrame gfx pes) = GraphicFrame gfx <$> mapM f pes applyToShape f (TextBox paras) = TextBox <$> mapM (applyToParagraph f) paras applyToShape _ (RawOOXMLShape str) = return $ RawOOXMLShape str @@ -827,6 +941,19 @@ applyToLayout f (TwoColumnSlide hdr contentL contentR) = do contentL' <- mapM (applyToShape f) contentL contentR' <- mapM (applyToShape f) contentR return $ TwoColumnSlide hdr' contentL' contentR' +applyToLayout f (ComparisonSlide hdr (contentL1, contentL2) (contentR1, contentR2)) = do + hdr' <- mapM f hdr + contentL1' <- mapM (applyToShape f) contentL1 + contentL2' <- mapM (applyToShape f) contentL2 + contentR1' <- mapM (applyToShape f) contentR1 + contentR2' <- mapM (applyToShape f) contentR2 + return $ ComparisonSlide hdr' (contentL1', contentL2') (contentR1', contentR2') +applyToLayout f (ContentWithCaptionSlide hdr textShapes contentShapes) = do + hdr' <- mapM f hdr + textShapes' <- mapM (applyToShape f) textShapes + contentShapes' <- mapM (applyToShape f) contentShapes + return $ ContentWithCaptionSlide hdr' textShapes' contentShapes' +applyToLayout _ BlankSlide = pure BlankSlide applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide applyToSlide f slide = do @@ -878,9 +1005,72 @@ emptyLayout layout = case layout of all emptyParaElem hdr && all emptyShape shapes1 && all emptyShape shapes2 + ComparisonSlide hdr (shapesL1, shapesL2) (shapesR1, shapesR2) -> + all emptyParaElem hdr && + all emptyShape shapesL1 && + all emptyShape shapesL2 && + all emptyShape shapesR1 && + all emptyShape shapesR2 + ContentWithCaptionSlide hdr textShapes contentShapes -> + all emptyParaElem hdr && + all emptyShape textShapes && + all emptyShape contentShapes + BlankSlide -> False + emptySlide :: Slide -> Bool -emptySlide (Slide _ layout notes) = (notes == mempty) && emptyLayout layout +emptySlide (Slide _ layout notes backgroundImage) + = (notes == mempty) + && emptyLayout layout + && isNothing backgroundImage + +makesBlankSlide :: [Block] -> Bool +makesBlankSlide = all blockIsBlank + +blockIsBlank :: Block -> Bool +blockIsBlank + = \case + Plain ins -> all inlineIsBlank ins + Para ins -> all inlineIsBlank ins + LineBlock inss -> all (all inlineIsBlank) inss + CodeBlock _ txt -> textIsBlank txt + RawBlock _ txt -> textIsBlank txt + BlockQuote bls -> all blockIsBlank bls + OrderedList _ blss -> all (all blockIsBlank) blss + BulletList blss -> all (all blockIsBlank) blss + DefinitionList ds -> all (uncurry (&&) . bimap (all inlineIsBlank) (all (all blockIsBlank))) ds + Header _ _ ils -> all inlineIsBlank ils + HorizontalRule -> True + Table{} -> False + Div _ bls -> all blockIsBlank bls + Null -> True + +textIsBlank :: T.Text -> Bool +textIsBlank = T.all isSpace + +inlineIsBlank :: Inline -> Bool +inlineIsBlank + = \case + (Str txt) -> textIsBlank txt + (Emph ins) -> all inlineIsBlank ins + (Underline ins) -> all inlineIsBlank ins + (Strong ins) -> all inlineIsBlank ins + (Strikeout ins) -> all inlineIsBlank ins + (Superscript ins) -> all inlineIsBlank ins + (Subscript ins) -> all inlineIsBlank ins + (SmallCaps ins) -> all inlineIsBlank ins + (Quoted _ ins) -> all inlineIsBlank ins + (Cite _ _) -> False + (Code _ txt) -> textIsBlank txt + Space -> True + SoftBreak -> True + LineBreak -> True + (Math _ txt) -> textIsBlank txt + (RawInline _ txt) -> textIsBlank txt + (Link _ ins (t1, t2)) -> all inlineIsBlank ins && textIsBlank t1 && textIsBlank t2 + (Image _ ins (t1, t2)) -> all inlineIsBlank ins && textIsBlank t1 && textIsBlank t2 + (Note bls) -> all blockIsBlank bls + (Span _ ins) -> all inlineIsBlank ins blocksToPresentationSlides :: [Block] -> Pres [Slide] blocksToPresentationSlides blks = do @@ -960,7 +1150,11 @@ metaToDocProps meta = , dcKeywords = keywords , dcDescription = description , cpCategory = Shared.stringify <$> lookupMeta "category" meta - , dcCreated = Nothing + , dcDate = + let t = Shared.stringify (docDate meta) + in if T.null t + then Nothing + else Just t , customProperties = customProperties' } diff --git a/src/Text/Pandoc/Writers/RST.hs b/src/Text/Pandoc/Writers/RST.hs index 983ef412a..08733a792 100644 --- a/src/Text/Pandoc/Writers/RST.hs +++ b/src/Text/Pandoc/Writers/RST.hs @@ -219,28 +219,34 @@ blockToRST (Div (ident,classes,_kvs) bs) = do nest 3 contents $$ blankline blockToRST (Plain inlines) = inlineListToRST inlines -blockToRST (Para [Image attr txt (src, rawtit)]) = do +blockToRST (SimpleFigure attr txt (src, tit)) = do description <- inlineListToRST txt dims <- imageDimsToRST attr - -- title beginning with fig: indicates that the image is a figure - let (isfig, tit) = case T.stripPrefix "fig:" rawtit of - Nothing -> (False, rawtit) - Just tit' -> (True, tit') - let fig | isfig = "figure:: " <> literal src - | otherwise = "image:: " <> literal src - alt | isfig = ":alt: " <> if T.null tit then description else literal tit - | null txt = empty + let fig = "figure:: " <> literal src + alt = ":alt: " <> if T.null tit then description else literal tit + capt = description + (_,cls,_) = attr + classes = case cls of + [] -> empty + ["align-right"] -> ":align: right" + ["align-left"] -> ":align: left" + ["align-center"] -> ":align: center" + _ -> ":figclass: " <> literal (T.unwords cls) + return $ hang 3 ".. " (fig $$ alt $$ classes $$ dims $+$ capt) $$ blankline +blockToRST (Para [Image attr txt (src, _)]) = do + description <- inlineListToRST txt + dims <- imageDimsToRST attr + let fig = "image:: " <> literal src + alt | null txt = empty | otherwise = ":alt: " <> description - capt | isfig = description - | otherwise = empty + capt = empty (_,cls,_) = attr classes = case cls of [] -> empty ["align-right"] -> ":align: right" ["align-left"] -> ":align: left" ["align-center"] -> ":align: center" - _ | isfig -> ":figclass: " <> literal (T.unwords cls) - | otherwise -> ":class: " <> literal (T.unwords cls) + _ -> ":class: " <> literal (T.unwords cls) return $ hang 3 ".. " (fig $$ alt $$ classes $$ dims $+$ capt) $$ blankline blockToRST (Para inlines) | LineBreak `elem` inlines = @@ -270,7 +276,12 @@ blockToRST (Header level (name,classes,_) inlines) = do let headerChar = if level > 5 then ' ' else "=-~^'" !! (level - 1) let border = literal $ T.replicate (offset contents) $ T.singleton headerChar let anchor | T.null name || name == autoId = empty - | otherwise = ".. _" <> literal name <> ":" $$ blankline + | otherwise = ".. _" <> + (if T.any (==':') name || + T.take 1 name == "_" + then "`" <> literal name <> "`" + else literal name) <> + ":" $$ blankline return $ nowrap $ anchor $$ contents $$ border $$ blankline else do let rub = "rubric:: " <> contents @@ -402,7 +413,7 @@ blockListToRST' topLevel blocks = do toClose Header{} = False toClose LineBlock{} = False toClose HorizontalRule = False - toClose (Para [Image _ _ (_,t)]) = "fig:" `T.isPrefixOf` t + toClose SimpleFigure{} = True toClose Para{} = False toClose _ = True commentSep = RawBlock "rst" "..\n\n" diff --git a/src/Text/Pandoc/Writers/RTF.hs b/src/Text/Pandoc/Writers/RTF.hs index 3527949b4..eeef3eaf3 100644 --- a/src/Text/Pandoc/Writers/RTF.hs +++ b/src/Text/Pandoc/Writers/RTF.hs @@ -43,10 +43,11 @@ rtfEmbedImage opts x@(Image attr _ (src,_)) = catchError (do result <- P.fetchItem src case result of (imgdata, Just mime) - | mime == "image/jpeg" || mime == "image/png" -> do + | mime' <- T.takeWhile (/=';') mime + , mime' == "image/jpeg" || mime' == "image/png" -> do let bytes = map (T.pack . printf "%02x") $ B.unpack imgdata filetype <- - case mime of + case mime' of "image/jpeg" -> return "\\jpegblip" "image/png" -> return "\\pngblip" _ -> throwError $ @@ -64,7 +65,7 @@ rtfEmbedImage opts x@(Image attr _ (src,_)) = catchError -- twip = 1/1440in = 1/20pt where (xpx, ypx) = sizeInPixels sz (xpt, ypt) = desiredSizeInPoints opts attr sz - let raw = "{\\pict" <> filetype <> sizeSpec <> "\\bin " <> + let raw = "{\\pict" <> filetype <> sizeSpec <> " " <> T.concat bytes <> "}" if B.null imgdata then do @@ -259,7 +260,8 @@ blockToRTF indent _ HorizontalRule = return $ blockToRTF indent alignment (Header level _ lst) = do contents <- inlinesToRTF lst return $ rtfPar indent 0 alignment $ - "\\b \\fs" <> tshow (40 - (level * 4)) <> " " <> contents + "\\outlinelevel" <> tshow (level - 1) <> + " \\b \\fs" <> tshow (40 - (level * 4)) <> " " <> contents blockToRTF indent alignment (Table _ blkCapt specs thead tbody tfoot) = do let (caption, aligns, sizes, headers, rows) = toLegacyTable blkCapt specs thead tbody tfoot caption' <- inlinesToRTF caption diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs index 0b7c6bee0..b23fc1341 100644 --- a/src/Text/Pandoc/Writers/Shared.hs +++ b/src/Text/Pandoc/Writers/Shared.hs @@ -36,6 +36,7 @@ module Text.Pandoc.Writers.Shared ( , toTableOfContents , endsWithPlain , toLegacyTable + , splitSentences ) where import Safe (lastMay) @@ -49,6 +50,7 @@ import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import Data.Text.Conversions (FromText(..)) import qualified Data.Map as M import qualified Data.Text as T +import Data.Text (Text) import qualified Text.Pandoc.Builder as Builder import Text.Pandoc.Definition import Text.Pandoc.Options @@ -119,13 +121,13 @@ metaValueToVal _ inlineWriter (MetaInlines is) = SimpleVal <$> inlineWriter is -- | Retrieve a field value from a template context. -getField :: FromContext a b => T.Text -> Context a -> Maybe b +getField :: FromContext a b => Text -> Context a -> Maybe b getField field (Context m) = M.lookup field m >>= fromVal -- | Set a field of a template context. If the field already has a value, -- convert it into a list with the new value appended to the old value(s). -- This is a utility function to be used in preparing template contexts. -setField :: ToContext a b => T.Text -> b -> Context a -> Context a +setField :: ToContext a b => Text -> b -> Context a -> Context a setField field val (Context m) = Context $ M.insertWith combine field (toVal val) m where @@ -135,21 +137,21 @@ setField field val (Context m) = -- | Reset a field of a template context. If the field already has a -- value, the new value replaces it. -- This is a utility function to be used in preparing template contexts. -resetField :: ToContext a b => T.Text -> b -> Context a -> Context a +resetField :: ToContext a b => Text -> b -> Context a -> Context a resetField field val (Context m) = Context (M.insert field (toVal val) m) -- | Set a field of a template context if it currently has no value. -- If it has a value, do nothing. -- This is a utility function to be used in preparing template contexts. -defField :: ToContext a b => T.Text -> b -> Context a -> Context a +defField :: ToContext a b => Text -> b -> Context a -> Context a defField field val (Context m) = Context (M.insertWith f field (toVal val) m) where f _newval oldval = oldval -- | Get the contents of the `lang` metadata field or variable. -getLang :: WriterOptions -> Meta -> Maybe T.Text +getLang :: WriterOptions -> Meta -> Maybe Text getLang opts meta = case lookupContext "lang" (writerVariables opts) of Just s -> Just s @@ -162,7 +164,7 @@ getLang opts meta = _ -> Nothing -- | Produce an HTML tag with the given pandoc attributes. -tagWithAttrs :: HasChars a => T.Text -> Attr -> Doc a +tagWithAttrs :: HasChars a => Text -> Attr -> Doc a tagWithAttrs tag (ident,classes,kvs) = hsep ["<" <> text (T.unpack tag) ,if T.null ident @@ -213,7 +215,7 @@ fixDisplayMath x = x -- | Converts a Unicode character into the ASCII sequence used to -- represent the character in "smart" Markdown. -unsmartify :: WriterOptions -> T.Text -> T.Text +unsmartify :: WriterOptions -> Text -> Text unsmartify opts = T.concatMap $ \c -> case c of '\8217' -> "'" '\8230' -> "..." @@ -345,7 +347,7 @@ gridTable opts blocksToDoc headless aligns widths headers rows = do -- | Retrieve the metadata value for a given @key@ -- and convert to Bool. -lookupMetaBool :: T.Text -> Meta -> Bool +lookupMetaBool :: Text -> Meta -> Bool lookupMetaBool key meta = case lookupMeta key meta of Just (MetaBlocks _) -> True @@ -356,7 +358,7 @@ lookupMetaBool key meta = -- | Retrieve the metadata value for a given @key@ -- and extract blocks. -lookupMetaBlocks :: T.Text -> Meta -> [Block] +lookupMetaBlocks :: Text -> Meta -> [Block] lookupMetaBlocks key meta = case lookupMeta key meta of Just (MetaBlocks bs) -> bs @@ -366,7 +368,7 @@ lookupMetaBlocks key meta = -- | Retrieve the metadata value for a given @key@ -- and extract inlines. -lookupMetaInlines :: T.Text -> Meta -> [Inline] +lookupMetaInlines :: Text -> Meta -> [Inline] lookupMetaInlines key meta = case lookupMeta key meta of Just (MetaString s) -> [Str s] @@ -377,7 +379,7 @@ lookupMetaInlines key meta = -- | Retrieve the metadata value for a given @key@ -- and convert to String. -lookupMetaString :: T.Text -> Meta -> T.Text +lookupMetaString :: Text -> Meta -> Text lookupMetaString key meta = case lookupMeta key meta of Just (MetaString s) -> s @@ -506,7 +508,7 @@ toLegacyTable (Caption _ cbody) specs thead tbodies tfoot = let (h, w, cBody) = getComponents c cRowPieces = cBody : replicate (w - 1) mempty cPendingPieces = replicate w $ replicate (h - 1) mempty - pendingPieces' = dropWhile null pendingPieces + pendingPieces' = drop w pendingPieces (pendingPieces'', rowPieces) = placeCutCells pendingPieces' cells' in (cPendingPieces <> pendingPieces'', cRowPieces <> rowPieces) | otherwise = ([], []) @@ -519,3 +521,27 @@ toLegacyTable (Caption _ cbody) specs thead tbodies tfoot getComponents (Cell _ _ (RowSpan h) (ColSpan w) body) = (h, w, body) + +splitSentences :: Doc Text -> Doc Text +splitSentences = go . toList + where + go [] = mempty + go (Text len t : BreakingSpace : xs) = + if isSentenceEnding t + then Text len t <> NewLine <> go xs + else Text len t <> BreakingSpace <> go xs + go (x:xs) = x <> go xs + + toList (Concat (Concat a b) c) = toList (Concat a (Concat b c)) + toList (Concat a b) = a : toList b + toList x = [x] + + isSentenceEnding t = + case T.unsnoc t of + Just (t',c) + | c == '.' || c == '!' || c == '?' -> True + | c == ')' || c == ']' || c == '"' || c == '\x201D' -> + case T.unsnoc t' of + Just (_,d) -> d == '.' || d == '!' || d == '?' + _ -> False + _ -> False diff --git a/src/Text/Pandoc/Writers/Texinfo.hs b/src/Text/Pandoc/Writers/Texinfo.hs index 6a33b4283..3c5591b3a 100644 --- a/src/Text/Pandoc/Writers/Texinfo.hs +++ b/src/Text/Pandoc/Writers/Texinfo.hs @@ -123,8 +123,7 @@ blockToTexinfo (Plain lst) = inlineListToTexinfo lst -- title beginning with fig: indicates that the image is a figure -blockToTexinfo (Para [Image attr txt (src,tgt)]) - | Just tit <- T.stripPrefix "fig:" tgt = do +blockToTexinfo (SimpleFigure attr txt (src, tit)) = do capt <- if null txt then return empty else (\c -> text "@caption" <> braces c) `fmap` diff --git a/src/Text/Pandoc/Writers/Textile.hs b/src/Text/Pandoc/Writers/Textile.hs index 03d030477..7f0d668e5 100644 --- a/src/Text/Pandoc/Writers/Textile.hs +++ b/src/Text/Pandoc/Writers/Textile.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.Textile Copyright : Copyright (C) 2010-2021 John MacFarlane @@ -111,8 +110,7 @@ blockToTextile opts (Div attr bs) = do blockToTextile opts (Plain inlines) = inlineListToTextile opts inlines --- title beginning with fig: indicates that the image is a figure -blockToTextile opts (Para [Image attr txt (src,T.stripPrefix "fig:" -> Just tit)]) = do +blockToTextile opts (SimpleFigure attr txt (src, tit)) = do capt <- blockToTextile opts (Para txt) im <- inlineToTextile opts (Image attr txt (src,tit)) return $ im <> "\n" <> capt diff --git a/src/Text/Pandoc/Writers/ZimWiki.hs b/src/Text/Pandoc/Writers/ZimWiki.hs index df914f590..5722b6d2e 100644 --- a/src/Text/Pandoc/Writers/ZimWiki.hs +++ b/src/Text/Pandoc/Writers/ZimWiki.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.ZimWiki Copyright : © 2008-2021 John MacFarlane, @@ -86,9 +85,8 @@ blockToZimWiki opts (Div _attrs bs) = do blockToZimWiki opts (Plain inlines) = inlineListToZimWiki opts inlines --- title beginning with fig: indicates that the image is a figure -- ZimWiki doesn't support captions - so combine together alt and caption into alt -blockToZimWiki opts (Para [Image attr txt (src,T.stripPrefix "fig:" -> Just tit)]) = do +blockToZimWiki opts (SimpleFigure attr txt (src, tit)) = do capt <- if null txt then return "" else (" " <>) `fmap` inlineListToZimWiki opts txt |