pandoc 2.1 → 2.1.1
raw patch · 64 files changed
+4229/−2582 lines, 64 filesdep +exceptionsdep ~QuickCheckdep ~basedep ~criterionbinary-added
Dependencies added: exceptions
Dependency ranges changed: QuickCheck, base, criterion, skylighting, tasty
Files
- AUTHORS.md +1/−0
- INSTALL.md +1/−1
- MANUAL.txt +40/−27
- README.md +1/−1
- changelog +200/−13
- data/pandoc.lua +162/−132
- data/templates/default.context +5/−0
- man/pandoc.1 +40/−26
- pandoc.cabal +15/−25
- prelude/Prelude.hs +0/−26
- src/Text/Pandoc/App.hs +5/−95
- src/Text/Pandoc/Extensions.hs +1/−0
- src/Text/Pandoc/Filter.hs +60/−0
- src/Text/Pandoc/Filter/JSON.hs +97/−0
- src/Text/Pandoc/Filter/Lua.hs +53/−0
- src/Text/Pandoc/Filter/Path.hs +53/−0
- src/Text/Pandoc/ImageSize.hs +1/−0
- src/Text/Pandoc/Lua.hs +11/−6
- src/Text/Pandoc/Lua/Filter.hs +6/−2
- src/Text/Pandoc/Lua/Module/Utils.hs +26/−3
- src/Text/Pandoc/Lua/Packages.hs +2/−1
- src/Text/Pandoc/Lua/StackInstances.hs +67/−15
- src/Text/Pandoc/Lua/Util.hs +9/−0
- src/Text/Pandoc/Parsing.hs +1/−0
- src/Text/Pandoc/Readers/Docx.hs +5/−0
- src/Text/Pandoc/Readers/Docx/Fields.hs +89/−0
- src/Text/Pandoc/Readers/Docx/Parse.hs +89/−5
- src/Text/Pandoc/Readers/HTML.hs +6/−3
- src/Text/Pandoc/Readers/LaTeX.hs +18/−14
- src/Text/Pandoc/Readers/Markdown.hs +30/−16
- src/Text/Pandoc/Readers/Muse.hs +80/−97
- src/Text/Pandoc/Readers/RST.hs +19/−4
- src/Text/Pandoc/Writers/ConTeXt.hs +71/−25
- src/Text/Pandoc/Writers/Docx.hs +1/−11
- src/Text/Pandoc/Writers/HTML.hs +1/−1
- src/Text/Pandoc/Writers/LaTeX.hs +3/−3
- src/Text/Pandoc/Writers/Markdown.hs +1/−1
- src/Text/Pandoc/Writers/OOXML.hs +40/−41
- src/Text/Pandoc/Writers/Powerpoint.hs +63/−1777
- src/Text/Pandoc/Writers/Powerpoint/Output.hs +1481/−0
- src/Text/Pandoc/Writers/Powerpoint/Presentation.hs +880/−0
- src/Text/Pandoc/Writers/Shared.hs +9/−0
- stack.yaml +7/−3
- test/Tests/Lua.hs +37/−4
- test/Tests/Readers/Docx.hs +4/−0
- test/Tests/Readers/Muse.hs +57/−30
- test/Tests/Writers/ConTeXt.hs +55/−0
- test/command/4159.md +2/−1
- test/command/4235.md +12/−0
- test/command/4240.md +33/−0
- test/command/4253.md +8/−0
- test/command/4254.md +12/−0
- test/command/adjacent_latex_blocks.md +9/−0
- test/command/cite-in-inline-note.md +6/−0
- test/command/macros.md +3/−0
- test/docx/instrText_hyperlink.docx binary
- test/docx/instrText_hyperlink.native +1/−0
- test/markdown-reader-more.native +3/−1
- test/rst-reader.native +1/−1
- test/tables.context +210/−155
- test/tables.markdown +8/−8
- test/tables.plain +8/−8
- test/writer.context +5/−0
- test/writers-lang-and-dir.context +5/−0
AUTHORS.md view
@@ -185,6 +185,7 @@ - infinity0x - lwolfsonkin - nkalvi+- oltolm - qerub - robabla - roblabla
INSTALL.md view
@@ -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:
MANUAL.txt view
@@ -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: - \ + \ Note that in reveal.js slide shows, an image in a paragraph by itself that has the `stretch` class will fill the screen,
README.md view
@@ -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
changelog view
@@ -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.
data/pandoc.lua view
@@ -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, }
data/templates/default.context view
@@ -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$
man/pandoc.1 view
@@ -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
pandoc.cabal view
@@ -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
− prelude/Prelude.hs
@@ -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
src/Text/Pandoc/App.hs view
@@ -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)
src/Text/Pandoc/Extensions.hs view
@@ -133,6 +133,7 @@ | Ext_multiline_tables -- ^ Pandoc-style multiline tables | Ext_native_divs -- ^ Use Div blocks for contents of <div> tags | Ext_native_spans -- ^ Use Span inlines for contents of <span>+ | 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)
+ src/Text/Pandoc/Filter.hs view
@@ -0,0 +1,60 @@+{-+Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu>++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 <jgm@berkeley@edu>+ 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)
+ src/Text/Pandoc/Filter/JSON.hs view
@@ -0,0 +1,97 @@+{-+Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu>++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 <jgm@berkeley@edu>+ 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)
+ src/Text/Pandoc/Filter/Lua.hs view
@@ -0,0 +1,53 @@+{-+Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu>++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 <jgm@berkeley@edu>+ 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)
+ src/Text/Pandoc/Filter/Path.hs view
@@ -0,0 +1,53 @@+{-+Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu>++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 <jgm@berkeley@edu>+ 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
src/Text/Pandoc/ImageSize.hs view
@@ -83,6 +83,7 @@ | Inch Double | Percent Double | Em Double+ deriving Eq instance Show Dimension where show (Pixel a) = show a ++ "px"
src/Text/Pandoc/Lua.hs view
@@ -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
src/Text/Pandoc/Lua/Filter.hs view
@@ -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)
src/Text/Pandoc/Lua/Module/Utils.hs view
@@ -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
src/Text/Pandoc/Lua/Packages.hs view
@@ -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
src/Text/Pandoc/Lua/StackInstances.hs view
@@ -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+
src/Text/Pandoc/Lua/Util.hs view
@@ -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
src/Text/Pandoc/Parsing.hs view
@@ -180,6 +180,7 @@ sourceLine, setSourceColumn, setSourceLine,+ incSourceColumn, newPos, Line, Column
src/Text/Pandoc/Readers/Docx.hs view
@@ -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) _) =
+ src/Text/Pandoc/Readers/Docx/Fields.hs view
@@ -0,0 +1,89 @@+{-+Copyright (C) 2014-2018 Jesse Rosenthal <jrosenthal@jhu.edu>++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 <jrosenthal@jhu.edu>+ 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
src/Text/Pandoc/Readers/Docx/Parse.hs view
@@ -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 <w:fldChar fldCharType="begin"> in a run, then a run with+<w:instrText>, then a <w:fldChar fldCharType="separate"> run, then the+content runs, and finally a <w:fldChar fldCharType="end"> run. For+example (omissions and my comments in brackets):++ <w:r>+ [...]+ <w:fldChar w:fldCharType="begin"/>+ </w:r>+ <w:r>+ [...]+ <w:instrText xml:space="preserve"> HYPERLINK [hyperlink url] </w:instrText>+ </w:r>+ <w:r>+ [...]+ <w:fldChar w:fldCharType="separate"/>+ </w:r>+ <w:r w:rsidRPr=[...]>+ [...]+ <w:t>Foundations of Analysis, 2nd Edition</w:t>+ </w:r>+ <w:r>+ [...]+ <w:fldChar w:fldCharType="end"/>+ </w:r>++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)
src/Text/Pandoc/Readers/HTML.hs view
@@ -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
src/Text/Pandoc/Readers/LaTeX.hs view
@@ -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
src/Text/Pandoc/Readers/Markdown.hs view
@@ -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
src/Text/Pandoc/Readers/Muse.hs view
@@ -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
src/Text/Pandoc/Readers/RST.hs view
@@ -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
src/Text/Pandoc/Writers/ConTeXt.hs view
@@ -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 >>=
src/Text/Pandoc/Writers/Docx.hs view
@@ -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
src/Text/Pandoc/Writers/HTML.hs view
@@ -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
src/Text/Pandoc/Writers/LaTeX.hs view
@@ -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
src/Text/Pandoc/Writers/Markdown.hs view
@@ -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)
src/Text/Pandoc/Writers/OOXML.hs view
@@ -1,55 +1,55 @@+{-+Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu>++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 <jgm@berkeley.edu>+ 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)-
src/Text/Pandoc/Writers/Powerpoint.hs view
@@ -1,1777 +1,63 @@-{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-}--{--Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu>--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 <jrosenthal@jhu.edu>- 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 <jrosenthal@jhu.edu>++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 <jrosenthal@jhu.edu>+ 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
+ src/Text/Pandoc/Writers/Powerpoint/Output.hs view
@@ -0,0 +1,1481 @@+{-# LANGUAGE PatternGuards #-}++{-+Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu>++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 <jrosenthal@jhu.edu>+ 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"
+ src/Text/Pandoc/Writers/Powerpoint/Presentation.hs view
@@ -0,0 +1,880 @@+{-# LANGUAGE PatternGuards #-}++{-+Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu>++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 <jrosenthal@jhu.edu>+ 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)
@@ -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 _ = []
stack.yaml view
@@ -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
test/Tests/Lua.hs view
@@ -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
test/Tests/Readers/Docx.hs view
@@ -128,6 +128,10 @@ "docx/links.docx" "docx/links.native" , testCompare+ "hyperlinks in <w:instrText> tag"+ "docx/instrText_hyperlink.docx"+ "docx/instrText_hyperlink.native"+ , testCompare "inline image" "docx/image.docx" "docx/image_no_embed.native"
test/Tests/Readers/Muse.hs view
@@ -114,8 +114,8 @@ , "Linebreak" =: "Line <br> 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" =: "<code>foo(bar)</code>" =?> para (code "foo(bar)")@@ -161,6 +164,8 @@ , "Verbatim inside code" =: "<code><verbatim>foo</verbatim></code>" =?> para (code "<verbatim>foo</verbatim>") + , "Verbatim tag after text" =: "Foo <verbatim>bar</verbatim>" =?> para "Foo bar"+ , testGroup "Links" [ "Link without description" =: "[[https://amusewiki.org/]]" =?>@@ -279,20 +284,12 @@ , " One two three" , "" , "</verse>"- , "<verse>Foo bar</verse>"- , "<verse>"- , "Foo bar</verse>"- , "<verse>"- , " Foo</verse>" ] =?> 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 @@ , " </example>" ] =?> bulletList [ codeBlock "foo" ]+ , "Empty example inside list" =:+ T.unlines [ " - <example>"+ , " </example>"+ ] =?>+ bulletList [ codeBlock "" ] , "Example inside list with empty lines" =: T.unlines [ " - <example>" , " 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"
test/Tests/Writers/ConTeXt.hs view
@@ -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" ]+ ] ]
test/command/4159.md view
@@ -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"]] ```
+ test/command/4235.md view
@@ -0,0 +1,12 @@+```+% pandoc --id-prefix=foo+This.^[Has a footnote.]+^D+<p>This.<a href="#foofn1" class="footnote-ref" id="foofnref1"><sup>1</sup></a></p>+<section class="footnotes">+<hr />+<ol>+<li id="foofn1"><p>Has a footnote.<a href="#foofnref1" class="footnote-back">↩</a></p></li>+</ol>+</section>+```
+ test/command/4240.md view
@@ -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",[],[]) []]]+```
+ test/command/4253.md view
@@ -0,0 +1,8 @@+```+% pandoc -f latex -t native+\newcommand{\noop}[1]{#1}+\noop{\newcommand{\foo}[1]{#1}}+\foo{hi}+^D+[Para [Str "hi"]]+```
+ test/command/4254.md view
@@ -0,0 +1,12 @@+```+% pandoc -f rst -t latex+.. math::++ x &= y\\+ y &= z+^D+\[\begin{aligned}+x &= y\\+y &= z+\end{aligned}\]+```
+ test/command/adjacent_latex_blocks.md view
@@ -0,0 +1,9 @@+```+% pandoc -f markdown -t native+\listoffigures++\listoftables+^D+[RawBlock (Format "latex") "\\listoffigures"+,RawBlock (Format "latex") "\\listoftables"]+```
+ test/command/cite-in-inline-note.md view
@@ -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]"]]]]]+```
test/command/macros.md view
@@ -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} ```
+ test/docx/instrText_hyperlink.docx view
binary file changed (absent → 13628 bytes)
+ test/docx/instrText_hyperlink.native view
@@ -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"]]
test/markdown-reader-more.native view
@@ -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","")]
test/rst-reader.native view
@@ -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."]
test/tables.context view
@@ -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
test/tables.markdown view
@@ -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.- ----------- ---------- ------------ --------------------------+ ----------- ---------- ------------ -------------------------
test/tables.plain view
@@ -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.- ----------- ---------- ------------ --------------------------+ ----------- ---------- ------------ -------------------------
test/writer.context view
@@ -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]
test/writers-lang-and-dir.context view
@@ -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