diff --git a/AUTHORS.md b/AUTHORS.md --- a/AUTHORS.md +++ b/AUTHORS.md @@ -185,6 +185,7 @@ - infinity0x - lwolfsonkin - nkalvi +- oltolm - qerub - robabla - roblabla diff --git a/INSTALL.md b/INSTALL.md --- a/INSTALL.md +++ b/INSTALL.md @@ -137,7 +137,7 @@ 1. Install the [Haskell platform]. This will give you [GHC] and the [cabal-install] build tool. Note that pandoc requires - GHC >= 7.8. + GHC >= 7.10. 2. Update your package database: diff --git a/MANUAL.txt b/MANUAL.txt --- a/MANUAL.txt +++ b/MANUAL.txt @@ -1,6 +1,6 @@ % Pandoc User's Guide % John MacFarlane -% January 7, 2018 +% January 18, 2018 Synopsis ======== @@ -102,7 +102,7 @@ [PDF]: https://www.adobe.com/pdf/ [reveal.js]: http://lab.hakim.se/reveal-js/ [FictionBook2]: http://www.fictionbook.org/index.php/Eng:XML_Schema_Fictionbook_2.1 -[InDesign ICML]: https://www.adobe.com/content/dam/Adobe/en/devnet/indesign/cs55-docs/IDML/idml-specification.pdf +[InDesign ICML]: http://wwwimages.adobe.com/www.adobe.com/content/dam/acom/en/devnet/indesign/sdk/cs6/idml/idml-cookbook.pdf [TEI Simple]: https://github.com/TEIC/TEI-Simple [Muse]: https://amusewiki.org/library/manual [PowerPoint]: https://en.wikipedia.org/wiki/Microsoft_PowerPoint @@ -370,7 +370,7 @@ : Generate a bash completion script. To enable bash completion with pandoc, add this to your `.bashrc`: - eval "$(pandoc --bash-completion)" + eval "$(pandoc --bash-completion)" `--verbose` @@ -1314,7 +1314,7 @@ `toc-title` : title of table of contents (works only with EPUB, - opendocument, odt, docx) + opendocument, odt, docx, pptx) `include-before` : contents specified by `-B/--include-before-body` (may have @@ -1350,21 +1350,12 @@ format stored in the additional variables `babel-lang`, `polyglossia-lang` (LaTeX) and `context-lang` (ConTeXt). - Native pandoc `span`s and `div`s with the lang attribute + Native pandoc Spans and Divs with the lang attribute (value in BCP 47) can be used to switch the language in - that range. - -`otherlangs` -: a list of other languages used in the document - in the YAML metadata, according to [BCP 47]. For example: - `otherlangs: [en-GB, fr]`. - This is automatically generated from the `lang` attributes - in all `span`s and `div`s but can be overridden. - Currently only used by LaTeX through the generated - `babel-otherlangs` and `polyglossia-otherlangs` variables. - The LaTeX writer outputs polyglossia commands in the text but - the `babel-newcommands` variable contains mappings for them - to the corresponding babel. + that range. In LaTeX output, `babel-otherlangs` and + `polyglossia-otherlangs` variables will be generated + automatically based on the `lang` attributes of Spans + and Divs in the document. `dir` : the base direction of the document, either `rtl` (right-to-left) @@ -1732,7 +1723,7 @@ Interpret straight quotes as curly quotes, `---` as em-dashes, `--` as en-dashes, and `...` as ellipses. Nonbreaking spaces are -inserted after certain abbreviations, such as "Mr." +inserted after certain abbreviations, such as "Mr." This extension can be enabled/disabled for the following formats: @@ -1969,7 +1960,15 @@ Some aspects of [Pandoc's Markdown citation syntax](#citations) are also accepted in `org` input. +#### Extension: `ntb` #### +In the `context` output format this enables the use of [Natural Tables +(TABLE)](http://wiki.contextgarden.net/TABLE) instead of the default +[Extreme Tables (xtables)](http://wiki.contextgarden.net/xtables). +Natural tables allow more fine-grained global customization but come +at a performance penalty compared to extreme tables. + + Pandoc's Markdown ================= @@ -2607,9 +2606,9 @@ + First + Second: - - Fee - - Fie - - Foe + - Fee + - Fie + - Foe + Third @@ -3046,7 +3045,18 @@ $endif$ $endfor$ +Raw content to include in the document's header may be specified +using `header-includes`; however, it is important to mark up +this content as raw code for a particular output format, using +the [`raw_attribute` extension](#extension-raw_attribute)), or it +will be interpreted as markdown. For example: + header-includes: + - ```{=latex} + \let\oldsection\section + \renewcommand{\section}[1]{\clearpage\oldsection{#1}} + ``` + Backslash escapes ----------------- @@ -3386,14 +3396,17 @@ $\tuple{a, b, c}$ -In LaTeX output, the macro definitions will not be passed -through as raw LaTeX. +Note that LaTeX macros will not be applied if they occur +inside inside a raw span or block marked with the +[`raw_attribute` extension](#extension-raw_attribute). -When `latex_macros` is disabled, the macro definitions will -be passed through as raw LaTeX, and the raw LaTeX and math will +When `latex_macros` is disabled, the raw LaTeX and math will not have macros applied. This is usually a better approach when you are targeting LaTeX or PDF. +Whether or not `latex_macros` is enabled, the macro definitions +will still be passed through as raw LaTeX. + Links ----- @@ -3532,7 +3545,7 @@ the only thing in the paragraph. One way to do this is to insert a nonbreaking space after the image: - ![This image won't be a figure](/url/of/image.png)\ + ![This image won't be a figure](/url/of/image.png)\ Note that in reveal.js slide shows, an image in a paragraph by itself that has the `stretch` class will fill the screen, diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -83,7 +83,7 @@ ms](http://man7.org/linux/man-pages/man7/groff_ms.7.html), [Emacs Org mode](http://orgmode.org), [AsciiDoc](http://www.methods.co.nz/asciidoc/), [InDesign -ICML](https://www.adobe.com/content/dam/Adobe/en/devnet/indesign/cs55-docs/IDML/idml-specification.pdf), +ICML](http://wwwimages.adobe.com/www.adobe.com/content/dam/acom/en/devnet/indesign/sdk/cs6/idml/idml-cookbook.pdf), [TEI Simple](https://github.com/TEIC/TEI-Simple), [Muse](https://amusewiki.org/library/manual), [PowerPoint](https://en.wikipedia.org/wiki/Microsoft_PowerPoint) slide diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,188 @@ +pandoc (2.1.1) + + * Markdown reader: + + + Don't coalesce adjacent raw LaTeX blocks if they are separated by a + blank line. See lierdakil/pandoc-crossref#160. + + Improved `inlinesInBalancedBrackets` (#4272, jgm/pandoc-citeproc#315). + The change both improves performance and fixes a regression whereby + normal citations inside inline notes and figure captions were not + parsed correctly. + + * RST reader: + + + Better handling for headers with an anchor (#4240). Instead of creating a + Div containing the header, we put the id directly on the header. + This way header promotion will work properly. + + Add aligned environment when needed in math (#4254). `rst2latex.py` + uses an `align*` environment for math in `.. math::` blocks, so this + math may contain line breaks. If it does, we put the math in an + `aligned` environment to simulate `rst2latex.py`'s behavior. + + * HTML reader: + + + Fix col width parsing for percentages < 10% (#4262, n3fariox). + + * LaTeX reader: + + + Advance source position at end of stream. + + Pass through macro defs in `rawLaTeXBlock` even if the `latex_macros` + extension is set (#4246). This reverts to earlier behavior and is + probably safer on the whole, since some macros only modify things in + included packages, which pandoc's macro expansion can't modify. + + Fixed pos calculation in tokenizing escaped space. + + Allow macro definitions inside macros (#4253). Previously we went into + an infinite loop with + ``` + \newcommand{\noop}[1]{#1} + \noop{\newcommand{\foo}[1]{#1}} + \foo{hi} + ``` + + Fix inconsistent column widths (#4238). This fixes a bug whereby column + widths for the body were different from widths for the header in some + tables. + + * Docx reader (Jesse Rosenthal): + + + Parse hyperlinks in `instrText` tags (#3389, #4266). This was a form of + hyperlink found in older versions of word. The changes introduced for + this, though, create a framework for parsing further fields in MS Word + (see the spec, ECMA-376-1:2016, §17.16.5, for more on these fields). + We introduce a new module, `Text.Pandoc.Readers.Docx.Fields` which + contains a simple parsec parser. At the moment, only simple hyperlink + fields are accepted, but that can be extended in the future. + + * Muse reader (Alexander Krotov): + + + Parse `~~` as non-breaking space in Text::Amuse mode. + + Refactor list parsing. + + * Powerpoint writer (Jesse Rosenthal): + + + Change reference to `notesSlide` to `endNotesSlide`. + + Move image sizing into `picProps`. + + Improve table placement. + + Make our own `_rels/.rels` file. + + Import reference-doc images properly. + + Move `Presentation.hs` out of `PandocMonad`. + + Refactor into separate modules. T.P.W.Powerpoint.Presentation + defines the Presentation datatype and goes Pandoc->Presentation; + T.P.W.Pandoc.Output goes Presentation->Archive. + Text.Pandoc.Writers.Powerpoint a thin wrapper around the two modules. + + Avoid overlapping blocks in column output. + + Position images correctly in two-column layout. + + Make content shape retrieval environment-aware. + + Improve image handling. We now determine image and caption placement + by getting the dimensions of the content box in a given layout. + This allows for images to be correctly sized and positioned in a + different template. Note that images without captions and headers are + no longer full-screened. We can't do this dependably in different + layouts, because we don't know where the header is (it could be to + the side of the content, for example). + + Read presentation size from reference file. Our presentation size is + now dependent on the reference/template file we use. + + Handle (sub)headers above slidelevel correctly. Above the slidelevel, + subheaders will be printed in bold and given a bit of extra space + before them. Note that at the moment, no distinction is made between + levels of headers above the slide header, though that can be changed. + + Check for required files. Since we now import from reference/dist + file by glob, we need to make sure that we're getting the files we + need to make a non-corrupt Powerpoint. This performs that check. + + Improve templating using `--reference-doc`. Templating should work + much more reliably now. + + Include Notes slide in TOC. + + Set notes slide header to slide-level. + + Add table of contents. This is triggered by the `--toc` flag. Note + that in a long slide deck this risks overrunning the text box. The user + can address this by setting `--toc-depth=1`. + + Set notes slide number correctly. + + Clean up adding metadata slide. We want to count the slide numbers + correctly if it's in there. + + Add anchor links. For anchor-type links (`[foo](#bar)`) we produce + an anchor link. In powerpoint these are links to slides, so we keep + track of a map relating anchors to the slides they occur on. + + Make the slide number available to the blocks. For anchors, + block-processing functions need to know what slide number + they're in. We make the `envCurSlideId` available to blocks. + + Move `curSlideId` to environment. + + Allow setting `toc-title` in metadata. + + Link notes to endnotes slide. + + * Markdown writer: + + + Fix cell width calculation (#4265). Previously we could get + ever-lengthening cell widths when a table was run repeatedly through + `pandoc -f markdown -t markdown`. + + * LaTeX writer: + + + Escape `&` in lstinline (Robert Schütz). + + * ConTeXt writer: + + + Use xtables instead of Tables (#4223, Henri Menke). + Default to xtables for context output. Natural Tables are used + if the new `ntb` extension is set. + + * HTML writer: + + + Fixed footnote backlinks with `--id-prefix` (#4235). + + * `Text.Pandoc.Extensions`: Added `Ext_ntb` constructor (API change, + Henri Menke). + + * `Text.Pandoc.ImageSize`: add derived `Eq` instance to `Dimension` + (Jesse Rosenthal, API change). + + * Lua filters (Albert Krewinkel): + + + Make `PANDOC_READER_OPTIONS` available. + The options which were used to read the document are made available to + Lua filters via the `PANDOC_READER_OPTIONS` global. + + Add lua module `pandoc.utils.run_json_filter`, which runs a JSON filter + on a Pandoc document. + + Refactor filter-handling code into `Text.Pandoc.Filter.JSON`, + `Text.Pandoc.Filter.Lua`, and `Text.Pandoc.Filter.Path`. + + Improve error messages. Provide more context about the task + which caused an error. + + * data/pandoc.lua (Albert Krewinkel): + + + Accept singleton inline as a list. Every constructor which accepts a + list of inlines now also accepts a single inline element for + convenience. + + Accept single block as singleton list. Every constructor which accepts + a list of blocks now also accepts a single block element for + convenience. Furthermore, strings are accepted as shorthand for + `{pandoc.Str "text"}` in constructors. + + Add attr, listAttributes accessors. Elements with + attributes got an additional `attr` accessor. Attributes were + accessible only via the `identifier`, `classes`, and `attributes`, + which was in conflict with the documentation, which indirectly states + that such elements have the an `attr` property. + + Drop `_VERSION`. Having a `_VERSION` became superfluous, as this + module is closely tied to the pandoc version, which is available via + `PANDOC_VERSION`. + + Fix access to Attr components. Accessing an Attr value (e.g., + ` Attr().classes`) was broken; the more common case of accessing it via + an Inline or Block element was unaffected by this. + + * Move `metaValueToInlines` to from Docx writer to + `Text.Pandoc.Writers.Shared`, so it can be used by other writers + (Jesse Rosenthal). + + * MANUAL.txt: + + + Clarify otherlangs in LaTeX (#4072). + + Clarify `latex_macros` extension. + + Recommend use of `raw_attribute` extension in header includes (#4253). + + * Allow latest QuickCheck, tasty, criterion. + + * Remove custom prelude and ghc 7.8 support. + + * Reduce compiler noise (exact paths for compiled modules). + pandoc (2.1) * Allow filters and lua filters to be interspersed (#4196). Previously @@ -94,6 +279,8 @@ supported. + Added more tests. + * OpenDocument/ODT writers: improved rendering of formulas (#4170, oltolm). + * Lua filters (Albert Krewinkel): + `data/pandoc.lua`: drop 'pandoc-api-version' from Pandoc objects @@ -11335,7 +11522,7 @@ * Added Maybe datadir parameter to readDataFile, saveOpenDocumentAsODT, latexMathMLScript, s5HeaderIncludes, and getDefaultTemplate. If - Nothing, no user directory is searched for an override. + Nothing, no user directory is searched for an override. * Added 'plain' output format. This is similar to markdown, but removes links, pictures, inline formatting, and most anything that @@ -11449,8 +11636,8 @@ + Allow footnotes to be indented < 4 spaces. This fixes a regression. A test case has been added. + Escape spaces in URLs as %20. Previously they were incorrectly - escaped as +, which is appropriate only for the query part of - a URL. Resolves Issue #220. + escaped as +, which is appropriate only for the query part of + a URL. Resolves Issue #220. + Require two spaces after capital letter + period for list item. Otherwise "E. coli" starts a list. This might change the semantics of some existing documents, since previously the two-space @@ -11577,7 +11764,7 @@ * Pandoc no longer requires Template Haskell. Resolves Issue #186. + Removed need for TH in ODT module. Instead get reference.odt from - data file at run time. + data file at run time. + Removed TH dependency from S5 module. S5 module now exports s5HeaderIncludes, which pandoc.hs includes if writer is s5 and standalone. @@ -11594,7 +11781,7 @@ on unix), or, if not found there, from the system data directory ($CABALDIR/shared/pandoc-VERSION/). All data files, including templates, LaTeXMathML.js, s5 styles, - and reference.odt, can be overridden by the user. + and reference.odt, can be overridden by the user. * s5 files moved from data/ui/default to s5/default. @@ -11619,7 +11806,7 @@ * Added --reference-odt option, so users may customize the styles used in pandoc-generated ODT files. Users may also place a - default reference.odt in the ~\.pandoc directory. + default reference.odt in the ~\.pandoc directory. * ODT writer: + Indented and line-broke styles.xml so it can be modified more easily. @@ -11703,8 +11890,8 @@ * Treat a backslash followed by a newline as a hard line break in markdown. Resolves Issue #154. This is a nice alternative - to markdown's "invisible" way of indicating hardline breaks - using lines that end with two spaces. + to markdown's "invisible" way of indicating hardline breaks + using lines that end with two spaces. * Improved performance of markdown reader by ~10% by eliminating the need for a separate parsing pass for notes. Raw notes are now stored @@ -11715,7 +11902,7 @@ * In markdown reader, treat 4 or more * or _ in a row as literal text. (Trying to parse long strings of * or _ as strong or emph - leads to exponential performance problems.) + leads to exponential performance problems.) * Markdown reader: Use + rather than %20 for spaces in URLs. @@ -11733,8 +11920,8 @@ * Modified html+lhs output to use "haskell" highlighter instead of "literateHaskell". The highlighting module now adds bird tracks - after highlighting (for HTML output), if the code block has the - "literate" class. This gives better results, because kate's + after highlighting (for HTML output), if the code block has the + "literate" class. This gives better results, because kate's haskell highlighter is much better than the literateHaskell highlighter. @@ -11855,7 +12042,7 @@ explicit marker. For example: A. my list - #. continued + #. continued Resolves Issue #140. + Allow continuation lines in line blocks. Also added test cases for @@ -11888,7 +12075,7 @@ * Added new Haskell version of markdown2pdf, due to Paulo Tanimoto. This should be more portable than the old - shell script. + shell script. * Made 'pandoc -v' more explicit about compiler options. Resolves Issue #139. diff --git a/data/pandoc.lua b/data/pandoc.lua --- a/data/pandoc.lua +++ b/data/pandoc.lua @@ -22,13 +22,91 @@ -- @author Albert Krewinkel -- @copyright © 2017–2018 Albert Krewinkel -- @license MIT -local M = { - _VERSION = "0.4.0" -} +local M = {} local List = require 'pandoc.List' ------------------------------------------------------------------------ +-- Accessor objects +-- +-- Create metatables which allow to access numerical indices via accessor +-- methods. +-- @section +-- @local + +--- Create a new indexing function. +-- @param template function template +-- @param indices list of indices, starting with the most deeply nested +-- @return newly created function +-- @local +function make_indexing_function(template, indices) + local loadstring = loadstring or load + local bracketed = {} + for i = 1, #indices do + bracketed[i] = string.format('[%d]', indices[#indices - i + 1]) + end + local fnstr = string.format('return ' .. template, table.concat(bracketed)) + return assert(loadstring(fnstr))() +end + +--- Create accessor functions using a function template. +-- @param fn_template function template in which '%s' is replacd with indices +-- @param accessors list of accessors +-- @return mapping from accessor names to accessor functions +-- @local +local function create_accessor_functions (fn_template, accessors) + local res = {} + function add_accessors(acc, ...) + if type(acc) == 'string' then + res[acc] = make_indexing_function(fn_template, {...}) + elseif type(acc) == 'table' and #acc == 0 and next(acc) then + local name, substructure = next(acc) + res[name] = make_indexing_function(fn_template, {...}) + add_accessors(substructure, ...) + else + for i = 1, #(acc or {}) do + add_accessors(acc[i], i, ...) + end + end + end + add_accessors(accessors) + return res +end + +--- Create a new table which allows to access numerical indices via accessor +-- functions. +-- @local +local function create_accessor_behavior (tag, accessors) + local behavior = {tag = tag} + behavior.getters = create_accessor_functions( + 'function (x) return x.c%s end', + accessors + ) + behavior.setters = create_accessor_functions( + 'function (x, v) x.c%s = v end', + accessors + ) + behavior.__index = function(t, k) + if getmetatable(t).getters[k] then + return getmetatable(t).getters[k](t) + elseif k == "t" then + return getmetatable(t)["tag"] + else + return getmetatable(t)[k] + end + end + behavior.__newindex = function(t, k, v) + if getmetatable(t).setters[k] then + getmetatable(t).setters[k](t, v) + else + rawset(t, k, v) + end + end + return behavior +end + + +------------------------------------------------------------------------ -- The base class for types -- @type Type -- @local @@ -79,7 +157,7 @@ -- @local local AstElement = Type:make_subtype 'AstElement' AstElement.__call = function(t, ...) - local success, ret = pcall(t.constructor, ...) + local success, ret = pcall(t.new, t, ...) if success then return setmetatable(ret, t.behavior) else @@ -87,6 +165,14 @@ end end +--- Make a new subtype which constructs a new value when called. +-- @local +function AstElement:make_subtype(...) + local newtype = Type.make_subtype(self, ...) + newtype.__call = self.__call + return newtype +end + --- Create a new constructor -- @local -- @param tag Tag used to identify the constructor @@ -94,55 +180,7 @@ -- @param accessors names to use as accessors for numerical fields -- @return function that constructs a new element function AstElement:create_constructor(tag, fn, accessors) - local constr = self:make_subtype(tag, {tag = tag, getters = {}, setters = {}}) - behavior = constr.behavior - behavior.__index = function(t, k) - if getmetatable(t).getters[k] then - return getmetatable(t).getters[k](t) - elseif k == "t" then - return getmetatable(t)["tag"] - else - return getmetatable(t)[k] - end - end - behavior.__newindex = function(t, k, v) - if getmetatable(t).setters[k] then - getmetatable(t).setters[k](t, v) - else - rawset(t, k, v) - end - end - - -- Add accessors to the metatable - if type(accessors) == "string" then - behavior.getters[accessors] = function(elem) - return elem.c - end - behavior.setters[accessors] = function(elem, v) - elem.c = v - end - else - for i = 1, #(accessors or {}) do - if type(accessors[i]) == "string" then - behavior.getters[accessors[i]] = function(elem) - return elem.c[i] - end - behavior.setters[accessors[i]] = function(elem, v) - elem.c[i] = v - end - else -- only two levels of nesting are supported - for k, v in ipairs(accessors[i]) do - behavior.getters[v] = function(elem) - return elem.c[i][k] - end - behavior.setters[v] = function(elem, v) - elem.c[i][k] = v - end - end - end - end - end - + local constr = self:make_subtype(tag, create_accessor_behavior(tag, accessors)) function constr:new(...) return setmetatable(fn(...), self.behavior) end @@ -151,24 +189,27 @@ return constr end ---- Create a new element given its tag and arguments +--- Convert AstElement input into a list if necessary. -- @local -function AstElement.new(constr, ...) - local element = {} - local content = {...} - -- special case for unary constructors - if #content == 1 then - element.c = content[1] - -- Don't set 'c' field if no further arguments were given. This is important - -- for nullary constructors like `Space` and `HorizontalRule`. - elseif #content > 0 then - element.c = content +local function ensureList (x) + if x.tag then + -- Lists are not tagged, but all elements are + return List:new{x} + else + return List:new(x) end - setmetatable(element, constr) - element.__index = element - return element end +--- Ensure a given object is an Inline element, or convert it into one. +-- @local +local function ensureInlineList (x) + if type(x) == 'string' then + return List:new{M.Str(x)} + else + return ensureList(x) + end +end + ------------------------------------------------------------------------ --- Pandoc Document -- @section document @@ -178,9 +219,9 @@ -- @tparam {Block,...} blocks document content -- @tparam[opt] Meta meta document meta data M.Pandoc = AstElement:make_subtype'Pandoc' -function M.Pandoc.constructor (blocks, meta) +function M.Pandoc:new (blocks, meta) return { - blocks = List:new(blocks), + blocks = ensureList(blocks), meta = meta or {}, } end @@ -197,41 +238,37 @@ -- @function Meta -- @tparam meta table table containing document meta information M.Meta = AstElement:make_subtype'Meta' -M.Meta.constructor = function (meta) return meta end +function M.Meta:new (meta) return meta end ------------------------------------------------------------------------ -- MetaValue -- @section MetaValue M.MetaValue = AstElement:make_subtype('MetaValue') -M.MetaValue.__call = function (t, ...) - return t:new(...) -end --- Meta blocks -- @function MetaBlocks -- @tparam {Block,...} blocks blocks +M.MetaBlocks = M.MetaValue:create_constructor( + 'MetaBlocks', + function (content) return ensureList(content) end +) --- Meta inlines -- @function MetaInlines -- @tparam {Inline,...} inlines inlines +M.MetaInlines = M.MetaValue:create_constructor( + 'MetaInlines', + function (content) return ensureInlineList(content) end +) --- Meta list -- @function MetaList -- @tparam {MetaValue,...} meta_values list of meta values -M.meta_value_list_types = { - "MetaBlocks", - "MetaInlines", - "MetaList", -} -for i = 1, #M.meta_value_list_types do - M[M.meta_value_list_types[i]] = M.MetaValue:create_constructor( - M.meta_value_list_types[i], - function(content) - return List:new(content) - end - ) -end +M.MetaList = M.MetaValue:create_constructor( + 'MetaList', + function (content) return ensureList(content) end +) --- Meta map -- @function MetaMap @@ -263,9 +300,6 @@ --- Block elements M.Block = AstElement:make_subtype'Block' -M.Block.__call = function (t, ...) - return t:new(...) -end --- Creates a block quote element -- @function BlockQuote @@ -273,7 +307,7 @@ -- @treturn Block block quote element M.BlockQuote = M.Block:create_constructor( "BlockQuote", - function(content) return {c = content} end, + function(content) return {c = ensureList(content)} end, "content" ) @@ -283,7 +317,7 @@ -- @treturn Block bullet list element M.BulletList = M.Block:create_constructor( "BulletList", - function(content) return {c = content} end, + function(content) return {c = ensureList(content)} end, "content" ) @@ -295,7 +329,7 @@ M.CodeBlock = M.Block:create_constructor( "CodeBlock", function(text, attr) return {c = {attr or M.Attr(), text}} end, - {{"identifier", "classes", "attributes"}, "text"} + {{attr = {"identifier", "classes", "attributes"}}, "text"} ) --- Creates a definition list, containing terms and their explanation. @@ -304,7 +338,7 @@ -- @treturn Block definition list element M.DefinitionList = M.Block:create_constructor( "DefinitionList", - function(content) return {c = List:new(content)} end, + function(content) return {c = ensureList(content)} end, "content" ) @@ -316,9 +350,9 @@ M.Div = M.Block:create_constructor( "Div", function(content, attr) - return {c = {attr or M.Attr(), List:new(content)}} + return {c = {attr or M.Attr(), ensureList(content)}} end, - {{"identifier", "classes", "attributes"}, "content"} + {{attr = {"identifier", "classes", "attributes"}}, "content"} ) --- Creates a header element. @@ -330,9 +364,9 @@ M.Header = M.Block:create_constructor( "Header", function(level, content, attr) - return {c = {level, attr or M.Attr(), content}} + return {c = {level, attr or M.Attr(), ensureInlineList(content)}} end, - {"level", {"identifier", "classes", "attributes"}, "content"} + {"level", {attr = {"identifier", "classes", "attributes"}}, "content"} ) --- Creates a horizontal rule. @@ -349,7 +383,7 @@ -- @treturn Block line block element M.LineBlock = M.Block:create_constructor( "LineBlock", - function(content) return {c = List:new(content)} end, + function(content) return {c = ensureList(content)} end, "content" ) @@ -370,9 +404,9 @@ "OrderedList", function(items, listAttributes) listAttributes = listAttributes or {1, M.DefaultStyle, M.DefaultDelim} - return {c = {listAttributes, List:new(items)}} + return {c = {listAttributes, ensureList(items)}} end, - {{"start", "style", "delimiter"}, "content"} + {{listAttributes = {"start", "style", "delimiter"}}, "content"} ) --- Creates a para element. @@ -381,7 +415,7 @@ -- @treturn Block paragraph element M.Para = M.Block:create_constructor( "Para", - function(content) return {c = List:new(content)} end, + function(content) return {c = ensureInlineList(content)} end, "content" ) @@ -391,7 +425,7 @@ -- @treturn Block plain element M.Plain = M.Block:create_constructor( "Plain", - function(content) return {c = List:new(content)} end, + function(content) return {c = ensureInlineList(content)} end, "content" ) @@ -419,7 +453,7 @@ function(caption, aligns, widths, headers, rows) return { c = { - List:new(caption), + ensureInlineList(caption), List:new(aligns), List:new(widths), List:new(headers), @@ -437,9 +471,6 @@ --- Inline element class M.Inline = AstElement:make_subtype'Inline' -M.Inline.__call = function (t, ...) - return t:new(...) -end --- Creates a Cite inline element -- @function Cite @@ -449,7 +480,7 @@ M.Cite = M.Inline:create_constructor( "Cite", function(content, citations) - return {c = {List:new(citations), List:new(content)}} + return {c = {ensureList(citations), ensureInlineList(content)}} end, {"citations", "content"} ) @@ -462,7 +493,7 @@ M.Code = M.Inline:create_constructor( "Code", function(text, attr) return {c = {attr or M.Attr(), text}} end, - {{"identifier", "classes", "attributes"}, "text"} + {{attr = {"identifier", "classes", "attributes"}}, "text"} ) --- Creates an inline element representing emphasised text. @@ -471,7 +502,7 @@ -- @treturn Inline emphasis element M.Emph = M.Inline:create_constructor( "Emph", - function(content) return {c = List:new(content)} end, + function(content) return {c = ensureInlineList(content)} end, "content" ) @@ -487,9 +518,9 @@ function(caption, src, title, attr) title = title or "" attr = attr or M.Attr() - return {c = {attr, List:new(caption), {src, title}}} + return {c = {attr, ensureInlineList(caption), {src, title}}} end, - {{"identifier", "classes", "attributes"}, "caption", {"src", "title"}} + {{attr = {"identifier", "classes", "attributes"}}, "caption", {"src", "title"}} ) --- Create a LineBreak inline element @@ -512,9 +543,9 @@ function(content, target, title, attr) title = title or "" attr = attr or M.Attr() - return {c = {attr, List:new(content), {target, title}}} + return {c = {attr, ensureInlineList(content), {target, title}}} end, - {{"identifier", "classes", "attributes"}, "content", {"target", "title"}} + {{attr = {"identifier", "classes", "attributes"}}, "content", {"target", "title"}} ) --- Creates a Math element, either inline or displayed. @@ -553,7 +584,7 @@ -- @tparam {Block,...} content footnote block content M.Note = M.Inline:create_constructor( "Note", - function(content) return {c = List:new(content)} end, + function(content) return {c = ensureList(content)} end, "content" ) @@ -564,7 +595,7 @@ -- @treturn Inline quoted element M.Quoted = M.Inline:create_constructor( "Quoted", - function(quotetype, content) return {c = {quotetype, List:new(content)}} end, + function(quotetype, content) return {c = {quotetype, ensureInlineList(content)}} end, {"quotetype", "content"} ) --- Creates a single-quoted inline element (DEPRECATED). @@ -605,7 +636,7 @@ -- @treturn Inline smallcaps element M.SmallCaps = M.Inline:create_constructor( "SmallCaps", - function(content) return {c = List:new(content)} end, + function(content) return {c = ensureInlineList(content)} end, "content" ) @@ -633,9 +664,9 @@ M.Span = M.Inline:create_constructor( "Span", function(content, attr) - return {c = {attr or M.Attr(), List:new(content)}} + return {c = {attr or M.Attr(), ensureInlineList(content)}} end, - {{"identifier", "classes", "attributes"}, "content"} + {{attr = {"identifier", "classes", "attributes"}}, "content"} ) --- Creates a Str inline element @@ -654,7 +685,7 @@ -- @treturn Inline strikeout element M.Strikeout = M.Inline:create_constructor( "Strikeout", - function(content) return {c = List:new(content)} end, + function(content) return {c = ensureInlineList(content)} end, "content" ) @@ -664,7 +695,7 @@ -- @treturn Inline strong element M.Strong = M.Inline:create_constructor( "Strong", - function(content) return {c = List:new(content)} end, + function(content) return {c = ensureInlineList(content)} end, "content" ) @@ -674,7 +705,7 @@ -- @treturn Inline subscript element M.Subscript = M.Inline:create_constructor( "Subscript", - function(content) return {c = List:new(content)} end, + function(content) return {c = ensureInlineList(content)} end, "content" ) @@ -684,7 +715,7 @@ -- @treturn Inline strong element M.Superscript = M.Inline:create_constructor( "Superscript", - function(content) return {c = List:new(content)} end, + function(content) return {c = ensureInlineList(content)} end, "content" ) @@ -785,21 +816,20 @@ -- @tparam[opt] table attributes table containing string keys and values -- @return element attributes M.Attr = AstElement:make_subtype'Attr' -M.Attr.constructor = function(identifier, classes, attributes) +function M.Attr:new (identifier, classes, attributes) identifier = identifier or '' - classes = List:new(classes or {}) + classes = ensureList(classes or {}) attributes = setmetatable(to_alist(attributes or {}), AttributeList) return {identifier, classes, attributes} end M.Attr.behavior._field_names = {identifier = 1, classes = 2, attributes = 3} M.Attr.behavior.__index = function(t, k) - return rawget(t, k) or - rawget(t, M.Attr._field_names[k]) or - rawget(getmetatable(t), k) + return rawget(t, getmetatable(t)._field_names[k]) or + getmetatable(t)[k] end M.Attr.behavior.__newindex = function(t, k, v) - if M.Attr._field_names[k] then - rawset(t, M.Attr._field_names[k], v) + if getmetatable(t)._field_names[k] then + rawset(t, getmetatable(t)._field_names[k], v) else rawset(t, k, v) end @@ -816,12 +846,12 @@ -- @tparam[opt] {Inline,...} suffix citation suffix -- @tparam[opt] int note_num note number -- @tparam[opt] int hash hash number -function M.Citation.constructor (id, mode, prefix, suffix, note_num, hash) +function M.Citation:new (id, mode, prefix, suffix, note_num, hash) return { id = id, mode = mode, - prefix = prefix or {}, - suffix = suffix or {}, + prefix = ensureList(prefix or {}), + suffix = ensureList(suffix or {}), note_num = note_num or 0, hash = hash or 0, } diff --git a/data/templates/default.context b/data/templates/default.context --- a/data/templates/default.context +++ b/data/templates/default.context @@ -92,6 +92,11 @@ \setupthinrules[width=15em] % width of horizontal rules +\setupxtable[frame=off] +\setupxtable[head][topframe=on,bottomframe=on] +\setupxtable[body][] +\setupxtable[foot][bottomframe=on] + $for(header-includes)$ $header-includes$ $endfor$ diff --git a/man/pandoc.1 b/man/pandoc.1 --- a/man/pandoc.1 +++ b/man/pandoc.1 @@ -1,5 +1,5 @@ .\"t -.TH PANDOC 1 "January 7, 2018" "pandoc 2.1" +.TH PANDOC 1 "January 18, 2018" "pandoc 2.1.1" .SH NAME pandoc - general markup converter .SH SYNOPSIS @@ -346,7 +346,7 @@ .IP .nf \f[C] -\ eval\ "$(pandoc\ \-\-bash\-completion)" +eval\ "$(pandoc\ \-\-bash\-completion)" \f[] .fi .RE @@ -1487,7 +1487,7 @@ .TP .B \f[C]toc\-title\f[] title of table of contents (works only with EPUB, opendocument, odt, -docx) +docx, pptx) .RS .RE .TP @@ -1524,23 +1524,12 @@ \f[C]polyglossia\-lang\f[] (LaTeX) and \f[C]context\-lang\f[] (ConTeXt). .RS .PP -Native pandoc \f[C]span\f[]s and \f[C]div\f[]s with the lang attribute -(value in BCP 47) can be used to switch the language in that range. -.RE -.TP -.B \f[C]otherlangs\f[] -a list of other languages used in the document in the YAML metadata, -according to BCP 47. -For example: \f[C]otherlangs:\ [en\-GB,\ fr]\f[]. -This is automatically generated from the \f[C]lang\f[] attributes in all -\f[C]span\f[]s and \f[C]div\f[]s but can be overridden. -Currently only used by LaTeX through the generated -\f[C]babel\-otherlangs\f[] and \f[C]polyglossia\-otherlangs\f[] -variables. -The LaTeX writer outputs polyglossia commands in the text but the -\f[C]babel\-newcommands\f[] variable contains mappings for them to the -corresponding babel. -.RS +Native pandoc Spans and Divs with the lang attribute (value in BCP 47) +can be used to switch the language in that range. +In LaTeX output, \f[C]babel\-otherlangs\f[] and +\f[C]polyglossia\-otherlangs\f[] variables will be generated +automatically based on the \f[C]lang\f[] attributes of Spans and Divs in +the document. .RE .TP .B \f[C]dir\f[] @@ -2360,6 +2349,12 @@ .PP Some aspects of Pandoc\[aq]s Markdown citation syntax are also accepted in \f[C]org\f[] input. +.SS Extension: \f[C]ntb\f[] +.PP +In the \f[C]context\f[] output format this enables the use of Natural +Tables (TABLE) instead of the default Extreme Tables (xtables). +Natural tables allow more fine\-grained global customization but come at +a performance penalty compared to extreme tables. .SH PANDOC\[aq]S MARKDOWN .PP Pandoc understands an extended and slightly revised version of John @@ -3714,6 +3709,23 @@ $endfor$ \f[] .fi +.PP +Raw content to include in the document\[aq]s header may be specified +using \f[C]header\-includes\f[]; however, it is important to mark up +this content as raw code for a particular output format, using the +\f[C]raw_attribute\f[] extension), or it will be interpreted as +markdown. +For example: +.IP +.nf +\f[C] +header\-includes: +\-\ ```{=latex} +\ \ \\let\\oldsection\\section +\ \ \\renewcommand{\\section}[1]{\\clearpage\\oldsection{#1}} +\ \ ``` +\f[] +.fi .SS Backslash escapes .SS Extension: \f[C]all_symbols_escapable\f[] .PP @@ -4157,13 +4169,15 @@ \f[] .fi .PP -In LaTeX output, the macro definitions will not be passed through as raw -LaTeX. +Note that LaTeX macros will not be applied if they occur inside inside a +raw span or block marked with the \f[C]raw_attribute\f[] extension. .PP -When \f[C]latex_macros\f[] is disabled, the macro definitions will be -passed through as raw LaTeX, and the raw LaTeX and math will not have -macros applied. +When \f[C]latex_macros\f[] is disabled, the raw LaTeX and math will not +have macros applied. This is usually a better approach when you are targeting LaTeX or PDF. +.PP +Whether or not \f[C]latex_macros\f[] is enabled, the macro definitions +will still be passed through as raw LaTeX. .SS Links .PP Markdown allows links to be specified in several ways. @@ -4359,7 +4373,7 @@ .IP .nf \f[C] -![This\ image\ won\[aq]t\ be\ a\ figure](/url/of/image.png)\\\ +![This\ image\ won\[aq]t\ be\ a\ figure](/url/of/image.png)\\ \f[] .fi .PP diff --git a/pandoc.cabal b/pandoc.cabal --- a/pandoc.cabal +++ b/pandoc.cabal @@ -1,5 +1,5 @@ name: pandoc -version: 2.1 +version: 2.1.1 cabal-version: >= 1.10 build-type: Custom license: GPL @@ -11,7 +11,7 @@ stability: alpha homepage: http://pandoc.org category: Text -tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2 +tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2 synopsis: Conversion between markup formats description: Pandoc is a Haskell library for converting from one markup format to another, and a command-line tool that uses @@ -347,6 +347,7 @@ unordered-containers >= 0.2 && < 0.3, parsec >= 3.1 && < 3.2, mtl >= 2.2 && < 2.3, + exceptions >= 0.8 && < 0.9, filepath >= 1.1 && < 1.5, process >= 1.2.3 && < 1.7, directory >= 1 && < 1.4, @@ -365,7 +366,7 @@ tagsoup >= 0.14.2 && < 0.15, base64-bytestring >= 0.1 && < 1.1, zlib >= 0.5 && < 0.7, - skylighting >= 0.5.1 && < 0.6, + skylighting >= 0.5.1 && < 0.7, data-default >= 0.4 && < 0.8, temporary >= 1.1 && < 1.3, blaze-html >= 0.5 && < 0.10, @@ -414,9 +415,6 @@ RelaxedPolyRec, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances hs-source-dirs: src - if impl(ghc < 7.10) - hs-source-dirs: prelude - other-modules: Prelude exposed-modules: Text.Pandoc, Text.Pandoc.App, @@ -501,11 +499,16 @@ Text.Pandoc.ImageSize, Text.Pandoc.BCP47, Text.Pandoc.Class - other-modules: Text.Pandoc.Readers.Docx.Lists, + other-modules: Text.Pandoc.Filter, + Text.Pandoc.Filter.JSON, + Text.Pandoc.Filter.Lua, + Text.Pandoc.Filter.Path, + Text.Pandoc.Readers.Docx.Lists, Text.Pandoc.Readers.Docx.Combine, Text.Pandoc.Readers.Docx.Parse, Text.Pandoc.Readers.Docx.Util, Text.Pandoc.Readers.Docx.StyleMap, + Text.Pandoc.Readers.Docx.Fields, Text.Pandoc.Readers.Odt.Base, Text.Pandoc.Readers.Odt.Namespaces, Text.Pandoc.Readers.Odt.StyleReader, @@ -526,6 +529,8 @@ Text.Pandoc.Readers.Org.ParserState, Text.Pandoc.Readers.Org.Parsing, Text.Pandoc.Readers.Org.Shared, + Text.Pandoc.Writers.Powerpoint.Presentation, + Text.Pandoc.Writers.Powerpoint.Output, Text.Pandoc.Lua.Filter, Text.Pandoc.Lua.Init, Text.Pandoc.Lua.Module.MediaBag, @@ -556,9 +561,6 @@ RelaxedPolyRec, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances hs-source-dirs: . - if impl(ghc < 7.10) - hs-source-dirs: prelude - other-modules: Prelude main-is: pandoc.hs buildable: True other-modules: Paths_pandoc @@ -566,9 +568,6 @@ executable trypandoc main-is: trypandoc.hs hs-source-dirs: trypandoc - if impl(ghc < 7.10) - hs-source-dirs: prelude - other-modules: Prelude default-language: Haskell2010 if flag(trypandoc) build-depends: base, aeson, pandoc, @@ -580,9 +579,6 @@ executable weigh-pandoc main-is: weigh-pandoc.hs hs-source-dirs: benchmark - if impl(ghc < 7.10) - hs-source-dirs: prelude - other-modules: Prelude if flag(weigh-pandoc) build-depends: pandoc, base >= 4.2 && < 5, @@ -599,9 +595,6 @@ type: exitcode-stdio-1.0 main-is: test-pandoc.hs hs-source-dirs: test - if impl(ghc < 7.10) - hs-source-dirs: prelude - other-modules: Prelude build-depends: base >= 4.2 && < 5, pandoc, pandoc-types >= 1.17.3 && < 1.18, @@ -615,11 +608,11 @@ process >= 1.2.3 && < 1.7, temporary >= 1.1 && < 1.3, Diff >= 0.2 && < 0.4, - tasty >= 0.11 && < 0.13, + tasty >= 0.11 && < 1.1, tasty-hunit >= 0.9 && < 0.11, tasty-quickcheck >= 0.8 && < 0.10, tasty-golden >= 2.3 && < 2.4, - QuickCheck >= 2.4 && < 2.11, + QuickCheck >= 2.4 && < 2.12, containers >= 0.4.2.1 && < 0.6, executable-path >= 0.0 && < 0.1, zip-archive >= 0.2.3.4 && < 0.4, @@ -681,13 +674,10 @@ type: exitcode-stdio-1.0 main-is: benchmark-pandoc.hs hs-source-dirs: benchmark - if impl(ghc < 7.10) - hs-source-dirs: prelude - other-modules: Prelude build-depends: pandoc, time, bytestring, containers, base >= 4.2 && < 5, text >= 0.11 && < 1.3, - criterion >= 1.0 && < 1.3 + criterion >= 1.0 && < 1.4 ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind default-language: Haskell98 diff --git a/prelude/Prelude.hs b/prelude/Prelude.hs deleted file mode 100644 --- a/prelude/Prelude.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE CPP #-} - --- This custom Prelude emulates the API of the prelude --- with base 4.8. - -module Prelude -( - module P -#if MIN_VERSION_base(4,8,0) -#else -, Monoid(..) -, Applicative(..) -, (<$>) -, (<$) -#endif -) -where - -#if MIN_VERSION_base(4,8,0) -import "base" Prelude as P -#else -import "base" Prelude as P -import Control.Applicative -import Data.Monoid -#endif diff --git a/src/Text/Pandoc/App.hs b/src/Text/Pandoc/App.hs --- a/src/Text/Pandoc/App.hs +++ b/src/Text/Pandoc/App.hs @@ -46,12 +46,11 @@ import Control.Monad import Control.Monad.Except (catchError, throwError) import Control.Monad.Trans -import Data.Aeson (defaultOptions, eitherDecode', encode) +import Data.Aeson (defaultOptions) import Data.Aeson.TH (deriveJSON) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as B import Data.Char (toLower, toUpper) -import Data.Foldable (foldrM) import Data.List (find, intercalate, isPrefixOf, isSuffixOf, sort) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust, isNothing) @@ -73,10 +72,9 @@ pygments) import Skylighting.Parser (addSyntaxDefinition, parseSyntaxDefinition) import System.Console.GetOpt -import System.Directory (Permissions (..), doesFileExist, findExecutable, - getAppUserDataDirectory, getPermissions) -import System.Environment (getArgs, getEnvironment, getProgName) -import System.Exit (ExitCode (..), exitSuccess) +import System.Directory (getAppUserDataDirectory) +import System.Environment (getArgs, getProgName) +import System.Exit (exitSuccess) import System.FilePath import System.IO (nativeNewline, stdout) import qualified System.IO as IO (Newline (..)) @@ -84,10 +82,9 @@ import Text.Pandoc import Text.Pandoc.BCP47 (Lang (..), parseBCP47) import Text.Pandoc.Builder (setMeta, deleteMeta) +import Text.Pandoc.Filter (Filter (JSONFilter, LuaFilter), applyFilters) import Text.Pandoc.Highlighting (highlightingStyles) -import Text.Pandoc.Lua (LuaException (..), runLuaFilter) import Text.Pandoc.PDF (makePDF) -import Text.Pandoc.Process (pipeProcess) import Text.Pandoc.SelfContained (makeDataURI, makeSelfContained) import Text.Pandoc.Shared (eastAsianLineBreakFilter, stripEmptyParagraphs, headerShift, isURI, ordNub, safeRead, tabFilter) @@ -538,48 +535,6 @@ isTextFormat :: String -> Bool isTextFormat s = s `notElem` ["odt","docx","epub2","epub3","epub","pptx"] -externalFilter :: MonadIO m - => ReaderOptions -> FilePath -> [String] -> Pandoc -> m Pandoc -externalFilter ropts f args' d = liftIO $ do - exists <- doesFileExist f - isExecutable <- if exists - then executable <$> getPermissions f - else return True - let (f', args'') = if exists - then case map toLower (takeExtension f) of - _ | isExecutable -> ("." f, args') - ".py" -> ("python", f:args') - ".hs" -> ("runhaskell", f:args') - ".pl" -> ("perl", f:args') - ".rb" -> ("ruby", f:args') - ".php" -> ("php", f:args') - ".js" -> ("node", f:args') - ".r" -> ("Rscript", f:args') - _ -> (f, args') - else (f, args') - unless (exists && isExecutable) $ do - mbExe <- findExecutable f' - when (isNothing mbExe) $ - E.throwIO $ PandocFilterError f ("Could not find executable " ++ f') - env <- getEnvironment - let env' = Just - ( ("PANDOC_VERSION", pandocVersion) - : ("PANDOC_READER_OPTIONS", UTF8.toStringLazy (encode ropts)) - : env ) - (exitcode, outbs) <- E.handle filterException $ - pipeProcess env' f' args'' $ encode d - case exitcode of - ExitSuccess -> either (E.throwIO . PandocFilterError f) - return $ eitherDecode' outbs - ExitFailure ec -> E.throwIO $ PandocFilterError f - ("Filter returned error status " ++ show ec) - where filterException :: E.SomeException -> IO a - filterException e = E.throwIO $ PandocFilterError f (show e) - -data Filter = LuaFilter FilePath - | JSONFilter FilePath - deriving (Show) - -- | Data structure for command line options. data Opt = Opt { optTabStop :: Int -- ^ Number of spaces per tab @@ -824,50 +779,6 @@ applyTransforms :: Monad m => [Transform] -> Pandoc -> m Pandoc applyTransforms transforms d = return $ foldr ($) d transforms - -- First we check to see if a filter is found. If not, and if it's - -- not an absolute path, we check to see whether it's in `userdir/filters`. - -- If not, we leave it unchanged. -expandFilterPath :: PandocMonad m => FilePath -> m FilePath -expandFilterPath fp = do - mbDatadir <- getUserDataDir - fpExists <- fileExists fp - if fpExists - then return fp - else case mbDatadir of - Just datadir | isRelative fp -> do - let filterPath = datadir "filters" fp - filterPathExists <- fileExists filterPath - if filterPathExists - then return filterPath - else return fp - _ -> return fp - -applyFilters :: ReaderOptions - -> [Filter] - -> [String] - -> Pandoc - -> PandocIO Pandoc -applyFilters ropts filters args d = do - foldrM ($) d $ map (applyFilter ropts args) filters - -applyFilter :: ReaderOptions - -> [String] - -> Filter - -> Pandoc - -> PandocIO Pandoc -applyFilter _ropts args (LuaFilter f) d = do - f' <- expandFilterPath f - let format = case args of - (x:_) -> x - _ -> error "Format not supplied for lua filter" - res <- runLuaFilter f' format d - case res of - Right x -> return x - Left (LuaException s) -> E.throw (PandocFilterError f s) -applyFilter ropts args (JSONFilter f) d = do - f' <- expandFilterPath f - liftIO $ externalFilter ropts f' args d - readSource :: FilePath -> PandocIO Text readSource "-" = liftIO (UTF8.toText <$> BS.getContents) readSource src = case parseURI src of @@ -1722,5 +1633,4 @@ -- see https://github.com/jgm/pandoc/pull/4083 -- using generic deriving caused long compilation times $(deriveJSON defaultOptions ''LineEnding) -$(deriveJSON defaultOptions ''Filter) $(deriveJSON defaultOptions ''Opt) diff --git a/src/Text/Pandoc/Extensions.hs b/src/Text/Pandoc/Extensions.hs --- a/src/Text/Pandoc/Extensions.hs +++ b/src/Text/Pandoc/Extensions.hs @@ -133,6 +133,7 @@ | Ext_multiline_tables -- ^ Pandoc-style multiline tables | Ext_native_divs -- ^ Use Div blocks for contents of
tags | Ext_native_spans -- ^ Use Span inlines for contents of + | Ext_ntb -- ^ ConTeXt Natural Tables | Ext_old_dashes -- ^ -- = em, - before number = en | Ext_pandoc_title_block -- ^ Pandoc title block | Ext_pipe_tables -- ^ Pipe tables (as in PHP markdown extra) diff --git a/src/Text/Pandoc/Filter.hs b/src/Text/Pandoc/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Filter.hs @@ -0,0 +1,60 @@ +{- +Copyright (C) 2006-2017 John MacFarlane + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} +{-# LANGUAGE TemplateHaskell #-} + +{- | + Module : Text.Pandoc.Filter + Copyright : Copyright (C) 2006-2017 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Programmatically modifications of pandoc documents. +-} +module Text.Pandoc.Filter + ( Filter (..) + , applyFilters + ) where + +import Data.Aeson (defaultOptions) +import Data.Aeson.TH (deriveJSON) +import Data.Foldable (foldrM) +import Text.Pandoc.Class (PandocIO) +import Text.Pandoc.Definition (Pandoc) +import Text.Pandoc.Options (ReaderOptions) +import qualified Text.Pandoc.Filter.JSON as JSONFilter +import qualified Text.Pandoc.Filter.Lua as LuaFilter + +data Filter = LuaFilter FilePath + | JSONFilter FilePath + deriving (Show) + +applyFilters :: ReaderOptions + -> [Filter] + -> [String] + -> Pandoc + -> PandocIO Pandoc +applyFilters ropts filters args d = do + foldrM ($) d $ map applyFilter filters + where + applyFilter (JSONFilter f) = JSONFilter.apply ropts args f + applyFilter (LuaFilter f) = LuaFilter.apply ropts args f + +$(deriveJSON defaultOptions ''Filter) diff --git a/src/Text/Pandoc/Filter/JSON.hs b/src/Text/Pandoc/Filter/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Filter/JSON.hs @@ -0,0 +1,97 @@ +{- +Copyright (C) 2006-2018 John MacFarlane + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Filter + Copyright : Copyright (C) 2006-2018 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Programmatically modifications of pandoc documents via JSON filters. +-} +module Text.Pandoc.Filter.JSON (apply) where + +import Control.Monad (unless, when) +import Control.Monad.Trans (MonadIO (liftIO)) +import Data.Aeson (eitherDecode', encode) +import Data.Char (toLower) +import Data.Maybe (isNothing) +import System.Directory (executable, doesFileExist, findExecutable, + getPermissions) +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..)) +import System.FilePath ((), takeExtension) +import Text.Pandoc.Class (PandocIO) +import Text.Pandoc.Error (PandocError (PandocFilterError)) +import Text.Pandoc.Definition (Pandoc) +import Text.Pandoc.Filter.Path (expandFilterPath) +import Text.Pandoc.Options (ReaderOptions) +import Text.Pandoc.Process (pipeProcess) +import Text.Pandoc.Shared (pandocVersion) +import qualified Control.Exception as E +import qualified Text.Pandoc.UTF8 as UTF8 + +apply :: ReaderOptions + -> [String] + -> FilePath + -> Pandoc + -> PandocIO Pandoc +apply ropts args f d = do + f' <- expandFilterPath f + liftIO $ externalFilter ropts f' args d + +externalFilter :: MonadIO m + => ReaderOptions -> FilePath -> [String] -> Pandoc -> m Pandoc +externalFilter ropts f args' d = liftIO $ do + exists <- doesFileExist f + isExecutable <- if exists + then executable <$> getPermissions f + else return True + let (f', args'') = if exists + then case map toLower (takeExtension f) of + _ | isExecutable -> ("." f, args') + ".py" -> ("python", f:args') + ".hs" -> ("runhaskell", f:args') + ".pl" -> ("perl", f:args') + ".rb" -> ("ruby", f:args') + ".php" -> ("php", f:args') + ".js" -> ("node", f:args') + ".r" -> ("Rscript", f:args') + _ -> (f, args') + else (f, args') + unless (exists && isExecutable) $ do + mbExe <- findExecutable f' + when (isNothing mbExe) $ + E.throwIO $ PandocFilterError f ("Could not find executable " ++ f') + env <- getEnvironment + let env' = Just + ( ("PANDOC_VERSION", pandocVersion) + : ("PANDOC_READER_OPTIONS", UTF8.toStringLazy (encode ropts)) + : env ) + (exitcode, outbs) <- E.handle filterException $ + pipeProcess env' f' args'' $ encode d + case exitcode of + ExitSuccess -> either (E.throwIO . PandocFilterError f) + return $ eitherDecode' outbs + ExitFailure ec -> E.throwIO $ PandocFilterError f + ("Filter returned error status " ++ show ec) + where filterException :: E.SomeException -> IO a + filterException e = E.throwIO $ PandocFilterError f (show e) diff --git a/src/Text/Pandoc/Filter/Lua.hs b/src/Text/Pandoc/Filter/Lua.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Filter/Lua.hs @@ -0,0 +1,53 @@ +{- +Copyright (C) 2006-2018 John MacFarlane + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Filter.Lua + Copyright : Copyright (C) 2006-2018 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Apply Lua filters to modify a pandoc documents programmatically. +-} +module Text.Pandoc.Filter.Lua (apply) where + +import Control.Exception (throw) +import Text.Pandoc.Class (PandocIO) +import Text.Pandoc.Definition (Pandoc) +import Text.Pandoc.Error (PandocError (PandocFilterError)) +import Text.Pandoc.Filter.Path (expandFilterPath) +import Text.Pandoc.Lua (LuaException (..), runLuaFilter) +import Text.Pandoc.Options (ReaderOptions) + +apply :: ReaderOptions + -> [String] + -> FilePath + -> Pandoc + -> PandocIO Pandoc +apply ropts args f d = do + f' <- expandFilterPath f + let format = case args of + (x:_) -> x + _ -> error "Format not supplied for lua filter" + res <- runLuaFilter ropts f' format d + case res of + Right x -> return x + Left (LuaException s) -> throw (PandocFilterError f s) diff --git a/src/Text/Pandoc/Filter/Path.hs b/src/Text/Pandoc/Filter/Path.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Filter/Path.hs @@ -0,0 +1,53 @@ +{- +Copyright (C) 2006-2018 John MacFarlane + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Filter.Path + Copyright : Copyright (C) 2006-2018 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Expand paths of filters, searching the data directory. +-} +module Text.Pandoc.Filter.Path + ( expandFilterPath + ) where + +import Text.Pandoc.Class (PandocMonad, fileExists, getUserDataDir) +import System.FilePath ((), isRelative) + + -- First we check to see if a filter is found. If not, and if it's + -- not an absolute path, we check to see whether it's in `userdir/filters`. + -- If not, we leave it unchanged. +expandFilterPath :: PandocMonad m => FilePath -> m FilePath +expandFilterPath fp = do + mbDatadir <- getUserDataDir + fpExists <- fileExists fp + if fpExists + then return fp + else case mbDatadir of + Just datadir | isRelative fp -> do + let filterPath = datadir "filters" fp + filterPathExists <- fileExists filterPath + if filterPathExists + then return filterPath + else return fp + _ -> return fp diff --git a/src/Text/Pandoc/ImageSize.hs b/src/Text/Pandoc/ImageSize.hs --- a/src/Text/Pandoc/ImageSize.hs +++ b/src/Text/Pandoc/ImageSize.hs @@ -83,6 +83,7 @@ | Inch Double | Percent Double | Em Double + deriving Eq instance Show Dimension where show (Pixel a) = show a ++ "px" diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs --- a/src/Text/Pandoc/Lua.hs +++ b/src/Text/Pandoc/Lua.hs @@ -39,21 +39,22 @@ import Text.Pandoc.Lua.Filter (LuaFilter, walkMWithLuaFilter) import Text.Pandoc.Lua.Init (runPandocLua) import Text.Pandoc.Lua.Util (popValue) +import Text.Pandoc.Options (ReaderOptions) import qualified Foreign.Lua as Lua -- | Run the Lua filter in @filterPath@ for a transformation to target -- format @format@. Pandoc uses Lua init files to setup the Lua -- interpreter. -runLuaFilter :: FilePath -> String +runLuaFilter :: ReaderOptions -> FilePath -> String -> Pandoc -> PandocIO (Either LuaException Pandoc) -runLuaFilter filterPath format doc = - runPandocLua (runLuaFilter' filterPath format doc) +runLuaFilter ropts filterPath format doc = + runPandocLua (runLuaFilter' ropts filterPath format doc) -runLuaFilter' :: FilePath -> String +runLuaFilter' :: ReaderOptions -> FilePath -> String -> Pandoc -> Lua Pandoc -runLuaFilter' filterPath format pd = do - -- store module in global "pandoc" +runLuaFilter' ropts filterPath format pd = do registerFormat + registerReaderOptions top <- Lua.gettop stat <- Lua.dofile filterPath if stat /= OK @@ -72,6 +73,10 @@ registerFormat = do push format Lua.setglobal "FORMAT" + + registerReaderOptions = do + push ropts + Lua.setglobal "PANDOC_READER_OPTIONS" runAll :: [LuaFilter] -> Pandoc -> Lua Pandoc runAll = foldr ((>=>) . walkMWithLuaFilter) return diff --git a/src/Text/Pandoc/Lua/Filter.hs b/src/Text/Pandoc/Lua/Filter.hs --- a/src/Text/Pandoc/Lua/Filter.hs +++ b/src/Text/Pandoc/Lua/Filter.hs @@ -11,6 +11,7 @@ , inlineElementNames ) where import Control.Monad (mplus, unless, when, (>=>)) +import Control.Monad.Catch (finally) import Text.Pandoc.Definition import Data.Foldable (foldrM) import Data.Map (Map) @@ -22,6 +23,7 @@ import Data.Data (Data, DataType, dataTypeConstrs, dataTypeName, dataTypeOf, showConstr, toConstr, tyconUQname) import Text.Pandoc.Lua.StackInstances() +import Text.Pandoc.Lua.Util (typeCheck) type FunctionMap = Map String LuaFilterFunction @@ -65,7 +67,7 @@ elementOrList :: FromLuaStack a => a -> Lua [a] elementOrList x = do - let topOfStack = Lua.StackIndex (-1) + let topOfStack = Lua.stackTop elementUnchanged <- Lua.isnil topOfStack if elementUnchanged then [x] <$ Lua.pop 1 @@ -73,7 +75,9 @@ mbres <- Lua.peekEither topOfStack case mbres of Right res -> [res] <$ Lua.pop 1 - Left _ -> Lua.toList topOfStack <* Lua.pop 1 + Left _ -> do + typeCheck Lua.stackTop Lua.TypeTable + Lua.toList topOfStack `finally` Lua.pop 1 -- | Try running a filter for the given element tryFilter :: (Data a, FromLuaStack a, ToLuaStack a) diff --git a/src/Text/Pandoc/Lua/Module/Utils.hs b/src/Text/Pandoc/Lua/Module/Utils.hs --- a/src/Text/Pandoc/Lua/Module/Utils.hs +++ b/src/Text/Pandoc/Lua/Module/Utils.hs @@ -30,22 +30,26 @@ ) where import Control.Applicative ((<|>)) +import Data.Default (def) import Foreign.Lua (FromLuaStack, Lua, LuaInteger, NumResults) +import Text.Pandoc.Class (runIO, setUserDataDir) import Text.Pandoc.Definition (Pandoc, Meta, MetaValue, Block, Inline) import Text.Pandoc.Lua.StackInstances () -import Text.Pandoc.Lua.Util (addFunction) +import Text.Pandoc.Lua.Util (addFunction, popValue) import qualified Data.Digest.Pure.SHA as SHA import qualified Data.ByteString.Lazy as BSL import qualified Foreign.Lua as Lua +import qualified Text.Pandoc.Filter.JSON as JSONFilter import qualified Text.Pandoc.Shared as Shared -- | Push the "pandoc.utils" module to the lua stack. -pushModule :: Lua NumResults -pushModule = do +pushModule :: Maybe FilePath -> Lua NumResults +pushModule mbDatadir = do Lua.newtable addFunction "hierarchicalize" hierarchicalize addFunction "normalize_date" normalizeDate + addFunction "run_json_filter" (runJSONFilter mbDatadir) addFunction "sha1" sha1 addFunction "stringify" stringify addFunction "to_roman_numeral" toRomanNumeral @@ -61,6 +65,25 @@ -- Returns nil instead of a string if the conversion failed. normalizeDate :: String -> Lua (Lua.Optional String) normalizeDate = return . Lua.Optional . Shared.normalizeDate + +-- | Run a JSON filter on the given document. +runJSONFilter :: Maybe FilePath + -> Pandoc + -> FilePath + -> Lua.Optional [String] + -> Lua NumResults +runJSONFilter mbDatadir doc filterFile optArgs = do + args <- case Lua.fromOptional optArgs of + Just x -> return x + Nothing -> do + Lua.getglobal "FORMAT" + (:[]) <$> popValue + filterRes <- Lua.liftIO . runIO $ do + setUserDataDir mbDatadir + JSONFilter.apply def args filterFile doc + case filterRes of + Left err -> Lua.raiseError (show err) + Right d -> (1 :: NumResults) <$ Lua.push d -- | Calculate the hash of the given contents. sha1 :: BSL.ByteString diff --git a/src/Text/Pandoc/Lua/Packages.hs b/src/Text/Pandoc/Lua/Packages.hs --- a/src/Text/Pandoc/Lua/Packages.hs +++ b/src/Text/Pandoc/Lua/Packages.hs @@ -78,7 +78,8 @@ "pandoc.mediabag" -> let st = luaPkgCommonState luaPkgParams mbRef = luaPkgMediaBag luaPkgParams in pushWrappedHsFun (MediaBag.pushModule st mbRef) - "pandoc.utils" -> pushWrappedHsFun Utils.pushModule + "pandoc.utils" -> let datadirMb = luaPkgDataDir luaPkgParams + in pushWrappedHsFun (Utils.pushModule datadirMb) _ -> searchPureLuaLoader where pushWrappedHsFun f = do diff --git a/src/Text/Pandoc/Lua/StackInstances.hs b/src/Text/Pandoc/Lua/StackInstances.hs --- a/src/Text/Pandoc/Lua/StackInstances.hs +++ b/src/Text/Pandoc/Lua/StackInstances.hs @@ -16,8 +16,9 @@ along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- | Module : Text.Pandoc.Lua.StackInstances @@ -34,30 +35,43 @@ import Control.Applicative ((<|>)) import Control.Monad (when) +import Control.Monad.Catch (finally) +import Data.Data (showConstr, toConstr) +import Data.Foldable (forM_) import Foreign.Lua (FromLuaStack (peek), Lua, LuaInteger, LuaNumber, StackIndex, ToLuaStack (push), Type (..), throwLuaError, tryLua) import Text.Pandoc.Definition -import Text.Pandoc.Lua.Util (adjustIndexBy, getTable, pushViaConstructor) +import Text.Pandoc.Extensions (Extensions) +import Text.Pandoc.Lua.Util (adjustIndexBy, getTable, pushViaConstructor, + typeCheck) +import Text.Pandoc.Options (ReaderOptions (..), TrackChanges) import Text.Pandoc.Shared (Element (Blk, Sec), safeRead) import qualified Foreign.Lua as Lua +import qualified Data.Set as Set import qualified Text.Pandoc.Lua.Util as LuaUtil +defineHowTo :: String -> Lua a -> Lua a +defineHowTo ctx op = op `Lua.modifyLuaError` (("Could not " ++ ctx ++ ": ") ++) + instance ToLuaStack Pandoc where push (Pandoc meta blocks) = pushViaConstructor "Pandoc" blocks meta instance FromLuaStack Pandoc where - peek idx = do + peek idx = defineHowTo "get Pandoc value" $ do + typeCheck idx Lua.TypeTable blocks <- getTable idx "blocks" - meta <- getTable idx "meta" + meta <- Lua.getfield idx "meta" *> (Lua.peek Lua.stackTop `finally` Lua.pop 1) return $ Pandoc meta blocks instance ToLuaStack Meta where push (Meta mmap) = pushViaConstructor "Meta" mmap instance FromLuaStack Meta where - peek idx = Meta <$> peek idx + peek idx = defineHowTo "get Meta value" $ do + typeCheck idx Lua.TypeTable + Meta <$> peek idx instance ToLuaStack MetaValue where push = pushMetaValue @@ -154,7 +168,7 @@ -- | Interpret the value at the given stack index as meta value. peekMetaValue :: StackIndex -> Lua MetaValue -peekMetaValue idx = do +peekMetaValue idx = defineHowTo "get MetaValue" $ do -- Get the contents of an AST element. let elementContent :: FromLuaStack a => Lua a elementContent = peek idx @@ -203,7 +217,8 @@ -- | Return the value at the given index as block if possible. peekBlock :: StackIndex -> Lua Block -peekBlock idx = do +peekBlock idx = defineHowTo "get Block value" $ do + typeCheck idx Lua.TypeTable tag <- getTag idx case tag of "BlockQuote" -> BlockQuote <$> elementContent @@ -254,7 +269,8 @@ -- | Return the value at the given index as inline if possible. peekInline :: StackIndex -> Lua Inline -peekInline idx = do +peekInline idx = defineHowTo "get Inline value" $ do + typeCheck idx Lua.TypeTable tag <- getTag idx case tag of "Cite" -> uncurry Cite <$> elementContent @@ -290,11 +306,7 @@ hasMT <- Lua.getmetatable idx push "tag" if hasMT then Lua.rawget (-2) else Lua.rawget (idx `adjustIndexBy` 1) - r <- tryLua (peek (-1)) - Lua.settop top - case r of - Left (Lua.LuaException err) -> throwLuaError err - Right res -> return res + peek Lua.stackTop `finally` Lua.settop top withAttr :: (Attr -> a -> b) -> (LuaAttr, a) -> b withAttr f (attributes, x) = f (fromLuaAttr attributes) x @@ -307,7 +319,7 @@ pushViaConstructor "Attr" id' classes kv instance FromLuaStack LuaAttr where - peek idx = LuaAttr <$> peek idx + peek idx = defineHowTo "get Attr value" (LuaAttr <$> peek idx) -- -- Hierarchical elements @@ -332,3 +344,43 @@ Lua.push "__index" Lua.pushvalue (-2) Lua.rawset (-3) + + +-- +-- Reader Options +-- +instance ToLuaStack Extensions where + push exts = push (show exts) + +instance ToLuaStack TrackChanges where + push = push . showConstr . toConstr + +instance ToLuaStack a => ToLuaStack (Set.Set a) where + push set = do + Lua.newtable + forM_ set (`LuaUtil.addValue` True) + +instance ToLuaStack ReaderOptions where + push ro = do + let ReaderOptions + (extensions :: Extensions) + (standalone :: Bool) + (columns :: Int) + (tabStop :: Int) + (indentedCodeClasses :: [String]) + (abbreviations :: Set.Set String) + (defaultImageExtension :: String) + (trackChanges :: TrackChanges) + (stripComments :: Bool) + = ro + Lua.newtable + LuaUtil.addValue "extensions" extensions + LuaUtil.addValue "standalone" standalone + LuaUtil.addValue "columns" columns + LuaUtil.addValue "tabStop" tabStop + LuaUtil.addValue "indentedCodeClasses" indentedCodeClasses + LuaUtil.addValue "abbreviations" abbreviations + LuaUtil.addValue "defaultImageExtension" defaultImageExtension + LuaUtil.addValue "trackChanges" trackChanges + LuaUtil.addValue "stripComments" stripComments + diff --git a/src/Text/Pandoc/Lua/Util.hs b/src/Text/Pandoc/Lua/Util.hs --- a/src/Text/Pandoc/Lua/Util.hs +++ b/src/Text/Pandoc/Lua/Util.hs @@ -36,6 +36,7 @@ , getRawInt , setRawInt , addRawInt + , typeCheck , raiseError , popValue , PushViaCall @@ -99,6 +100,14 @@ -- | Set numeric key/value in table at the top of the stack. addRawInt :: ToLuaStack a => Int -> a -> Lua () addRawInt = setRawInt (-1) + +typeCheck :: StackIndex -> Lua.Type -> Lua () +typeCheck idx expected = do + actual <- Lua.ltype idx + when (actual /= expected) $ do + expName <- Lua.typename expected + actName <- Lua.typename actual + Lua.throwLuaError $ "expected " ++ expName ++ " but got " ++ actName ++ "." raiseError :: ToLuaStack a => a -> Lua NumResults raiseError e = do diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs --- a/src/Text/Pandoc/Parsing.hs +++ b/src/Text/Pandoc/Parsing.hs @@ -180,6 +180,7 @@ sourceLine, setSourceColumn, setSourceLine, + incSourceColumn, newPos, Line, Column diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs --- a/src/Text/Pandoc/Readers/Docx.hs +++ b/src/Text/Pandoc/Readers/Docx.hs @@ -446,6 +446,11 @@ return $ math $ writeTeX exps parPartToInlines' (SmartTag runs) = do smushInlines <$> mapM runToInlines runs +parPartToInlines' (Field info runs) = do + case info of + HyperlinkField url -> parPartToInlines' $ ExternalHyperLink url runs + UnknownField -> smushInlines <$> mapM runToInlines runs +parPartToInlines' NullParPart = return mempty isAnchorSpan :: Inline -> Bool isAnchorSpan (Span (_, classes, kvs) _) = diff --git a/src/Text/Pandoc/Readers/Docx/Fields.hs b/src/Text/Pandoc/Readers/Docx/Fields.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/Docx/Fields.hs @@ -0,0 +1,89 @@ +{- +Copyright (C) 2014-2018 Jesse Rosenthal + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Readers.Docx.Fields + Copyright : Copyright (C) 2014-2018 Jesse Rosenthal + License : GNU GPL, version 2 or above + + Maintainer : Jesse Rosenthal + Stability : alpha + Portability : portable + +For parsing Field definitions in instText tags, as described in +ECMA-376-1:2016, §17.16.5 -} + +module Text.Pandoc.Readers.Docx.Fields ( FieldInfo(..) + , parseFieldInfo + ) where + +import Text.Parsec +import Text.Parsec.String (Parser) + +type URL = String + +data FieldInfo = HyperlinkField URL + | UnknownField + deriving (Show) + +parseFieldInfo :: String -> Either ParseError FieldInfo +parseFieldInfo = parse fieldInfo "" + +fieldInfo :: Parser FieldInfo +fieldInfo = + (try $ HyperlinkField <$> hyperlink) + <|> + return UnknownField + +escapedQuote :: Parser String +escapedQuote = string "\\\"" + +inQuotes :: Parser String +inQuotes = do + (try escapedQuote) <|> (anyChar >>= (\c -> return [c])) + +quotedString :: Parser String +quotedString = do + char '"' + concat <$> manyTill inQuotes (try (char '"')) + +unquotedString :: Parser String +unquotedString = manyTill anyChar (try (space)) + +fieldArgument :: Parser String +fieldArgument = quotedString <|> unquotedString + +-- there are other switches, but this is the only one I've seen in the wild so far, so it's the first one I'll implement. See §17.16.5.25 +hyperlinkSwitch :: Parser (String, String) +hyperlinkSwitch = do + sw <- string "\\l" + spaces + farg <- fieldArgument + return (sw, farg) + +hyperlink :: Parser URL +hyperlink = do + many space + string "HYPERLINK" + spaces + farg <- fieldArgument + switches <- (spaces *> many hyperlinkSwitch) + let url = case switches of + ("\\l", s) : _ -> farg ++ ('#': s) + _ -> farg + return url diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs --- a/src/Text/Pandoc/Readers/Docx/Parse.hs +++ b/src/Text/Pandoc/Readers/Docx/Parse.hs @@ -54,6 +54,7 @@ , TrackedChange(..) , ChangeType(..) , ChangeInfo(..) + , FieldInfo(..) , archiveToDocx , archiveToDocxWithWarnings ) where @@ -70,6 +71,7 @@ import Data.Maybe import System.FilePath import Text.Pandoc.Readers.Docx.Util +import Text.Pandoc.Readers.Docx.Fields import Text.Pandoc.Shared (filteredFilesFromArchive, safeRead) import qualified Text.Pandoc.UTF8 as UTF8 import Text.TeXMath (Exp) @@ -90,10 +92,19 @@ } deriving Show -data ReaderState = ReaderState { stateWarnings :: [String] } +data ReaderState = ReaderState { stateWarnings :: [String] + , stateFldCharState :: FldCharState + } deriving Show -data DocxError = DocxError | WrongElem +data FldCharState = FldCharOpen + | FldCharFieldInfo FieldInfo + | FldCharContent FieldInfo [Run] + | FldCharClosed + deriving (Show) + +data DocxError = DocxError + | WrongElem deriving Show type D = ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) @@ -265,6 +276,9 @@ | Chart -- placeholder for now | PlainOMath [Exp] | SmartTag [Run] + | Field FieldInfo [Run] + | NullParPart -- when we need to return nothing, but + -- not because of an error. deriving Show data Run = Run RunStyle [RunElem] @@ -328,7 +342,9 @@ (styles, parstyles) = archiveToStyles archive rEnv = ReaderEnv notes comments numbering rels media Nothing styles parstyles InDocument - rState = ReaderState { stateWarnings = [] } + rState = ReaderState { stateWarnings = [] + , stateFldCharState = FldCharClosed + } (eitherDoc, st) = runD (archiveToDocument archive) rEnv rState case eitherDoc of Right doc -> Right (Docx doc, stateWarnings st) @@ -736,9 +752,77 @@ , c_ns <- "http://schemas.openxmlformats.org/drawingml/2006/chart" , Just _ <- findElement (QName "chart" (Just c_ns) (Just "c")) drawingElem = return Chart +{- +The next one is a bit complicated. fldChar fields work by first +having a in a run, then a run with +, then a run, then the +content runs, and finally a run. For +example (omissions and my comments in brackets): + + + [...] + + + + [...] + HYPERLINK [hyperlink url] + + + [...] + + + + [...] + Foundations of Analysis, 2nd Edition + + + [...] + + + +So we do this in a number of steps. If we encounter the fldchar begin +tag, we start open a fldchar state variable (see state above). We add +the instrtext to it as FieldInfo. Then we close that and start adding +the runs when we get to separate. Then when we get to end, we produce +the Field type with approriate FieldInfo and Runs. +-} elemToParPart ns element - | isElem ns "w" "r" element = - elemToRun ns element >>= (\r -> return $ PlainRun r) + | isElem ns "w" "r" element + , Just fldChar <- findChildByName ns "w" "fldChar" element + , Just fldCharType <- findAttrByName ns "w" "fldCharType" fldChar = do + fldCharState <- gets stateFldCharState + case fldCharState of + FldCharClosed | fldCharType == "begin" -> do + modify $ \st -> st {stateFldCharState = FldCharOpen} + return NullParPart + FldCharFieldInfo info | fldCharType == "separate" -> do + modify $ \st -> st {stateFldCharState = FldCharContent info []} + return NullParPart + FldCharContent info runs | fldCharType == "end" -> do + modify $ \st -> st {stateFldCharState = FldCharClosed} + return $ Field info $ reverse runs + _ -> throwError WrongElem +elemToParPart ns element + | isElem ns "w" "r" element + , Just instrText <- findChildByName ns "w" "instrText" element = do + fldCharState <- gets stateFldCharState + case fldCharState of + FldCharOpen -> do + info <- eitherToD $ parseFieldInfo $ strContent instrText + modify $ \st -> st{stateFldCharState = FldCharFieldInfo info} + return NullParPart + _ -> return NullParPart +elemToParPart ns element + | isElem ns "w" "r" element = do + run <- elemToRun ns element + -- we check to see if we have an open FldChar in state that we're + -- recording. + fldCharState <- gets stateFldCharState + case fldCharState of + FldCharContent info runs -> do + modify $ \st -> st{stateFldCharState = FldCharContent info (run : runs)} + return NullParPart + _ -> return $ PlainRun run elemToParPart ns element | Just change <- getTrackedChange ns element = do runs <- mapD (elemToRun ns) (elChildren element) diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs --- a/src/Text/Pandoc/Readers/HTML.hs +++ b/src/Text/Pandoc/Readers/HTML.hs @@ -531,15 +531,18 @@ skipMany pBlank optional $ pSatisfy (matchTagClose "col") skipMany pBlank - return $ case lookup "width" attribs of + let width = case lookup "width" attribs of Nothing -> case lookup "style" attribs of Just ('w':'i':'d':'t':'h':':':xs) | '%' `elem` xs -> - fromMaybe 0.0 $ safeRead ('0':'.':filter + fromMaybe 0.0 $ safeRead (filter (`notElem` (" \t\r\n%'\";" :: [Char])) xs) _ -> 0.0 Just x | not (null x) && last x == '%' -> - fromMaybe 0.0 $ safeRead ('0':'.':init x) + fromMaybe 0.0 $ safeRead (init x) _ -> 0.0 + if width > 0.0 + then return $ width / 100.0 + else return 0.0 pColgroup :: PandocMonad m => TagParser m [Double] pColgroup = try $ do diff --git a/src/Text/Pandoc/Readers/LaTeX.hs b/src/Text/Pandoc/Readers/LaTeX.hs --- a/src/Text/Pandoc/Readers/LaTeX.hs +++ b/src/Text/Pandoc/Readers/LaTeX.hs @@ -272,10 +272,8 @@ lookAhead (try (char '\\' >> letter)) -- we don't want to apply newly defined latex macros to their own -- definitions: - (do (_, raw) <- rawLaTeXParser macroDef - (guardDisabled Ext_latex_macros >> return raw) <|> return "") - <|> (do (_, raw) <- rawLaTeXParser (environment <|> blockCommand) - applyMacros raw) + (snd <$> rawLaTeXParser macroDef) + <|> ((snd <$> rawLaTeXParser (environment <|> blockCommand)) >>= applyMacros) rawLaTeXInline :: (PandocMonad m, HasMacros s, HasReaderOptions s) => ParserT String s m String @@ -333,13 +331,16 @@ -> (T.pack "\n", T.span isSpaceOrTab r2) _ -> (mempty, (mempty, r1)) + ws = "\\" <> w1 <> w2 <> w3 in case T.uncons r3 of Just ('\n', _) -> Tok pos (CtrlSeq " ") ("\\" <> w1) - : totoks (incSourceColumn pos 1) r1 + : totoks (incSourceColumn pos (T.length ws)) + r1 _ -> - Tok pos (CtrlSeq " ") ("\\" <> w1 <> w2 <> w3) - : totoks (incSourceColumn pos 1) r3 + Tok pos (CtrlSeq " ") ws + : totoks (incSourceColumn pos (T.length ws)) + r3 | otherwise -> Tok pos (CtrlSeq (T.singleton d)) (T.pack [c,d]) : totoks (incSourceColumn pos 2) rest' @@ -404,7 +405,7 @@ | otherwise = Nothing updatePos :: SourcePos -> Tok -> [Tok] -> SourcePos updatePos _spos _ (Tok pos _ _ : _) = pos - updatePos spos _ [] = spos + updatePos spos _ [] = incSourceColumn spos 1 doMacros :: PandocMonad m => Int -> LP m () doMacros n = do @@ -442,19 +443,22 @@ Just o -> (:) <$> option o bracketedToks <*> count (numargs - 1) getarg - let addTok (Tok _ (Arg i) _) acc | i > 0 - , i <= numargs = - foldr addTok acc (args !! (i - 1)) + -- first boolean param is true if we're tokenizing + -- an argument (in which case we don't want to + -- expand #1 etc.) + let addTok False (Tok _ (Arg i) _) acc | i > 0 + , i <= numargs = + foldr (addTok True) acc (args !! (i - 1)) -- add space if needed after control sequence -- see #4007 - addTok (Tok _ (CtrlSeq x) txt) + addTok _ (Tok _ (CtrlSeq x) txt) acc@(Tok _ Word _ : _) | not (T.null txt) && (isLetter (T.last txt)) = Tok spos (CtrlSeq x) (txt <> " ") : acc - addTok t acc = setpos spos t : acc + addTok _ t acc = setpos spos t : acc ts' <- getInput - setInput $ foldr addTok ts' newtoks + setInput $ foldr (addTok False) ts' newtoks case expansionPoint of ExpandWhenUsed -> if n > 20 -- detect macro expansion loops diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs --- a/src/Text/Pandoc/Readers/Markdown.hs +++ b/src/Text/Pandoc/Readers/Markdown.hs @@ -122,6 +122,13 @@ skipSpaces notFollowedBy (char '\n') +spnl' :: PandocMonad m => ParserT [Char] st m String +spnl' = try $ do + xs <- many spaceChar + ys <- option "" $ try $ (:) <$> newline + <*> (many spaceChar <* notFollowedBy (char '\n')) + return (xs ++ ys) + indentSpaces :: PandocMonad m => MarkdownParser m String indentSpaces = try $ do tabStop <- getOption readerTabStop @@ -148,19 +155,27 @@ -- | Parse a sequence of inline elements between square brackets, -- including inlines between balanced pairs of square brackets. inlinesInBalancedBrackets :: PandocMonad m => MarkdownParser m (F Inlines) -inlinesInBalancedBrackets = try $ char '[' >> go 1 - where go :: PandocMonad m => Int -> MarkdownParser m (F Inlines) - go 0 = return mempty - go openBrackets = - (mappend <$> (bracketedSpan <|> link <|> image) <*> - go openBrackets) - <|> ((if openBrackets > 1 - then (return (B.str "]") <>) - else id) <$> - (char ']' >> go (openBrackets - 1))) - <|> ((return (B.str "[") <>) <$> - (char '[' >> go (openBrackets + 1))) - <|> (mappend <$> inline <*> go openBrackets) +inlinesInBalancedBrackets = + try $ char '[' >> withRaw (go 1) >>= + parseFromString inlines . stripBracket . snd + where stripBracket [] = [] + stripBracket xs = if last xs == ']' then init xs else xs + go :: PandocMonad m => Int -> MarkdownParser m () + go 0 = return () + go openBrackets = do + (() <$ (escapedChar <|> + code <|> + rawHtmlInline <|> + rawLaTeXInline') >> go openBrackets) + <|> + (do char ']' + if openBrackets > 1 + then go (openBrackets - 1) + else return ()) + <|> + (char '[' >> go (openBrackets + 1)) + <|> + (anyChar >> go openBrackets) -- -- document structure @@ -1117,10 +1132,9 @@ lookAhead $ try $ char '\\' >> letter result <- (B.rawBlock "context" . trim . concat <$> many1 ((++) <$> (rawConTeXtEnvironment <|> conTeXtCommand) - <*> (blanklines <|> many spaceChar))) + <*> spnl')) <|> (B.rawBlock "latex" . trim . concat <$> - many1 ((++) <$> rawLaTeXBlock - <*> (blanklines <|> many spaceChar))) + many1 ((++) <$> rawLaTeXBlock <*> spnl')) return $ case B.toList result of [RawBlock _ cs] | all (`elem` [' ','\t','\n']) cs -> return mempty diff --git a/src/Text/Pandoc/Readers/Muse.hs b/src/Text/Pandoc/Readers/Muse.hs --- a/src/Text/Pandoc/Readers/Muse.hs +++ b/src/Text/Pandoc/Readers/Muse.hs @@ -42,7 +42,8 @@ import Control.Monad import Control.Monad.Except (throwError) import Data.Char (isLetter) -import Data.List (stripPrefix) +import Data.List (stripPrefix, intercalate) +import Data.List.Split (splitOn) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Text (Text, unpack) @@ -187,17 +188,19 @@ -- block parsers -- -block :: PandocMonad m => MuseParser m (F Blocks) -block = do - res <- mempty <$ skipMany1 blankline - <|> blockElements - <|> para - skipMany blankline +parseBlock :: PandocMonad m => MuseParser m (F Blocks) +parseBlock = do + res <- blockElements <|> para + optionMaybe blankline trace (take 60 $ show $ B.toList $ runF res defaultParserState) return res +block :: PandocMonad m => MuseParser m (F Blocks) +block = parseBlock <* skipMany blankline + blockElements :: PandocMonad m => MuseParser m (F Blocks) -blockElements = choice [ comment +blockElements = choice [ mempty <$ blankline + , comment , separator , header , example @@ -221,7 +224,7 @@ comment :: PandocMonad m => MuseParser m (F Blocks) comment = try $ do char ';' - optionMaybe (spaceChar >> (many $ noneOf "\n")) + optionMaybe (spaceChar >> many (noneOf "\n")) eol return mempty @@ -257,15 +260,26 @@ -- in case opening and/or closing tags are on separate lines. chop :: String -> String chop = lchop . rchop - where lchop s = case s of + +lchop :: String -> String +lchop s = case s of '\n':ss -> ss _ -> s - rchop = reverse . lchop . reverse +rchop :: String -> String +rchop = reverse . lchop . reverse + +dropSpacePrefix :: [String] -> [String] +dropSpacePrefix lns = + map (drop maxIndent) lns + where flns = filter (not . all (== ' ')) lns + maxIndent = if null flns then maximum (map length lns) else length $ takeWhile (== ' ') $ foldl1 commonPrefix flns + exampleTag :: PandocMonad m => MuseParser m (F Blocks) -exampleTag = do +exampleTag = try $ do + many spaceChar (attr, contents) <- htmlElement "example" - return $ return $ B.codeBlockWith attr $ chop contents + return $ return $ B.codeBlockWith attr $ rchop $ intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop contents literal :: PandocMonad m => MuseParser m (F Blocks) literal = do @@ -309,7 +323,7 @@ verseLines :: PandocMonad m => MuseParser m (F Blocks) verseLines = do - optionMaybe blankline -- Skip blankline after opening tag on separate line + --optionMaybe blankline -- Skip blankline after opening tag on separate line lns <- many verseLine lns' <- mapM (parseFromString' (trimInlinesF . mconcat <$> many inline)) lns return $ B.lineBlock <$> sequence lns' @@ -317,7 +331,7 @@ verseTag :: PandocMonad m => MuseParser m (F Blocks) verseTag = do (_, content) <- htmlElement "verse" - parseFromString verseLines content + parseFromString verseLines (intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop content) commentTag :: PandocMonad m => MuseParser m (F Blocks) commentTag = parseHtmlContent "comment" anyChar >> return mempty @@ -349,7 +363,7 @@ guardEnabled Ext_amuse pos <- getPosition ref <- noteMarker <* spaceChar - content <- listItemContents $ 3 + length ref + content <- listItemContents oldnotes <- stateNotes' <$> getState case M.lookup ref oldnotes of Just _ -> logMessage $ DuplicateNoteReference ref pos @@ -399,11 +413,6 @@ -- lists -- -listLine :: PandocMonad m => Int -> MuseParser m String -listLine markerLength = try $ do - indentWith markerLength - manyTill anyChar eol - withListContext :: PandocMonad m => MuseParser m a -> MuseParser m a withListContext p = do state <- getState @@ -413,96 +422,75 @@ updateState (\st -> st {stateParserContext = oldContext}) return parsed -listContinuation :: PandocMonad m => Int -> MuseParser m [String] -listContinuation markerLength = try $ do - result <- many1 $ listLine markerLength - blank <- option id ((++ [""]) <$ blankline) - return $ blank result - -listStart :: PandocMonad m => MuseParser m Int -> MuseParser m Int -listStart marker = try $ do - preWhitespace <- length <$> many spaceChar - st <- stateParserContext <$> getState - getPosition >>= \pos -> guard (st == ListItemState || sourceColumn pos /= 1) - markerLength <- marker - void spaceChar <|> eol - return $ preWhitespace + markerLength + 1 - -dropSpacePrefix :: [String] -> [String] -dropSpacePrefix lns = - map (drop maxIndent) lns - where flns = filter (not . all (== ' ')) lns - maxIndent = if null flns then 0 else length $ takeWhile (== ' ') $ foldl1 commonPrefix flns - -listItemContents :: PandocMonad m => Int -> MuseParser m (F Blocks) -listItemContents markerLength = do - firstLine <- manyTill anyChar eol - restLines <- many $ listLine markerLength - blank <- option id ((++ [""]) <$ blankline) - let first = firstLine : blank restLines - rest <- many $ listContinuation markerLength - let allLines = concat (first : rest) - parseFromString (withListContext parseBlocks) $ unlines (dropSpacePrefix allLines) - -listItem :: PandocMonad m => MuseParser m Int -> MuseParser m (F Blocks) -listItem start = try $ do - markerLength <- start - listItemContents markerLength +listItemContents' :: PandocMonad m => Int -> MuseParser m (F Blocks) +listItemContents' col = do + first <- try $ withListContext parseBlock + rest <- many $ try (skipMany blankline >> indentWith col >> withListContext parseBlock) + return $ mconcat (first : rest) -bulletListItems :: PandocMonad m => MuseParser m (F [Blocks]) -bulletListItems = sequence <$> many1 (listItem bulletListStart) +listItemContents :: PandocMonad m => MuseParser m (F Blocks) +listItemContents = do + pos <- getPosition + let col = sourceColumn pos - 1 + listItemContents' col -bulletListStart :: PandocMonad m => MuseParser m Int -bulletListStart = listStart (char '-' >> return 1) +listItem :: PandocMonad m => Int -> MuseParser m () -> MuseParser m (F Blocks) +listItem n p = try $ do + optionMaybe blankline + count n spaceChar + p + void spaceChar <|> lookAhead eol + listItemContents bulletList :: PandocMonad m => MuseParser m (F Blocks) -bulletList = do - listItems <- bulletListItems - return $ B.bulletList <$> listItems - -orderedListStart :: PandocMonad m - => ListNumberStyle - -> ListNumberDelim - -> MuseParser m Int -orderedListStart style delim = listStart (snd <$> withHorizDisplacement (orderedListMarker style delim)) +bulletList = try $ do + many spaceChar + pos <- getPosition + let col = sourceColumn pos + guard $ col /= 1 + char '-' + void spaceChar <|> lookAhead eol + first <- listItemContents + rest <- many $ listItem (col - 1) (void (char '-')) + return $ B.bulletList <$> sequence (first : rest) orderedList :: PandocMonad m => MuseParser m (F Blocks) orderedList = try $ do - p@(_, style, delim) <- lookAhead (many spaceChar *> anyOrderedListMarker <* (eol <|> void spaceChar)) + many spaceChar + pos <- getPosition + let col = sourceColumn pos + guard $ col /= 1 + p@(_, style, delim) <- anyOrderedListMarker guard $ style `elem` [Decimal, LowerAlpha, UpperAlpha, LowerRoman, UpperRoman] guard $ delim == Period - items <- sequence <$> many1 (listItem $ orderedListStart style delim) - return $ B.orderedListWith p <$> items + void spaceChar <|> lookAhead eol + first <- listItemContents + rest <- many $ listItem (col - 1) (void (orderedListMarker style delim)) + return $ B.orderedListWith p <$> sequence (first : rest) definitionListItem :: PandocMonad m => MuseParser m (F (Inlines, [Blocks])) definitionListItem = try $ do - rawTerm <- termParser + guardDisabled Ext_amuse <|> void spaceChar -- Initial space is required by Amusewiki, but not Emacs Muse + many spaceChar + pos <- getPosition + rawTerm <- many1Till (noneOf "\n") (lookAhead (void (try (spaceChar >> string "::")))) term <- parseFromString (trimInlinesF . mconcat <$> many inline) rawTerm many1 spaceChar string "::" - firstLine <- manyTill anyChar eol - restLines <- manyTill anyLine endOfListItemElement - let lns = dropWhile (== ' ') firstLine : dropSpacePrefix restLines - lineContent <- parseFromString (withListContext parseBlocks) $ unlines lns - pure $ do lineContent' <- lineContent + void spaceChar <|> lookAhead eol + contents <- listItemContents' $ sourceColumn pos + optionMaybe blankline + pure $ do lineContent' <- contents term' <- term pure (term', [lineContent']) - where - termParser = (guardDisabled Ext_amuse <|> void spaceChar) >> -- Initial space is required by Amusewiki, but not Emacs Muse - many spaceChar >> - many1Till (noneOf "\n") (lookAhead (void (try (spaceChar >> string "::")))) - endOfInput = lookAhead $ try $ skipMany blankline >> skipSpaces >> eof - twoBlankLines = try $ blankline >> skipMany1 blankline - newDefinitionListItem = try $ void termParser - endOfListItemElement = lookAhead $ endOfInput <|> newDefinitionListItem <|> twoBlankLines definitionListItems :: PandocMonad m => MuseParser m (F [(Inlines, [Blocks])]) definitionListItems = sequence <$> many1 definitionListItem definitionList :: PandocMonad m => MuseParser m (F Blocks) definitionList = do - listItems <- definitionListItems - return $ B.definitionList <$> listItems + items <- definitionListItems + return $ B.definitionList <$> items -- -- tables @@ -658,7 +646,7 @@ return $ B.note contents' whitespace :: PandocMonad m => MuseParser m (F Inlines) -whitespace = fmap return (lb <|> regsp) +whitespace = return <$> (lb <|> regsp) where lb = try $ skipMany spaceChar >> linebreak >> return B.space regsp = try $ skipMany1 spaceChar >> return B.space @@ -724,24 +712,19 @@ return $ return $ B.text content nbsp :: PandocMonad m => MuseParser m (F Inlines) -nbsp = do - guardDisabled Ext_amuse -- Supported only by Emacs Muse +nbsp = try $ do string "~~" return $ return $ B.str "\160" code :: PandocMonad m => MuseParser m (F Inlines) code = try $ do - pos <- getPosition - sp <- if sourceColumn pos == 1 - then pure mempty - else skipMany1 spaceChar >> pure B.space - char '=' + atStart $ char '=' contents <- many1Till (noneOf "\n\r" <|> (newline <* notFollowedBy newline)) $ char '=' guard $ not $ null contents guard $ head contents `notElem` " \t\n" guard $ last contents `notElem` " \t\n" notFollowedBy $ satisfy isLetter - return $ return (sp B.<> B.code contents) + return $ return $ B.code contents codeTag :: PandocMonad m => MuseParser m (F Inlines) codeTag = do diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs --- a/src/Text/Pandoc/Readers/RST.hs +++ b/src/Text/Pandoc/Readers/RST.hs @@ -972,11 +972,16 @@ legend <- optional blanklines >> (mconcat <$> many block) return (capt,legend) --- divide string by blanklines +-- divide string by blanklines, and surround with +-- \begin{aligned}...\end{aligned} if needed. toChunks :: String -> [String] toChunks = dropWhile null - . map (trim . unlines) + . map (addAligned . trim . unlines) . splitBy (all (`elem` (" \t" :: String))) . lines + -- we put this in an aligned environment if it contains \\, see #4254 + where addAligned s = if "\\\\" `isInfixOf` s + then "\\begin{aligned}\n" ++ s ++ "\n\\end{aligned}" + else s codeblock :: [String] -> Maybe String -> String -> String -> RSTParser m Blocks codeblock classes numberLines lang body = @@ -1157,9 +1162,19 @@ refs <- referenceNames blanklines b <- block - -- put identifier on next block: let addDiv ref = B.divWith (ref, [], []) - return $ foldr addDiv b refs + let emptySpanWithId id' = Span (id',[],[]) [] + -- put identifier on next block: + case B.toList b of + [Header lev (_,classes,kvs) txt] -> + case reverse refs of + [] -> return b + (r:rs) -> return $ B.singleton $ + Header lev (r,classes,kvs) + (txt ++ map emptySpanWithId rs) + -- we avoid generating divs for headers, + -- because it hides them from promoteHeader, see #4240 + _ -> return $ foldr addDiv b refs headerBlock :: PandocMonad m => RSTParser m [Char] headerBlock = do diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs --- a/src/Text/Pandoc/Writers/ConTeXt.hs +++ b/src/Text/Pandoc/Writers/ConTeXt.hs @@ -55,6 +55,8 @@ , stOptions :: WriterOptions -- writer options } +data Tabl = Xtb | Ntb deriving (Show, Eq) + orderedListStyles :: [Char] orderedListStyles = cycle "narg" @@ -252,33 +254,77 @@ -- If this is ever executed, provide a default for the reference identifier. blockToConTeXt (Header level attr lst) = sectionHeader attr level lst blockToConTeXt (Table caption aligns widths heads rows) = do - let colDescriptor colWidth alignment = (case alignment of - AlignLeft -> 'l' - AlignRight -> 'r' - AlignCenter -> 'c' - AlignDefault -> 'l'): - if colWidth == 0 - then "|" - else ("p(" ++ printf "%.2f" colWidth ++ "\\textwidth)|") - let colDescriptors = "|" ++ concat ( - zipWith colDescriptor widths aligns) - headers <- if all null heads - then return empty - else liftM ($$ "\\HL") $ tableRowToConTeXt heads + opts <- gets stOptions + let tabl = if isEnabled Ext_ntb opts + then Ntb + else Xtb captionText <- inlineListToConTeXt caption - rows' <- mapM tableRowToConTeXt rows - return $ "\\placetable" <> (if null caption - then brackets "none" - else empty) - <> braces captionText $$ - "\\starttable" <> brackets (text colDescriptors) $$ - "\\HL" $$ headers $$ - vcat rows' $$ "\\HL" $$ "\\stoptable" <> blankline + headers <- if all null heads + then return empty + else tableRowToConTeXt tabl aligns widths heads + rows' <- mapM (tableRowToConTeXt tabl aligns widths) rows + body <- tableToConTeXt tabl headers rows' + return $ "\\startplacetable" <> brackets ( + if null caption + then "location=none" + else "caption=" <> braces captionText + ) $$ body $$ "\\stopplacetable" <> blankline -tableRowToConTeXt :: PandocMonad m => [[Block]] -> WM m Doc -tableRowToConTeXt cols = do - cols' <- mapM blockListToConTeXt cols - return $ vcat (map ("\\NC " <>) cols') $$ "\\NC\\AR" +tableToConTeXt :: PandocMonad m => Tabl -> Doc -> [Doc] -> WM m Doc +tableToConTeXt Xtb heads rows = + return $ "\\startxtable" $$ + (if isEmpty heads + then empty + else "\\startxtablehead[head]" $$ heads $$ "\\stopxtablehead") $$ + (if null rows + then empty + else "\\startxtablebody[body]" $$ vcat (init rows) $$ "\\stopxtablebody" $$ + "\\startxtablefoot[foot]" $$ last rows $$ "\\stopxtablefoot") $$ + "\\stopxtable" +tableToConTeXt Ntb heads rows = + return $ "\\startTABLE" $$ + (if isEmpty heads + then empty + else "\\startTABLEhead" $$ heads $$ "\\stopTABLEhead") $$ + (if null rows + then empty + else "\\startTABLEbody" $$ vcat (init rows) $$ "\\stopTABLEbody" $$ + "\\startTABLEfoot" $$ last rows $$ "\\stopTABLEfoot") $$ + "\\stopTABLE" + +tableRowToConTeXt :: PandocMonad m => Tabl -> [Alignment] -> [Double] -> [[Block]] -> WM m Doc +tableRowToConTeXt Xtb aligns widths cols = do + cells <- mapM (tableColToConTeXt Xtb) $ zip3 aligns widths cols + return $ "\\startxrow" $$ vcat cells $$ "\\stopxrow" +tableRowToConTeXt Ntb aligns widths cols = do + cells <- mapM (tableColToConTeXt Ntb) $ zip3 aligns widths cols + return $ vcat cells $$ "\\NC\\NR" + +tableColToConTeXt :: PandocMonad m => Tabl -> (Alignment, Double, [Block]) -> WM m Doc +tableColToConTeXt tabl (align, width, blocks) = do + cellContents <- blockListToConTeXt blocks + let colwidth = if width == 0 + then empty + else "width=" <> braces (text (printf "%.2f\\textwidth" width)) + let halign = alignToConTeXt align + let options = (if keys == empty + then empty + else brackets keys) <> space + where keys = hcat $ intersperse "," $ filter (empty /=) [halign, colwidth] + tableCellToConTeXt tabl options cellContents + +tableCellToConTeXt :: PandocMonad m => Tabl -> Doc -> Doc -> WM m Doc +tableCellToConTeXt Xtb options cellContents = + return $ "\\startxcell" <> options <> cellContents <> " \\stopxcell" +tableCellToConTeXt Ntb options cellContents = + return $ "\\NC" <> options <> cellContents + +alignToConTeXt :: Alignment -> Doc +alignToConTeXt align = case align of + AlignLeft -> "align=right" + AlignRight -> "align=left" + AlignCenter -> "align=middle" + AlignDefault -> empty listItemToConTeXt :: PandocMonad m => [Block] -> WM m Doc listItemToConTeXt list = blockListToConTeXt list >>= diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -65,7 +64,7 @@ import Text.Pandoc.Shared hiding (Element) import Text.Pandoc.Walk import Text.Pandoc.Writers.Math -import Text.Pandoc.Writers.Shared (fixDisplayMath) +import Text.Pandoc.Writers.Shared (fixDisplayMath, metaValueToInlines) import Text.Printf (printf) import Text.TeXMath import Text.XML.Light as XML @@ -195,15 +194,6 @@ | 0xE000 <= c && c <= 0xFFFD = True | 0x10000 <= c && c <= 0x10FFFF = True | otherwise = False - -metaValueToInlines :: MetaValue -> [Inline] -metaValueToInlines (MetaString s) = [Str s] -metaValueToInlines (MetaInlines ils) = ils -metaValueToInlines (MetaBlocks bs) = query return bs -metaValueToInlines (MetaBool b) = [Str $ show b] -metaValueToInlines _ = [] - - writeDocx :: (PandocMonad m) => WriterOptions -- ^ Writer options diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -1150,7 +1150,7 @@ blockListToNote opts ref blocks = -- If last block is Para or Plain, include the backlink at the end of -- that block. Otherwise, insert a new Plain block with the backlink. - let backlink = [Link ("",["footnote-back"],[]) [Str "↩"] ("#" ++ writerIdentifierPrefix opts ++ "fnref" ++ ref,[])] + let backlink = [Link ("",["footnote-back"],[]) [Str "↩"] ("#" ++ "fnref" ++ ref,[])] blocks' = if null blocks then [] else let lastBlock = last blocks diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs --- a/src/Text/Pandoc/Writers/LaTeX.hs +++ b/src/Text/Pandoc/Writers/LaTeX.hs @@ -749,9 +749,9 @@ isSimple [] = True isSimple _ = False -- simple tables have to have simple cells: - let widths' = if not (all isSimple cols) + let widths' = if all (== 0) widths && not (all isSimple cols) then replicate (length aligns) - (0.97 / fromIntegral (length aligns)) + (scaleFactor / fromIntegral (length aligns)) else map (scaleFactor *) widths cells <- mapM (tableCellToLaTeX header) $ zip3 widths' aligns cols return $ hsep (intersperse "&" cells) <> "\\tabularnewline" @@ -1015,7 +1015,7 @@ let chr = case "!\"&'()*,-./:;?@_" \\ str of (c:_) -> c [] -> '!' - let str' = escapeStringUsing (backslashEscapes "\\{}%~_") str + let str' = escapeStringUsing (backslashEscapes "\\{}%~_&") str -- we always put lstinline in a dummy 'passthrough' command -- (defined in the default template) so that we don't have -- to change the way we escape characters depending on whether diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs --- a/src/Text/Pandoc/Writers/Markdown.hs +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -701,7 +701,7 @@ let columns = transpose (rawHeaders : rawRows) -- minimal column width without wrapping a single word let relWidth w col = - max (floor $ fromIntegral (writerColumns opts) * w) + max (floor $ fromIntegral (writerColumns opts - 1) * w) (if writerWrapText opts == WrapAuto then minNumChars col else numChars col) diff --git a/src/Text/Pandoc/Writers/OOXML.hs b/src/Text/Pandoc/Writers/OOXML.hs --- a/src/Text/Pandoc/Writers/OOXML.hs +++ b/src/Text/Pandoc/Writers/OOXML.hs @@ -1,55 +1,55 @@ +{- +Copyright (C) 2012-2018 John MacFarlane + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Writers.OOXML + Copyright : Copyright (C) 2012-2018 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Functions common to OOXML writers (Docx and Powerpoint) +-} module Text.Pandoc.Writers.OOXML ( mknode - , nodename - , toLazy - , renderXml - , parseXml - , elemToNameSpaces - , elemName - , isElem - , NameSpaces - , fitToPage - ) where + , nodename + , toLazy + , renderXml + , parseXml + , elemToNameSpaces + , elemName + , isElem + , NameSpaces + , fitToPage + ) where + import Codec.Archive.Zip ---import Control.Applicative ((<|>)) --- import Control.Monad.Except (catchError) import Control.Monad.Reader --- import Control.Monad.State import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8 --- import Data.Char (isSpace, ord, toLower) --- import Data.List (intercalate, isPrefixOf, isSuffixOf) --- import qualified Data.Map as M import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) --- import qualified Data.Set as Set --- import qualified Data.Text as T --- import Data.Time.Clock.POSIX --- import Skylighting --- import System.Random (randomR) import Text.Pandoc.Class (PandocMonad) --- import qualified Text.Pandoc.Class as P --- import Text.Pandoc.Compat.Time --- import Text.Pandoc.Definition --- import Text.Pandoc.Generic --- import Text.Pandoc.Highlighting (highlight) --- import Text.Pandoc.ImageSize --- import Text.Pandoc.Logging --- import Text.Pandoc.MIME (MimeType, extensionFromMimeType, getMimeType, --- getMimeTypeDef) --- import Text.Pandoc.Options --- import Text.Pandoc.Readers.Docx.StyleMap --- import Text.Pandoc.Shared hiding (Element) import qualified Text.Pandoc.UTF8 as UTF8 --- import Text.Pandoc.Walk --- import Text.Pandoc.Writers.Math --- import Text.Pandoc.Writers.Shared (fixDisplayMath) --- import Text.Printf (printf) --- import Text.TeXMath import Text.XML.Light as XML --- import Text.XML.Light.Cursor as XMLC - mknode :: Node t => String -> [(String,String)] -> t -> Element mknode s attrs = add_attrs (map (\(k,v) -> Attr (nodename k) v) attrs) . node (nodename s) @@ -106,4 +106,3 @@ | x > fromIntegral pageWidth = (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y) | otherwise = (floor x, floor y) - diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs --- a/src/Text/Pandoc/Writers/Powerpoint.hs +++ b/src/Text/Pandoc/Writers/Powerpoint.hs @@ -1,1777 +1,63 @@ -{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-} - -{- -Copyright (C) 2017-2018 Jesse Rosenthal - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- | - Module : Text.Pandoc.Writers.Powerpoint - Copyright : Copyright (C) 2017-2018 Jesse Rosenthal - License : GNU GPL, version 2 or above - - Maintainer : Jesse Rosenthal - Stability : alpha - Portability : portable - -Conversion of 'Pandoc' documents to powerpoint (pptx). --} - -module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where - -import Control.Monad.Except (throwError) -import Control.Monad.Reader -import Control.Monad.State -import Codec.Archive.Zip -import Data.List (intercalate, stripPrefix, isPrefixOf, nub) -import Data.Default -import Data.Time.Clock (UTCTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) -import System.FilePath.Posix (splitDirectories, splitExtension) -import Text.XML.Light -import qualified Text.XML.Light.Cursor as XMLC -import Text.Pandoc.Definition -import qualified Text.Pandoc.UTF8 as UTF8 -import Text.Pandoc.Class (PandocMonad) -import Text.Pandoc.Error (PandocError(..)) -import Text.Pandoc.Slides (getSlideLevel) -import qualified Text.Pandoc.Class as P -import Text.Pandoc.Options -import Text.Pandoc.MIME -import Text.Pandoc.Logging -import qualified Data.ByteString.Lazy as BL -import Text.Pandoc.Walk -import Text.Pandoc.Writers.Shared (fixDisplayMath) -import Text.Pandoc.Writers.OOXML -import qualified Data.Map as M -import Data.Maybe (mapMaybe, listToMaybe, maybeToList) -import Text.Pandoc.ImageSize -import Control.Applicative ((<|>)) - -import Text.TeXMath -import Text.Pandoc.Writers.Math (convertMath) - - -writePowerpoint :: (PandocMonad m) - => WriterOptions -- ^ Writer options - -> Pandoc -- ^ Document to convert - -> m BL.ByteString -writePowerpoint opts (Pandoc meta blks) = do - let blks' = walk fixDisplayMath blks - distArchive <- (toArchive . BL.fromStrict) <$> - P.readDefaultDataFile "reference.pptx" - refArchive <- case writerReferenceDoc opts of - Just f -> toArchive <$> P.readFileLazy f - Nothing -> (toArchive . BL.fromStrict) <$> - P.readDataFile "reference.pptx" - - utctime <- P.getCurrentTime - - let env = def { envMetadata = meta - , envRefArchive = refArchive - , envDistArchive = distArchive - , envUTCTime = utctime - , envOpts = opts - , envSlideLevel = case writerSlideLevel opts of - Just n -> n - Nothing -> getSlideLevel blks' - } - runP env def $ do pres <- blocksToPresentation blks' - archv <- presentationToArchive pres - return $ fromArchive archv - -concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] -concatMapM f xs = liftM concat (mapM f xs) - -data WriterEnv = WriterEnv { envMetadata :: Meta - , envRunProps :: RunProps - , envParaProps :: ParaProps - , envSlideLevel :: Int - , envRefArchive :: Archive - , envDistArchive :: Archive - , envUTCTime :: UTCTime - , envOpts :: WriterOptions - , envPresentationSize :: PresentationSize - , envSlideHasHeader :: Bool - , envInList :: Bool - , envInNoteSlide :: Bool - } - deriving (Show) - -instance Default WriterEnv where - def = WriterEnv { envMetadata = mempty - , envRunProps = def - , envParaProps = def - , envSlideLevel = 2 - , envRefArchive = emptyArchive - , envDistArchive = emptyArchive - , envUTCTime = posixSecondsToUTCTime 0 - , envOpts = def - , envPresentationSize = def - , envSlideHasHeader = False - , envInList = False - , envInNoteSlide = False - } - -data MediaInfo = MediaInfo { mInfoFilePath :: FilePath - , mInfoLocalId :: Int - , mInfoGlobalId :: Int - , mInfoMimeType :: Maybe MimeType - , mInfoExt :: Maybe String - , mInfoCaption :: Bool - } deriving (Show, Eq) - -data WriterState = WriterState { stCurSlideId :: Int - -- the difference between the number at - -- the end of the slide file name and - -- the rId number - , stSlideIdOffset :: Int - , stLinkIds :: M.Map Int (M.Map Int (URL, String)) - -- (FP, Local ID, Global ID, Maybe Mime) - , stMediaIds :: M.Map Int [MediaInfo] - , stMediaGlobalIds :: M.Map FilePath Int - , stNoteIds :: M.Map Int [Block] - } deriving (Show, Eq) - -instance Default WriterState where - def = WriterState { stCurSlideId = 0 - , stSlideIdOffset = 1 - , stLinkIds = mempty - , stMediaIds = mempty - , stMediaGlobalIds = mempty - , stNoteIds = mempty - } - -type P m = ReaderT WriterEnv (StateT WriterState m) - -runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a -runP env st p = evalStateT (runReaderT p env) st - -type Pixels = Integer - -data Presentation = Presentation PresentationSize [Slide] - deriving (Show) - -data PresentationSize = PresentationSize { presSizeWidth :: Pixels - , presSizeRatio :: PresentationRatio - } - deriving (Show, Eq) - -data PresentationRatio = Ratio4x3 - | Ratio16x9 - | Ratio16x10 - deriving (Show, Eq) - --- Note that right now we're only using Ratio4x3. -getPageHeight :: PresentationSize -> Pixels -getPageHeight sz = case presSizeRatio sz of - Ratio4x3 -> floor (((fromInteger (presSizeWidth sz)) / 4) * 3 :: Double) - Ratio16x9 -> floor (((fromInteger (presSizeWidth sz)) / 16) * 9 :: Double) - Ratio16x10 -> floor (((fromInteger (presSizeWidth sz)) / 16) * 10 :: Double) - -instance Default PresentationSize where - def = PresentationSize 720 Ratio4x3 - -data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem] - , metadataSlideSubtitle :: [ParaElem] - , metadataSlideAuthors :: [[ParaElem]] - , metadataSlideDate :: [ParaElem] - } - | TitleSlide { titleSlideHeader :: [ParaElem]} - | ContentSlide { contentSlideHeader :: [ParaElem] - , contentSlideContent :: [Shape] - } - | TwoColumnSlide { twoColumnSlideHeader :: [ParaElem] - , twoColumnSlideLeft :: [Shape] - , twoColumnSlideRight :: [Shape] - } - deriving (Show, Eq) - -data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape - deriving (Show, Eq) - -data Shape = Pic PicProps FilePath Text.Pandoc.Definition.Attr [ParaElem] - | GraphicFrame [Graphic] [ParaElem] - | TextBox [Paragraph] - deriving (Show, Eq) - -type Cell = [Paragraph] - -data TableProps = TableProps { tblPrFirstRow :: Bool - , tblPrBandRow :: Bool - } deriving (Show, Eq) - -type ColWidth = Integer - -data Graphic = Tbl TableProps [ColWidth] [Cell] [[Cell]] - deriving (Show, Eq) - - -data Paragraph = Paragraph { paraProps :: ParaProps - , paraElems :: [ParaElem] - } deriving (Show, Eq) - -data HeaderType = TitleHeader | SlideHeader | InternalHeader Int - deriving (Show, Eq) - -autoNumberingToType :: ListAttributes -> String -autoNumberingToType (_, numStyle, numDelim) = - typeString ++ delimString - where - typeString = case numStyle of - Decimal -> "arabic" - UpperAlpha -> "alphaUc" - LowerAlpha -> "alphaLc" - UpperRoman -> "romanUc" - LowerRoman -> "romanLc" - _ -> "arabic" - delimString = case numDelim of - Period -> "Period" - OneParen -> "ParenR" - TwoParens -> "ParenBoth" - _ -> "Period" - -data BulletType = Bullet - | AutoNumbering ListAttributes - deriving (Show, Eq) - -data Algnment = AlgnLeft | AlgnRight | AlgnCenter - deriving (Show, Eq) - -data ParaProps = ParaProps { pPropHeaderType :: Maybe HeaderType - , pPropMarginLeft :: Maybe Pixels - , pPropMarginRight :: Maybe Pixels - , pPropLevel :: Int - , pPropBullet :: Maybe BulletType - , pPropAlign :: Maybe Algnment - } deriving (Show, Eq) - -instance Default ParaProps where - def = ParaProps { pPropHeaderType = Nothing - , pPropMarginLeft = Just 0 - , pPropMarginRight = Just 0 - , pPropLevel = 0 - , pPropBullet = Nothing - , pPropAlign = Nothing - } - -newtype TeXString = TeXString {unTeXString :: String} - deriving (Eq, Show) - -data ParaElem = Break - | Run RunProps String - -- It would be more elegant to have native TeXMath - -- Expressions here, but this allows us to use - -- `convertmath` from T.P.Writers.Math. Will perhaps - -- revisit in the future. - | MathElem MathType TeXString - deriving (Show, Eq) - -data Strikethrough = NoStrike | SingleStrike | DoubleStrike - deriving (Show, Eq) - -data Capitals = NoCapitals | SmallCapitals | AllCapitals - deriving (Show, Eq) - -type URL = String - -data RunProps = RunProps { rPropBold :: Bool - , rPropItalics :: Bool - , rStrikethrough :: Maybe Strikethrough - , rBaseline :: Maybe Int - , rCap :: Maybe Capitals - , rLink :: Maybe (URL, String) - , rPropCode :: Bool - , rPropBlockQuote :: Bool - , rPropForceSize :: Maybe Pixels - } deriving (Show, Eq) - -instance Default RunProps where - def = RunProps { rPropBold = False - , rPropItalics = False - , rStrikethrough = Nothing - , rBaseline = Nothing - , rCap = Nothing - , rLink = Nothing - , rPropCode = False - , rPropBlockQuote = False - , rPropForceSize = Nothing - } - -data PicProps = PicProps { picPropLink :: Maybe (URL, String) - } deriving (Show, Eq) - -instance Default PicProps where - def = PicProps { picPropLink = Nothing - } - --------------------------------------------------- - -inlinesToParElems :: Monad m => [Inline] -> P m [ParaElem] -inlinesToParElems ils = concatMapM inlineToParElems ils - -inlineToParElems :: Monad m => Inline -> P m [ParaElem] -inlineToParElems (Str s) = do - pr <- asks envRunProps - return [Run pr s] -inlineToParElems (Emph ils) = - local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $ - inlinesToParElems ils -inlineToParElems (Strong ils) = - local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $ - inlinesToParElems ils -inlineToParElems (Strikeout ils) = - local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $ - inlinesToParElems ils -inlineToParElems (Superscript ils) = - local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $ - inlinesToParElems ils -inlineToParElems (Subscript ils) = - local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $ - inlinesToParElems ils -inlineToParElems (SmallCaps ils) = - local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $ - inlinesToParElems ils -inlineToParElems Space = inlineToParElems (Str " ") -inlineToParElems SoftBreak = inlineToParElems (Str " ") -inlineToParElems LineBreak = return [Break] -inlineToParElems (Link _ ils (url, title)) = do - local (\r ->r{envRunProps = (envRunProps r){rLink = Just (url, title)}}) $ - inlinesToParElems ils -inlineToParElems (Code _ str) = do - local (\r ->r{envRunProps = (envRunProps r){rPropCode = True}}) $ - inlineToParElems $ Str str -inlineToParElems (Math mathtype str) = - return [MathElem mathtype (TeXString str)] -inlineToParElems (Note blks) = do - notes <- gets stNoteIds - let maxNoteId = case M.keys notes of - [] -> 0 - lst -> maximum lst - curNoteId = maxNoteId + 1 - modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes } - inlineToParElems $ Superscript [Str $ show curNoteId] -inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils -inlineToParElems (RawInline _ _) = return [] -inlineToParElems _ = return [] - -isListType :: Block -> Bool -isListType (OrderedList _ _) = True -isListType (BulletList _) = True -isListType (DefinitionList _) = True -isListType _ = False - -blockToParagraphs :: PandocMonad m => Block -> P m [Paragraph] -blockToParagraphs (Plain ils) = do - parElems <- inlinesToParElems ils - pProps <- asks envParaProps - return [Paragraph pProps parElems] -blockToParagraphs (Para ils) = do - parElems <- inlinesToParElems ils - pProps <- asks envParaProps - return [Paragraph pProps parElems] -blockToParagraphs (LineBlock ilsList) = do - parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList - pProps <- asks envParaProps - return [Paragraph pProps parElems] --- TODO: work out the attributes -blockToParagraphs (CodeBlock attr str) = - local (\r -> r{envParaProps = def{pPropMarginLeft = Just 100}}) $ - blockToParagraphs $ Para [Code attr str] --- We can't yet do incremental lists, but we should render a --- (BlockQuote List) as a list to maintain compatibility with other --- formats. -blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do - ps <- blockToParagraphs blk - ps' <- blockToParagraphs $ BlockQuote blks - return $ ps ++ ps' -blockToParagraphs (BlockQuote blks) = - local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100} - , envRunProps = (envRunProps r){rPropForceSize = Just blockQuoteSize}})$ - concatMapM blockToParagraphs blks --- TODO: work out the format -blockToParagraphs (RawBlock _ _) = return [] -blockToParagraphs (Header n _ ils) = do - slideLevel <- asks envSlideLevel - parElems <- inlinesToParElems ils - -- For the time being we're not doing headers inside of bullets, but - -- we might change that. - let headerType = case n `compare` slideLevel of - LT -> TitleHeader - EQ -> SlideHeader - GT -> InternalHeader (n - slideLevel) - return [Paragraph def{pPropHeaderType = Just headerType} parElems] -blockToParagraphs (BulletList blksLst) = do - pProps <- asks envParaProps - let lvl = pPropLevel pProps - local (\env -> env{ envInList = True - , envParaProps = pProps{ pPropLevel = lvl + 1 - , pPropBullet = Just Bullet - , pPropMarginLeft = Nothing - }}) $ - concatMapM multiParBullet blksLst -blockToParagraphs (OrderedList listAttr blksLst) = do - pProps <- asks envParaProps - let lvl = pPropLevel pProps - local (\env -> env{ envInList = True - , envParaProps = pProps{ pPropLevel = lvl + 1 - , pPropBullet = Just (AutoNumbering listAttr) - , pPropMarginLeft = Nothing - }}) $ - concatMapM multiParBullet blksLst -blockToParagraphs (DefinitionList entries) = do - let go :: PandocMonad m => ([Inline], [[Block]]) -> P m [Paragraph] - go (ils, blksLst) = do - term <-blockToParagraphs $ Para [Strong ils] - -- For now, we'll treat each definition term as a - -- blockquote. We can extend this further later. - definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst - return $ term ++ definition - concatMapM go entries -blockToParagraphs (Div (_, ("notes" : []), _) _) = return [] -blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks -blockToParagraphs blk = do - P.report $ BlockNotRendered blk - return [] - --- Make sure the bullet env gets turned off after the first para. -multiParBullet :: PandocMonad m => [Block] -> P m [Paragraph] -multiParBullet [] = return [] -multiParBullet (b:bs) = do - pProps <- asks envParaProps - p <- blockToParagraphs b - ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $ - concatMapM blockToParagraphs bs - return $ p ++ ps - -cellToParagraphs :: PandocMonad m => Alignment -> TableCell -> P m [Paragraph] -cellToParagraphs algn tblCell = do - paras <- mapM (blockToParagraphs) tblCell - let alignment = case algn of - AlignLeft -> Just AlgnLeft - AlignRight -> Just AlgnRight - AlignCenter -> Just AlgnCenter - AlignDefault -> Nothing - paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras - return $ concat paras' - -rowToParagraphs :: PandocMonad m => [Alignment] -> [TableCell] -> P m [[Paragraph]] -rowToParagraphs algns tblCells = do - -- We have to make sure we have the right number of alignments - let pairs = zip (algns ++ repeat AlignDefault) tblCells - mapM (\(a, tc) -> cellToParagraphs a tc) pairs - -blockToShape :: PandocMonad m => Block -> P m Shape -blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il = - Pic def url attr <$> (inlinesToParElems ils) -blockToShape (Para (il:_)) | Image attr ils (url, _) <- il = - Pic def url attr <$> (inlinesToParElems ils) -blockToShape (Plain (il:_)) | Link _ (il':_) target <- il - , Image attr ils (url, _) <- il' = - Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils) -blockToShape (Para (il:_)) | Link _ (il':_) target <- il - , Image attr ils (url, _) <- il' = - Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils) -blockToShape (Table caption algn _ hdrCells rows) = do - caption' <- inlinesToParElems caption - pageWidth <- presSizeWidth <$> asks envPresentationSize - hdrCells' <- rowToParagraphs algn hdrCells - rows' <- mapM (rowToParagraphs algn) rows - let tblPr = if null hdrCells - then TableProps { tblPrFirstRow = False - , tblPrBandRow = True - } - else TableProps { tblPrFirstRow = True - , tblPrBandRow = True - } - colWidths = if null hdrCells - then case rows of - r : _ | not (null r) -> replicate (length r) $ - (pageWidth - (2 * hardcodedTableMargin))`div` (toInteger $ length r) - -- satisfy the compiler. This is the same as - -- saying that rows is empty, but the compiler - -- won't understand that `[]` exhausts the - -- alternatives. - _ -> [] - else replicate (length hdrCells) $ - (pageWidth - (2 * hardcodedTableMargin)) `div` (toInteger $ length hdrCells) - - return $ GraphicFrame [Tbl tblPr colWidths hdrCells' rows'] caption' -blockToShape blk = TextBox <$> blockToParagraphs blk - -blocksToShapes :: PandocMonad m => [Block] -> P m [Shape] -blocksToShapes blks = combineShapes <$> mapM blockToShape blks - -isImage :: Inline -> Bool -isImage (Image _ _ _) = True -isImage (Link _ ((Image _ _ _) : _) _) = True -isImage _ = False - -splitBlocks' :: Monad m => [Block] -> [[Block]] -> [Block] -> P m [[Block]] -splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur]) -splitBlocks' cur acc (HorizontalRule : blks) = - splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks -splitBlocks' cur acc (h@(Header n _ _) : blks) = do - slideLevel <- asks envSlideLevel - case compare n slideLevel of - LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[h]]) blks - EQ -> splitBlocks' [h] (acc ++ (if null cur then [] else [cur])) blks - GT -> splitBlocks' (cur ++ [h]) acc blks --- `blockToParagraphs` treats Plain and Para the same, so we can save --- some code duplication by treating them the same here. -splitBlocks' cur acc ((Plain ils) : blks) = splitBlocks' cur acc ((Para ils) : blks) -splitBlocks' cur acc ((Para (il:ils)) : blks) | isImage il = do - slideLevel <- asks envSlideLevel - case cur of - (Header n _ _) : [] | n == slideLevel -> - splitBlocks' [] - (acc ++ [cur ++ [Para [il]]]) - (if null ils then blks else (Para ils) : blks) - _ -> splitBlocks' [] - (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]]]) - (if null ils then blks else (Para ils) : blks) -splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do - slideLevel <- asks envSlideLevel - case cur of - (Header n _ _) : [] | n == slideLevel -> - splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks - _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks -splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes = do - slideLevel <- asks envSlideLevel - case cur of - (Header n _ _) : [] | n == slideLevel -> - splitBlocks' [] (acc ++ [cur ++ [d]]) blks - _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) blks -splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks - -splitBlocks :: Monad m => [Block] -> P m [[Block]] -splitBlocks = splitBlocks' [] [] - -blocksToSlide' :: PandocMonad m => Int -> [Block] -> P m Slide -blocksToSlide' lvl ((Header n _ ils) : blks) - | n < lvl = do - hdr <- inlinesToParElems ils - return $ TitleSlide {titleSlideHeader = hdr} - | n == lvl = do - hdr <- inlinesToParElems ils - -- Now get the slide without the header, and then add the header - -- in. - slide <- blocksToSlide' lvl blks - return $ case slide of - ContentSlide _ cont -> ContentSlide hdr cont - TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR - slide' -> slide' -blocksToSlide' _ (blk : blks) - | Div (_, classes, _) divBlks <- blk - , "columns" `elem` classes - , (Div (_, clsL, _) blksL) : (Div (_, clsR, _) blksR) : remaining <- divBlks - , "column" `elem` clsL, "column" `elem` clsR = do - unless (null blks) - (mapM (P.report . BlockNotRendered) blks >> return ()) - unless (null remaining) - (mapM (P.report . BlockNotRendered) remaining >> return ()) - shapesL <- blocksToShapes blksL - shapesR <- blocksToShapes blksR - return $ TwoColumnSlide { twoColumnSlideHeader = [] - , twoColumnSlideLeft = shapesL - , twoColumnSlideRight = shapesR - } -blocksToSlide' _ (blk : blks) = do - inNoteSlide <- asks envInNoteSlide - shapes <- if inNoteSlide - then forceFontSize noteSize $ blocksToShapes (blk : blks) - else blocksToShapes (blk : blks) - return $ ContentSlide { contentSlideHeader = [] - , contentSlideContent = shapes - } -blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = [] - , contentSlideContent = [] - } - -blocksToSlide :: PandocMonad m => [Block] -> P m Slide -blocksToSlide blks = do - slideLevel <- asks envSlideLevel - blocksToSlide' slideLevel blks - -makeNoteEntry :: Int -> [Block] -> [Block] -makeNoteEntry n blks = - let enum = Str (show n ++ ".") - in - case blks of - (Para ils : blks') -> (Para $ enum : Space : ils) : blks' - _ -> (Para [enum]) : blks - -forceFontSize :: PandocMonad m => Pixels -> P m a -> P m a -forceFontSize px x = do - rpr <- asks envRunProps - local (\r -> r {envRunProps = rpr{rPropForceSize = Just px}}) x - --- Right now, there's no logic for making more than one slide, but I --- want to leave the option open to make multiple slides if we figure --- out how to guess at how much space the text of the notes will take --- up (or if we allow a way for it to be manually controlled). Plus a --- list will make it easier to put together in the final --- `blocksToPresentation` function (since we can just add an empty --- list without checking the state). -makeNotesSlides :: PandocMonad m => P m [Slide] -makeNotesSlides = local (\env -> env{envInNoteSlide=True}) $ do - noteIds <- gets stNoteIds - if M.null noteIds - then return [] - else do let hdr = Header 2 nullAttr [Str "Notes"] - blks <- return $ - concatMap (\(n, bs) -> makeNoteEntry n bs) $ - M.toList noteIds - sld <- blocksToSlide $ hdr : blks - return [sld] - -getMetaSlide :: PandocMonad m => P m (Maybe Slide) -getMetaSlide = do - meta <- asks envMetadata - title <- inlinesToParElems $ docTitle meta - subtitle <- inlinesToParElems $ - case lookupMeta "subtitle" meta of - Just (MetaString s) -> [Str s] - Just (MetaInlines ils) -> ils - Just (MetaBlocks [Plain ils]) -> ils - Just (MetaBlocks [Para ils]) -> ils - _ -> [] - authors <- mapM inlinesToParElems $ docAuthors meta - date <- inlinesToParElems $ docDate meta - if null title && null subtitle && null authors && null date - then return Nothing - else return $ Just $ MetadataSlide { metadataSlideTitle = title - , metadataSlideSubtitle = subtitle - , metadataSlideAuthors = authors - , metadataSlideDate = date - } - -blocksToPresentation :: PandocMonad m => [Block] -> P m Presentation -blocksToPresentation blks = do - blksLst <- splitBlocks blks - slides <- mapM blocksToSlide blksLst - noteSlides <- makeNotesSlides - let slides' = slides ++ noteSlides - metadataslide <- getMetaSlide - presSize <- asks envPresentationSize - return $ case metadataslide of - Just metadataslide' -> Presentation presSize $ metadataslide' : slides' - Nothing -> Presentation presSize slides' - --------------------------------------------------------------------- - -copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive -copyFileToArchive arch fp = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of - Nothing -> fail $ fp ++ " missing in reference file" - Just e -> return $ addEntryToArchive e arch - -getMediaFiles :: PandocMonad m => P m [FilePath] -getMediaFiles = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - let allEntries = nub $ filesInArchive refArchive ++ filesInArchive distArchive - return $ filter (isPrefixOf "ppt/media") allEntries - - -copyFileToArchiveIfExists :: PandocMonad m => Archive -> FilePath -> P m Archive -copyFileToArchiveIfExists arch fp = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of - Nothing -> return $ arch - Just e -> return $ addEntryToArchive e arch - -inheritedFiles :: [FilePath] -inheritedFiles = [ "_rels/.rels" - , "docProps/app.xml" - , "docProps/core.xml" - , "ppt/slideLayouts/slideLayout4.xml" - , "ppt/slideLayouts/_rels/slideLayout9.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout2.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout10.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout1.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout3.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout5.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout7.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout8.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout11.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout4.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout6.xml.rels" - , "ppt/slideLayouts/slideLayout2.xml" - , "ppt/slideLayouts/slideLayout8.xml" - , "ppt/slideLayouts/slideLayout11.xml" - , "ppt/slideLayouts/slideLayout3.xml" - , "ppt/slideLayouts/slideLayout6.xml" - , "ppt/slideLayouts/slideLayout9.xml" - , "ppt/slideLayouts/slideLayout5.xml" - , "ppt/slideLayouts/slideLayout7.xml" - , "ppt/slideLayouts/slideLayout1.xml" - , "ppt/slideLayouts/slideLayout10.xml" - -- , "ppt/_rels/presentation.xml.rels" - , "ppt/theme/theme1.xml" - , "ppt/presProps.xml" - -- , "ppt/slides/_rels/slide1.xml.rels" - -- , "ppt/slides/_rels/slide2.xml.rels" - -- This is the one we're - -- going to build - -- , "ppt/slides/slide2.xml" - -- , "ppt/slides/slide1.xml" - , "ppt/viewProps.xml" - , "ppt/tableStyles.xml" - , "ppt/slideMasters/_rels/slideMaster1.xml.rels" - , "ppt/slideMasters/slideMaster1.xml" - -- , "ppt/presentation.xml" - -- , "[Content_Types].xml" - ] - --- Here are some that might not be there. We won't fail if they're not -possibleInheritedFiles :: [FilePath] -possibleInheritedFiles = [ "ppt/theme/_rels/theme1.xml.rels" ] - -presentationToArchive :: PandocMonad m => Presentation -> P m Archive -presentationToArchive p@(Presentation _ slides) = do - newArch <- foldM copyFileToArchive emptyArchive inheritedFiles - mediaDir <- getMediaFiles - newArch' <- foldM copyFileToArchiveIfExists newArch $ - possibleInheritedFiles ++ mediaDir - -- 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 - slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..] - slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..] - -- These have to come after everything, because they need the info - -- built up in the state. - mediaEntries <- makeMediaEntries - contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry - -- fold everything into our inherited archive and return it. - return $ foldr addEntryToArchive newArch' $ - slideEntries ++ - slideRelEntries ++ - mediaEntries ++ - [contentTypesEntry, presEntry, presRelsEntry] - --------------------------------------------------- - -combineShapes :: [Shape] -> [Shape] -combineShapes [] = [] -combineShapes (s : []) = [s] -combineShapes (pic@(Pic _ _ _ _) : ss) = pic : combineShapes ss -combineShapes ((TextBox []) : ss) = combineShapes ss -combineShapes (s : TextBox [] : ss) = combineShapes (s : ss) -combineShapes (s@(TextBox (p:ps)) : s'@(TextBox (p':ps')) : ss) - | pPropHeaderType (paraProps p) == Just TitleHeader || - pPropHeaderType (paraProps p) == Just SlideHeader = - TextBox [p] : (combineShapes $ TextBox ps : s' : ss) - | pPropHeaderType (paraProps p') == Just TitleHeader || - pPropHeaderType (paraProps p') == Just SlideHeader = - s : TextBox [p'] : (combineShapes $ TextBox ps' : ss) - | otherwise = combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss -combineShapes (s:ss) = s : combineShapes ss - --------------------------------------------------- - -getLayout :: PandocMonad m => Slide -> P m Element -getLayout slide = do - let layoutpath = case slide of - (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml" - (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml" - (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml" - (TwoColumnSlide _ _ _) -> "ppt/slideLayouts/slideLayout4.xml" - distArchive <- asks envDistArchive - root <- case findEntryByPath layoutpath distArchive of - Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of - Just element -> return $ element - Nothing -> throwError $ - PandocSomeError $ - layoutpath ++ " corrupt in reference file" - Nothing -> throwError $ - PandocSomeError $ - layoutpath ++ " missing in reference file" - return root - -shapeHasName :: NameSpaces -> String -> Element -> Bool -shapeHasName ns name element - | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element - , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr - , Just nm <- findAttr (QName "name" Nothing Nothing) cNvPr = - nm == name - | otherwise = False - -getContentShape :: NameSpaces -> Element -> Maybe Element -getContentShape ns spTreeElem - | isElem ns "p" "spTree" spTreeElem = - filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Content Placeholder 2" e)) spTreeElem - | otherwise = Nothing - -replaceNamedChildren :: NameSpaces - -> String - -> String - -> [Element] - -> Element - -> Element -replaceNamedChildren ns prefix name newKids element = - element { elContent = concat $ fun True $ elContent element } - where - fun :: Bool -> [Content] -> [[Content]] - fun _ [] = [] - fun switch ((Elem e) : conts) | isElem ns prefix name e = - if switch - then (map Elem $ newKids) : fun False conts - else fun False conts - fun switch (cont : conts) = [cont] : fun switch conts - ----------------------------------------------------------------- - -registerLink :: PandocMonad m => (URL, String) -> P m Int -registerLink link = do - curSlideId <- gets stCurSlideId - linkReg <- gets stLinkIds - mediaReg <- gets stMediaIds - let maxLinkId = case M.lookup curSlideId linkReg of - Just mp -> case M.keys mp of - [] -> 1 - ks -> maximum ks - Nothing -> 1 - maxMediaId = case M.lookup curSlideId mediaReg of - Just [] -> 1 - Just mInfos -> maximum $ map mInfoLocalId mInfos - Nothing -> 1 - maxId = max maxLinkId maxMediaId - slideLinks = case M.lookup curSlideId linkReg of - Just mp -> M.insert (maxId + 1) link mp - Nothing -> M.singleton (maxId + 1) link - modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg} - return $ maxId + 1 - -registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo -registerMedia fp caption = do - curSlideId <- gets stCurSlideId - linkReg <- gets stLinkIds - mediaReg <- gets stMediaIds - globalIds <- gets stMediaGlobalIds - let maxLinkId = case M.lookup curSlideId linkReg of - Just mp -> case M.keys mp of - [] -> 1 - ks -> maximum ks - Nothing -> 1 - maxMediaId = case M.lookup curSlideId mediaReg of - Just [] -> 1 - Just mInfos -> maximum $ map mInfoLocalId mInfos - Nothing -> 1 - maxLocalId = max maxLinkId maxMediaId - - maxGlobalId = case M.elems globalIds of - [] -> 0 - ids -> maximum ids - - (imgBytes, mbMt) <- P.fetchItem fp - let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x)) - <|> - case imageType imgBytes of - Just Png -> Just ".png" - Just Jpeg -> Just ".jpeg" - Just Gif -> Just ".gif" - Just Pdf -> Just ".pdf" - Just Eps -> Just ".eps" - Just Svg -> Just ".svg" - Nothing -> Nothing - - let newGlobalId = case M.lookup fp globalIds of - Just ident -> ident - Nothing -> maxGlobalId + 1 - - let newGlobalIds = M.insert fp newGlobalId globalIds - - let mediaInfo = MediaInfo { mInfoFilePath = fp - , mInfoLocalId = maxLocalId + 1 - , mInfoGlobalId = newGlobalId - , mInfoMimeType = mbMt - , mInfoExt = imgExt - , mInfoCaption = (not . null) caption - } - - let slideMediaInfos = case M.lookup curSlideId mediaReg of - Just minfos -> mediaInfo : minfos - Nothing -> [mediaInfo] - - - modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg - , stMediaGlobalIds = newGlobalIds - } - return mediaInfo - -makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry -makeMediaEntry mInfo = do - epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime - (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo) - let ext = case mInfoExt mInfo of - Just e -> e - Nothing -> "" - let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext - return $ toEntry fp epochtime $ BL.fromStrict imgBytes - -makeMediaEntries :: PandocMonad m => P m [Entry] -makeMediaEntries = do - mediaInfos <- gets stMediaIds - let allInfos = mconcat $ M.elems mediaInfos - mapM makeMediaEntry allInfos - --- | Scales the image to fit the page --- sizes are passed in emu -fitToPage' :: (Double, Double) -- image size in emu - -> Integer -- pageWidth - -> Integer -- pageHeight - -> (Integer, Integer) -- imagesize -fitToPage' (x, y) pageWidth pageHeight - -- Fixes width to the page width and scales the height - | x <= fromIntegral pageWidth && y <= fromIntegral pageHeight = - (floor x, floor y) - | x / fromIntegral pageWidth > y / fromIntegral pageWidth = - (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y) - | otherwise = - (floor $ ((fromIntegral pageHeight) / y) * x, pageHeight) - -positionImage :: (Double, Double) -> Integer -> Integer -> (Integer, Integer) -positionImage (x, y) pageWidth pageHeight = - let (x', y') = fitToPage' (x, y) pageWidth pageHeight - in - ((pageWidth - x') `div` 2, (pageHeight - y') `div` 2) - -getMaster :: PandocMonad m => P m Element -getMaster = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml" - --- 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. - -getHeaderSize :: PandocMonad m => P m ((Integer, Integer), (Integer, Integer)) -getHeaderSize = do - master <- getMaster - let ns = elemToNameSpaces master - sps = [master] >>= - findChildren (elemName ns "p" "cSld") >>= - findChildren (elemName ns "p" "spTree") >>= - findChildren (elemName ns "p" "sp") - mbXfrm = - listToMaybe (filter (shapeHasName ns "Title Placeholder 1") sps) >>= - findChild (elemName ns "p" "spPr") >>= - findChild (elemName ns "a" "xfrm") - xoff = mbXfrm >>= - findChild (elemName ns "a" "off") >>= - findAttr (QName "x" Nothing Nothing) >>= - (listToMaybe . (\s -> reads s :: [(Integer, String)])) - yoff = mbXfrm >>= - findChild (elemName ns "a" "off") >>= - findAttr (QName "y" Nothing Nothing) >>= - (listToMaybe . (\s -> reads s :: [(Integer, String)])) - xext = mbXfrm >>= - findChild (elemName ns "a" "ext") >>= - findAttr (QName "cx" Nothing Nothing) >>= - (listToMaybe . (\s -> reads s :: [(Integer, String)])) - yext = mbXfrm >>= - findChild (elemName ns "a" "ext") >>= - findAttr (QName "cy" Nothing Nothing) >>= - (listToMaybe . (\s -> reads s :: [(Integer, String)])) - off = case xoff of - Just (xoff', _) | Just (yoff',_) <- yoff -> (xoff', yoff') - _ -> (1043490, 1027664) - ext = case xext of - Just (xext', _) | Just (yext',_) <- yext -> (xext', yext') - _ -> (7024744, 1143000) - return $ (off, ext) - - --- Hard-coded for now -captionPosition :: ((Integer, Integer), (Integer, Integer)) -captionPosition = ((457200, 6061972), (8229600, 527087)) - -createCaption :: PandocMonad m => [ParaElem] -> P m Element -createCaption paraElements = do - let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements - elements <- mapM paragraphToElement [para] - let ((x, y), (cx, cy)) = captionPosition - 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", show x), ("y", show y)] () - , mknode "a:ext" [("cx", show cx), ("cy", show cy)] () - ] - , mknode "a:prstGeom" [("prst", "rect")] - [ mknode "a:avLst" [] () - ] - , mknode "a:noFill" [] () - ] - , txBody - ] - --- Largely lifted from inlineToOpenXML' in T.P.W.Docx. Can't be easily --- abstracted because of some different namespaces and monads. TODO. -makePicElement :: PandocMonad m - => PicProps - -> MediaInfo - -> Text.Pandoc.Definition.Attr - -> P m Element -makePicElement picProps mInfo attr = do - opts <- asks envOpts - pageWidth <- presSizeWidth <$> asks envPresentationSize - pageHeight <- getPageHeight <$> asks envPresentationSize - hasHeader <- asks envSlideHasHeader - let hasCaption = mInfoCaption mInfo - (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo) - -- We're not using x exts - ((hXoff, hYoff), (_, hYext)) <- if hasHeader - then getHeaderSize - else return ((0, 0), (0, 0)) - - let ((capX, capY), (_, _)) = if hasCaption - then captionPosition - else ((0,0), (0,0)) - let (xpt,ypt) = desiredSizeInPoints opts attr - (either (const def) id (imageSize opts imgBytes)) - -- 12700 emu = 1 pt - let (xemu,yemu) = fitToPage' (xpt * 12700, ypt * 12700) - ((pageWidth * 12700) - (2 * hXoff) - (2 * capX)) - ((if hasCaption then capY else (pageHeight * 12700)) - (hYoff + hYext)) - (xoff, yoff) = positionImage (xpt * 12700, ypt * 12700) (pageWidth * 12700) (pageHeight * 12700) - xoff' = if hasHeader then xoff + hXoff else xoff - xoff'' = if hasCaption then xoff' + capX else xoff' - yoff' = if hasHeader then hYoff + hYext else yoff - let cNvPicPr = mknode "p:cNvPicPr" [] $ - mknode "a:picLocks" [("noGrp","1") - ,("noChangeAspect","1")] () - -- cNvPr will contain the link information so we do that separately, - -- and register the link if necessary. - let cNvPrAttr = [("descr", mInfoFilePath mInfo), ("id","0"),("name","Picture 1")] - cNvPr <- case picPropLink picProps of - Just link -> do idNum <- registerLink link - return $ mknode "p:cNvPr" cNvPrAttr $ - mknode "a:hlinkClick" [("r:id", "rId" ++ show idNum)] () - Nothing -> return $ mknode "p:cNvPr" cNvPrAttr () - let nvPicPr = mknode "p:nvPicPr" [] - [ cNvPr - , cNvPicPr - , mknode "p:nvPr" [] ()] - let blipFill = mknode "p:blipFill" [] - [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] () - , mknode "a:stretch" [] $ - mknode "a:fillRect" [] () ] - let xfrm = mknode "a:xfrm" [] - [ mknode "a:off" [("x",show xoff''), ("y",show yoff')] () - , mknode "a:ext" [("cx",show xemu) - ,("cy",show yemu)] () ] - let prstGeom = mknode "a:prstGeom" [("prst","rect")] $ - mknode "a:avLst" [] () - let ln = mknode "a:ln" [("w","9525")] - [ mknode "a:noFill" [] () - , mknode "a:headEnd" [] () - , mknode "a:tailEnd" [] () ] - let spPr = mknode "p:spPr" [("bwMode","auto")] - [xfrm, prstGeom, mknode "a:noFill" [] (), ln] - return $ - mknode "p:pic" [] - [ nvPicPr - , blipFill - , spPr ] - --- Currently hardcoded, until I figure out how to make it dynamic. -blockQuoteSize :: Pixels -blockQuoteSize = 20 - -noteSize :: Pixels -noteSize = 18 - -paraElemToElement :: PandocMonad m => ParaElem -> P m Element -paraElemToElement Break = return $ mknode "a:br" [] () -paraElemToElement (Run rpr s) = do - let sizeAttrs = case rPropForceSize rpr of - Just n -> [("sz", (show $ n * 100))] - Nothing -> [] - attrs = sizeAttrs ++ - if rPropCode rpr - then [] - else (if rPropBold rpr then [("b", "1")] else []) ++ - (if rPropItalics rpr then [("i", "1")] else []) ++ - (case rStrikethrough rpr of - Just NoStrike -> [("strike", "noStrike")] - Just SingleStrike -> [("strike", "sngStrike")] - Just DoubleStrike -> [("strike", "dblStrike")] - Nothing -> []) ++ - (case rBaseline rpr of - Just n -> [("baseline", show n)] - Nothing -> []) ++ - (case rCap rpr of - Just NoCapitals -> [("cap", "none")] - Just SmallCapitals -> [("cap", "small")] - Just AllCapitals -> [("cap", "all")] - Nothing -> []) ++ - [] - linkProps <- case rLink rpr of - Just link -> do idNum <- registerLink link - return [mknode "a:hlinkClick" - [("r:id", "rId" ++ show idNum)] - () - ] - Nothing -> return [] - let propContents = if rPropCode rpr - then [mknode "a:latin" [("typeface", "Courier")] ()] - else linkProps - return $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents - , mknode "a:t" [] s - ] -paraElemToElement (MathElem mathType texStr) = do - res <- convertMath writeOMML mathType (unTeXString texStr) - case res of - Right r -> return $ mknode "a14:m" [] $ addMathInfo r - Left (Str s) -> paraElemToElement (Run def s) - Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback" - --- This is a bit of a kludge -- really requires adding an option to --- TeXMath, but since that's a different package, we'll do this one --- step at a time. -addMathInfo :: Element -> Element -addMathInfo element = - let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns")) - , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math" - } - in add_attr mathspace element - --- We look through the element to see if it contains an a14:m --- element. If so, we surround it. This is a bit ugly, but it seems --- more dependable than looking through shapes for math. Plus this is --- an xml implementation detail, so it seems to make sense to do it at --- the xml level. -surroundWithMathAlternate :: Element -> Element -surroundWithMathAlternate element = - case findElement (QName "m" Nothing (Just "a14")) element of - Just _ -> - mknode "mc:AlternateContent" - [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006") - ] [ mknode "mc:Choice" - [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main") - , ("Requires", "a14")] [ element ] - ] - Nothing -> element - -paragraphToElement :: PandocMonad m => Paragraph -> P m Element -paragraphToElement par = do - let - attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++ - (case pPropMarginLeft (paraProps par) of - Just px -> [("marL", show $ 12700 * px), ("indent", "0")] - Nothing -> [] - ) ++ - (case pPropAlign (paraProps par) of - Just AlgnLeft -> [("algn", "l")] - Just AlgnRight -> [("algn", "r")] - Just AlgnCenter -> [("algn", "ctr")] - Nothing -> [] - ) - props = [] ++ - (case pPropBullet $ paraProps par of - Just Bullet -> [] - Just (AutoNumbering attrs') -> - [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()] - Nothing -> [mknode "a:buNone" [] ()] - ) - paras <- mapM paraElemToElement (combineParaElems $ paraElems par) - return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras - -shapeToElement :: PandocMonad m => Element -> Shape -> P m Element -shapeToElement layout (TextBox paras) - | ns <- elemToNameSpaces layout - , Just cSld <- findChild (elemName ns "p" "cSld") layout - , Just spTree <- findChild (elemName ns "p" "spTree") cSld - , Just sp <- getContentShape ns spTree = do - elements <- mapM paragraphToElement paras - let txBody = mknode "p:txBody" [] $ - [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements - emptySpPr = mknode "p:spPr" [] () - return $ - surroundWithMathAlternate $ - replaceNamedChildren ns "p" "txBody" [txBody] $ - replaceNamedChildren ns "p" "spPr" [emptySpPr] $ - sp - -- XXX: TODO - | otherwise = return $ mknode "p:sp" [] () --- XXX: TODO -shapeToElement layout (Pic picProps fp attr alt) = do - mInfo <- registerMedia fp alt - case mInfoExt mInfo of - Just _ -> makePicElement picProps mInfo attr - Nothing -> shapeToElement layout $ TextBox [Paragraph def alt] -shapeToElement _ (GraphicFrame tbls _) = do - elements <- mapM graphicToElement tbls - return $ 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", "457200"), ("y", "1600200")] () - , mknode "a:ext" [("cx", "8029388"), ("cy", "3644152")] () - ] - ] ++ elements - -shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element] -shapeToElements layout shp = do - case shp of - (Pic _ _ _ alt) | (not . null) alt -> do - element <- shapeToElement layout shp - caption <- createCaption alt - return [element, caption] - (GraphicFrame _ cptn) | (not . null) cptn -> do - element <- shapeToElement layout shp - caption <- createCaption cptn - return [element, caption] - _ -> do - element <- shapeToElement layout shp - return [element] - -shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element] -shapesToElements layout shps = do - concat <$> mapM (shapeToElements layout) shps - -hardcodedTableMargin :: Integer -hardcodedTableMargin = 36 - - -graphicToElement :: PandocMonad m => Graphic -> P m Element -graphicToElement (Tbl tblPr colWidths hdrCells rows) = do - let cellToOpenXML paras = - do elements <- mapM paragraphToElement paras - let elements' = if null elements - then [mknode "a:p" [] [mknode "a:endParaRPr" [] ()]] - else elements - return $ - [mknode "a:txBody" [] $ - ([ mknode "a:bodyPr" [] () - , mknode "a:lstStyle" [] ()] - ++ elements')] - headers' <- mapM cellToOpenXML hdrCells - rows' <- mapM (mapM cellToOpenXML) rows - let borderProps = mknode "a:tcPr" [] () - let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]] - let mkcell border contents = mknode "a:tc" [] - $ (if null contents - then emptyCell - else contents) ++ [ borderProps | border ] - let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells - - let mkgridcol w = mknode "a:gridCol" - [("w", show ((12700 * w) :: Integer))] () - let hasHeader = not (all null hdrCells) - return $ mknode "a:graphic" [] $ - [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $ - [mknode "a:tbl" [] $ - [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0") - , ("bandRow", if tblPrBandRow tblPr then "1" else "0") - ] () - , mknode "a:tblGrid" [] (if all (==0) colWidths - then [] - else map mkgridcol colWidths) - ] - ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows' - ] - ] - -getShapeByName :: NameSpaces -> Element -> String -> Maybe Element -getShapeByName ns spTreeElem name - | isElem ns "p" "spTree" spTreeElem = - filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem - | otherwise = Nothing - -nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element -nonBodyTextToElement layout shapeName paraElements - | ns <- elemToNameSpaces layout - , Just cSld <- findChild (elemName ns "p" "cSld") layout - , Just spTree <- findChild (elemName ns "p" "spTree") cSld - , Just sp <- getShapeByName ns spTree shapeName = 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 - -- XXX: TODO - | otherwise = return $ mknode "p:sp" [] () - -contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m 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 "Title 1" hdrShape - let hdrShapeElements = if null hdrShape - then [] - else [element] - contentElements <- shapesToElements layout shapes - return $ - replaceNamedChildren ns "p" "sp" - (hdrShapeElements ++ contentElements) - spTree -contentToElement _ _ _ = return $ mknode "p:sp" [] () - -setIdx'' :: NameSpaces -> String -> Content -> Content -setIdx'' _ idx (Elem element) = - let tag = XMLC.getTag element - attrs = XMLC.tagAttribs tag - idxKey = (QName "idx" Nothing Nothing) - attrs' = Attr idxKey idx : (filter (\a -> attrKey a /= idxKey) attrs) - tag' = tag {XMLC.tagAttribs = attrs'} - in Elem $ XMLC.setTag tag' element -setIdx'' _ _ c = c - -setIdx' :: NameSpaces -> String -> XMLC.Cursor -> XMLC.Cursor -setIdx' ns idx cur = - let modifiedCur = XMLC.modifyContent (setIdx'' ns idx) cur - in - case XMLC.nextDF modifiedCur of - Just cur' -> setIdx' ns idx cur' - Nothing -> XMLC.root modifiedCur - -setIdx :: NameSpaces -> String -> Element -> Element -setIdx ns idx element = - let cur = XMLC.fromContent (Elem element) - cur' = setIdx' ns idx cur - in - case XMLC.toTree cur' of - Elem element' -> element' - _ -> element - -twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m 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 "Title 1" hdrShape - let hdrShapeElements = if null hdrShape - then [] - else [element] - contentElementsL <- shapesToElements layout shapesL - contentElementsR <- shapesToElements layout shapesR - let contentElementsL' = map (setIdx ns "1") contentElementsL - contentElementsR' = map (setIdx ns "2") contentElementsR - return $ - replaceNamedChildren ns "p" "sp" - (hdrShapeElements ++ contentElementsL' ++ contentElementsR') - spTree -twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] () - - -titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m 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 "Title 1" titleElems - let titleShapeElements = if null titleElems - then [] - else [element] - return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree -titleToElement _ _ = return $ mknode "p:sp" [] () - -metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m 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 "Title 1" titleElems] - let combinedAuthorElems = intercalate [Break] authorsElems - subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems] - subtitleShapeElements <- if null subtitleAndAuthorElems - then return [] - else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems] - dateShapeElements <- if null dateElems - then return [] - else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems] - return $ replaceNamedChildren ns "p" "sp" - (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements) - spTree -metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] () - -slideToElement :: PandocMonad m => Slide -> P m Element -slideToElement s@(ContentSlide hdrElems shapes) = do - layout <- getLayout s - spTree <- local (\env -> if null hdrElems - then env - else env{envSlideHasHeader=True}) $ - contentToElement layout hdrElems 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" [] [spTree]] -slideToElement s@(TwoColumnSlide hdrElems shapesL shapesR) = do - layout <- getLayout s - spTree <- local (\env -> if null hdrElems - then env - else env{envSlideHasHeader=True}) $ - twoColumnToElement layout hdrElems shapesL 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 s@(TitleSlide hdrElems) = do - layout <- getLayout s - 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 s@(MetadataSlide titleElems subtitleElems authorElems dateElems) = do - layout <- getLayout s - 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]] - ------------------------------------------------------------------------ - -slideToFilePath :: Slide -> Int -> FilePath -slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml" - -slideToSlideId :: Monad m => Slide -> Int -> P m String -slideToSlideId _ idNum = do - n <- gets stSlideIdOffset - return $ "rId" ++ (show $ idNum + n) - - -data Relationship = Relationship { relId :: Int - , relType :: MimeType - , relTarget :: FilePath - } deriving (Show, Eq) - -elementToRel :: Element -> Maybe Relationship -elementToRel element - | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing = - do rId <- findAttr (QName "Id" Nothing Nothing) element - numStr <- stripPrefix "rId" rId - num <- case reads numStr :: [(Int, String)] of - (n, _) : _ -> Just n - [] -> Nothing - type' <- findAttr (QName "Type" Nothing Nothing) element - target <- findAttr (QName "Target" Nothing Nothing) element - return $ Relationship num type' target - | otherwise = Nothing - -slideToPresRel :: Monad m => Slide -> Int -> P m Relationship -slideToPresRel slide idNum = do - n <- gets stSlideIdOffset - let rId = idNum + n - fp = "slides/" ++ slideToFilePath slide idNum - return $ Relationship { relId = rId - , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" - , relTarget = fp - } - -getRels :: PandocMonad m => P m [Relationship] -getRels = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels" - let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships" - let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem - return $ mapMaybe elementToRel relElems - -presentationToRels :: PandocMonad m => Presentation -> P m [Relationship] -presentationToRels (Presentation _ slides) = do - mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..] - rels <- getRels - let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") 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) - - let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of - [] -> 0 -- doesn't matter in this case, since - -- there will be nothing to map the - -- function over - l -> minimum l - - modifyRelNum :: Int -> Int - modifyRelNum 1 = 1 - modifyRelNum n = n - minRelNotOne + 2 + length slides - - relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides - - return $ mySlideRels ++ relsWithoutSlides' - -relToElement :: Relationship -> Element -relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel)) - , ("Type", relType rel) - , ("Target", relTarget rel) ] () - -relsToElement :: [Relationship] -> Element -relsToElement rels = mknode "Relationships" - [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] - (map relToElement rels) - -presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry -presentationToRelsEntry pres = do - rels <- presentationToRels pres - elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels - -elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry -elemToEntry fp element = do - epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime - return $ toEntry fp epochtime $ renderXml element - -slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry -slideToEntry slide idNum = do - modify $ \st -> st{stCurSlideId = idNum} - element <- slideToElement slide - elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element - -slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry -slideToSlideRelEntry slide idNum = do - element <- slideToSlideRelElement slide idNum - elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element - -linkRelElement :: Int -> (URL, String) -> Element -linkRelElement idNum (url, _) = - mknode "Relationship" [ ("Id", "rId" ++ show idNum) - , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") - , ("Target", url) - , ("TargetMode", "External") - ] () - -linkRelElements :: M.Map Int (URL, String) -> [Element] -linkRelElements mp = map (\(n, lnk) -> linkRelElement n lnk) (M.toList mp) - -mediaRelElement :: MediaInfo -> Element -mediaRelElement mInfo = - let ext = case mInfoExt mInfo of - Just e -> e - Nothing -> "" - in - mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo)) - , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image") - , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext) - ] () - -slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element -slideToSlideRelElement slide idNum = do - let target = case slide of - (MetadataSlide _ _ _ _) -> "../slideLayouts/slideLayout1.xml" - (TitleSlide _) -> "../slideLayouts/slideLayout3.xml" - (ContentSlide _ _) -> "../slideLayouts/slideLayout2.xml" - (TwoColumnSlide _ _ _) -> "../slideLayouts/slideLayout4.xml" - - linkIds <- gets stLinkIds - mediaIds <- gets stMediaIds - - let linkRels = case M.lookup idNum linkIds of - Just mp -> linkRelElements mp - Nothing -> [] - mediaRels = case M.lookup idNum mediaIds of - Just mInfos -> map mediaRelElement mInfos - Nothing -> [] - - return $ - mknode "Relationships" - [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] - ([mknode "Relationship" [ ("Id", "rId1") - , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout") - , ("Target", target)] () - ] ++ linkRels ++ mediaRels) - -slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element -slideToSldIdElement slide idNum = do - let id' = show $ idNum + 255 - rId <- slideToSlideId slide idNum - return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] () - -presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element -presentationToSldIdLst (Presentation _ slides) = do - ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..]) - return $ mknode "p:sldIdLst" [] ids - -presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element -presentationToPresentationElement pres = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - element <- parseXml refArchive distArchive "ppt/presentation.xml" - sldIdLst <- presentationToSldIdLst pres - - let modifySldIdLst :: Content -> Content - modifySldIdLst (Elem e) = case elName e of - (QName "sldIdLst" _ _) -> Elem sldIdLst - _ -> Elem e - modifySldIdLst ct = ct - - newContent = map modifySldIdLst $ elContent element - - return $ element{elContent = newContent} - -presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry -presentationToPresEntry pres = presentationToPresentationElement pres >>= - elemToEntry "ppt/presentation.xml" - - - - -defaultContentTypeToElem :: DefaultContentType -> Element -defaultContentTypeToElem dct = - mknode "Default" - [("Extension", defContentTypesExt dct), - ("ContentType", defContentTypesType dct)] - () - -overrideContentTypeToElem :: OverrideContentType -> Element -overrideContentTypeToElem oct = - mknode "Override" - [("PartName", overrideContentTypesPart oct), - ("ContentType", overrideContentTypesType oct)] - () - -contentTypesToElement :: ContentTypes -> Element -contentTypesToElement ct = - let ns = "http://schemas.openxmlformats.org/package/2006/content-types" - in - mknode "Types" [("xmlns", ns)] $ - (map defaultContentTypeToElem $ contentTypesDefaults ct) ++ - (map overrideContentTypeToElem $ contentTypesOverrides ct) - -data DefaultContentType = DefaultContentType - { defContentTypesExt :: String - , defContentTypesType:: MimeType - } - deriving (Show, Eq) - -data OverrideContentType = OverrideContentType - { overrideContentTypesPart :: FilePath - , overrideContentTypesType :: MimeType - } - deriving (Show, Eq) - -data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType] - , contentTypesOverrides :: [OverrideContentType] - } - deriving (Show, Eq) - -contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry -contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct - -pathToOverride :: FilePath -> Maybe OverrideContentType -pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp) - -mediaContentType :: MediaInfo -> Maybe DefaultContentType -mediaContentType mInfo - | Just ('.' : ext) <- mInfoExt mInfo = - Just $ DefaultContentType { defContentTypesExt = ext - , defContentTypesType = - case mInfoMimeType mInfo of - Just mt -> mt - Nothing -> "application/octet-stream" - } - | otherwise = Nothing - -presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes -presentationToContentTypes (Presentation _ slides) = do - mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds - let defaults = [ DefaultContentType "xml" "application/xml" - , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml" - ] - mediaDefaults = nub $ mapMaybe mediaContentType mediaInfos - inheritedOverrides = mapMaybe pathToOverride inheritedFiles - presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"] - slideOverrides = - mapMaybe - (\(s, n) -> - pathToOverride $ "ppt/slides/" ++ slideToFilePath s n) - (zip slides [1..]) - -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"] - return $ ContentTypes - (defaults ++ mediaDefaults) - (inheritedOverrides ++ presOverride ++ slideOverrides) - -presML :: String -presML = "application/vnd.openxmlformats-officedocument.presentationml" - -noPresML :: String -noPresML = "application/vnd.openxmlformats-officedocument" - -getContentType :: FilePath -> Maybe MimeType -getContentType fp - | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml" - | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml" - | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml" - | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml" - | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml" - | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml" - | "ppt" : "slideMasters" : f : [] <- splitDirectories fp - , (_, ".xml") <- splitExtension f = - Just $ presML ++ ".slideMaster+xml" - | "ppt" : "slides" : f : [] <- splitDirectories fp - , (_, ".xml") <- splitExtension f = - Just $ presML ++ ".slide+xml" - | "ppt" : "notesMasters" : f : [] <- splitDirectories fp - , (_, ".xml") <- splitExtension f = - Just $ presML ++ ".notesMaster+xml" - | "ppt" : "notesSlides" : f : [] <- splitDirectories fp - , (_, ".xml") <- splitExtension f = - Just $ presML ++ ".notesSlide+xml" - | "ppt" : "theme" : f : [] <- splitDirectories fp - , (_, ".xml") <- splitExtension f = - Just $ noPresML ++ ".theme+xml" - | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp= - Just $ presML ++ ".slideLayout+xml" - | otherwise = Nothing - -------------------------------------------------------- - -combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem] -combineParaElems' mbPElem [] = maybeToList mbPElem -combineParaElems' Nothing (pElem : pElems) = - combineParaElems' (Just pElem) pElems -combineParaElems' (Just pElem') (pElem : pElems) - | Run rPr' s' <- pElem' - , Run rPr s <- pElem - , rPr == rPr' = - combineParaElems' (Just $ Run rPr' $ s' ++ s) pElems - | otherwise = - pElem' : combineParaElems' (Just pElem) pElems - -combineParaElems :: [ParaElem] -> [ParaElem] -combineParaElems = combineParaElems' Nothing +{-# LANGUAGE PatternGuards #-} + +{- +Copyright (C) 2017-2018 Jesse Rosenthal + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Writers.Powerpoint + Copyright : Copyright (C) 2017-2018 Jesse Rosenthal + License : GNU GPL, version 2 or above + + Maintainer : Jesse Rosenthal + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' documents to powerpoint (pptx). -} + +{- +This is a wrapper around two modules: + + - Text.Pandoc.Writers.Powerpoint.Presentation (which converts a + pandoc document into a Presentation datatype), and + + - Text.Pandoc.Writers.Powerpoint.Output (which converts a + Presentation into a zip archive, which can be output). +-} + +module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where + +import Codec.Archive.Zip +import Text.Pandoc.Definition +import Text.Pandoc.Walk +import Text.Pandoc.Class (PandocMonad, report) +import Text.Pandoc.Options (WriterOptions) +import Text.Pandoc.Writers.Shared (fixDisplayMath) +import Text.Pandoc.Writers.Powerpoint.Presentation (documentToPresentation) +import Text.Pandoc.Writers.Powerpoint.Output (presentationToArchive) +import qualified Data.ByteString.Lazy as BL + +writePowerpoint :: (PandocMonad m) + => WriterOptions -- ^ Writer options + -> Pandoc -- ^ Document to convert + -> m BL.ByteString +writePowerpoint opts (Pandoc meta blks) = do + let blks' = walk fixDisplayMath blks + let (pres, logMsgs) = documentToPresentation opts (Pandoc meta blks') + mapM_ report logMsgs + archv <- presentationToArchive opts pres + return $ fromArchive archv diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -0,0 +1,1481 @@ +{-# LANGUAGE PatternGuards #-} + +{- +Copyright (C) 2017-2018 Jesse Rosenthal + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Writers.Powerpoint.Output + Copyright : Copyright (C) 2017-2018 Jesse Rosenthal + License : GNU GPL, version 2 or above + + Maintainer : Jesse Rosenthal + Stability : alpha + Portability : portable + +Conversion of Presentation datatype (defined in +Text.Pandoc.Writers.Powerpoint.Presentation) to a zip archive. +-} + +module Text.Pandoc.Writers.Powerpoint.Output ( presentationToArchive + ) where + +import Control.Monad.Except (throwError, catchError) +import Control.Monad.Reader +import Control.Monad.State +import Codec.Archive.Zip +import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf) +import Data.Default +import Text.Pandoc.Compat.Time (formatTime, defaultTimeLocale) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) +import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension) +import Text.XML.Light +import Text.Pandoc.Definition +import qualified Text.Pandoc.UTF8 as UTF8 +import Text.Pandoc.Class (PandocMonad) +import Text.Pandoc.Error (PandocError(..)) +import qualified Text.Pandoc.Class as P +import Text.Pandoc.Options +import Text.Pandoc.MIME +import qualified Data.ByteString.Lazy as BL +import Text.Pandoc.Writers.OOXML +import qualified Data.Map as M +import Data.Maybe (mapMaybe, listToMaybe, fromMaybe) +import Text.Pandoc.ImageSize +import Control.Applicative ((<|>)) +import System.FilePath.Glob +import Text.TeXMath +import Text.Pandoc.Writers.Math (convertMath) +import Text.Pandoc.Writers.Powerpoint.Presentation + +-- This populates the global ids map with images already in the +-- template, so the ids won't be used by images introduced by the +-- user. +initialGlobalIds :: Archive -> Archive -> M.Map FilePath Int +initialGlobalIds refArchive distArchive = + let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive + mediaPaths = filter (isPrefixOf "ppt/media/image") archiveFiles + + go :: FilePath -> Maybe (FilePath, Int) + go fp = do + s <- stripPrefix "ppt/media/image" $ fst $ splitExtension fp + (n, _) <- listToMaybe $ reads s + return (fp, n) + in + M.fromList $ mapMaybe go mediaPaths + +getPresentationSize :: Archive -> Archive -> Maybe (Integer, Integer) +getPresentationSize refArchive distArchive = do + entry <- findEntryByPath "ppt/presentation.xml" refArchive `mplus` + findEntryByPath "ppt/presentation.xml" distArchive + presElement <- parseXMLDoc $ UTF8.toStringLazy $ fromEntry entry + let ns = elemToNameSpaces presElement + sldSize <- findChild (elemName ns "p" "sldSz") presElement + cxS <- findAttr (QName "cx" Nothing Nothing) sldSize + cyS <- findAttr (QName "cy" Nothing Nothing) sldSize + (cx, _) <- listToMaybe $ reads cxS :: Maybe (Integer, String) + (cy, _) <- listToMaybe $ reads cyS :: Maybe (Integer, String) + return (cx `div` 12700, cy `div` 12700) + +data WriterEnv = WriterEnv { envRefArchive :: Archive + , envDistArchive :: Archive + , envUTCTime :: UTCTime + , envOpts :: WriterOptions + , envPresentationSize :: (Integer, Integer) + , envSlideHasHeader :: Bool + , 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 + , envSlideIdMap :: M.Map SlideId Int + } + deriving (Show) + +instance Default WriterEnv where + def = WriterEnv { envRefArchive = emptyArchive + , envDistArchive = emptyArchive + , envUTCTime = posixSecondsToUTCTime 0 + , envOpts = def + , envPresentationSize = (720, 540) + , envSlideHasHeader = False + , envInList = False + , envInNoteSlide = False + , envCurSlideId = 1 + , envSlideIdOffset = 1 + , envContentType = NormalContent + , envSlideIdMap = mempty + } + +data ContentType = NormalContent + | TwoColumnLeftContent + | TwoColumnRightContent + deriving (Show, Eq) + +data MediaInfo = MediaInfo { mInfoFilePath :: FilePath + , mInfoLocalId :: Int + , mInfoGlobalId :: Int + , mInfoMimeType :: Maybe MimeType + , mInfoExt :: Maybe String + , mInfoCaption :: Bool + } deriving (Show, Eq) + +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 + } deriving (Show, Eq) + +instance Default WriterState where + def = WriterState { stLinkIds = mempty + , stMediaIds = mempty + , stMediaGlobalIds = mempty + } + +type P m = ReaderT WriterEnv (StateT WriterState m) + +runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a +runP env st p = evalStateT (runReaderT p env) st + +-------------------------------------------------------------------- + +copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive +copyFileToArchive arch fp = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of + Nothing -> fail $ fp ++ " missing in reference file" + Just e -> return $ addEntryToArchive e arch + +inheritedPatterns :: [Pattern] +inheritedPatterns = map compile [ "docProps/app.xml" + , "ppt/slideLayouts/slideLayout*.xml" + , "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/presProps.xml" + , "ppt/viewProps.xml" + , "ppt/tableStyles.xml" + , "ppt/media/image*" + ] + +patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath] +patternToFilePaths pat = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + + let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive + return $ filter (match pat) archiveFiles + +patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath] +patternsToFilePaths pats = concat <$> mapM patternToFilePaths pats + +-- Here are the files we'll require to make a Powerpoint document. If +-- any of these are missing, we should error out of our build. +requiredFiles :: [FilePath] +requiredFiles = [ "docProps/app.xml" + , "ppt/presProps.xml" + , "ppt/slideLayouts/slideLayout1.xml" + , "ppt/slideLayouts/_rels/slideLayout1.xml.rels" + , "ppt/slideLayouts/slideLayout2.xml" + , "ppt/slideLayouts/_rels/slideLayout2.xml.rels" + , "ppt/slideLayouts/slideLayout3.xml" + , "ppt/slideLayouts/_rels/slideLayout3.xml.rels" + , "ppt/slideLayouts/slideLayout4.xml" + , "ppt/slideLayouts/_rels/slideLayout4.xml.rels" + , "ppt/slideMasters/slideMaster1.xml" + , "ppt/slideMasters/_rels/slideMaster1.xml.rels" + , "ppt/theme/theme1.xml" + , "ppt/viewProps.xml" + , "ppt/tableStyles.xml" + ] + + +presentationToArchiveP :: PandocMonad m => Presentation -> P m Archive +presentationToArchiveP p@(Presentation docProps slides) = do + filePaths <- patternsToFilePaths inheritedPatterns + + -- make sure all required files are available: + let missingFiles = filter (\fp -> not (fp `elem` filePaths)) requiredFiles + unless (null missingFiles) + (throwError $ + PandocSomeError $ + "The following required files are missing:\n" ++ + (unlines $ map (" " ++) missingFiles) + ) + + newArch' <- foldM copyFileToArchive emptyArchive filePaths + -- we make a docProps/core.xml entry out of the presentation docprops + docPropsEntry <- docPropsToEntry docProps + -- 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 + slideEntries <- mapM slideToEntry slides + slideRelEntries <- mapM slideToSlideRelEntry slides + -- These have to come after everything, because they need the info + -- built up in the state. + mediaEntries <- makeMediaEntries + contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry + -- fold everything into our inherited archive and return it. + return $ foldr addEntryToArchive newArch' $ + slideEntries ++ + slideRelEntries ++ + mediaEntries ++ + [contentTypesEntry, docPropsEntry, relsEntry, presEntry, presRelsEntry] + +makeSlideIdMap :: Presentation -> M.Map SlideId Int +makeSlideIdMap (Presentation _ slides) = + M.fromList $ (map slideId slides) `zip` [1..] + +presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive +presentationToArchive opts pres = do + distArchive <- (toArchive . BL.fromStrict) <$> + P.readDefaultDataFile "reference.pptx" + refArchive <- case writerReferenceDoc opts of + Just f -> toArchive <$> P.readFileLazy f + Nothing -> (toArchive . BL.fromStrict) <$> + P.readDataFile "reference.pptx" + + utctime <- P.getCurrentTime + + presSize <- case getPresentationSize refArchive distArchive of + Just sz -> return sz + Nothing -> throwError $ + PandocSomeError $ + "Could not determine presentation size" + + let env = def { envRefArchive = refArchive + , envDistArchive = distArchive + , envUTCTime = utctime + , envOpts = opts + , envPresentationSize = presSize + , envSlideIdMap = makeSlideIdMap pres + } + + let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive + } + + runP env st $ presentationToArchiveP pres + + + +-------------------------------------------------- + +-------------------------------------------------- + +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" + distArchive <- asks envDistArchive + root <- case findEntryByPath layoutpath distArchive of + Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of + Just element -> return $ element + Nothing -> throwError $ + PandocSomeError $ + layoutpath ++ " corrupt in reference file" + Nothing -> throwError $ + PandocSomeError $ + layoutpath ++ " missing in reference file" + return root + +shapeHasName :: NameSpaces -> String -> Element -> Bool +shapeHasName ns name element + | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element + , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr + , Just nm <- findAttr (QName "name" Nothing Nothing) cNvPr = + nm == name + | otherwise = False + +shapeHasId :: NameSpaces -> String -> 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 + +-- The content shape in slideLayout2 (Title/Content) has id=3 In +-- slideLayout4 (two column) the left column is id=3, and the right +-- column is id=4. +getContentShape :: PandocMonad m => NameSpaces -> Element -> P m Element +getContentShape ns spTreeElem + | isElem ns "p" "spTree" spTreeElem = do + contentType <- asks envContentType + let ident = case contentType of + NormalContent -> "3" + TwoColumnLeftContent -> "3" + TwoColumnRightContent -> "4" + case filterChild + (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) + spTreeElem + of + Just e -> return e + Nothing -> throwError $ + PandocSomeError $ + "Could not find shape for Powerpoint content" +getContentShape _ _ = throwError $ + PandocSomeError $ + "Attempted to find content on non shapeTree" + +getShapeDimensions :: NameSpaces + -> Element + -> Maybe ((Integer, Integer), (Integer, Integer)) +getShapeDimensions ns element + | isElem ns "p" "sp" element = do + spPr <- findChild (elemName ns "p" "spPr") element + xfrm <- findChild (elemName ns "a" "xfrm") spPr + off <- findChild (elemName ns "a" "off") xfrm + xS <- findAttr (QName "x" Nothing Nothing) off + yS <- findAttr (QName "y" Nothing Nothing) off + ext <- findChild (elemName ns "a" "ext") xfrm + cxS <- findAttr (QName "cx" Nothing Nothing) ext + cyS <- findAttr (QName "cy" Nothing Nothing) ext + (x, _) <- listToMaybe $ reads xS + (y, _) <- listToMaybe $ reads yS + (cx, _) <- listToMaybe $ reads cxS + (cy, _) <- listToMaybe $ reads cyS + return $ ((x `div` 12700, y `div` 12700), (cx `div` 12700, cy `div` 12700)) + | otherwise = Nothing + + +getMasterShapeDimensionsById :: String + -> Element + -> Maybe ((Integer, Integer), (Integer, Integer)) +getMasterShapeDimensionsById ident master = do + let ns = elemToNameSpaces master + cSld <- findChild (elemName ns "p" "cSld") master + spTree <- findChild (elemName ns "p" "spTree") cSld + sp <- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTree + getShapeDimensions ns sp + +getContentShapeSize :: PandocMonad m + => NameSpaces + -> Element + -> Element + -> P m ((Integer, Integer), (Integer, Integer)) +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 + case getShapeDimensions ns sp of + Just sz -> return sz + Nothing -> do let mbSz = + findChild (elemName ns "p" "nvSpPr") sp >>= + findChild (elemName ns "p" "cNvPr") >>= + findAttr (QName "id" Nothing Nothing) >>= + flip getMasterShapeDimensionsById master + case mbSz of + Just sz' -> return sz' + Nothing -> throwError $ + PandocSomeError $ + "Couldn't find necessary content shape size" +getContentShapeSize _ _ _ = throwError $ + PandocSomeError $ + "Attempted to find content shape size in non-layout" + +replaceNamedChildren :: NameSpaces + -> String + -> String + -> [Element] + -> Element + -> Element +replaceNamedChildren ns prefix name newKids element = + element { elContent = concat $ fun True $ elContent element } + where + fun :: Bool -> [Content] -> [[Content]] + fun _ [] = [] + fun switch ((Elem e) : conts) | isElem ns prefix name e = + if switch + then (map Elem $ newKids) : fun False conts + else fun False conts + fun switch (cont : conts) = [cont] : fun switch conts + +---------------------------------------------------------------- + +registerLink :: PandocMonad m => LinkTarget -> P m Int +registerLink link = do + curSlideId <- asks envCurSlideId + linkReg <- gets stLinkIds + mediaReg <- gets stMediaIds + let maxLinkId = case M.lookup curSlideId linkReg of + Just mp -> case M.keys mp of + [] -> 1 + ks -> maximum ks + Nothing -> 1 + maxMediaId = case M.lookup curSlideId mediaReg of + Just [] -> 1 + Just mInfos -> maximum $ map mInfoLocalId mInfos + Nothing -> 1 + maxId = max maxLinkId maxMediaId + slideLinks = case M.lookup curSlideId linkReg of + Just mp -> M.insert (maxId + 1) link mp + Nothing -> M.singleton (maxId + 1) link + modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg} + return $ maxId + 1 + +registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo +registerMedia fp caption = do + curSlideId <- asks envCurSlideId + linkReg <- gets stLinkIds + mediaReg <- gets stMediaIds + globalIds <- gets stMediaGlobalIds + let maxLinkId = case M.lookup curSlideId linkReg of + Just mp -> case M.keys mp of + [] -> 1 + ks -> maximum ks + Nothing -> 1 + maxMediaId = case M.lookup curSlideId mediaReg of + Just [] -> 1 + Just mInfos -> maximum $ map mInfoLocalId mInfos + Nothing -> 1 + maxLocalId = max maxLinkId maxMediaId + + maxGlobalId = case M.elems globalIds of + [] -> 0 + ids -> maximum ids + + (imgBytes, mbMt) <- P.fetchItem fp + let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x)) + <|> + case imageType imgBytes of + Just Png -> Just ".png" + Just Jpeg -> Just ".jpeg" + Just Gif -> Just ".gif" + Just Pdf -> Just ".pdf" + Just Eps -> Just ".eps" + Just Svg -> Just ".svg" + Nothing -> Nothing + + let newGlobalId = case M.lookup fp globalIds of + Just ident -> ident + Nothing -> maxGlobalId + 1 + + let newGlobalIds = M.insert fp newGlobalId globalIds + + let mediaInfo = MediaInfo { mInfoFilePath = fp + , mInfoLocalId = maxLocalId + 1 + , mInfoGlobalId = newGlobalId + , mInfoMimeType = mbMt + , mInfoExt = imgExt + , mInfoCaption = (not . null) caption + } + + let slideMediaInfos = case M.lookup curSlideId mediaReg of + Just minfos -> mediaInfo : minfos + Nothing -> [mediaInfo] + + + modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg + , stMediaGlobalIds = newGlobalIds + } + return mediaInfo + +makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry +makeMediaEntry mInfo = do + epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime + (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo) + let ext = case mInfoExt mInfo of + Just e -> e + Nothing -> "" + let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext + return $ toEntry fp epochtime $ BL.fromStrict imgBytes + +makeMediaEntries :: PandocMonad m => P m [Entry] +makeMediaEntries = do + mediaInfos <- gets stMediaIds + let allInfos = mconcat $ M.elems mediaInfos + mapM makeMediaEntry allInfos + +-- -- | Scales the image to fit the page +-- -- sizes are passed in emu +-- fitToPage' :: (Double, Double) -- image size in emu +-- -> Integer -- pageWidth +-- -> Integer -- pageHeight +-- -> (Integer, Integer) -- imagesize +-- fitToPage' (x, y) pageWidth pageHeight +-- -- Fixes width to the page width and scales the height +-- | x <= fromIntegral pageWidth && y <= fromIntegral pageHeight = +-- (floor x, floor y) +-- | x / fromIntegral pageWidth > y / fromIntegral pageWidth = +-- (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y) +-- | otherwise = +-- (floor $ ((fromIntegral pageHeight) / y) * x, pageHeight) + +-- positionImage :: (Double, Double) -> Integer -> Integer -> (Integer, Integer) +-- positionImage (x, y) pageWidth pageHeight = +-- let (x', y') = fitToPage' (x, y) pageWidth pageHeight +-- in +-- ((pageWidth - x') `div` 2, (pageHeight - y') `div` 2) + +getMaster :: PandocMonad m => P m Element +getMaster = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml" + +-- 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. + +-- getHeaderSize :: PandocMonad m => P m ((Integer, Integer), (Integer, Integer)) +-- getHeaderSize = do +-- master <- getMaster +-- let ns = elemToNameSpaces master +-- sps = [master] >>= +-- findChildren (elemName ns "p" "cSld") >>= +-- findChildren (elemName ns "p" "spTree") >>= +-- findChildren (elemName ns "p" "sp") +-- mbXfrm = +-- listToMaybe (filter (shapeHasName ns "Title Placeholder 1") sps) >>= +-- findChild (elemName ns "p" "spPr") >>= +-- findChild (elemName ns "a" "xfrm") +-- xoff = mbXfrm >>= +-- findChild (elemName ns "a" "off") >>= +-- findAttr (QName "x" Nothing Nothing) >>= +-- (listToMaybe . (\s -> reads s :: [(Integer, String)])) +-- yoff = mbXfrm >>= +-- findChild (elemName ns "a" "off") >>= +-- findAttr (QName "y" Nothing Nothing) >>= +-- (listToMaybe . (\s -> reads s :: [(Integer, String)])) +-- xext = mbXfrm >>= +-- findChild (elemName ns "a" "ext") >>= +-- findAttr (QName "cx" Nothing Nothing) >>= +-- (listToMaybe . (\s -> reads s :: [(Integer, String)])) +-- yext = mbXfrm >>= +-- findChild (elemName ns "a" "ext") >>= +-- findAttr (QName "cy" Nothing Nothing) >>= +-- (listToMaybe . (\s -> reads s :: [(Integer, String)])) +-- off = case xoff of +-- Just (xoff', _) | Just (yoff',_) <- yoff -> (xoff', yoff') +-- _ -> (1043490, 1027664) +-- ext = case xext of +-- Just (xext', _) | Just (yext',_) <- yext -> (xext', yext') +-- _ -> (7024744, 1143000) +-- return $ (off, ext) + +-- Hard-coded for now +-- captionPosition :: ((Integer, Integer), (Integer, Integer)) +-- captionPosition = ((457200, 6061972), (8229600, 527087)) + +captionHeight :: Integer +captionHeight = 40 + +createCaption :: PandocMonad m + => ((Integer, Integer), (Integer, Integer)) + -> [ParaElem] + -> P m 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", show $ 12700 * x), + ("y", show $ 12700 * (y + cy - captionHeight))] () + , mknode "a:ext" [("cx", show $ 12700 * cx), + ("cy", show $ 12700 * captionHeight)] () + ] + , mknode "a:prstGeom" [("prst", "rect")] + [ mknode "a:avLst" [] () + ] + , mknode "a:noFill" [] () + ] + , txBody + ] + +makePicElements :: PandocMonad m + => Element + -> PicProps + -> MediaInfo + -> [ParaElem] + -> P m [Element] +makePicElements layout picProps mInfo alt = do + opts <- asks envOpts + (pageWidth, pageHeight) <- asks envPresentationSize + -- hasHeader <- asks envSlideHasHeader + let hasCaption = mInfoCaption mInfo + (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo) + let (pxX, pxY) = case imageSize opts imgBytes of + Right sz -> sizeInPixels $ sz + Left _ -> sizeInPixels $ def + master <- getMaster + let ns = elemToNameSpaces layout + ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master + `catchError` + (\_ -> return ((0, 0), (pageWidth, pageHeight))) + + let cy = if hasCaption then cytmp - captionHeight else cytmp + + let imgRatio = fromIntegral pxX / fromIntegral pxY :: Double + boxRatio = fromIntegral cx / fromIntegral cy :: Double + (dimX, dimY) = if imgRatio > boxRatio + then (fromIntegral cx, fromIntegral cx / imgRatio) + else (fromIntegral cy * imgRatio, fromIntegral cy) + + (dimX', dimY') = (round dimX * 12700, round dimY * 12700) :: (Integer, Integer) + (xoff, yoff) = (fromIntegral x + (fromIntegral cx - dimX) / 2, + fromIntegral y + (fromIntegral cy - dimY) / 2) + (xoff', yoff') = (round xoff * 12700, round yoff * 12700) :: (Integer, Integer) + + let cNvPicPr = mknode "p:cNvPicPr" [] $ + mknode "a:picLocks" [("noGrp","1") + ,("noChangeAspect","1")] () + -- cNvPr will contain the link information so we do that separately, + -- and register the link if necessary. + let cNvPrAttr = [("descr", mInfoFilePath mInfo), ("id","0"),("name","Picture 1")] + cNvPr <- case picPropLink picProps of + Just link -> do idNum <- registerLink link + return $ mknode "p:cNvPr" cNvPrAttr $ + mknode "a:hlinkClick" [("r:id", "rId" ++ show idNum)] () + Nothing -> return $ mknode "p:cNvPr" cNvPrAttr () + let nvPicPr = mknode "p:nvPicPr" [] + [ cNvPr + , cNvPicPr + , mknode "p:nvPr" [] ()] + let blipFill = mknode "p:blipFill" [] + [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] () + , mknode "a:stretch" [] $ + mknode "a:fillRect" [] () ] + let xfrm = mknode "a:xfrm" [] + [ mknode "a:off" [("x",show xoff'), ("y",show yoff')] () + , mknode "a:ext" [("cx",show dimX') + ,("cy",show dimY')] () ] + let prstGeom = mknode "a:prstGeom" [("prst","rect")] $ + mknode "a:avLst" [] () + let ln = mknode "a:ln" [("w","9525")] + [ mknode "a:noFill" [] () + , mknode "a:headEnd" [] () + , mknode "a:tailEnd" [] () ] + let spPr = mknode "p:spPr" [("bwMode","auto")] + [xfrm, prstGeom, mknode "a:noFill" [] (), ln] + + let picShape = mknode "p:pic" [] + [ nvPicPr + , blipFill + , spPr ] + + -- And now, maybe create the caption: + if hasCaption + then do cap <- createCaption ((x, y), (cx, cytmp)) alt + return [picShape, cap] + else return [picShape] + + +paraElemToElement :: PandocMonad m => ParaElem -> P m Element +paraElemToElement Break = return $ mknode "a:br" [] () +paraElemToElement (Run rpr s) = do + let sizeAttrs = case rPropForceSize rpr of + Just n -> [("sz", (show $ n * 100))] + Nothing -> [] + attrs = sizeAttrs ++ + if rPropCode rpr + then [] + else (if rPropBold rpr then [("b", "1")] else []) ++ + (if rPropItalics rpr then [("i", "1")] else []) ++ + (case rStrikethrough rpr of + Just NoStrike -> [("strike", "noStrike")] + Just SingleStrike -> [("strike", "sngStrike")] + Just DoubleStrike -> [("strike", "dblStrike")] + Nothing -> []) ++ + (case rBaseline rpr of + Just n -> [("baseline", show n)] + Nothing -> []) ++ + (case rCap rpr of + Just NoCapitals -> [("cap", "none")] + Just SmallCapitals -> [("cap", "small")] + Just AllCapitals -> [("cap", "all")] + Nothing -> []) ++ + [] + linkProps <- case rLink rpr of + Just link -> do + idNum <- registerLink link + -- first we have to make sure that if it's an + -- anchor, it's in the anchor map. If not, there's + -- no link. + return $ case link of + InternalTarget _ -> + let linkAttrs = + [ ("r:id", "rId" ++ show idNum) + , ("action", "ppaction://hlinksldjump") + ] + in [mknode "a:hlinkClick" linkAttrs ()] + -- external + ExternalTarget _ -> + let linkAttrs = + [ ("r:id", "rId" ++ show idNum) + ] + in [mknode "a:hlinkClick" linkAttrs ()] + Nothing -> return [] + let propContents = if rPropCode rpr + then [mknode "a:latin" [("typeface", "Courier")] ()] + else linkProps + return $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents + , mknode "a:t" [] s + ] +paraElemToElement (MathElem mathType texStr) = do + res <- convertMath writeOMML mathType (unTeXString texStr) + case res of + Right r -> return $ mknode "a14:m" [] $ addMathInfo r + Left (Str s) -> paraElemToElement (Run def s) + Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback" + +-- This is a bit of a kludge -- really requires adding an option to +-- TeXMath, but since that's a different package, we'll do this one +-- step at a time. +addMathInfo :: Element -> Element +addMathInfo element = + let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns")) + , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math" + } + in add_attr mathspace element + +-- We look through the element to see if it contains an a14:m +-- element. If so, we surround it. This is a bit ugly, but it seems +-- more dependable than looking through shapes for math. Plus this is +-- an xml implementation detail, so it seems to make sense to do it at +-- the xml level. +surroundWithMathAlternate :: Element -> Element +surroundWithMathAlternate element = + case findElement (QName "m" Nothing (Just "a14")) element of + Just _ -> + mknode "mc:AlternateContent" + [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006") + ] [ mknode "mc:Choice" + [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main") + , ("Requires", "a14")] [ element ] + ] + Nothing -> element + +paragraphToElement :: PandocMonad m => Paragraph -> P m Element +paragraphToElement par = do + let + attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++ + (case pPropMarginLeft (paraProps par) of + Just px -> [("marL", show $ 12700 * px), ("indent", "0")] + Nothing -> [] + ) ++ + (case pPropAlign (paraProps par) of + Just AlgnLeft -> [("algn", "l")] + Just AlgnRight -> [("algn", "r")] + Just AlgnCenter -> [("algn", "ctr")] + Nothing -> [] + ) + props = [] ++ + (case pPropSpaceBefore $ paraProps par of + Just px -> [mknode "a:spcBef" [] [ + mknode "a:spcPts" [("val", show $ 100 * px)] () + ] + ] + Nothing -> [] + ) ++ + (case pPropBullet $ paraProps par of + Just Bullet -> [] + Just (AutoNumbering attrs') -> + [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()] + Nothing -> [mknode "a:buNone" [] ()] + ) + paras <- mapM paraElemToElement (paraElems par) + return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras + +shapeToElement :: PandocMonad m => Element -> Shape -> P m 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 + elements <- mapM paragraphToElement paras + let txBody = mknode "p:txBody" [] $ + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements + emptySpPr = mknode "p:spPr" [] () + return $ + surroundWithMathAlternate $ + replaceNamedChildren ns "p" "txBody" [txBody] $ + replaceNamedChildren ns "p" "spPr" [emptySpPr] $ + sp +-- GraphicFrame and Pic should never reach this. +shapeToElement _ _ = return $ mknode "p:sp" [] () + +shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element] +shapeToElements layout (Pic picProps fp alt) = do + mInfo <- registerMedia fp alt + case mInfoExt mInfo of + Just _ -> do + makePicElements layout picProps mInfo alt + Nothing -> shapeToElements layout $ TextBox [Paragraph def alt] +shapeToElements layout (GraphicFrame tbls cptn) = + graphicFrameToElements layout tbls cptn +shapeToElements layout shp = do + element <- shapeToElement layout shp + return [element] + +shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element] +shapesToElements layout shps = do + concat <$> mapM (shapeToElements layout) shps + +graphicFrameToElements :: PandocMonad m => Element -> [Graphic] -> [ParaElem] -> P m [Element] +graphicFrameToElements layout tbls caption = do + -- get the sizing + master <- getMaster + (pageWidth, pageHeight) <- asks envPresentationSize + let ns = elemToNameSpaces layout + ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master + `catchError` + (\_ -> return ((0, 0), (pageWidth, pageHeight))) + + let cy = if (not $ null caption) then cytmp - captionHeight else cytmp + + 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", show $ 12700 * x), ("y", show $ 12700 * y)] () + , mknode "a:ext" [("cx", show $ 12700 * cx), ("cy", show $ 12700 * cy)] () + ] + ] ++ elements + + if (not $ null caption) + then do capElt <- createCaption ((x, y), (cx, cytmp)) caption + return [graphicFrameElts, capElt] + else return [graphicFrameElts] + +graphicToElement :: PandocMonad m => Integer -> Graphic -> P m Element +graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do + let colWidths = if null hdrCells + then case rows of + r : _ | not (null r) -> replicate (length r) $ + (tableWidth `div` (toInteger $ length r)) + -- satisfy the compiler. This is the same as + -- saying that rows is empty, but the compiler + -- won't understand that `[]` exhausts the + -- alternatives. + _ -> [] + else replicate (length hdrCells) $ + (tableWidth `div` (toInteger $ length hdrCells)) + + let cellToOpenXML paras = + do elements <- mapM paragraphToElement paras + let elements' = if null elements + then [mknode "a:p" [] [mknode "a:endParaRPr" [] ()]] + else elements + return $ + [mknode "a:txBody" [] $ + ([ mknode "a:bodyPr" [] () + , mknode "a:lstStyle" [] ()] + ++ elements')] + headers' <- mapM cellToOpenXML hdrCells + rows' <- mapM (mapM cellToOpenXML) rows + let borderProps = mknode "a:tcPr" [] () + let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]] + let mkcell border contents = mknode "a:tc" [] + $ (if null contents + then emptyCell + else contents) ++ [ borderProps | border ] + let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells + + let mkgridcol w = mknode "a:gridCol" + [("w", show ((12700 * w) :: Integer))] () + let hasHeader = not (all null hdrCells) + return $ mknode "a:graphic" [] $ + [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $ + [mknode "a:tbl" [] $ + [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0") + , ("bandRow", if tblPrBandRow tblPr then "1" else "0") + ] () + , mknode "a:tblGrid" [] (if all (==0) colWidths + then [] + else map mkgridcol colWidths) + ] + ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows' + ] + ] + +getShapeByName :: NameSpaces -> Element -> String -> Maybe Element +getShapeByName ns spTreeElem name + | isElem ns "p" "spTree" spTreeElem = + filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem + | otherwise = Nothing + +-- getShapeById :: NameSpaces -> Element -> String -> Maybe Element +-- getShapeById ns spTreeElem ident +-- | isElem ns "p" "spTree" spTreeElem = +-- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTreeElem +-- | otherwise = Nothing + +nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element +nonBodyTextToElement layout shapeName paraElements + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld + , Just sp <- getShapeByName ns spTree shapeName = 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 + -- XXX: TODO + | otherwise = return $ mknode "p:sp" [] () + +contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m 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 "Title 1" hdrShape + let hdrShapeElements = if null hdrShape + then [] + else [element] + contentElements <- local + (\env -> env {envContentType = NormalContent}) + (shapesToElements layout shapes) + return $ + replaceNamedChildren ns "p" "sp" + (hdrShapeElements ++ contentElements) + spTree +contentToElement _ _ _ = return $ mknode "p:sp" [] () + +twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m 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 "Title 1" hdrShape + let hdrShapeElements = if null hdrShape + then [] + else [element] + contentElementsL <- local + (\env -> env {envContentType =TwoColumnLeftContent}) + (shapesToElements layout shapesL) + contentElementsR <- local + (\env -> env {envContentType =TwoColumnRightContent}) + (shapesToElements layout shapesR) + -- let contentElementsL' = map (setIdx ns "1") contentElementsL + -- contentElementsR' = map (setIdx ns "2") contentElementsR + return $ + replaceNamedChildren ns "p" "sp" + (hdrShapeElements ++ contentElementsL ++ contentElementsR) + spTree +twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] () + + +titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m 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 "Title 1" titleElems + let titleShapeElements = if null titleElems + then [] + else [element] + return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree +titleToElement _ _ = return $ mknode "p:sp" [] () + +metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m 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 "Title 1" titleElems] + let combinedAuthorElems = intercalate [Break] authorsElems + subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems] + subtitleShapeElements <- if null subtitleAndAuthorElems + then return [] + else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems] + dateShapeElements <- if null dateElems + then return [] + else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems] + return $ replaceNamedChildren ns "p" "sp" + (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements) + spTree +metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] () + +slideToElement :: PandocMonad m => Slide -> P m Element +slideToElement (Slide _ l@(ContentSlide hdrElems shapes) _ )= do + layout <- getLayout l + spTree <- local (\env -> if null hdrElems + then env + else env{envSlideHasHeader=True}) $ + contentToElement layout hdrElems 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" [] [spTree]] +slideToElement (Slide _ l@(TwoColumnSlide hdrElems shapesL shapesR) _) = do + layout <- getLayout l + spTree <- local (\env -> if null hdrElems + then env + else env{envSlideHasHeader=True}) $ + twoColumnToElement layout hdrElems shapesL 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@(TitleSlide hdrElems) _) = do + layout <- getLayout l + 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@(MetadataSlide titleElems subtitleElems authorElems dateElems) _) = do + layout <- getLayout l + 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]] + +----------------------------------------------------------------------- + +getSlideIdNum :: PandocMonad m => SlideId -> P m Int +getSlideIdNum sldId = do + slideIdMap <- asks envSlideIdMap + case M.lookup sldId slideIdMap of + Just n -> return n + Nothing -> throwError $ + PandocShouldNeverHappenError $ + "Slide Id " ++ (show sldId) ++ " not found." + +slideNum :: PandocMonad m => Slide -> P m Int +slideNum slide = getSlideIdNum $ slideId slide + +idNumToFilePath :: Int -> FilePath +idNumToFilePath idNum = "slide" ++ (show $ idNum) ++ ".xml" + +slideToFilePath :: PandocMonad m => Slide -> P m FilePath +slideToFilePath slide = do + idNum <- slideNum slide + return $ "slide" ++ (show $ idNum) ++ ".xml" + +slideToRelId :: PandocMonad m => Slide -> P m String +slideToRelId slide = do + n <- slideNum slide + offset <- asks envSlideIdOffset + return $ "rId" ++ (show $ n + offset) + + +data Relationship = Relationship { relId :: Int + , relType :: MimeType + , relTarget :: FilePath + } deriving (Show, Eq) + +elementToRel :: Element -> Maybe Relationship +elementToRel element + | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing = + do rId <- findAttr (QName "Id" Nothing Nothing) element + numStr <- stripPrefix "rId" rId + num <- case reads numStr :: [(Int, String)] of + (n, _) : _ -> Just n + [] -> Nothing + type' <- findAttr (QName "Type" Nothing Nothing) element + target <- findAttr (QName "Target" Nothing Nothing) element + return $ Relationship num type' target + | otherwise = Nothing + +slideToPresRel :: PandocMonad m => Slide -> P m Relationship +slideToPresRel slide = do + idNum <- slideNum slide + n <- asks envSlideIdOffset + let rId = idNum + n + 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 + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels" + let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships" + let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem + return $ mapMaybe elementToRel relElems + +presentationToRels :: PandocMonad m => Presentation -> P m [Relationship] +presentationToRels (Presentation _ slides) = do + mySlideRels <- mapM slideToPresRel slides + rels <- getRels + let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") 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) + + let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of + [] -> 0 -- doesn't matter in this case, since + -- there will be nothing to map the + -- function over + l -> minimum l + + modifyRelNum :: Int -> Int + modifyRelNum 1 = 1 + modifyRelNum n = n - minRelNotOne + 2 + length slides + + relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides + + return $ mySlideRels ++ relsWithoutSlides' + +-- We make this ourselves, in case there's a thumbnail in the one from +-- the template. +topLevelRels :: [Relationship] +topLevelRels = + [ Relationship { relId = 1 + , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" + , relTarget = "ppt/presentation.xml" + } + , Relationship { relId = 2 + , relType = "http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" + , relTarget = "docProps/core.xml" + } + , Relationship { relId = 3 + , relType = "http://schemas.openxmlformats.org/package/2006/relationships/metadata/extended-properties" + , relTarget = "docProps/app.xml" + } + ] + +topLevelRelsEntry :: PandocMonad m => P m Entry +topLevelRelsEntry = elemToEntry "_rels/.rels" $ relsToElement topLevelRels + +relToElement :: Relationship -> Element +relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel)) + , ("Type", relType rel) + , ("Target", relTarget rel) ] () + +relsToElement :: [Relationship] -> Element +relsToElement rels = mknode "Relationships" + [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] + (map relToElement rels) + +presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry +presentationToRelsEntry pres = do + rels <- presentationToRels pres + elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels + +elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry +elemToEntry fp element = do + epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime + return $ toEntry fp epochtime $ renderXml element + +slideToEntry :: PandocMonad m => Slide -> P m Entry +slideToEntry slide = do + idNum <- slideNum slide + local (\env -> env{envCurSlideId = idNum}) $ do + element <- slideToElement slide + elemToEntry ("ppt/slides/" ++ idNumToFilePath idNum) element + +slideToSlideRelEntry :: PandocMonad m => Slide -> P m Entry +slideToSlideRelEntry slide = do + idNum <- slideNum slide + element <- slideToSlideRelElement slide + elemToEntry ("ppt/slides/_rels/" ++ idNumToFilePath idNum ++ ".rels") element + +linkRelElement :: PandocMonad m => Int -> LinkTarget -> P m Element +linkRelElement rIdNum (InternalTarget targetId) = do + targetIdNum <- getSlideIdNum targetId + return $ + mknode "Relationship" [ ("Id", "rId" ++ show rIdNum) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") + , ("Target", "slide" ++ show targetIdNum ++ ".xml") + ] () +linkRelElement rIdNum (ExternalTarget (url, _)) = do + return $ + mknode "Relationship" [ ("Id", "rId" ++ show rIdNum) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") + , ("Target", url) + , ("TargetMode", "External") + ] () + +linkRelElements :: PandocMonad m => M.Map Int LinkTarget -> P m [Element] +linkRelElements mp = mapM (\(n, lnk) -> linkRelElement n lnk) (M.toList mp) + +mediaRelElement :: MediaInfo -> Element +mediaRelElement mInfo = + let ext = case mInfoExt mInfo of + Just e -> e + Nothing -> "" + in + mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo)) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image") + , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext) + ] () + +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" + + linkIds <- gets stLinkIds + mediaIds <- gets stMediaIds + + linkRels <- case M.lookup idNum linkIds of + Just mp -> linkRelElements mp + Nothing -> return [] + let mediaRels = case M.lookup idNum mediaIds of + Just mInfos -> map mediaRelElement mInfos + Nothing -> [] + + return $ + mknode "Relationships" + [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] + ([mknode "Relationship" [ ("Id", "rId1") + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout") + , ("Target", target)] () + ] ++ linkRels ++ mediaRels) + +slideToSldIdElement :: PandocMonad m => Slide -> P m Element +slideToSldIdElement slide = do + n <- slideNum slide + let id' = show $ n + 255 + rId <- slideToRelId 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 + return $ mknode "p:sldIdLst" [] ids + +presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element +presentationToPresentationElement pres = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + element <- parseXml refArchive distArchive "ppt/presentation.xml" + sldIdLst <- presentationToSldIdLst pres + + let modifySldIdLst :: Content -> Content + modifySldIdLst (Elem e) = case elName e of + (QName "sldIdLst" _ _) -> Elem sldIdLst + _ -> Elem e + modifySldIdLst ct = ct + + newContent = map modifySldIdLst $ elContent element + + return $ element{elContent = newContent} + +presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry +presentationToPresEntry pres = presentationToPresentationElement pres >>= + elemToEntry "ppt/presentation.xml" + +-- adapted from the Docx writer +docPropsElement :: PandocMonad m => DocProps -> P m Element +docPropsElement docProps = do + utctime <- asks envUTCTime + let keywords = case dcKeywords docProps of + Just xs -> intercalate "," xs + Nothing -> "" + return $ + mknode "cp:coreProperties" + [("xmlns:cp","http://schemas.openxmlformats.org/package/2006/metadata/core-properties") + ,("xmlns:dc","http://purl.org/dc/elements/1.1/") + ,("xmlns:dcterms","http://purl.org/dc/terms/") + ,("xmlns:dcmitype","http://purl.org/dc/dcmitype/") + ,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")] + $ (mknode "dc:title" [] $ fromMaybe "" $ dcTitle docProps) + : (mknode "dc:creator" [] $ fromMaybe "" $ dcCreator docProps) + : (mknode "cp:keywords" [] keywords) + : (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x + , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x + ]) (formatTime defaultTimeLocale "%FT%XZ" utctime) + +docPropsToEntry :: PandocMonad m => DocProps -> P m Entry +docPropsToEntry docProps = docPropsElement docProps >>= + elemToEntry "docProps/core.xml" + + +defaultContentTypeToElem :: DefaultContentType -> Element +defaultContentTypeToElem dct = + mknode "Default" + [("Extension", defContentTypesExt dct), + ("ContentType", defContentTypesType dct)] + () + +overrideContentTypeToElem :: OverrideContentType -> Element +overrideContentTypeToElem oct = + mknode "Override" + [("PartName", overrideContentTypesPart oct), + ("ContentType", overrideContentTypesType oct)] + () + +contentTypesToElement :: ContentTypes -> Element +contentTypesToElement ct = + let ns = "http://schemas.openxmlformats.org/package/2006/content-types" + in + mknode "Types" [("xmlns", ns)] $ + (map defaultContentTypeToElem $ contentTypesDefaults ct) ++ + (map overrideContentTypeToElem $ contentTypesOverrides ct) + +data DefaultContentType = DefaultContentType + { defContentTypesExt :: String + , defContentTypesType:: MimeType + } + deriving (Show, Eq) + +data OverrideContentType = OverrideContentType + { overrideContentTypesPart :: FilePath + , overrideContentTypesType :: MimeType + } + deriving (Show, Eq) + +data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType] + , contentTypesOverrides :: [OverrideContentType] + } + deriving (Show, Eq) + +contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry +contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct + +pathToOverride :: FilePath -> Maybe OverrideContentType +pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp) + +mediaFileContentType :: FilePath -> Maybe DefaultContentType +mediaFileContentType fp = case takeExtension fp of + '.' : ext -> Just $ + DefaultContentType { defContentTypesExt = ext + , defContentTypesType = + case getMimeType fp of + Just mt -> mt + Nothing -> "application/octet-stream" + } + _ -> Nothing + +mediaContentType :: MediaInfo -> Maybe DefaultContentType +mediaContentType mInfo + | Just ('.' : ext) <- mInfoExt mInfo = + Just $ DefaultContentType { defContentTypesExt = ext + , defContentTypesType = + case mInfoMimeType mInfo of + Just mt -> mt + Nothing -> "application/octet-stream" + } + | otherwise = Nothing + +presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes +presentationToContentTypes (Presentation _ slides) = do + mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds + filePaths <- patternsToFilePaths inheritedPatterns + let mediaFps = filter (match (compile "ppt/media/image*")) filePaths + let defaults = [ DefaultContentType "xml" "application/xml" + , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml" + ] + mediaDefaults = nub $ + (mapMaybe mediaContentType $ mediaInfos) ++ + (mapMaybe mediaFileContentType $ mediaFps) + + inheritedOverrides = mapMaybe pathToOverride filePaths + docPropsOverride = mapMaybe pathToOverride ["docProps/core.xml"] + presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"] + relativePaths <- mapM slideToFilePath slides + let slideOverrides = mapMaybe + (\fp -> pathToOverride $ "ppt/slides/" ++ fp) + relativePaths + return $ ContentTypes + (defaults ++ mediaDefaults) + (inheritedOverrides ++ docPropsOverride ++ presOverride ++ slideOverrides) + +presML :: String +presML = "application/vnd.openxmlformats-officedocument.presentationml" + +noPresML :: String +noPresML = "application/vnd.openxmlformats-officedocument" + +getContentType :: FilePath -> Maybe MimeType +getContentType fp + | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml" + | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml" + | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml" + | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml" + | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml" + | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml" + | "ppt" : "slideMasters" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".slideMaster+xml" + | "ppt" : "slides" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".slide+xml" + | "ppt" : "notesMasters" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".notesMaster+xml" + | "ppt" : "notesSlides" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".notesSlide+xml" + | "ppt" : "theme" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ noPresML ++ ".theme+xml" + | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp= + Just $ presML ++ ".slideLayout+xml" + | otherwise = Nothing + +autoNumberingToType :: ListAttributes -> String +autoNumberingToType (_, numStyle, numDelim) = + typeString ++ delimString + where + typeString = case numStyle of + Decimal -> "arabic" + UpperAlpha -> "alphaUc" + LowerAlpha -> "alphaLc" + UpperRoman -> "romanUc" + LowerRoman -> "romanLc" + _ -> "arabic" + delimString = case numDelim of + Period -> "Period" + OneParen -> "ParenR" + TwoParens -> "ParenBoth" + _ -> "Period" diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -0,0 +1,880 @@ +{-# LANGUAGE PatternGuards #-} + +{- +Copyright (C) 2017-2018 Jesse Rosenthal + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Writers.Powerpoint.Presentation + Copyright : Copyright (C) 2017-2018 Jesse Rosenthal + License : GNU GPL, version 2 or above + + Maintainer : Jesse Rosenthal + Stability : alpha + Portability : portable + +Definition of Presentation datatype, modeling a MS Powerpoint (pptx) +document, and functions for converting a Pandoc document to +Presentation. +-} + +module Text.Pandoc.Writers.Powerpoint.Presentation ( documentToPresentation + , Presentation(..) + , DocProps(..) + , Slide(..) + , Layout(..) + , Notes(..) + , SlideId(..) + , Shape(..) + , Graphic(..) + , BulletType(..) + , Algnment(..) + , Paragraph(..) + , ParaElem(..) + , ParaProps(..) + , RunProps(..) + , TableProps(..) + , Strikethrough(..) + , Capitals(..) + , PicProps(..) + , URL + , TeXString(..) + , LinkTarget(..) + ) where + + +import Control.Monad.Reader +import Control.Monad.State +import Data.List (intercalate) +import Data.Default +import Text.Pandoc.Definition +import Text.Pandoc.ImageSize +import Text.Pandoc.Slides (getSlideLevel) +import Text.Pandoc.Options +import Text.Pandoc.Logging +import Text.Pandoc.Walk +import Text.Pandoc.Compat.Time (UTCTime) +import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element" +import Text.Pandoc.Writers.Shared (metaValueToInlines) +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Maybe (maybeToList) + +data WriterEnv = WriterEnv { envMetadata :: Meta + , envRunProps :: RunProps + , envParaProps :: ParaProps + , envSlideLevel :: Int + , envOpts :: WriterOptions + , envSlideHasHeader :: Bool + , envInList :: Bool + , envInNoteSlide :: Bool + , envCurSlideId :: SlideId + } + deriving (Show) + +instance Default WriterEnv where + def = WriterEnv { envMetadata = mempty + , envRunProps = def + , envParaProps = def + , envSlideLevel = 2 + , envOpts = def + , envSlideHasHeader = False + , envInList = False + , envInNoteSlide = False + , envCurSlideId = SlideId "Default" + } + + +data WriterState = WriterState { stNoteIds :: M.Map Int [Block] + -- associate anchors with slide id + , stAnchorMap :: M.Map String SlideId + , stSlideIdSet :: S.Set SlideId + , stLog :: [LogMessage] + + } deriving (Show, Eq) + +instance Default WriterState where + def = WriterState { stNoteIds = mempty + , stAnchorMap = mempty + -- we reserve this s + , stSlideIdSet = reservedSlideIds + , stLog = [] + } + +metadataSlideId :: SlideId +metadataSlideId = SlideId "Metadata" + +tocSlideId :: SlideId +tocSlideId = SlideId "TOC" + +endNotesSlideId :: SlideId +endNotesSlideId = SlideId "EndNotes" + +reservedSlideIds :: S.Set SlideId +reservedSlideIds = S.fromList [ metadataSlideId + , tocSlideId + , endNotesSlideId + ] + +uniqueSlideId' :: Integer -> S.Set SlideId -> String -> SlideId +uniqueSlideId' n idSet s = + let s' = if n == 0 then s else (s ++ "-" ++ show n) + in if SlideId s' `S.member` idSet + then uniqueSlideId' (n+1) idSet s + else SlideId s' + +uniqueSlideId :: S.Set SlideId -> String -> SlideId +uniqueSlideId = uniqueSlideId' 0 + +runUniqueSlideId :: String -> Pres SlideId +runUniqueSlideId s = do + idSet <- gets stSlideIdSet + let sldId = uniqueSlideId idSet s + modify $ \st -> st{stSlideIdSet = S.insert sldId idSet} + return sldId + +addLogMessage :: LogMessage -> Pres () +addLogMessage msg = modify $ \st -> st{stLog = msg : (stLog st)} + +type Pres = ReaderT WriterEnv (State WriterState) + +runPres :: WriterEnv -> WriterState -> Pres a -> (a, [LogMessage]) +runPres env st p = (pres, reverse $ stLog finalSt) + where (pres, finalSt) = runState (runReaderT p env) st + +-- GHC 7.8 will still complain about concat <$> mapM unless we specify +-- Functor. We can get rid of this when we stop supporting GHC 7.8. +concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat (mapM f xs) + +type Pixels = Integer + +data Presentation = Presentation DocProps [Slide] + deriving (Show) + +data DocProps = DocProps { dcTitle :: Maybe String + , dcSubject :: Maybe String + , dcCreator :: Maybe String + , dcKeywords :: Maybe [String] + , dcCreated :: Maybe UTCTime + } deriving (Show, Eq) + + +data Slide = Slide { slideId :: SlideId + , slideLayout :: Layout + , slideNotes :: (Maybe Notes) + } deriving (Show, Eq) + +newtype SlideId = SlideId String + deriving (Show, Eq, Ord) + +-- In theory you could have anything on a notes slide but it seems +-- designed mainly for one textbox, so we'll just put in the contents +-- of that textbox, to avoid other shapes that won't work as well. +newtype Notes = Notes [Paragraph] + deriving (Show, Eq) + +data Layout = MetadataSlide { metadataSlideTitle :: [ParaElem] + , metadataSlideSubtitle :: [ParaElem] + , metadataSlideAuthors :: [[ParaElem]] + , metadataSlideDate :: [ParaElem] + } + | TitleSlide { titleSlideHeader :: [ParaElem]} + | ContentSlide { contentSlideHeader :: [ParaElem] + , contentSlideContent :: [Shape] + } + | TwoColumnSlide { twoColumnSlideHeader :: [ParaElem] + , twoColumnSlideLeft :: [Shape] + , twoColumnSlideRight :: [Shape] + } + deriving (Show, Eq) + +data Shape = Pic PicProps FilePath [ParaElem] + | GraphicFrame [Graphic] [ParaElem] + | TextBox [Paragraph] + deriving (Show, Eq) + +type Cell = [Paragraph] + +data TableProps = TableProps { tblPrFirstRow :: Bool + , tblPrBandRow :: Bool + } deriving (Show, Eq) + +data Graphic = Tbl TableProps [Cell] [[Cell]] + deriving (Show, Eq) + + +data Paragraph = Paragraph { paraProps :: ParaProps + , paraElems :: [ParaElem] + } deriving (Show, Eq) + + +data BulletType = Bullet + | AutoNumbering ListAttributes + deriving (Show, Eq) + +data Algnment = AlgnLeft | AlgnRight | AlgnCenter + deriving (Show, Eq) + +data ParaProps = ParaProps { pPropMarginLeft :: Maybe Pixels + , pPropMarginRight :: Maybe Pixels + , pPropLevel :: Int + , pPropBullet :: Maybe BulletType + , pPropAlign :: Maybe Algnment + , pPropSpaceBefore :: Maybe Pixels + } deriving (Show, Eq) + +instance Default ParaProps where + def = ParaProps { pPropMarginLeft = Just 0 + , pPropMarginRight = Just 0 + , pPropLevel = 0 + , pPropBullet = Nothing + , pPropAlign = Nothing + , pPropSpaceBefore = Nothing + } + +newtype TeXString = TeXString {unTeXString :: String} + deriving (Eq, Show) + +data ParaElem = Break + | Run RunProps String + -- It would be more elegant to have native TeXMath + -- Expressions here, but this allows us to use + -- `convertmath` from T.P.Writers.Math. Will perhaps + -- revisit in the future. + | MathElem MathType TeXString + deriving (Show, Eq) + +data Strikethrough = NoStrike | SingleStrike | DoubleStrike + deriving (Show, Eq) + +data Capitals = NoCapitals | SmallCapitals | AllCapitals + deriving (Show, Eq) + +type URL = String + +data LinkTarget = ExternalTarget (URL, String) + | InternalTarget SlideId + deriving (Show, Eq) + +data RunProps = RunProps { rPropBold :: Bool + , rPropItalics :: Bool + , rStrikethrough :: Maybe Strikethrough + , rBaseline :: Maybe Int + , rCap :: Maybe Capitals + , rLink :: Maybe LinkTarget + , rPropCode :: Bool + , rPropBlockQuote :: Bool + , rPropForceSize :: Maybe Pixels + } deriving (Show, Eq) + +instance Default RunProps where + def = RunProps { rPropBold = False + , rPropItalics = False + , rStrikethrough = Nothing + , rBaseline = Nothing + , rCap = Nothing + , rLink = Nothing + , rPropCode = False + , rPropBlockQuote = False + , rPropForceSize = Nothing + } + +data PicProps = PicProps { picPropLink :: Maybe LinkTarget + , picWidth :: Maybe Dimension + , picHeight :: Maybe Dimension + } deriving (Show, Eq) + +instance Default PicProps where + def = PicProps { picPropLink = Nothing + , picWidth = Nothing + , picHeight = Nothing + } + +-------------------------------------------------- + +inlinesToParElems :: [Inline] -> Pres [ParaElem] +inlinesToParElems ils = concatMapM inlineToParElems ils + +inlineToParElems :: Inline -> Pres [ParaElem] +inlineToParElems (Str s) = do + pr <- asks envRunProps + return [Run pr s] +inlineToParElems (Emph ils) = + local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $ + inlinesToParElems ils +inlineToParElems (Strong ils) = + local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $ + inlinesToParElems ils +inlineToParElems (Strikeout ils) = + local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $ + inlinesToParElems ils +inlineToParElems (Superscript ils) = + local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $ + inlinesToParElems ils +inlineToParElems (Subscript ils) = + local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $ + inlinesToParElems ils +inlineToParElems (SmallCaps ils) = + local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $ + inlinesToParElems ils +inlineToParElems Space = inlineToParElems (Str " ") +inlineToParElems SoftBreak = inlineToParElems (Str " ") +inlineToParElems LineBreak = return [Break] +inlineToParElems (Link _ ils (url, title)) = do + local (\r ->r{envRunProps = (envRunProps r){rLink = Just $ ExternalTarget (url, title)}}) $ + inlinesToParElems ils +inlineToParElems (Code _ str) = do + local (\r ->r{envRunProps = (envRunProps r){rPropCode = True}}) $ + inlineToParElems $ Str str +inlineToParElems (Math mathtype str) = + return [MathElem mathtype (TeXString str)] +inlineToParElems (Note blks) = do + notes <- gets stNoteIds + let maxNoteId = case M.keys notes of + [] -> 0 + lst -> maximum lst + curNoteId = maxNoteId + 1 + modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes } + local (\env -> env{envRunProps = (envRunProps env){rLink = Just $ InternalTarget endNotesSlideId}}) $ + inlineToParElems $ Superscript [Str $ show curNoteId] +inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils +inlineToParElems (RawInline _ _) = return [] +inlineToParElems _ = return [] + +isListType :: Block -> Bool +isListType (OrderedList _ _) = True +isListType (BulletList _) = True +isListType (DefinitionList _) = True +isListType _ = False + +registerAnchorId :: String -> Pres () +registerAnchorId anchor = do + anchorMap <- gets stAnchorMap + sldId <- asks envCurSlideId + unless (null anchor) $ + modify $ \st -> st {stAnchorMap = M.insert anchor sldId anchorMap} + +-- Currently hardcoded, until I figure out how to make it dynamic. +blockQuoteSize :: Pixels +blockQuoteSize = 20 + +noteSize :: Pixels +noteSize = 18 + +blockToParagraphs :: Block -> Pres [Paragraph] +blockToParagraphs (Plain ils) = do + parElems <- inlinesToParElems ils + pProps <- asks envParaProps + return [Paragraph pProps parElems] +blockToParagraphs (Para ils) = do + parElems <- inlinesToParElems ils + pProps <- asks envParaProps + return [Paragraph pProps parElems] +blockToParagraphs (LineBlock ilsList) = do + parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList + pProps <- asks envParaProps + return [Paragraph pProps parElems] +-- TODO: work out the attributes +blockToParagraphs (CodeBlock attr str) = + local (\r -> r{envParaProps = def{pPropMarginLeft = Just 100}}) $ + blockToParagraphs $ Para [Code attr str] +-- We can't yet do incremental lists, but we should render a +-- (BlockQuote List) as a list to maintain compatibility with other +-- formats. +blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do + ps <- blockToParagraphs blk + ps' <- blockToParagraphs $ BlockQuote blks + return $ ps ++ ps' +blockToParagraphs (BlockQuote blks) = + local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100} + , envRunProps = (envRunProps r){rPropForceSize = Just blockQuoteSize}})$ + concatMapM blockToParagraphs blks +-- TODO: work out the format +blockToParagraphs (RawBlock _ _) = return [] +blockToParagraphs (Header _ (ident, _, _) ils) = do + -- Note that this function only deals with content blocks, so it + -- will only touch headers that are above the current slide level -- + -- slides at or below the slidelevel will be taken care of by + -- `blocksToSlide'`. We have the register anchors in both of them. + registerAnchorId ident + -- we set the subeader to bold + parElems <- local (\e->e{envRunProps = (envRunProps e){rPropBold=True}}) $ + inlinesToParElems ils + -- and give it a bit of space before it. + return [Paragraph def{pPropSpaceBefore = Just 30} parElems] +blockToParagraphs (BulletList blksLst) = do + pProps <- asks envParaProps + let lvl = pPropLevel pProps + local (\env -> env{ envInList = True + , envParaProps = pProps{ pPropLevel = lvl + 1 + , pPropBullet = Just Bullet + , pPropMarginLeft = Nothing + }}) $ + concatMapM multiParBullet blksLst +blockToParagraphs (OrderedList listAttr blksLst) = do + pProps <- asks envParaProps + let lvl = pPropLevel pProps + local (\env -> env{ envInList = True + , envParaProps = pProps{ pPropLevel = lvl + 1 + , pPropBullet = Just (AutoNumbering listAttr) + , pPropMarginLeft = Nothing + }}) $ + concatMapM multiParBullet blksLst +blockToParagraphs (DefinitionList entries) = do + let go :: ([Inline], [[Block]]) -> Pres [Paragraph] + go (ils, blksLst) = do + term <-blockToParagraphs $ Para [Strong ils] + -- For now, we'll treat each definition term as a + -- blockquote. We can extend this further later. + definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst + return $ term ++ definition + concatMapM go entries +blockToParagraphs (Div (_, ("notes" : []), _) _) = return [] +blockToParagraphs (Div _ blks) = 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 + pProps <- asks envParaProps + p <- blockToParagraphs b + ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $ + concatMapM blockToParagraphs bs + return $ p ++ ps + +cellToParagraphs :: Alignment -> TableCell -> Pres [Paragraph] +cellToParagraphs algn tblCell = do + paras <- mapM (blockToParagraphs) tblCell + let alignment = case algn of + AlignLeft -> Just AlgnLeft + AlignRight -> Just AlgnRight + AlignCenter -> Just AlgnCenter + AlignDefault -> Nothing + paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras + return $ concat paras' + +rowToParagraphs :: [Alignment] -> [TableCell] -> Pres [[Paragraph]] +rowToParagraphs algns tblCells = do + -- We have to make sure we have the right number of alignments + let pairs = zip (algns ++ repeat AlignDefault) tblCells + mapM (\(a, tc) -> cellToParagraphs a tc) pairs + +withAttr :: Attr -> Shape -> Shape +withAttr attr (Pic picPr url caption) = + let picPr' = picPr { picWidth = dimension Width attr + , picHeight = dimension Height attr + } + in + Pic picPr' url caption +withAttr _ sp = sp + +blockToShape :: Block -> Pres Shape +blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il = + (withAttr attr . Pic def url) <$> (inlinesToParElems ils) +blockToShape (Para (il:_)) | Image attr ils (url, _) <- il = + (withAttr attr . Pic def url) <$> (inlinesToParElems ils) +blockToShape (Plain (il:_)) | Link _ (il':_) target <- il + , Image attr ils (url, _) <- il' = + (withAttr attr . Pic def {picPropLink = Just $ ExternalTarget target} url) <$> + (inlinesToParElems ils) +blockToShape (Para (il:_)) | Link _ (il':_) target <- il + , Image attr ils (url, _) <- il' = + (withAttr attr . Pic def{picPropLink = Just $ ExternalTarget target} url) <$> + (inlinesToParElems ils) +blockToShape (Table caption algn _ hdrCells rows) = do + caption' <- inlinesToParElems caption + hdrCells' <- rowToParagraphs algn hdrCells + rows' <- mapM (rowToParagraphs algn) rows + let tblPr = if null hdrCells + then TableProps { tblPrFirstRow = False + , tblPrBandRow = True + } + else TableProps { tblPrFirstRow = True + , tblPrBandRow = True + } + + return $ GraphicFrame [Tbl tblPr hdrCells' rows'] caption' +blockToShape blk = do paras <- blockToParagraphs blk + let paras' = map (\par -> par{paraElems = combineParaElems $ paraElems par}) paras + return $ TextBox paras' + +combineShapes :: [Shape] -> [Shape] +combineShapes [] = [] +combineShapes (s : []) = [s] +combineShapes (pic@(Pic _ _ _) : ss) = pic : combineShapes ss +combineShapes ((TextBox []) : ss) = combineShapes ss +combineShapes (s : TextBox [] : ss) = combineShapes (s : ss) +combineShapes ((TextBox (p:ps)) : (TextBox (p':ps')) : ss) = + combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss +combineShapes (s:ss) = s : combineShapes ss + +blocksToShapes :: [Block] -> Pres [Shape] +blocksToShapes blks = combineShapes <$> mapM blockToShape blks + +isImage :: Inline -> Bool +isImage (Image _ _ _) = True +isImage (Link _ ((Image _ _ _) : _) _) = True +isImage _ = False + +splitBlocks' :: [Block] -> [[Block]] -> [Block] -> Pres [[Block]] +splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur]) +splitBlocks' cur acc (HorizontalRule : blks) = + splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks +splitBlocks' cur acc (h@(Header n _ _) : blks) = do + slideLevel <- asks envSlideLevel + case compare n slideLevel of + LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[h]]) blks + EQ -> splitBlocks' [h] (acc ++ (if null cur then [] else [cur])) blks + GT -> splitBlocks' (cur ++ [h]) acc blks +-- `blockToParagraphs` treats Plain and Para the same, so we can save +-- some code duplication by treating them the same here. +splitBlocks' cur acc ((Plain ils) : blks) = splitBlocks' cur acc ((Para ils) : blks) +splitBlocks' cur acc ((Para (il:ils)) : blks) | isImage il = do + slideLevel <- asks envSlideLevel + case cur of + (Header n _ _) : [] | n == slideLevel -> + splitBlocks' [] + (acc ++ [cur ++ [Para [il]]]) + (if null ils then blks else (Para ils) : blks) + _ -> splitBlocks' [] + (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]]]) + (if null ils then blks else (Para ils) : blks) +splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do + slideLevel <- asks envSlideLevel + case cur of + (Header n _ _) : [] | n == slideLevel -> + splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks + _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks +splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes = do + slideLevel <- asks envSlideLevel + case cur of + (Header n _ _) : [] | n == slideLevel -> + splitBlocks' [] (acc ++ [cur ++ [d]]) blks + _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) blks +splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks + +splitBlocks :: [Block] -> Pres [[Block]] +splitBlocks = splitBlocks' [] [] + +blocksToSlide' :: Int -> [Block] -> Pres Slide +blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks) + | n < lvl = do + registerAnchorId ident + sldId <- asks envCurSlideId + hdr <- inlinesToParElems ils + return $ Slide sldId (TitleSlide {titleSlideHeader = hdr}) Nothing + | n == lvl = do + registerAnchorId ident + hdr <- inlinesToParElems ils + -- Now get the slide without the header, and then add the header + -- in. + slide <- blocksToSlide' lvl blks + let layout = case slideLayout slide of + ContentSlide _ cont -> ContentSlide hdr cont + TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR + layout' -> layout' + return $ slide{slideLayout = layout} +blocksToSlide' _ (blk : blks) + | Div (_, classes, _) divBlks <- blk + , "columns" `elem` classes + , (Div (_, clsL, _) blksL) : (Div (_, clsR, _) blksR) : remaining <- divBlks + , "column" `elem` clsL, "column" `elem` clsR = do + unless (null blks) + (mapM (addLogMessage . BlockNotRendered) blks >> return ()) + unless (null remaining) + (mapM (addLogMessage . BlockNotRendered) remaining >> return ()) + 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 { twoColumnSlideHeader = [] + , twoColumnSlideLeft = shapesL + , twoColumnSlideRight = shapesR + } + Nothing +blocksToSlide' _ (blk : blks) = do + inNoteSlide <- asks envInNoteSlide + shapes <- if inNoteSlide + then forceFontSize noteSize $ blocksToShapes (blk : blks) + else blocksToShapes (blk : blks) + sldId <- asks envCurSlideId + return $ + Slide + sldId + ContentSlide { contentSlideHeader = [] + , contentSlideContent = shapes + } + Nothing +blocksToSlide' _ [] = do + sldId <- asks envCurSlideId + return $ + Slide + sldId + ContentSlide { contentSlideHeader = [] + , contentSlideContent = [] + } + Nothing + +blocksToSlide :: [Block] -> Pres Slide +blocksToSlide blks = do + slideLevel <- asks envSlideLevel + blocksToSlide' slideLevel blks + +makeNoteEntry :: Int -> [Block] -> [Block] +makeNoteEntry n blks = + let enum = Str (show n ++ ".") + in + case blks of + (Para ils : blks') -> (Para $ enum : Space : ils) : blks' + _ -> (Para [enum]) : blks + +forceFontSize :: Pixels -> Pres a -> Pres a +forceFontSize px x = do + rpr <- asks envRunProps + local (\r -> r {envRunProps = rpr{rPropForceSize = Just px}}) x + +-- We leave these as blocks because we will want to include them in +-- the TOC. +makeEndNotesSlideBlocks :: Pres [Block] +makeEndNotesSlideBlocks = do + noteIds <- gets stNoteIds + slideLevel <- asks envSlideLevel + meta <- asks envMetadata + -- Get identifiers so we can give the notes section a unique ident. + anchorSet <- M.keysSet <$> gets stAnchorMap + if M.null noteIds + then return [] + else do let title = case lookupMeta "notes-title" meta of + Just val -> metaValueToInlines val + Nothing -> [Str "Notes"] + ident = Shared.uniqueIdent title anchorSet + hdr = Header slideLevel (ident, [], []) title + blks <- return $ + concatMap (\(n, bs) -> makeNoteEntry n bs) $ + M.toList noteIds + return $ hdr : blks + +getMetaSlide :: Pres (Maybe Slide) +getMetaSlide = do + meta <- asks envMetadata + title <- inlinesToParElems $ docTitle meta + subtitle <- inlinesToParElems $ + case lookupMeta "subtitle" meta of + Just (MetaString s) -> [Str s] + Just (MetaInlines ils) -> ils + Just (MetaBlocks [Plain ils]) -> ils + Just (MetaBlocks [Para ils]) -> ils + _ -> [] + authors <- mapM inlinesToParElems $ docAuthors meta + date <- inlinesToParElems $ docDate meta + if null title && null subtitle && null authors && null date + then return Nothing + else return $ + Just $ + Slide + metadataSlideId + MetadataSlide { metadataSlideTitle = title + , metadataSlideSubtitle = subtitle + , metadataSlideAuthors = authors + , metadataSlideDate = date + } + Nothing + +-- adapted from the markdown writer +elementToListItem :: Shared.Element -> Pres [Block] +elementToListItem (Shared.Sec lev _nums (ident,_,_) headerText subsecs) = do + opts <- asks envOpts + let headerLink = if null ident + then walk Shared.deNote headerText + else [Link nullAttr (walk Shared.deNote headerText) + ('#':ident, "")] + listContents <- if null subsecs || lev >= writerTOCDepth opts + then return [] + else mapM elementToListItem subsecs + return [Plain headerLink, BulletList listContents] +elementToListItem (Shared.Blk _) = return [] + +makeTOCSlide :: [Block] -> Pres Slide +makeTOCSlide blks = local (\env -> env{envCurSlideId = tocSlideId}) $ do + contents <- BulletList <$> mapM elementToListItem (Shared.hierarchicalize blks) + meta <- asks envMetadata + slideLevel <- asks envSlideLevel + let tocTitle = case lookupMeta "toc-title" meta of + Just val -> metaValueToInlines val + Nothing -> [Str "Table of Contents"] + hdr = Header slideLevel nullAttr tocTitle + sld <- blocksToSlide [hdr, contents] + return sld + +combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem] +combineParaElems' mbPElem [] = maybeToList mbPElem +combineParaElems' Nothing (pElem : pElems) = + combineParaElems' (Just pElem) pElems +combineParaElems' (Just pElem') (pElem : pElems) + | Run rPr' s' <- pElem' + , Run rPr s <- pElem + , rPr == rPr' = + combineParaElems' (Just $ Run rPr' $ s' ++ s) pElems + | otherwise = + pElem' : combineParaElems' (Just pElem) pElems + +combineParaElems :: [ParaElem] -> [ParaElem] +combineParaElems = combineParaElems' Nothing + +applyToParagraph :: Monad m => (ParaElem -> m ParaElem) -> Paragraph -> m Paragraph +applyToParagraph f para = do + paraElems' <- mapM f $ paraElems para + return $ para {paraElems = paraElems'} + +applyToShape :: Monad m => (ParaElem -> m ParaElem) -> Shape -> m Shape +applyToShape f (Pic pPr fp pes) = do + pes' <- mapM f pes + return $ Pic pPr fp pes' +applyToShape f (GraphicFrame gfx pes) = do + pes' <- mapM f pes + return $ GraphicFrame gfx pes' +applyToShape f (TextBox paras) = do + paras' <- mapM (applyToParagraph f) paras + return $ TextBox paras' + +applyToLayout :: Monad m => (ParaElem -> m ParaElem) -> Layout -> m Layout +applyToLayout f (MetadataSlide title subtitle authors date) = do + title' <- mapM f title + subtitle' <- mapM f subtitle + authors' <- mapM (mapM f) authors + date' <- mapM f date + return $ MetadataSlide title' subtitle' authors' date' +applyToLayout f (TitleSlide title) = do + title' <- mapM f title + return $ TitleSlide title' +applyToLayout f (ContentSlide hdr content) = do + hdr' <- mapM f hdr + content' <- mapM (applyToShape f) content + return $ ContentSlide hdr' content' +applyToLayout f (TwoColumnSlide hdr contentL contentR) = do + hdr' <- mapM f hdr + contentL' <- mapM (applyToShape f) contentL + contentR' <- mapM (applyToShape f) contentR + return $ TwoColumnSlide hdr' contentL' contentR' + +applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide +applyToSlide f slide = do + layout' <- applyToLayout f $ slideLayout slide + mbNotes' <- case slideNotes slide of + Just (Notes notes) -> (Just . Notes) <$> + mapM (applyToParagraph f) notes + Nothing -> return Nothing + return slide{slideLayout = layout', slideNotes = mbNotes'} + +replaceAnchor :: ParaElem -> Pres ParaElem +replaceAnchor (Run rProps s) + | Just (ExternalTarget ('#':anchor, _)) <- rLink rProps = do + anchorMap <- gets stAnchorMap + -- If the anchor is not in the anchormap, we just remove the + -- link. + let rProps' = case M.lookup anchor anchorMap of + Just n -> rProps{rLink = Just $ InternalTarget n} + Nothing -> rProps{rLink = Nothing} + return $ Run rProps' s +replaceAnchor pe = return pe + +blocksToPresentationSlides :: [Block] -> Pres [Slide] +blocksToPresentationSlides blks = do + opts <- asks envOpts + metadataslides <- maybeToList <$> getMetaSlide + -- As far as I can tell, if we want to have a variable-length toc in + -- the future, we'll have to make it twice. Once to get the length, + -- and a second time to include the notes slide. We can't make the + -- notes slide before the body slides because we need to know if + -- there are notes, and we can't make either before the toc slide, + -- because we need to know its length to get slide numbers right. + -- + -- For now, though, since the TOC slide is only length 1, if it + -- exists, we'll just get the length, and then come back to make the + -- slide later + blksLst <- splitBlocks blks + bodySlideIds <- mapM + (\n -> runUniqueSlideId $ "BodySlide" ++ show n) + (take (length blksLst) [1..] :: [Integer]) + bodyslides <- mapM + (\(bs, ident) -> + local (\st -> st{envCurSlideId = ident}) (blocksToSlide bs)) + (zip blksLst bodySlideIds) + endNotesSlideBlocks <- makeEndNotesSlideBlocks + -- now we come back and make the real toc... + tocSlides <- if writerTableOfContents opts + then do toc <- makeTOCSlide $ blks ++ endNotesSlideBlocks + return [toc] + else return [] + -- ... and the notes slide. We test to see if the blocks are empty, + -- because we don't want to make an empty slide. + endNotesSlides <- if null endNotesSlideBlocks + then return [] + else do endNotesSlide <- local + (\env -> env { envCurSlideId = endNotesSlideId + , envInNoteSlide = True + }) + (blocksToSlide $ endNotesSlideBlocks) + return [endNotesSlide] + + let slides = metadataslides ++ tocSlides ++ bodyslides ++ endNotesSlides + mapM (applyToSlide replaceAnchor) slides + +metaToDocProps :: Meta -> DocProps +metaToDocProps meta = + let keywords = case lookupMeta "keywords" meta of + Just (MetaList xs) -> Just $ map Shared.stringify xs + _ -> Nothing + + authors = case map Shared.stringify $ docAuthors meta of + [] -> Nothing + ss -> Just $ intercalate ";" ss + in + DocProps{ dcTitle = Shared.stringify <$> lookupMeta "title" meta + , dcSubject = Shared.stringify <$> lookupMeta "subject" meta + , dcCreator = authors + , dcKeywords = keywords + , dcCreated = Nothing + } + +documentToPresentation :: WriterOptions + -> Pandoc + -> (Presentation, [LogMessage]) +documentToPresentation opts (Pandoc meta blks) = + let env = def { envOpts = opts + , envMetadata = meta + , envSlideLevel = case writerSlideLevel opts of + Just lvl -> lvl + Nothing -> getSlideLevel blks + } + (presSlides, msgs) = runPres env def $ blocksToPresentationSlides blks + docProps = metaToDocProps meta + in + (Presentation docProps presSlides, msgs) diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs --- a/src/Text/Pandoc/Writers/Shared.hs +++ b/src/Text/Pandoc/Writers/Shared.hs @@ -40,6 +40,7 @@ , fixDisplayMath , unsmartify , gridTable + , metaValueToInlines ) where import Control.Monad (zipWithM) @@ -55,6 +56,7 @@ import Text.Pandoc.Definition import Text.Pandoc.Options import Text.Pandoc.Pretty +import Text.Pandoc.Walk (query) import Text.Pandoc.UTF8 (toStringLazy) import Text.Pandoc.XML (escapeStringForXML) @@ -308,3 +310,10 @@ head'' $$ body $$ border '-' (repeat AlignDefault) widthsInChars + +metaValueToInlines :: MetaValue -> [Inline] +metaValueToInlines (MetaString s) = [Str s] +metaValueToInlines (MetaInlines ils) = ils +metaValueToInlines (MetaBlocks bs) = query return bs +metaValueToInlines (MetaBool b) = [Str $ show b] +metaValueToInlines _ = [] diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -13,7 +13,11 @@ packages: - '.' extra-deps: -- pandoc-citeproc-0.12.2.5 +- pandoc-citeproc-0.13.0.1 - hslua-0.9.5 -- skylighting-0.5.1 -resolver: lts-10.2 +- skylighting-0.6 +- ansi-terminal-0.7.1.1 +- tasty-1.0.0.1 +ghc-options: + "$locals": -fhide-source-paths +resolver: lts-10.3 diff --git a/test/Tests/Lua.hs b/test/Tests/Lua.hs --- a/test/Tests/Lua.hs +++ b/test/Tests/Lua.hs @@ -12,8 +12,10 @@ header, linebreak, para, plain, rawBlock, singleQuoted, space, str, strong, (<>)) import Text.Pandoc.Class (runIOorExplode, setUserDataDir) -import Text.Pandoc.Definition (Block, Inline, Meta, Pandoc, pandocTypesVersion) +import Text.Pandoc.Definition (Block (BlockQuote, Div, Para), Inline (Emph, Str), + Attr, Meta, Pandoc, pandocTypesVersion) import Text.Pandoc.Lua (runLuaFilter, runPandocLua) +import Text.Pandoc.Options (def) import Text.Pandoc.Shared (pandocVersion) import qualified Foreign.Lua as Lua @@ -120,15 +122,46 @@ , testCase "Pandoc types version is set" . runPandocLua' $ do let versionNums = versionBranch pandocTypesVersion Lua.getglobal "PANDOC_API_VERSION" - Lua.liftIO . assertEqual "pandoc version is wrong" versionNums + Lua.liftIO . assertEqual "pandoc-types version is wrong" versionNums =<< Lua.peek Lua.stackTop + + , testCase "Allow singleton inline in constructors" . runPandocLua' $ do + Lua.liftIO . assertEqual "Not the exptected Emph" (Emph [Str "test"]) + =<< Lua.callFunc "pandoc.Emph" (Str "test") + Lua.liftIO . assertEqual "Unexpected element" (Para [Str "test"]) + =<< Lua.callFunc "pandoc.Para" ("test" :: String) + Lua.liftIO . assertEqual "Unexptected element" + (BlockQuote [Para [Str "foo"]]) =<< ( + do + Lua.getglobal' "pandoc.BlockQuote" + Lua.push (Para [Str "foo"]) + _ <- Lua.call 1 1 + Lua.peek Lua.stackTop + ) + + , testCase "Elements with Attr have `attr` accessor" . runPandocLua' $ do + Lua.push (Div ("hi", ["moin"], []) + [Para [Str "ignored"]]) + Lua.getfield Lua.stackTop "attr" + Lua.liftIO . assertEqual "no accessor" (("hi", ["moin"], []) :: Attr) + =<< Lua.peek Lua.stackTop + + , testCase "informative error messages" . runPandocLua' $ do + Lua.pushboolean True + err <- Lua.peekEither Lua.stackTop :: Lua.Lua (Either String Pandoc) + case err of + Left msg -> do + let expectedMsg = "Could not get Pandoc value: " + ++ "expected table but got boolean." + Lua.liftIO $ assertEqual "unexpected error message" expectedMsg msg + Right _ -> error "Getting a Pandoc element from a bool should fail." ] assertFilterConversion :: String -> FilePath -> Pandoc -> Pandoc -> Assertion assertFilterConversion msg filterPath docIn docExpected = do docEither <- runIOorExplode $ do setUserDataDir (Just "../data") - runLuaFilter ("lua" filterPath) [] docIn + runLuaFilter def ("lua" filterPath) [] docIn case docEither of Left _ -> fail "lua filter failed" Right docRes -> assertEqual msg docExpected docRes @@ -145,7 +178,7 @@ error ("not exactly one additional element on the stack: " ++ show size) res <- Lua.peekEither (-1) case res of - Left _ -> error "could not read from stack" + Left e -> error (show e) Right y -> return y runPandocLua' :: Lua.Lua a -> IO a diff --git a/test/Tests/Readers/Docx.hs b/test/Tests/Readers/Docx.hs --- a/test/Tests/Readers/Docx.hs +++ b/test/Tests/Readers/Docx.hs @@ -128,6 +128,10 @@ "docx/links.docx" "docx/links.native" , testCompare + "hyperlinks in tag" + "docx/instrText_hyperlink.docx" + "docx/instrText_hyperlink.native" + , testCompare "inline image" "docx/image.docx" "docx/image_no_embed.native" diff --git a/test/Tests/Readers/Muse.hs b/test/Tests/Readers/Muse.hs --- a/test/Tests/Readers/Muse.hs +++ b/test/Tests/Readers/Muse.hs @@ -114,8 +114,8 @@ , "Linebreak" =: "Line
break" =?> para ("Line" <> linebreak <> "break") - , test emacsMuse "Non-breaking space" - ("Foo~~bar" =?> para "Foo\160bar") + , "Non-breaking space" =: "Foo~~bar" =?> para "Foo\160bar" + , "Single ~" =: "Foo~bar" =?> para "Foo~bar" , testGroup "Code markup" [ "Code" =: "=foo(bar)=" =?> para (code "foo(bar)") @@ -153,6 +153,9 @@ ] =?> para "foo =bar" <> para "baz= foo" + + , "Code at the beginning of paragraph but not first column" =: + " - =foo=" =?> bulletList [ para $ code "foo" ] ] , "Code tag" =: "foo(bar)" =?> para (code "foo(bar)") @@ -161,6 +164,8 @@ , "Verbatim inside code" =: "foo" =?> para (code "foo") + , "Verbatim tag after text" =: "Foo bar" =?> para "Foo bar" + , testGroup "Links" [ "Link without description" =: "[[https://amusewiki.org/]]" =?> @@ -279,20 +284,12 @@ , " One two three" , "" , "" - , "Foo bar" - , "" - , "Foo bar" - , "" - , " Foo" ] =?> lineBlock [ "" , text "Foo bar baz" , text "\160\160One two three" , "" - ] <> - lineBlock [ "Foo bar" ] <> - lineBlock [ "Foo bar" ] <> - lineBlock [ "\160\160\160Foo" ] + ] , testGroup "Example" [ "Braces on separate lines" =: T.unlines [ "{{{" @@ -356,6 +353,11 @@ , " " ] =?> bulletList [ codeBlock "foo" ] + , "Empty example inside list" =: + T.unlines [ " - " + , " " + ] =?> + bulletList [ codeBlock "" ] , "Example inside list with empty lines" =: T.unlines [ " - " , " foo" @@ -537,12 +539,14 @@ , "[1] First footnote paragraph" , "" , " Second footnote paragraph" + , "with continuation" + , "" , "Not a note" , "[2] Second footnote" ] =?> para (text "Multiparagraph" <> note (para "First footnote paragraph" <> - para "Second footnote paragraph") <> + para "Second footnote paragraph\nwith continuation") <> text " footnotes" <> note (para "Second footnote")) <> para (text "Not a note") @@ -713,8 +717,48 @@ , mempty , para "Item3" ] + , "Bullet list with last item empty" =: + T.unlines + [ " -" + , "" + , "foo" + ] =?> + bulletList [ mempty ] <> + para "foo" , testGroup "Nested lists" - [ "Nested list" =: + [ "Nested bullet list" =: + T.unlines [ " - Item1" + , " - Item2" + , " - Item3" + , " - Item4" + , " - Item5" + , " - Item6" + ] =?> + bulletList [ para "Item1" <> + bulletList [ para "Item2" <> + bulletList [ para "Item3" ] + , para "Item4" <> + bulletList [ para "Item5" ] + ] + , para "Item6" + ] + , "Nested ordered list" =: + T.unlines [ " 1. Item1" + , " 1. Item2" + , " 1. Item3" + , " 2. Item4" + , " 1. Item5" + , " 2. Item6" + ] =?> + orderedListWith (1, Decimal, Period) [ para "Item1" <> + orderedListWith (1, Decimal, Period) [ para "Item2" <> + orderedListWith (1, Decimal, Period) [ para "Item3" ] + , para "Item4" <> + orderedListWith (1, Decimal, Period) [ para "Item5" ] + ] + , para "Item6" + ] + , "Mixed nested list" =: T.unlines [ " - Item1" , " - Item2" @@ -736,12 +780,6 @@ ] ] ] - , "Incorrectly indented Text::Amuse nested list" =: - T.unlines - [ " - First item" - , " - Not nested item" - ] =?> - bulletList [ para "First item", para "Not nested item"] , "Text::Amuse includes only one space in list marker" =: T.unlines [ " - First item" @@ -920,17 +958,6 @@ definitionList [ ("Term1", [ para "This is a first definition\nAnd it has two lines;\nno, make that three."]) , ("Term2", [ para "This is a second definition"]) ]) - -- Emacs Muse creates two separate lists when indentation of items is different. - -- We follow Amusewiki and allow different indentation within one list. - , "Changing indentation" =: - T.unlines - [ " First term :: Definition of first term" - , "and its continuation." - , " Second term :: Definition of second term." - ] =?> - definitionList [ ("First term", [ para "Definition of first term\nand its continuation." ]) - , ("Second term", [ para "Definition of second term." ]) - ] , "Two blank lines separate definition lists" =: T.unlines [ " First :: list" diff --git a/test/Tests/Writers/ConTeXt.hs b/test/Tests/Writers/ConTeXt.hs --- a/test/Tests/Writers/ConTeXt.hs +++ b/test/Tests/Writers/ConTeXt.hs @@ -15,6 +15,9 @@ context' :: (ToPandoc a) => a -> String context' = unpack . purely (writeConTeXt def{ writerWrapText = WrapNone }) . toPandoc +contextNtb :: (ToPandoc a) => a -> String +contextNtb = unpack . purely (writeConTeXt def{ writerExtensions = enableExtension Ext_ntb pandocExtensions }) . toPandoc + {- "my test" =: X =?> Y @@ -68,5 +71,57 @@ , " \\stopitemize" , "\\stopitemize" ] ] + , testGroup "natural tables" + [ test contextNtb "table with header and caption" $ + let caption = text "Table 1" + aligns = [(AlignRight, 0.0), (AlignLeft, 0.0), (AlignCenter, 0.0), (AlignDefault, 0.0)] + headers = [plain $ text "Right", + plain $ text "Left", + plain $ text "Center", + plain $ text "Default"] + rows = [[plain $ text "1.1", + plain $ text "1.2", + plain $ text "1.3", + plain $ text "1.4"] + ,[plain $ text "2.1", + plain $ text "2.2", + plain $ text "2.3", + plain $ text "2.4"] + ,[plain $ text "3.1", + plain $ text "3.2", + plain $ text "3.3", + plain $ text "3.4"]] + in table caption aligns headers rows + =?> unlines [ "\\startplacetable[caption={Table 1}]" + , "\\startTABLE" + , "\\startTABLEhead" + , "\\NC[align=left] Right" + , "\\NC[align=right] Left" + , "\\NC[align=middle] Center" + , "\\NC Default" + , "\\NC\\NR" + , "\\stopTABLEhead" + , "\\startTABLEbody" + , "\\NC[align=left] 1.1" + , "\\NC[align=right] 1.2" + , "\\NC[align=middle] 1.3" + , "\\NC 1.4" + , "\\NC\\NR" + , "\\NC[align=left] 2.1" + , "\\NC[align=right] 2.2" + , "\\NC[align=middle] 2.3" + , "\\NC 2.4" + , "\\NC\\NR" + , "\\stopTABLEbody" + , "\\startTABLEfoot" + , "\\NC[align=left] 3.1" + , "\\NC[align=right] 3.2" + , "\\NC[align=middle] 3.3" + , "\\NC 3.4" + , "\\NC\\NR" + , "\\stopTABLEfoot" + , "\\stopTABLE" + , "\\stopplacetable" ] + ] ] diff --git a/test/command/4159.md b/test/command/4159.md --- a/test/command/4159.md +++ b/test/command/4159.md @@ -3,5 +3,6 @@ \newcommand{\gen}{a\ Gen\ b} abc ^D -[Para [Str "abc"]] +[RawBlock (Format "latex") "\\newcommand{\\gen}{a\\ Gen\\ b}" +,Para [Str "abc"]] ``` diff --git a/test/command/4235.md b/test/command/4235.md new file mode 100644 --- /dev/null +++ b/test/command/4235.md @@ -0,0 +1,12 @@ +``` +% pandoc --id-prefix=foo +This.^[Has a footnote.] +^D +

This.1

+
+
+
    +

  1. Has a footnote.↩

    2. +
+
+``` diff --git a/test/command/4240.md b/test/command/4240.md new file mode 100644 --- /dev/null +++ b/test/command/4240.md @@ -0,0 +1,33 @@ +``` +% pandoc -f rst -s -t native +===== +Title +===== + +-------- +Subtitle +-------- + +header1 +======= + +header2 +------- + +.. _id: + +header3 +~~~~~~~ + +.. _id2: +.. _id3: + +header4 +~~~~~~~ +^D +Pandoc (Meta {unMeta = fromList [("subtitle",MetaInlines [Str "Subtitle"]),("title",MetaInlines [Str "Title"])]}) +[Header 1 ("header1",[],[]) [Str "header1"] +,Header 2 ("header2",[],[]) [Str "header2"] +,Header 3 ("id",[],[]) [Str "header3"] +,Header 3 ("id3",[],[]) [Str "header4",Span ("id2",[],[]) []]] +``` diff --git a/test/command/4253.md b/test/command/4253.md new file mode 100644 --- /dev/null +++ b/test/command/4253.md @@ -0,0 +1,8 @@ +``` +% pandoc -f latex -t native +\newcommand{\noop}[1]{#1} +\noop{\newcommand{\foo}[1]{#1}} +\foo{hi} +^D +[Para [Str "hi"]] +``` diff --git a/test/command/4254.md b/test/command/4254.md new file mode 100644 --- /dev/null +++ b/test/command/4254.md @@ -0,0 +1,12 @@ +``` +% pandoc -f rst -t latex +.. math:: + + x &= y\\ + y &= z +^D +\[\begin{aligned} +x &= y\\ +y &= z +\end{aligned}\] +``` diff --git a/test/command/adjacent_latex_blocks.md b/test/command/adjacent_latex_blocks.md new file mode 100644 --- /dev/null +++ b/test/command/adjacent_latex_blocks.md @@ -0,0 +1,9 @@ +``` +% pandoc -f markdown -t native +\listoffigures + +\listoftables +^D +[RawBlock (Format "latex") "\\listoffigures" +,RawBlock (Format "latex") "\\listoftables"] +``` diff --git a/test/command/cite-in-inline-note.md b/test/command/cite-in-inline-note.md new file mode 100644 --- /dev/null +++ b/test/command/cite-in-inline-note.md @@ -0,0 +1,6 @@ +``` +% pandoc -t native +foo^[bar [@doe]] +^D +[Para [Str "foo",Note [Para [Str "bar",Space,Cite [Citation {citationId = "doe", citationPrefix = [], citationSuffix = [], citationMode = NormalCitation, citationNoteNum = 0, citationHash = 0}] [Str "[@doe]"]]]]] +``` diff --git a/test/command/macros.md b/test/command/macros.md --- a/test/command/macros.md +++ b/test/command/macros.md @@ -3,6 +3,7 @@ \newcommand{\my}{\phi} $\my+\my$ ^D +\newcommand{\my}{\phi} $\phi+\phi$ ``` @@ -73,6 +74,7 @@ \my+\my \end{equation} ^D +\newcommand{\my}{\phi} \begin{equation} \phi+\phi \end{equation} @@ -96,5 +98,6 @@ \newcommand{\my}{\emph{a}} \my ^D +\newcommand{\my}{\emph{a}} \emph{a} ``` diff --git a/test/docx/instrText_hyperlink.docx b/test/docx/instrText_hyperlink.docx new file mode 100644 Binary files /dev/null and b/test/docx/instrText_hyperlink.docx differ diff --git a/test/docx/instrText_hyperlink.native b/test/docx/instrText_hyperlink.native new file mode 100644 --- /dev/null +++ b/test/docx/instrText_hyperlink.native @@ -0,0 +1,1 @@ +[Para [Str "\24076\26395\28145\20837\20102\35299\30340\35835\32773\21487\20197\21435\30475David",Space,Str "French",Space,Str "Belding\21644Kevin",Space,Str "J.",Space,Str "Mitchell\30340",Link ("",[],[]) [Str "Foundations",Space,Str "of",Space,Str "Analysis,",Space,Str "2nd",Space,Str "Edition"] ("https://books.google.com/books?id=sp_Zcb9ot90C&lpg=PR4&hl=zh-CN&pg=PA19#v=onepage&q&f=true",""),Str ",\21487\20174\&19\39029\30475\36215\65292\25110D.C.",Space,Str "Goldrei\30340",Space,Link ("",[],[]) [Str "Classic",Space,Str "Set",Space,Str "Theory:",Space,Str "For",Space,Str "Guided",Space,Str "Independent",Space,Str "Study"] ("https://books.google.ae/books?id=dlc0DwAAQBAJ&lpg=PT29&hl=zh-CN&pg=PT26#v=onepage&q&f=true",""),Str "\65292\20174\31532\20108\31456\30475\36215\65292\38405\35835\26102\35201\27880\24847\26412\25991\19982\36825\20123\20070\25152\19981\21516\30340\26159\24182\27809\26377\25226\23454\25968\30475\20316\26159\26377\29702\25968\38598\30340\20998\21106\12290"]] diff --git a/test/markdown-reader-more.native b/test/markdown-reader-more.native --- a/test/markdown-reader-more.native +++ b/test/markdown-reader-more.native @@ -3,7 +3,8 @@ ,Header 2 ("blank-line-before-url-in-link-reference",[],[]) [Str "Blank",Space,Str "line",Space,Str "before",Space,Str "URL",Space,Str "in",Space,Str "link",Space,Str "reference"] ,Para [Link ("",[],[]) [Str "foo"] ("/url",""),Space,Str "and",Space,Link ("",[],[]) [Str "bar"] ("/url","title")] ,Header 2 ("raw-context-environments",[],[]) [Str "Raw",Space,Str "ConTeXt",Space,Str "environments"] -,RawBlock (Format "context") "\\placeformula \\startformula\n L_{1} = L_{2}\n \\stopformula\n\n\\start[a2]\n\\start[a2]\n\\stop[a2]\n\\stop[a2]" +,RawBlock (Format "context") "\\placeformula \\startformula\n L_{1} = L_{2}\n \\stopformula" +,RawBlock (Format "context") "\\start[a2]\n\\start[a2]\n\\stop[a2]\n\\stop[a2]" ,Header 2 ("raw-latex-environments",[],[]) [Str "Raw",Space,Str "LaTeX",Space,Str "environments"] ,RawBlock (Format "latex") "\\begin{center}\n\\begin{tikzpicture}[baseline={([yshift=+-.5ex]current bounding box.center)}, level distance=24pt]\n\\Tree [.{S} [.NP John\\index{i} ] [.VP [.V likes ] [.NP himself\\index{i,*j} ]]]\n\\end{tikzpicture}\n\\end{center}" ,Header 2 ("urls-with-spaces-and-punctuation",[],[]) [Str "URLs",Space,Str "with",Space,Str "spaces",Space,Str "and",Space,Str "punctuation"] @@ -54,6 +55,7 @@ ,OrderedList (3,Example,TwoParens) [[Plain [Str "Third",Space,Str "example."]]] ,Header 2 ("macros",[],[]) [Str "Macros"] +,RawBlock (Format "latex") "\\newcommand{\\tuple}[1]{\\langle #1 \\rangle}" ,Para [Math InlineMath "\\langle x,y \\rangle"] ,Header 2 ("case-insensitive-references",[],[]) [Str "Case-insensitive",Space,Str "references"] ,Para [Link ("",[],[]) [Str "Fum"] ("/fum","")] diff --git a/test/rst-reader.native b/test/rst-reader.native --- a/test/rst-reader.native +++ b/test/rst-reader.native @@ -317,7 +317,7 @@ ,Para [Math DisplayMath "E=mc^2"] ,Para [Math DisplayMath "E = mc^2"] ,Para [Math DisplayMath "E = mc^2",Math DisplayMath "\\alpha = \\beta"] -,Para [Math DisplayMath "E &= mc^2\\\\\nF &= \\pi E",Math DisplayMath "F &= \\gamma \\alpha^2"] +,Para [Math DisplayMath "\\begin{aligned}\nE &= mc^2\\\\\nF &= \\pi E\n\\end{aligned}",Math DisplayMath "F &= \\gamma \\alpha^2"] ,Para [Str "All",Space,Str "done."] ,Header 1 ("default-role",[],[]) [Str "Default-Role"] ,Para [Str "Try",Space,Str "changing",Space,Str "the",Space,Str "default",Space,Str "role",Space,Str "to",Space,Str "a",Space,Str "few",Space,Str "different",Space,Str "things."] diff --git a/test/tables.context b/test/tables.context --- a/test/tables.context +++ b/test/tables.context @@ -1,175 +1,230 @@ Simple table with caption: -\placetable{Demonstration of simple table syntax.} -\starttable[|r|l|c|l|] -\HL -\NC Right -\NC Left -\NC Center -\NC Default -\NC\AR -\HL -\NC 12 -\NC 12 -\NC 12 -\NC 12 -\NC\AR -\NC 123 -\NC 123 -\NC 123 -\NC 123 -\NC\AR -\NC 1 -\NC 1 -\NC 1 -\NC 1 -\NC\AR -\HL -\stoptable +\startplacetable[caption={Demonstration of simple table syntax.}] +\startxtable +\startxtablehead[head] +\startxrow +\startxcell[align=left] Right \stopxcell +\startxcell[align=right] Left \stopxcell +\startxcell[align=middle] Center \stopxcell +\startxcell Default \stopxcell +\stopxrow +\stopxtablehead +\startxtablebody[body] +\startxrow +\startxcell[align=left] 12 \stopxcell +\startxcell[align=right] 12 \stopxcell +\startxcell[align=middle] 12 \stopxcell +\startxcell 12 \stopxcell +\stopxrow +\startxrow +\startxcell[align=left] 123 \stopxcell +\startxcell[align=right] 123 \stopxcell +\startxcell[align=middle] 123 \stopxcell +\startxcell 123 \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=left] 1 \stopxcell +\startxcell[align=right] 1 \stopxcell +\startxcell[align=middle] 1 \stopxcell +\startxcell 1 \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable Simple table without caption: -\placetable[none]{} -\starttable[|r|l|c|l|] -\HL -\NC Right -\NC Left -\NC Center -\NC Default -\NC\AR -\HL -\NC 12 -\NC 12 -\NC 12 -\NC 12 -\NC\AR -\NC 123 -\NC 123 -\NC 123 -\NC 123 -\NC\AR -\NC 1 -\NC 1 -\NC 1 -\NC 1 -\NC\AR -\HL -\stoptable +\startplacetable[location=none] +\startxtable +\startxtablehead[head] +\startxrow +\startxcell[align=left] Right \stopxcell +\startxcell[align=right] Left \stopxcell +\startxcell[align=middle] Center \stopxcell +\startxcell Default \stopxcell +\stopxrow +\stopxtablehead +\startxtablebody[body] +\startxrow +\startxcell[align=left] 12 \stopxcell +\startxcell[align=right] 12 \stopxcell +\startxcell[align=middle] 12 \stopxcell +\startxcell 12 \stopxcell +\stopxrow +\startxrow +\startxcell[align=left] 123 \stopxcell +\startxcell[align=right] 123 \stopxcell +\startxcell[align=middle] 123 \stopxcell +\startxcell 123 \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=left] 1 \stopxcell +\startxcell[align=right] 1 \stopxcell +\startxcell[align=middle] 1 \stopxcell +\startxcell 1 \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable Simple table indented two spaces: -\placetable{Demonstration of simple table syntax.} -\starttable[|r|l|c|l|] -\HL -\NC Right -\NC Left -\NC Center -\NC Default -\NC\AR -\HL -\NC 12 -\NC 12 -\NC 12 -\NC 12 -\NC\AR -\NC 123 -\NC 123 -\NC 123 -\NC 123 -\NC\AR -\NC 1 -\NC 1 -\NC 1 -\NC 1 -\NC\AR -\HL -\stoptable +\startplacetable[caption={Demonstration of simple table syntax.}] +\startxtable +\startxtablehead[head] +\startxrow +\startxcell[align=left] Right \stopxcell +\startxcell[align=right] Left \stopxcell +\startxcell[align=middle] Center \stopxcell +\startxcell Default \stopxcell +\stopxrow +\stopxtablehead +\startxtablebody[body] +\startxrow +\startxcell[align=left] 12 \stopxcell +\startxcell[align=right] 12 \stopxcell +\startxcell[align=middle] 12 \stopxcell +\startxcell 12 \stopxcell +\stopxrow +\startxrow +\startxcell[align=left] 123 \stopxcell +\startxcell[align=right] 123 \stopxcell +\startxcell[align=middle] 123 \stopxcell +\startxcell 123 \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=left] 1 \stopxcell +\startxcell[align=right] 1 \stopxcell +\startxcell[align=middle] 1 \stopxcell +\startxcell 1 \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable Multiline table with caption: -\placetable{Here's the caption. It may span multiple lines.} -\starttable[|cp(0.15\textwidth)|lp(0.14\textwidth)|rp(0.16\textwidth)|lp(0.34\textwidth)|] -\HL -\NC Centered Header -\NC Left Aligned -\NC Right Aligned -\NC Default aligned -\NC\AR -\HL -\NC First -\NC row -\NC 12.0 -\NC Example of a row that spans multiple lines. -\NC\AR -\NC Second -\NC row -\NC 5.0 -\NC Here's another one. Note the blank line between rows. -\NC\AR -\HL -\stoptable +\startplacetable[caption={Here's the caption. It may span multiple lines.}] +\startxtable +\startxtablehead[head] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] Centered Header \stopxcell +\startxcell[align=right,width={0.14\textwidth}] Left Aligned \stopxcell +\startxcell[align=left,width={0.16\textwidth}] Right Aligned \stopxcell +\startxcell[align=right,width={0.34\textwidth}] Default aligned \stopxcell +\stopxrow +\stopxtablehead +\startxtablebody[body] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] First \stopxcell +\startxcell[align=right,width={0.14\textwidth}] row \stopxcell +\startxcell[align=left,width={0.16\textwidth}] 12.0 \stopxcell +\startxcell[align=right,width={0.34\textwidth}] Example of a row that spans +multiple lines. \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] Second \stopxcell +\startxcell[align=right,width={0.14\textwidth}] row \stopxcell +\startxcell[align=left,width={0.16\textwidth}] 5.0 \stopxcell +\startxcell[align=right,width={0.34\textwidth}] Here's another one. Note the +blank line between rows. \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable Multiline table without caption: -\placetable[none]{} -\starttable[|cp(0.15\textwidth)|lp(0.14\textwidth)|rp(0.16\textwidth)|lp(0.34\textwidth)|] -\HL -\NC Centered Header -\NC Left Aligned -\NC Right Aligned -\NC Default aligned -\NC\AR -\HL -\NC First -\NC row -\NC 12.0 -\NC Example of a row that spans multiple lines. -\NC\AR -\NC Second -\NC row -\NC 5.0 -\NC Here's another one. Note the blank line between rows. -\NC\AR -\HL -\stoptable +\startplacetable[location=none] +\startxtable +\startxtablehead[head] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] Centered Header \stopxcell +\startxcell[align=right,width={0.14\textwidth}] Left Aligned \stopxcell +\startxcell[align=left,width={0.16\textwidth}] Right Aligned \stopxcell +\startxcell[align=right,width={0.34\textwidth}] Default aligned \stopxcell +\stopxrow +\stopxtablehead +\startxtablebody[body] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] First \stopxcell +\startxcell[align=right,width={0.14\textwidth}] row \stopxcell +\startxcell[align=left,width={0.16\textwidth}] 12.0 \stopxcell +\startxcell[align=right,width={0.34\textwidth}] Example of a row that spans +multiple lines. \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] Second \stopxcell +\startxcell[align=right,width={0.14\textwidth}] row \stopxcell +\startxcell[align=left,width={0.16\textwidth}] 5.0 \stopxcell +\startxcell[align=right,width={0.34\textwidth}] Here's another one. Note the +blank line between rows. \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable Table without column headers: -\placetable[none]{} -\starttable[|r|l|c|r|] -\HL -\NC 12 -\NC 12 -\NC 12 -\NC 12 -\NC\AR -\NC 123 -\NC 123 -\NC 123 -\NC 123 -\NC\AR -\NC 1 -\NC 1 -\NC 1 -\NC 1 -\NC\AR -\HL -\stoptable +\startplacetable[location=none] +\startxtable +\startxtablebody[body] +\startxrow +\startxcell[align=left] 12 \stopxcell +\startxcell[align=right] 12 \stopxcell +\startxcell[align=middle] 12 \stopxcell +\startxcell[align=left] 12 \stopxcell +\stopxrow +\startxrow +\startxcell[align=left] 123 \stopxcell +\startxcell[align=right] 123 \stopxcell +\startxcell[align=middle] 123 \stopxcell +\startxcell[align=left] 123 \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=left] 1 \stopxcell +\startxcell[align=right] 1 \stopxcell +\startxcell[align=middle] 1 \stopxcell +\startxcell[align=left] 1 \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable Multiline table without column headers: -\placetable[none]{} -\starttable[|cp(0.15\textwidth)|lp(0.14\textwidth)|rp(0.16\textwidth)|lp(0.34\textwidth)|] -\HL -\NC First -\NC row -\NC 12.0 -\NC Example of a row that spans multiple lines. -\NC\AR -\NC Second -\NC row -\NC 5.0 -\NC Here's another one. Note the blank line between rows. -\NC\AR -\HL -\stoptable +\startplacetable[location=none] +\startxtable +\startxtablebody[body] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] First \stopxcell +\startxcell[align=right,width={0.14\textwidth}] row \stopxcell +\startxcell[align=left,width={0.16\textwidth}] 12.0 \stopxcell +\startxcell[width={0.34\textwidth}] Example of a row that spans multiple +lines. \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] Second \stopxcell +\startxcell[align=right,width={0.14\textwidth}] row \stopxcell +\startxcell[align=left,width={0.16\textwidth}] 5.0 \stopxcell +\startxcell[width={0.34\textwidth}] Here's another one. Note the blank line +between rows. \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable diff --git a/test/tables.markdown b/test/tables.markdown --- a/test/tables.markdown +++ b/test/tables.markdown @@ -28,33 +28,33 @@ Multiline table with caption: - -------------------------------------------------------------- + ------------------------------------------------------------- Centered Left Right Default aligned Header Aligned Aligned - ----------- ---------- ------------ -------------------------- + ----------- ---------- ------------ ------------------------- First row 12.0 Example of a row that spans multiple lines. Second row 5.0 Here's another one. Note the blank line between rows. - -------------------------------------------------------------- + ------------------------------------------------------------- : Here's the caption. It may span multiple lines. Multiline table without caption: - -------------------------------------------------------------- + ------------------------------------------------------------- Centered Left Right Default aligned Header Aligned Aligned - ----------- ---------- ------------ -------------------------- + ----------- ---------- ------------ ------------------------- First row 12.0 Example of a row that spans multiple lines. Second row 5.0 Here's another one. Note the blank line between rows. - -------------------------------------------------------------- + ------------------------------------------------------------- Table without column headers: @@ -66,11 +66,11 @@ Multiline table without column headers: - ----------- ---------- ------------ -------------------------- + ----------- ---------- ------------ ------------------------- First row 12.0 Example of a row that spans multiple lines. Second row 5.0 Here's another one. Note the blank line between rows. - ----------- ---------- ------------ -------------------------- + ----------- ---------- ------------ ------------------------- diff --git a/test/tables.plain b/test/tables.plain --- a/test/tables.plain +++ b/test/tables.plain @@ -28,33 +28,33 @@ Multiline table with caption: - -------------------------------------------------------------- + ------------------------------------------------------------- Centered Left Right Default aligned Header Aligned Aligned - ----------- ---------- ------------ -------------------------- + ----------- ---------- ------------ ------------------------- First row 12.0 Example of a row that spans multiple lines. Second row 5.0 Here’s another one. Note the blank line between rows. - -------------------------------------------------------------- + ------------------------------------------------------------- : Here’s the caption. It may span multiple lines. Multiline table without caption: - -------------------------------------------------------------- + ------------------------------------------------------------- Centered Left Right Default aligned Header Aligned Aligned - ----------- ---------- ------------ -------------------------- + ----------- ---------- ------------ ------------------------- First row 12.0 Example of a row that spans multiple lines. Second row 5.0 Here’s another one. Note the blank line between rows. - -------------------------------------------------------------- + ------------------------------------------------------------- Table without column headers: @@ -66,11 +66,11 @@ Multiline table without column headers: - ----------- ---------- ------------ -------------------------- + ----------- ---------- ------------ ------------------------- First row 12.0 Example of a row that spans multiple lines. Second row 5.0 Here’s another one. Note the blank line between rows. - ----------- ---------- ------------ -------------------------- + ----------- ---------- ------------ ------------------------- diff --git a/test/writer.context b/test/writer.context --- a/test/writer.context +++ b/test/writer.context @@ -51,6 +51,11 @@ \setupthinrules[width=15em] % width of horizontal rules +\setupxtable[frame=off] +\setupxtable[head][topframe=on,bottomframe=on] +\setupxtable[body][] +\setupxtable[foot][bottomframe=on] + \starttext \startalignment[middle] diff --git a/test/writers-lang-and-dir.context b/test/writers-lang-and-dir.context --- a/test/writers-lang-and-dir.context +++ b/test/writers-lang-and-dir.context @@ -49,6 +49,11 @@ \setupthinrules[width=15em] % width of horizontal rules +\setupxtable[frame=off] +\setupxtable[head][topframe=on,bottomframe=on] +\setupxtable[body][] +\setupxtable[foot][bottomframe=on] + \starttext