diff options
121 files changed, 4795 insertions, 3027 deletions
diff --git a/.travis.yml b/.travis.yml index bb97802ac..06ce6e0a4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -31,10 +31,6 @@ matrix: include: # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: # https://github.com/hvr/multi-ghc-travis - - env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 OPTS="-O0 -Wall -fno-warn-unused-do-bind -Werror" FLAGS="fast embed_data_files" CABALARGS="--enable-benchmarks" - compiler: ": #GHC 7.8.4" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5], sources: [hvr-ghc]}} - # don't build benchmarks for ghc 7.10.3, because build takes too long... - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 OPTS="-O0 -Wall -fno-warn-unused-do-bind -Werror" FLAGS="fast embed_data_files" CABALARGS="" compiler: ": #GHC 7.10.3" diff --git a/INSTALL.md b/INSTALL.md index aae630838..c8f734bea 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -137,7 +137,7 @@ The easiest way to build pandoc from source is to use [stack]: 1. Install the [Haskell platform]. This will give you [GHC] and the [cabal-install] build tool. Note that pandoc requires - GHC >= 7.8. + GHC >= 7.10. 2. Update your package database: diff --git a/MANUAL.txt b/MANUAL.txt index 6e0920888..7c401f105 100644 --- a/MANUAL.txt +++ b/MANUAL.txt @@ -1,6 +1,6 @@ % Pandoc User's Guide % John MacFarlane -% January 7, 2018 +% January 18, 2018 Synopsis ======== @@ -370,7 +370,7 @@ General options : 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 @@ as the following: `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 @@ Language variables 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 @@ Typography 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,6 +1960,14 @@ extensions to Emacs Muse markup. 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 ================= @@ -2266,11 +2265,11 @@ this syntax: Here `mycode` is an identifier, `haskell` and `numberLines` are classes, and `startFrom` is an attribute with value `100`. Some output formats can use this information to do syntax highlighting. Currently, the only output formats -that uses this information are HTML, LaTeX, Docx, and Ms. If highlighting -is supported for your output format and language, then the code block above -will appear highlighted, with numbered lines. (To see which languages are -supported, type `pandoc --list-highlight-languages`.) Otherwise, the code -block above will appear as follows: +that uses this information are HTML, LaTeX, Docx, Ms, and PowerPoint. If +highlighting is supported for your output format and language, then the code +block above will appear highlighted, with numbered lines. (To see which +languages are supported, type `pandoc --list-highlight-languages`.) Otherwise, +the code block above will appear as follows: <pre id="mycode" class="haskell numberLines" startFrom="100"> <code> @@ -2607,9 +2606,9 @@ cases" involving lists. Consider this source: + First + Second: - - Fee - - Fie - - Foe + - Fee + - Fie + - Foe + Third @@ -3046,6 +3045,17 @@ template: $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 @@ all output formats, not just LaTeX: $\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 @@ If you just want a regular inline image, just make sure it is not 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, @@ -42,7 +42,10 @@ dist: man/pandoc.1 cd pandoc-${version} stack setup && stack test && cd .. && rm -rf "pandoc-${version}" -packages: winpkg debpkg macospkg +packages: checkdocs winpkg debpkg macospkg + +checkdocs: README.md + ! grep -n -e "\t" MANUAL.txt changelog debpkg: man/pandoc.1 make -C linux && \ @@ -109,4 +112,4 @@ update-website: clean: stack clean -.PHONY: deps quick full haddock install clean test bench changes_github macospkg dist prof download_stats reformat lint weigh doc/lua-filters.md packages pandoc-templates trypandoc update-website +.PHONY: deps quick full haddock install clean test bench changes_github macospkg dist prof download_stats reformat lint weigh doc/lua-filters.md packages pandoc-templates trypandoc update-website debpkg macospkg winpkg checkdocs @@ -83,7 +83,7 @@ man](http://man7.org/linux/man-pages/man7/groff_man.7.html), [groff ms](http://man7.org/linux/man-pages/man7/groff_ms.7.html), [Emacs Org mode](http://orgmode.org), [AsciiDoc](http://www.methods.co.nz/asciidoc/), [InDesign -ICML](https://www.adobe.com/content/dam/Adobe/en/devnet/indesign/cs55-docs/IDML/idml-specification.pdf), +ICML](http://wwwimages.adobe.com/www.adobe.com/content/dam/acom/en/devnet/indesign/sdk/cs6/idml/idml-cookbook.pdf), [TEI Simple](https://github.com/TEIC/TEI-Simple), [Muse](https://amusewiki.org/library/manual), [PowerPoint](https://en.wikipedia.org/wiki/Microsoft_PowerPoint) slide diff --git a/appveyor.yml b/appveyor.yml index 9401d6666..0df7abf32 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -4,6 +4,7 @@ environment: WIXBIN: "c:\\Program Files (x86)\\WiX Toolset v3.11\\bin" STACK_YAML: "c:\\pandoc\\stack.yaml" STACK_BUILD_OPTS: "-j1 --no-terminal --test --local-bin-path=.\\windows" + # see #4201, https://github.com/haskell-tools/haskell-tools/issues/277 matrix: - STACK_VERSION: "windows-i386" STACK_ROOT: "c:\\sr32" @@ -36,10 +37,7 @@ cache: # Note: to reset build cache, do the following in JavaScript # console on appveyor: -# $.ajax({ -# url: 'https://ci.appveyor.com/api/projects/jgm/pandoc/buildcache', -# type: 'DELETE'}) - +# $.ajax({ url: 'https://ci.appveyor.com/api/projects/jgm/pandoc/buildcache', type: 'DELETE'}) # We don't do a normal C build, but build in test_script via stack build: off @@ -57,7 +55,7 @@ test_script: %STACK% setup > nul %STACK% path echo "" | %STACK% clean - echo "" | %STACK% %STACK_BUILD_OPTS% install pandoc pandoc-citeproc %STACK_FLAGS% + echo "" | %STACK% install %STACK_BUILD_OPTS% pandoc pandoc-citeproc %STACK_FLAGS% after_test: # .\ in the stack commandline seems to be .\windows\ (where the stack-appveyor.yaml is) @@ -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 @@ -11337,7 +11522,7 @@ pandoc (1.5) * 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 @@ -11451,8 +11636,8 @@ pandoc (1.5) + 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 @@ -11579,7 +11764,7 @@ pandoc (1.4) * 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. @@ -11596,7 +11781,7 @@ pandoc (1.4) 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. @@ -11621,7 +11806,7 @@ pandoc (1.4) * 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. @@ -11705,8 +11890,8 @@ pandoc (1.3) * 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 @@ -11717,7 +11902,7 @@ pandoc (1.3) * 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. @@ -11735,8 +11920,8 @@ pandoc (1.3) * 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. @@ -11857,7 +12042,7 @@ pandoc (1.2.1) explicit marker. For example: A. my list - #. continued + #. continued Resolves Issue #140. + Allow continuation lines in line blocks. Also added test cases for @@ -11890,7 +12075,7 @@ pandoc (1.2.1) * Added new Haskell version of markdown2pdf, due to Paulo Tanimoto. This should be more portable than the old - shell script. + shell script. * Made 'pandoc -v' more explicit about compiler options. Resolves Issue #139. diff --git a/data/pandoc.lua b/data/pandoc.lua index b3cee4670..512b2919c 100644 --- a/data/pandoc.lua +++ b/data/pandoc.lua @@ -22,9 +22,7 @@ THIS SOFTWARE. -- @author Albert Krewinkel -- @copyright © 2017–2018 Albert Krewinkel -- @license MIT -local M = { - _VERSION = "0.4.0" -} +local M = {} local List = require 'pandoc.List' @@ -59,8 +57,12 @@ end local function create_accessor_functions (fn_template, accessors) local res = {} function add_accessors(acc, ...) - if type(acc) == "string" then + 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, ...) @@ -187,6 +189,27 @@ function AstElement:create_constructor(tag, fn, accessors) return constr end +--- Convert AstElement input into a list if necessary. +-- @local +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 +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 @@ -198,7 +221,7 @@ end M.Pandoc = AstElement:make_subtype'Pandoc' function M.Pandoc:new (blocks, meta) return { - blocks = List:new(blocks), + blocks = ensureList(blocks), meta = meta or {}, } end @@ -228,7 +251,7 @@ M.MetaValue = AstElement:make_subtype('MetaValue') -- @tparam {Block,...} blocks blocks M.MetaBlocks = M.MetaValue:create_constructor( 'MetaBlocks', - function (content) return List:new(content) end + function (content) return ensureList(content) end ) --- Meta inlines @@ -236,7 +259,7 @@ M.MetaBlocks = M.MetaValue:create_constructor( -- @tparam {Inline,...} inlines inlines M.MetaInlines = M.MetaValue:create_constructor( 'MetaInlines', - function (content) return List:new(content) end + function (content) return ensureInlineList(content) end ) --- Meta list @@ -244,7 +267,7 @@ M.MetaInlines = M.MetaValue:create_constructor( -- @tparam {MetaValue,...} meta_values list of meta values M.MetaList = M.MetaValue:create_constructor( 'MetaList', - function (content) return List:new(content) end + function (content) return ensureList(content) end ) --- Meta map @@ -284,7 +307,7 @@ M.Block = AstElement:make_subtype'Block' -- @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" ) @@ -294,7 +317,7 @@ M.BlockQuote = M.Block:create_constructor( -- @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" ) @@ -306,7 +329,7 @@ M.BulletList = M.Block:create_constructor( 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. @@ -315,7 +338,7 @@ M.CodeBlock = M.Block:create_constructor( -- @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" ) @@ -327,9 +350,9 @@ M.DefinitionList = M.Block:create_constructor( 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. @@ -341,9 +364,9 @@ M.Div = M.Block:create_constructor( 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. @@ -360,7 +383,7 @@ M.HorizontalRule = M.Block:create_constructor( -- @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" ) @@ -381,9 +404,9 @@ M.OrderedList = M.Block:create_constructor( "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. @@ -392,7 +415,7 @@ M.OrderedList = M.Block:create_constructor( -- @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" ) @@ -402,7 +425,7 @@ M.Para = M.Block:create_constructor( -- @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" ) @@ -430,7 +453,7 @@ M.Table = M.Block:create_constructor( function(caption, aligns, widths, headers, rows) return { c = { - List:new(caption), + ensureInlineList(caption), List:new(aligns), List:new(widths), List:new(headers), @@ -457,7 +480,7 @@ M.Inline = AstElement:make_subtype'Inline' 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"} ) @@ -470,7 +493,7 @@ M.Cite = M.Inline:create_constructor( 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. @@ -479,7 +502,7 @@ M.Code = M.Inline:create_constructor( -- @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" ) @@ -495,9 +518,9 @@ M.Image = M.Inline:create_constructor( 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 @@ -520,9 +543,9 @@ M.Link = M.Inline:create_constructor( 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. @@ -561,7 +584,7 @@ M.InlineMath = M.Inline:create_constructor( -- @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" ) @@ -572,7 +595,7 @@ M.Note = M.Inline:create_constructor( -- @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). @@ -613,7 +636,7 @@ M.RawInline = M.Inline:create_constructor( -- @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" ) @@ -641,9 +664,9 @@ M.Space = M.Inline:create_constructor( 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 @@ -662,7 +685,7 @@ M.Str = M.Inline:create_constructor( -- @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" ) @@ -672,7 +695,7 @@ M.Strikeout = M.Inline:create_constructor( -- @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" ) @@ -682,7 +705,7 @@ M.Strong = M.Inline:create_constructor( -- @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" ) @@ -692,7 +715,7 @@ M.Subscript = M.Inline:create_constructor( -- @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" ) @@ -795,7 +818,7 @@ end M.Attr = AstElement:make_subtype'Attr' 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 @@ -827,8 +850,8 @@ function M.Citation:new (id, mode, prefix, suffix, note_num, hash) return { id = id, mode = mode, - prefix = prefix or {}, - suffix = suffix or {}, + prefix = ensureList(prefix or {}), + suffix = ensureList(suffix or {}), note_num = note_num or 0, hash = hash or 0, } diff --git a/data/templates/default.context b/data/templates/default.context index e17d85b36..56f4e9cf7 100644 --- a/data/templates/default.context +++ b/data/templates/default.context @@ -92,6 +92,11 @@ $endif$ \setupthinrules[width=15em] % width of horizontal rules +\setupxtable[frame=off] +\setupxtable[head][topframe=on,bottomframe=on] +\setupxtable[body][] +\setupxtable[foot][bottomframe=on] + $for(header-includes)$ $header-includes$ $endfor$ diff --git a/data/templates/default.ms b/data/templates/default.ms index c13684372..f4204338a 100644 --- a/data/templates/default.ms +++ b/data/templates/default.ms @@ -40,6 +40,10 @@ $endif$ .nr FL \n[LL] .\" footnote point size .nr FPS (\n[PS] - 2000) +$if(papersize)$ +.\" paper size +.ds paper $papersize$ +$endif$ .\" color used for strikeout .defcolor strikecolor rgb 0.7 0.7 0.7 .\" color for links (rgb) diff --git a/doc/lua-filters.md b/doc/lua-filters.md index 9b82155be..6f03360bb 100644 --- a/doc/lua-filters.md +++ b/doc/lua-filters.md @@ -1433,6 +1433,37 @@ functions. print(table.concat(elements[1].numbering, '.')) -- 0.1 print(table.concat(elements[2].numbering, '.')) -- 0.2 +[`run_json_filter (doc, filter[, args])`]{#utils-run_json_filter} + +: Filter the given doc by passing it through the a JSON filter. + + Parameters: + + `doc`: + : the Pandoc document to filter + + `filter`: + : filter to run + + `args`: + : list of arguments passed to the filter. Defaults to + `{FORMAT}`. + + Returns: + + - ([Pandoc](#Pandoc)) Filtered document + + Usage: + + -- Assumes `some_blocks` contains blocks for which a + -- separate literature section is required. + local sub_doc = pandoc.Pandoc(some_blocks, metadata) + sub_doc_with_bib = pandoc.utils.run_json_filter( + sub_doc, + 'pandoc-citeproc' + ) + some_blocks = sub_doc.blocks -- some blocks with bib + [`normalize_date (date_string)`]{#utils-normalize_date} : Parse a date and convert (if possible) to "YYYY-MM-DD" diff --git a/man/pandoc.1 b/man/pandoc.1 index 8e3c9ffef..ee33b09ba 100644 --- a/man/pandoc.1 +++ b/man/pandoc.1 @@ -1,5 +1,5 @@ .\"t -.TH PANDOC 1 "January 7, 2018" "pandoc 2.1" +.TH PANDOC 1 "January 18, 2018" "pandoc 2.1.1" .SH NAME pandoc - general markup converter .SH SYNOPSIS @@ -346,7 +346,7 @@ To enable bash completion with pandoc, add this to your .IP .nf \f[C] -\ eval\ "$(pandoc\ \-\-bash\-completion)" +eval\ "$(pandoc\ \-\-bash\-completion)" \f[] .fi .RE @@ -1487,7 +1487,7 @@ specified .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 @@ stored in the additional variables \f[C]babel\-lang\f[], \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 @@ to Emacs Muse markup. .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 @@ $endif$ $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 @@ $\\tuple{a,\ b,\ c}$ \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 @@ One way to do this is to insert a nonbreaking space after the image: .IP .nf \f[C] -![This\ image\ won\[aq]t\ be\ a\ figure](/url/of/image.png)\\\ +![This\ image\ won\[aq]t\ be\ a\ figure](/url/of/image.png)\\ \f[] .fi .PP diff --git a/pandoc.cabal b/pandoc.cabal index dedeaaeca..b20b51842 100644 --- a/pandoc.cabal +++ b/pandoc.cabal @@ -1,5 +1,5 @@ name: pandoc -version: 2.1 +version: 2.1.1 cabal-version: >= 1.10 build-type: Custom license: GPL @@ -11,7 +11,7 @@ bug-reports: https://github.com/jgm/pandoc/issues 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 @@ -302,6 +302,8 @@ extra-source-files: test/docx/*.native test/epub/*.epub test/epub/*.native + test/pptx/*.pptx + test/pptx/*.native test/txt2tags.t2t test/twiki-reader.twiki test/tikiwiki-reader.tikiwiki @@ -347,6 +349,7 @@ library 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, @@ -362,10 +365,10 @@ library pandoc-types >= 1.17.3 && < 1.18, aeson >= 0.7 && < 1.3, aeson-pretty >= 0.8 && < 0.9, - tagsoup >= 0.14.2 && < 0.15, + tagsoup >= 0.14.3 && < 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 +417,6 @@ library 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 +501,16 @@ library 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 +531,8 @@ library 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 +563,6 @@ executable pandoc 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 +570,6 @@ executable pandoc 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 +581,6 @@ executable trypandoc 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 +597,6 @@ test-suite test-pandoc 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, @@ -619,7 +614,7 @@ test-suite test-pandoc 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,9 +676,6 @@ benchmark benchmark-pandoc 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, diff --git a/prelude/Prelude.hs b/prelude/Prelude.hs deleted file mode 100644 index 34f133d83..000000000 --- a/prelude/Prelude.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE CPP #-} - --- This custom Prelude emulates the API of the prelude --- with base 4.8. - -module Prelude -( - module P -#if MIN_VERSION_base(4,8,0) -#else -, Monoid(..) -, Applicative(..) -, (<$>) -, (<$) -#endif -) -where - -#if MIN_VERSION_base(4,8,0) -import "base" Prelude as P -#else -import "base" Prelude as P -import Control.Applicative -import Data.Monoid -#endif diff --git a/src/Text/Pandoc/App.hs b/src/Text/Pandoc/App.hs index ed16b07a5..26c754cd6 100644 --- a/src/Text/Pandoc/App.hs +++ b/src/Text/Pandoc/App.hs @@ -46,12 +46,11 @@ import qualified Control.Exception as E 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 @@ import Skylighting (Style, Syntax (..), defaultSyntaxMap, parseTheme, 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 System.IO.Error (isDoesNotExistError) 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 @@ type Transform = Pandoc -> Pandoc 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 @@ defaultWriterName x = 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 @@ deprecatedOption o msg = -- see https://github.com/jgm/pandoc/pull/4083 -- using generic deriving caused long compilation times $(deriveJSON defaultOptions ''LineEnding) -$(deriveJSON defaultOptions ''Filter) $(deriveJSON defaultOptions ''Opt) diff --git a/src/Text/Pandoc/Class.hs b/src/Text/Pandoc/Class.hs index f8d6b6737..ae538046a 100644 --- a/src/Text/Pandoc/Class.hs +++ b/src/Text/Pandoc/Class.hs @@ -142,11 +142,11 @@ import qualified System.Environment as IO (lookupEnv) import System.FilePath.Glob (match, compile) import System.Directory (createDirectoryIfMissing, getDirectoryContents, doesDirectoryExist) -import System.FilePath ((</>), (<.>), takeDirectory, - takeExtension, dropExtension, isRelative, normalise) +import System.FilePath + ((</>), (<.>), takeDirectory, takeExtension, dropExtension, + isRelative, normalise, splitDirectories) import qualified System.FilePath.Glob as IO (glob) import qualified System.FilePath.Posix as Posix -import System.FilePath (splitDirectories) import qualified System.Directory as IO (getModificationTime) import Control.Monad as M (fail) import Control.Monad.State.Strict diff --git a/src/Text/Pandoc/Extensions.hs b/src/Text/Pandoc/Extensions.hs index cb3490cf7..8f6d49ade 100644 --- a/src/Text/Pandoc/Extensions.hs +++ b/src/Text/Pandoc/Extensions.hs @@ -133,6 +133,7 @@ data Extension = | 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) diff --git a/src/Text/Pandoc/Filter.hs b/src/Text/Pandoc/Filter.hs new file mode 100644 index 000000000..e2a3c3e16 --- /dev/null +++ b/src/Text/Pandoc/Filter.hs @@ -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 = + foldrM ($) d $ map applyFilter filters + where + applyFilter (JSONFilter f) = JSONFilter.apply ropts args f + applyFilter (LuaFilter f) = LuaFilter.apply ropts args f + +$(deriveJSON defaultOptions ''Filter) diff --git a/src/Text/Pandoc/Filter/JSON.hs b/src/Text/Pandoc/Filter/JSON.hs new file mode 100644 index 000000000..5772c2c41 --- /dev/null +++ b/src/Text/Pandoc/Filter/JSON.hs @@ -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) diff --git a/src/Text/Pandoc/Filter/Lua.hs b/src/Text/Pandoc/Filter/Lua.hs new file mode 100644 index 000000000..597a31cbc --- /dev/null +++ b/src/Text/Pandoc/Filter/Lua.hs @@ -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) diff --git a/src/Text/Pandoc/Filter/Path.hs b/src/Text/Pandoc/Filter/Path.hs new file mode 100644 index 000000000..8074bcbb7 --- /dev/null +++ b/src/Text/Pandoc/Filter/Path.hs @@ -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 diff --git a/src/Text/Pandoc/ImageSize.hs b/src/Text/Pandoc/ImageSize.hs index 4ac1d535f..65559e1ce 100644 --- a/src/Text/Pandoc/ImageSize.hs +++ b/src/Text/Pandoc/ImageSize.hs @@ -83,6 +83,7 @@ data Dimension = Pixel Integer | Inch Double | Percent Double | Em Double + deriving Eq instance Show Dimension where show (Pixel a) = show a ++ "px" diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs index 48518aa54..790be47d5 100644 --- a/src/Text/Pandoc/Lua.hs +++ b/src/Text/Pandoc/Lua.hs @@ -39,21 +39,22 @@ import Text.Pandoc.Definition (Pandoc) 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 @@ -64,7 +65,7 @@ runLuaFilter' filterPath format pd = do newtop <- Lua.gettop -- Use the returned filters, or the implicitly defined global filter if -- nothing was returned. - luaFilters <- if (newtop - top >= 1) + luaFilters <- if newtop - top >= 1 then peek (-1) else Lua.getglobal "_G" *> fmap (:[]) popValue runAll luaFilters pd @@ -73,5 +74,9 @@ runLuaFilter' filterPath format pd = do push format Lua.setglobal "FORMAT" + registerReaderOptions = do + push ropts + Lua.setglobal "PANDOC_READER_OPTIONS" + runAll :: [LuaFilter] -> Pandoc -> Lua Pandoc runAll = foldr ((>=>) . walkMWithLuaFilter) return diff --git a/src/Text/Pandoc/Lua/Filter.hs b/src/Text/Pandoc/Lua/Filter.hs index 9e109bb52..cc2b9d47e 100644 --- a/src/Text/Pandoc/Lua/Filter.hs +++ b/src/Text/Pandoc/Lua/Filter.hs @@ -11,6 +11,7 @@ module Text.Pandoc.Lua.Filter ( LuaFilterFunction , 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 Text.Pandoc.Walk (walkM, Walkable) 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 @@ registerFilterFunction idx = do 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 @@ elementOrList x = do mbres <- Lua.peekEither topOfStack case mbres of Right res -> [res] <$ Lua.pop 1 - Left _ -> Lua.toList topOfStack <* Lua.pop 1 + Left _ -> do + typeCheck Lua.stackTop Lua.TypeTable + Lua.toList topOfStack `finally` Lua.pop 1 -- | Try running a filter for the given element tryFilter :: (Data a, FromLuaStack a, ToLuaStack a) diff --git a/src/Text/Pandoc/Lua/Module/Utils.hs b/src/Text/Pandoc/Lua/Module/Utils.hs index b453b38d7..f8eb96dc7 100644 --- a/src/Text/Pandoc/Lua/Module/Utils.hs +++ b/src/Text/Pandoc/Lua/Module/Utils.hs @@ -30,22 +30,26 @@ module Text.Pandoc.Lua.Module.Utils ) 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 @@ -62,6 +66,25 @@ hierarchicalize = return . Shared.hierarchicalize 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 -> Lua String diff --git a/src/Text/Pandoc/Lua/Packages.hs b/src/Text/Pandoc/Lua/Packages.hs index dda2dd2fe..1e6ff22fe 100644 --- a/src/Text/Pandoc/Lua/Packages.hs +++ b/src/Text/Pandoc/Lua/Packages.hs @@ -78,7 +78,8 @@ pandocPackageSearcher luaPkgParams pkgName = "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 @@ -112,4 +113,3 @@ dataDirScript datadir moduleFile = do return $ case res of Left _ -> Nothing Right s -> Just (unpack s) - diff --git a/src/Text/Pandoc/Lua/StackInstances.hs b/src/Text/Pandoc/Lua/StackInstances.hs index 531261099..a504e5626 100644 --- a/src/Text/Pandoc/Lua/StackInstances.hs +++ b/src/Text/Pandoc/Lua/StackInstances.hs @@ -16,8 +16,9 @@ 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 FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- | Module : Text.Pandoc.Lua.StackInstances @@ -34,30 +35,43 @@ module Text.Pandoc.Lua.StackInstances () where 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 @@ pushMetaValue = \case -- | 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 @@ pushBlock = \case -- | 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 @@ pushInline = \case -- | 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 @@ getTag idx = do 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 @@ instance ToLuaStack LuaAttr where 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,42 @@ instance ToLuaStack Element where Lua.push "__index" Lua.pushvalue (-2) Lua.rawset (-3) + + +-- +-- Reader Options +-- +instance ToLuaStack Extensions where + push exts = push (show exts) + +instance ToLuaStack TrackChanges where + push = push . showConstr . toConstr + +instance ToLuaStack a => ToLuaStack (Set.Set a) where + push set = do + Lua.newtable + forM_ set (`LuaUtil.addValue` True) + +instance ToLuaStack ReaderOptions where + push ro = do + let ReaderOptions + (extensions :: Extensions) + (standalone :: Bool) + (columns :: Int) + (tabStop :: Int) + (indentedCodeClasses :: [String]) + (abbreviations :: Set.Set String) + (defaultImageExtension :: String) + (trackChanges :: TrackChanges) + (stripComments :: Bool) + = ro + Lua.newtable + LuaUtil.addValue "extensions" extensions + LuaUtil.addValue "standalone" standalone + LuaUtil.addValue "columns" columns + LuaUtil.addValue "tabStop" tabStop + LuaUtil.addValue "indentedCodeClasses" indentedCodeClasses + LuaUtil.addValue "abbreviations" abbreviations + LuaUtil.addValue "defaultImageExtension" defaultImageExtension + LuaUtil.addValue "trackChanges" trackChanges + LuaUtil.addValue "stripComments" stripComments diff --git a/src/Text/Pandoc/Lua/Util.hs b/src/Text/Pandoc/Lua/Util.hs index 799b45b72..a3af155c9 100644 --- a/src/Text/Pandoc/Lua/Util.hs +++ b/src/Text/Pandoc/Lua/Util.hs @@ -36,6 +36,7 @@ module Text.Pandoc.Lua.Util , getRawInt , setRawInt , addRawInt + , typeCheck , raiseError , popValue , PushViaCall @@ -100,6 +101,14 @@ setRawInt idx key value = do 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 Lua.push e diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs index 9573d7875..e87ea71da 100644 --- a/src/Text/Pandoc/Parsing.hs +++ b/src/Text/Pandoc/Parsing.hs @@ -180,6 +180,7 @@ module Text.Pandoc.Parsing ( takeWhileP, sourceLine, setSourceColumn, setSourceLine, + incSourceColumn, newPos, Line, Column @@ -188,12 +189,12 @@ where import Control.Monad.Identity import Control.Monad.Reader -import Data.Char (chr, isAlphaNum, isAscii, isAsciiUpper, isHexDigit, isPunctuation, isSpace, - ord, toLower, toUpper) +import Data.Char (chr, isAlphaNum, isAscii, isAsciiUpper, isHexDigit, + isPunctuation, isSpace, ord, toLower, toUpper) import Data.Default import Data.List (intercalate, isSuffixOf, transpose) import qualified Data.Map as M -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import Data.Monoid ((<>)) import qualified Data.Set as Set import Data.Text (Text) @@ -303,7 +304,7 @@ indentWith :: Stream s m Char => Int -> ParserT s st m [Char] indentWith num = do tabStop <- getOption readerTabStop - if (num < tabStop) + if num < tabStop then count num (char ' ') else choice [ try (count num (char ' ')) , try (char '\t' >> indentWith (num - tabStop)) ] @@ -572,7 +573,7 @@ uri = try $ do let uriChunk = skipMany1 wordChar <|> percentEscaped <|> entity - <|> (try $ punct >> + <|> try (punct >> lookAhead (void (satisfy isWordChar) <|> percentEscaped)) str <- snd <$> withRaw (skipMany1 ( () <$ (enclosed (char '(') (char ')') uriChunk @@ -754,7 +755,7 @@ romanOne = (char 'i' >> return (LowerRoman, 1)) <|> -- | Parses an ordered list marker and returns list attributes. anyOrderedListMarker :: Stream s m Char => ParserT s ParserState m ListAttributes -anyOrderedListMarker = choice $ +anyOrderedListMarker = choice [delimParser numParser | delimParser <- [inPeriod, inOneParen, inTwoParens], numParser <- [decimal, exampleNum, defaultNum, romanOne, lowerAlpha, lowerRoman, upperAlpha, upperRoman]] @@ -895,7 +896,7 @@ widthsFromIndices numColumns' indices = quotient = if totLength > numColumns then fromIntegral totLength else fromIntegral numColumns - fracs = map (\l -> (fromIntegral l) / quotient) lengths in + fracs = map (\l -> fromIntegral l / quotient) lengths in tail fracs --- @@ -976,7 +977,7 @@ gridTableHeader headless blocks = try $ do then replicate (length underDashes) "" else map (unlines . map trim) $ transpose $ map (gridTableSplitLine indices) rawContent - heads <- fmap sequence $ mapM (parseFromString blocks . trim) rawHeads + heads <- sequence <$> mapM (parseFromString blocks . trim) rawHeads return (heads, aligns, indices) gridTableRawLine :: Stream s m Char => [Int] -> ParserT s st m [String] @@ -1322,9 +1323,7 @@ failIfInQuoteContext :: (HasQuoteContext st m, Stream s m t) -> ParserT s st m () failIfInQuoteContext context = do context' <- getQuoteContext - if context' == context - then fail "already inside quotes" - else return () + when (context' == context) $ fail "already inside quotes" charOrRef :: Stream s m Char => String -> ParserT s st m Char charOrRef cs = @@ -1417,9 +1416,7 @@ a <+?> b = a >>= flip fmap (try b <|> return mempty) . (<>) extractIdClass :: Attr -> Attr extractIdClass (ident, cls, kvs) = (ident', cls', kvs') where - ident' = case lookup "id" kvs of - Just v -> v - Nothing -> ident + ident' = fromMaybe ident (lookup "id" kvs) cls' = case lookup "class" kvs of Just cl -> words cl Nothing -> cls diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs index e0f32b908..c24c43901 100644 --- a/src/Text/Pandoc/Readers/Docx.hs +++ b/src/Text/Pandoc/Readers/Docx.hs @@ -81,7 +81,7 @@ import qualified Data.ByteString.Lazy as B import Data.Default (Default) import Data.List (delete, intersect) import qualified Data.Map as M -import Data.Maybe (isJust) +import Data.Maybe (isJust, fromMaybe) import Data.Sequence (ViewL (..), viewl) import qualified Data.Sequence as Seq import qualified Data.Set as Set @@ -187,7 +187,7 @@ bodyPartsToMeta' :: PandocMonad m => [BodyPart] -> DocxContext m (M.Map String M bodyPartsToMeta' [] = return M.empty bodyPartsToMeta' (bp : bps) | (Paragraph pPr parParts) <- bp - , (c : _)<- intersect (pStyle pPr) (M.keys metaStyles) + , (c : _)<- (pStyle pPr) `intersect` (M.keys metaStyles) , (Just metaField) <- M.lookup c metaStyles = do inlines <- smushInlines <$> mapM parPartToInlines parParts remaining <- bodyPartsToMeta' bps @@ -340,7 +340,7 @@ blocksToInlinesWarn cmtId blks = do notParaOrPlain (Para _) = False notParaOrPlain (Plain _) = False notParaOrPlain _ = True - unless (null $ filter notParaOrPlain blkList) $ + unless ( not (any notParaOrPlain blkList)) $ lift $ P.report $ DocxParserWarning $ "Docx comment " ++ cmtId ++ " will not retain formatting" return $ blocksToInlines' blkList @@ -351,7 +351,7 @@ blocksToInlinesWarn cmtId blks = do parPartToInlines :: PandocMonad m => ParPart -> DocxContext m Inlines parPartToInlines parPart = case parPart of - (BookMark _ anchor) | not $ anchor `elem` dummyAnchors -> do + (BookMark _ anchor) | notElem anchor dummyAnchors -> do inHdrBool <- asks docxInHeaderBlock ils <- parPartToInlines' parPart immedPrevAnchor <- gets docxImmedPrevAnchor @@ -444,8 +444,13 @@ parPartToInlines' (ExternalHyperLink target runs) = do return $ link target "" ils parPartToInlines' (PlainOMath exps) = return $ math $ writeTeX exps -parPartToInlines' (SmartTag runs) = do +parPartToInlines' (SmartTag runs) = smushInlines <$> mapM runToInlines runs +parPartToInlines' (Field info runs) = + 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) _) = @@ -621,9 +626,7 @@ bodyPartToBlocks (ListItem pPr numId lvl (Just levelInfo) parparts) = do (_, fmt,txt, startFromLevelInfo) = levelInfo start = case startFromState of Just n -> n + 1 - Nothing -> case startFromLevelInfo of - Just n' -> n' - Nothing -> 1 + Nothing -> fromMaybe 1 startFromLevelInfo kvs = [ ("level", lvl) , ("num-id", numId) , ("format", fmt) diff --git a/src/Text/Pandoc/Readers/Docx/Fields.hs b/src/Text/Pandoc/Readers/Docx/Fields.hs new file mode 100644 index 000000000..6eeb55d2f --- /dev/null +++ b/src/Text/Pandoc/Readers/Docx/Fields.hs @@ -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 = + (try escapedQuote) <|> (anyChar >>= (\c -> return [c])) + +quotedString :: Parser String +quotedString = do + char '"' + concat <$> manyTill inQuotes (try (char '"')) + +unquotedString :: Parser String +unquotedString = manyTill anyChar (try $ lookAhead space *> return () <|> eof) + +fieldArgument :: Parser String +fieldArgument = quotedString <|> unquotedString + +-- there are other switches, but this is the only one I've seen in the wild so far, so it's the first one I'll implement. See §17.16.5.25 +hyperlinkSwitch :: Parser (String, String) +hyperlinkSwitch = do + sw <- string "\\l" + spaces + farg <- fieldArgument + return (sw, farg) + +hyperlink :: Parser URL +hyperlink = do + many space + string "HYPERLINK" + spaces + farg <- fieldArgument + switches <- spaces *> many hyperlinkSwitch + let url = case switches of + ("\\l", s) : _ -> farg ++ ('#': s) + _ -> farg + return url diff --git a/src/Text/Pandoc/Readers/Docx/Lists.hs b/src/Text/Pandoc/Readers/Docx/Lists.hs index fa4870fff..c0f05094a 100644 --- a/src/Text/Pandoc/Readers/Docx/Lists.hs +++ b/src/Text/Pandoc/Readers/Docx/Lists.hs @@ -44,14 +44,14 @@ isListItem (Div (_, classes, _) _) | "list-item" `elem` classes = True isListItem _ = False getLevel :: Block -> Maybe Integer -getLevel (Div (_, _, kvs) _) = fmap read $ lookup "level" kvs +getLevel (Div (_, _, kvs) _) = read <$> lookup "level" kvs getLevel _ = Nothing getLevelN :: Block -> Integer getLevelN b = fromMaybe (-1) (getLevel b) getNumId :: Block -> Maybe Integer -getNumId (Div (_, _, kvs) _) = fmap read $ lookup "num-id" kvs +getNumId (Div (_, _, kvs) _) = read <$> lookup "num-id" kvs getNumId _ = Nothing getNumIdN :: Block -> Integer @@ -140,8 +140,8 @@ flatToBullets' num xs@(b : elems) (children, remaining) = span (\b' -> - (getLevelN b') > bLevel || - ((getLevelN b') == bLevel && (getNumIdN b') == bNumId)) + getLevelN b' > bLevel || + (getLevelN b' == bLevel && getNumIdN b' == bNumId)) xs in case getListType b of diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs index b79b39369..c123a0018 100644 --- a/src/Text/Pandoc/Readers/Docx/Parse.hs +++ b/src/Text/Pandoc/Readers/Docx/Parse.hs @@ -54,6 +54,7 @@ module Text.Pandoc.Readers.Docx.Parse ( Docx(..) , TrackedChange(..) , ChangeType(..) , ChangeInfo(..) + , FieldInfo(..) , archiveToDocx , archiveToDocxWithWarnings ) where @@ -70,6 +71,7 @@ import qualified Data.Map as M 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 @@ data ReaderEnv = ReaderEnv { envNotes :: Notes } 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 @@ data ParPart = PlainRun Run | 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 @@ archiveToDocxWithWarnings archive = do (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) @@ -342,9 +358,7 @@ archiveToDocument zf = do docElem <- maybeToD $ (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry let namespaces = elemToNameSpaces docElem bodyElem <- maybeToD $ findChildByName namespaces "w" "body" docElem - let bodyElem' = case walkDocument namespaces bodyElem of - Just e -> e - Nothing -> bodyElem + let bodyElem' = fromMaybe bodyElem (walkDocument namespaces bodyElem) body <- elemToBody namespaces bodyElem' return $ Document namespaces body @@ -587,7 +601,7 @@ elemToTblLook ns element | isElem ns "w" "tblLook" element = Just bitMask -> testBitMask bitMask 0x020 Nothing -> False in - return $ TblLook{firstRowFormatting = firstRowFmt} + return TblLook{firstRowFormatting = firstRowFmt} elemToTblLook _ _ = throwError WrongElem elemToRow :: NameSpaces -> Element -> D Row @@ -607,7 +621,7 @@ elemToCell _ _ = throwError WrongElem elemToParIndentation :: NameSpaces -> Element -> Maybe ParIndentation elemToParIndentation ns element | isElem ns "w" "ind" element = - Just $ ParIndentation { + Just ParIndentation { leftParIndent = findAttrByName ns "w" "left" element >>= stringToInteger @@ -736,9 +750,77 @@ elemToParPart ns element , 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) @@ -1089,8 +1171,7 @@ elemToRunElems ns element let font = do fontElem <- findElement (qualName "rFonts") element stringToFont =<< - foldr (<|>) Nothing ( - map (flip findAttr fontElem . qualName) ["ascii", "hAnsi"]) + foldr ((<|>) . (flip findAttr fontElem . qualName)) Nothing ["ascii", "hAnsi"] local (setFont font) (mapD (elemToRunElem ns) (elChildren element)) elemToRunElems _ _ = throwError WrongElem diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs index e8dd9ec11..0e79f9ec3 100644 --- a/src/Text/Pandoc/Readers/HTML.hs +++ b/src/Text/Pandoc/Readers/HTML.hs @@ -43,14 +43,14 @@ module Text.Pandoc.Readers.HTML ( readHtml ) where import Control.Applicative ((<|>)) -import Control.Arrow ((***)) +import Control.Arrow (first) import Control.Monad (guard, mplus, msum, mzero, unless, void) import Control.Monad.Except (throwError) import Control.Monad.Reader (ReaderT, ask, asks, lift, local, runReaderT) import Data.Char (isAlphaNum, isDigit, isLetter) import Data.Default (Default (..), def) import Data.Foldable (for_) -import Data.List (intercalate, isPrefixOf) +import Data.List (isPrefixOf) import Data.List.Split (wordsBy, splitWhen) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust, isNothing) @@ -531,15 +531,18 @@ pCol = try $ do 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 @@ -774,7 +777,7 @@ pCode = try $ do (TagOpen open attr') <- pSatisfy $ tagOpen (`elem` ["code","tt"]) (const True) let attr = toStringAttr attr' result <- manyTill pAnyTag (pCloses open) - return $ B.codeWith (mkAttr attr) $ intercalate " " $ lines $ T.unpack $ + return $ B.codeWith (mkAttr attr) $ unwords $ lines $ T.unpack $ innerText result pSpan :: PandocMonad m => TagParser m Inlines @@ -1224,7 +1227,7 @@ stripPrefixes = map stripPrefix stripPrefix :: Tag Text -> Tag Text stripPrefix (TagOpen s as) = - TagOpen (stripPrefix' s) (map (stripPrefix' *** id) as) + TagOpen (stripPrefix' s) (map (first stripPrefix') as) stripPrefix (TagClose s) = TagClose (stripPrefix' s) stripPrefix x = x diff --git a/src/Text/Pandoc/Readers/JATS.hs b/src/Text/Pandoc/Readers/JATS.hs index 9223db68c..8158a4511 100644 --- a/src/Text/Pandoc/Readers/JATS.hs +++ b/src/Text/Pandoc/Readers/JATS.hs @@ -494,4 +494,3 @@ parseInline (Elem e) = "" -> [] l -> [l] return $ codeWith (attrValue "id" e,classes',[]) $ strContentRecursive e - diff --git a/src/Text/Pandoc/Readers/LaTeX.hs b/src/Text/Pandoc/Readers/LaTeX.hs index 62d240688..1ce3d18e5 100644 --- a/src/Text/Pandoc/Readers/LaTeX.hs +++ b/src/Text/Pandoc/Readers/LaTeX.hs @@ -272,10 +272,8 @@ rawLaTeXBlock = do 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 @@ totoks pos t = -> (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' @@ -350,7 +351,7 @@ totoks pos t = Tok pos (Arg i) ("#" <> t1) : totoks (incSourceColumn pos (1 + T.length t1)) t2 Nothing -> - Tok pos Symbol ("#") + Tok pos Symbol "#" : totoks (incSourceColumn pos 1) t2 | c == '^' -> case T.uncons rest of @@ -368,10 +369,10 @@ totoks pos t = | d < '\128' -> Tok pos Esc1 (T.pack ['^','^',d]) : totoks (incSourceColumn pos 3) rest'' - _ -> Tok pos Symbol ("^") : - Tok (incSourceColumn pos 1) Symbol ("^") : + _ -> Tok pos Symbol "^" : + Tok (incSourceColumn pos 1) Symbol "^" : totoks (incSourceColumn pos 2) rest' - _ -> Tok pos Symbol ("^") + _ -> Tok pos Symbol "^" : totoks (incSourceColumn pos 1) rest | otherwise -> Tok pos Symbol (T.singleton c) : totoks (incSourceColumn pos 1) rest @@ -404,7 +405,7 @@ satisfyTok f = | 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 @@ doMacros n = do 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)) = + 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 @@ -1240,7 +1244,7 @@ inlineEnvironments = M.fromList [ ] inlineCommands :: PandocMonad m => M.Map Text (LP m Inlines) -inlineCommands = M.union inlineLanguageCommands $ M.fromList $ +inlineCommands = M.union inlineLanguageCommands $ M.fromList [ ("emph", extractSpaces emph <$> tok) , ("textit", extractSpaces emph <$> tok) , ("textsl", extractSpaces emph <$> tok) @@ -1497,7 +1501,7 @@ foreignlanguage :: PandocMonad m => LP m Inlines foreignlanguage = do babelLang <- T.unpack . untokenize <$> braced case babelLangToBCP47 babelLang of - Just lang -> spanWith ("", [], [("lang", renderLang $ lang)]) <$> tok + Just lang -> spanWith ("", [], [("lang", renderLang lang)]) <$> tok _ -> tok inlineLanguageCommands :: PandocMonad m => M.Map Text (LP m Inlines) @@ -2017,7 +2021,7 @@ closing = do return $ para (trimInlines contents) <> sigs blockCommands :: PandocMonad m => M.Map Text (LP m Blocks) -blockCommands = M.fromList $ +blockCommands = M.fromList [ ("par", mempty <$ skipopts) , ("parbox", skipopts >> braced >> grouped blocks) , ("title", mempty <$ (skipopts *> @@ -2101,7 +2105,7 @@ environments = M.fromList resetCaption *> simpTable "longtable" False >>= addTableCaption) , ("table", env "table" $ resetCaption *> skipopts *> blocks >>= addTableCaption) - , ("tabular*", env "tabular" $ simpTable "tabular*" True) + , ("tabular*", env "tabular*" $ simpTable "tabular*" True) , ("tabularx", env "tabularx" $ simpTable "tabularx" True) , ("tabular", env "tabular" $ simpTable "tabular" False) , ("quote", blockQuote <$> env "quote" blocks) @@ -2440,7 +2444,7 @@ parseAligns = try $ do spaces spec <- braced case safeRead ds of - Just n -> do + Just n -> getInput >>= setInput . (mconcat (replicate n spec) ++) Nothing -> fail $ "Could not parse " ++ ds ++ " as number" bgroup diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs index aaefa5ba1..14cf73de4 100644 --- a/src/Text/Pandoc/Readers/Markdown.hs +++ b/src/Text/Pandoc/Readers/Markdown.hs @@ -36,7 +36,7 @@ import Control.Monad import Control.Monad.Except (throwError) import Data.Char (isAlphaNum, isPunctuation, isSpace, toLower) import qualified Data.HashMap.Strict as H -import Data.List (findIndex, intercalate, sortBy, transpose) +import Data.List (intercalate, sortBy, transpose, elemIndex) import qualified Data.Map as M import Data.Maybe import Data.Monoid ((<>)) @@ -122,6 +122,13 @@ spnl = try $ do 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,25 @@ litChar = escapedChar' -- | 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 = + (() <$ (escapedChar <|> + code <|> + rawHtmlInline <|> + rawLaTeXInline') >> go openBrackets) + <|> + (do char ']' + Control.Monad.when (openBrackets > 1) $ go (openBrackets - 1)) + <|> + (char '[' >> go (openBrackets + 1)) + <|> + (anyChar >> go openBrackets) -- -- document structure @@ -242,13 +255,13 @@ yamlMetaBlock = try $ do v' <- yamlToMeta v let k' = T.unpack k updateState $ \st -> st{ stateMeta' = - (do m <- stateMeta' st - -- if there's already a value, leave it unchanged - case lookupMeta k' m of - Just _ -> return m - Nothing -> do - v'' <- v' - return $ B.setMeta (T.unpack k) v'' m)} + do m <- stateMeta' st + -- if there's already a value, leave it unchanged + case lookupMeta k' m of + Just _ -> return m + Nothing -> do + v'' <- v' + return $ B.setMeta (T.unpack k) v'' m} ) alist Right Yaml.Null -> return () Right _ -> do @@ -581,7 +594,7 @@ setextHeader = try $ do underlineChar <- oneOf setextHChars many (char underlineChar) blanklines - let level = fromMaybe 0 (findIndex (== underlineChar) setextHChars) + 1 + let level = fromMaybe 0 (elemIndex underlineChar setextHChars) + 1 attr' <- registerHeader attr (runF text defaultParserState) guardDisabled Ext_implicit_header_references <|> registerImplicitHeader raw attr' @@ -836,7 +849,7 @@ orderedListStart mbstydelim = try $ do return (num, style, delim)) listStart :: PandocMonad m => MarkdownParser m () -listStart = bulletListStart <|> (Control.Monad.void (orderedListStart Nothing)) +listStart = bulletListStart <|> Control.Monad.void (orderedListStart Nothing) listLine :: PandocMonad m => Int -> MarkdownParser m String listLine continuationIndent = try $ do @@ -866,7 +879,7 @@ rawListItem fourSpaceRule start = try $ do pos2 <- getPosition let continuationIndent = if fourSpaceRule then 4 - else (sourceColumn pos2 - sourceColumn pos1) + else sourceColumn pos2 - sourceColumn pos1 first <- listLineCommon rest <- many (do notFollowedBy listStart notFollowedBy (() <$ codeBlockFenced) @@ -897,10 +910,10 @@ listContinuation continuationIndent = try $ do return $ concat (x:xs) ++ blanks notFollowedByDivCloser :: PandocMonad m => MarkdownParser m () -notFollowedByDivCloser = do +notFollowedByDivCloser = guardDisabled Ext_fenced_divs <|> - do divLevel <- stateFencedDivLevel <$> getState - guard (divLevel < 1) <|> notFollowedBy divFenceEnd + do divLevel <- stateFencedDivLevel <$> getState + guard (divLevel < 1) <|> notFollowedBy divFenceEnd notFollowedByHtmlCloser :: PandocMonad m => MarkdownParser m () notFollowedByHtmlCloser = do @@ -1117,10 +1130,9 @@ rawTeXBlock = do 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 @@ -1208,7 +1220,7 @@ simpleTableHeader headless = try $ do if headless then lookAhead anyLine else return rawContent - let aligns = zipWith alignType (map ((: [])) rawHeads) lengths + let aligns = zipWith alignType (map (: []) rawHeads) lengths let rawHeads' = if headless then replicate (length dashes) "" else rawHeads @@ -1404,11 +1416,11 @@ pipeTableHeaderPart = try $ do skipMany spaceChar let len = length pipe + maybe 0 (const 1) left + maybe 0 (const 1) right return - ((case (left,right) of - (Nothing,Nothing) -> AlignDefault - (Just _,Nothing) -> AlignLeft - (Nothing,Just _) -> AlignRight - (Just _,Just _) -> AlignCenter), len) + (case (left,right) of + (Nothing,Nothing) -> AlignDefault + (Just _,Nothing) -> AlignLeft + (Nothing,Just _) -> AlignRight + (Just _,Just _) -> AlignCenter, len) -- Succeed only if current line contains a pipe. scanForPipe :: PandocMonad m => ParserT [Char] st m () @@ -1915,7 +1927,7 @@ rawConTeXtEnvironment = try $ do (try $ string "\\stop" >> string completion) return $ "\\start" ++ completion ++ concat contents ++ "\\stop" ++ completion -inBrackets :: PandocMonad m => (ParserT [Char] st m Char) -> ParserT [Char] st m String +inBrackets :: PandocMonad m => ParserT [Char] st m Char -> ParserT [Char] st m String inBrackets parser = do char '[' contents <- many parser @@ -1959,7 +1971,6 @@ divHtml = try $ do divFenced :: PandocMonad m => MarkdownParser m (F Blocks) divFenced = try $ do guardEnabled Ext_fenced_divs - nonindentSpaces string ":::" skipMany (char ':') skipMany spaceChar @@ -1974,7 +1985,6 @@ divFenced = try $ do divFenceEnd :: PandocMonad m => MarkdownParser m () divFenceEnd = try $ do - nonindentSpaces string ":::" skipMany (char ':') blanklines @@ -2136,6 +2146,6 @@ doubleQuoted :: PandocMonad m => MarkdownParser m (F Inlines) doubleQuoted = try $ do doubleQuoteStart contents <- mconcat <$> many (try $ notFollowedBy doubleQuoteEnd >> inline) - (withQuoteContext InDoubleQuote $ doubleQuoteEnd >> return + withQuoteContext InDoubleQuote (doubleQuoteEnd >> return (fmap B.doubleQuoted . trimInlinesF $ contents)) - <|> (return $ return (B.str "\8220") <> contents) + <|> return (return (B.str "\8220") <> contents) diff --git a/src/Text/Pandoc/Readers/Muse.hs b/src/Text/Pandoc/Readers/Muse.hs index 78c567759..8f36db9d1 100644 --- a/src/Text/Pandoc/Readers/Muse.hs +++ b/src/Text/Pandoc/Readers/Muse.hs @@ -42,7 +42,8 @@ module Text.Pandoc.Readers.Muse (readMuse) where 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) @@ -78,7 +79,8 @@ type MuseParser = ParserT String ParserState parseMuse :: PandocMonad m => MuseParser m Pandoc parseMuse = do many directive - blocks <- parseBlocks + blocks <- mconcat <$> many block + eof st <- getState let doc = runF (do Pandoc _ bs <- B.doc <$> blocks meta <- stateMeta' st @@ -86,13 +88,6 @@ parseMuse = do reportLogMessages return doc -parseBlocks :: PandocMonad m => MuseParser m (F Blocks) -parseBlocks = do - res <- mconcat <$> many block - spaces - eof - return res - -- -- utility functions -- @@ -155,10 +150,8 @@ parseDirectiveKey = do parseEmacsDirective :: PandocMonad m => MuseParser m (String, F Inlines) parseEmacsDirective = do key <- parseDirectiveKey - space - spaces - raw <- manyTill anyChar eol - value <- parseFromString (trimInlinesF . mconcat <$> many inline) raw + spaceChar + value <- trimInlinesF . mconcat <$> manyTill (choice inlineList) eol return (key, value) parseAmuseDirective :: PandocMonad m => MuseParser m (String, F Inlines) @@ -187,17 +180,19 @@ directive = do -- 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 +216,7 @@ blockElements = choice [ comment 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 +252,26 @@ example = try $ do -- 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 +315,6 @@ verseLine = do verseLines :: PandocMonad m => MuseParser m (F Blocks) verseLines = do - 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 +322,7 @@ verseLines = do 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 @@ -330,9 +335,8 @@ para = do let f = if st /= ListItemState && indent >= 2 && indent < 6 then B.blockQuote else id fmap (f . B.para) . trimInlinesF . mconcat <$> many1Till inline endOfParaElement where - endOfParaElement = lookAhead $ endOfInput <|> endOfPara <|> newBlockElement + endOfParaElement = lookAhead $ endOfInput <|> newBlockElement endOfInput = try $ skipMany blankline >> skipSpaces >> eof - endOfPara = try $ blankline >> skipMany1 blankline newBlockElement = try $ blankline >> void blockElements noteMarker :: PandocMonad m => MuseParser m String @@ -349,7 +353,7 @@ amuseNoteBlock = try $ do 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 @@ -379,31 +383,28 @@ emacsNoteBlock = try $ do -- Verse markup -- -lineVerseLine :: PandocMonad m => MuseParser m String +lineVerseLine :: PandocMonad m => MuseParser m (F Inlines) lineVerseLine = try $ do - char '>' - white <- many1 (char ' ' >> pure '\160') - rest <- anyLine - return $ tail white ++ rest + string "> " + indent <- B.str <$> many (char ' ' >> pure '\160') + rest <- manyTill (choice inlineList) eol + return $ trimInlinesF $ mconcat (pure indent : rest) -blanklineVerseLine :: PandocMonad m => MuseParser m Char -blanklineVerseLine = try $ char '>' >> blankline +blanklineVerseLine :: PandocMonad m => MuseParser m (F Inlines) +blanklineVerseLine = try $ do + char '>' + blankline + pure mempty lineBlock :: PandocMonad m => MuseParser m (F Blocks) lineBlock = try $ do - lns <- many1 (pure <$> blanklineVerseLine <|> lineVerseLine) - lns' <- mapM (parseFromString' (trimInlinesF . mconcat <$> many inline)) lns - return $ B.lineBlock <$> sequence lns' + lns <- many1 (blanklineVerseLine <|> lineVerseLine) + return $ B.lineBlock <$> sequence lns -- -- 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 +414,71 @@ withListContext p = do 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 a -> 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) (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 - -definitionListItem :: PandocMonad m => MuseParser m (F (Inlines, [Blocks])) -definitionListItem = try $ do - rawTerm <- termParser - 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 + first <- listItemContents + rest <- many $ listItem (col - 1) (orderedListMarker style delim) + return $ B.orderedListWith p <$> sequence (first : rest) + +definitionListItem :: PandocMonad m => Int -> MuseParser m (F (Inlines, [Blocks])) +definitionListItem n = try $ do + count n spaceChar + pos <- getPosition + term <- trimInlinesF . mconcat <$> manyTill (choice inlineList) (string "::") + void spaceChar <|> lookAhead eol + contents <- listItemContents' $ sourceColumn pos + 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 +definitionList = try $ do + many spaceChar + pos <- getPosition + guardDisabled Ext_amuse <|> guard (sourceColumn pos /= 1) -- Initial space is required by Amusewiki, but not Emacs Muse + first <- definitionListItem 0 + rest <- many $ try (optionMaybe blankline >> definitionListItem (sourceColumn pos - 1)) + return $ B.definitionList <$> sequence (first : rest) -- -- tables @@ -590,16 +566,14 @@ tableParseCaption :: PandocMonad m => MuseParser m MuseTableElement tableParseCaption = try $ do many spaceChar string "|+" - contents <- trimInlinesF . mconcat <$> many1Till inline (lookAhead $ string "+|") - string "+|" - return $ MuseCaption contents + MuseCaption <$> (trimInlinesF . mconcat <$> many1Till inline (string "+|")) -- -- inline parsers -- inlineList :: PandocMonad m => [MuseParser m (F Inlines)] -inlineList = [ endline +inlineList = [ whitespace , br , anchor , footnote @@ -617,13 +591,12 @@ inlineList = [ endline , code , codeTag , inlineLiteralTag - , whitespace , str , symbol ] inline :: PandocMonad m => MuseParser m (F Inlines) -inline = choice inlineList <?> "inline" +inline = choice [endline, linebreak] <|> choice inlineList <?> "inline" endline :: PandocMonad m => MuseParser m (F Inlines) endline = try $ do @@ -657,23 +630,23 @@ footnote = try $ do let contents' = runF contents st { stateNotes' = M.empty } return $ B.note contents' +linebreak :: PandocMonad m => MuseParser m (F Inlines) +linebreak = try $ do + skipMany spaceChar + newline + notFollowedBy newline + return $ return B.space + whitespace :: PandocMonad m => MuseParser m (F Inlines) -whitespace = fmap return (lb <|> regsp) - where lb = try $ skipMany spaceChar >> linebreak >> return B.space - regsp = try $ skipMany1 spaceChar >> return B.space +whitespace = try $ do + skipMany1 spaceChar + return $ return B.space br :: PandocMonad m => MuseParser m (F Inlines) br = try $ do string "<br>" return $ return B.linebreak -linebreak :: PandocMonad m => MuseParser m (F Inlines) -linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline) - where lastNewline = do - eof - return $ return mempty - innerNewline = return $ return B.space - emphasisBetween :: (PandocMonad m, Show a) => MuseParser m a -> MuseParser m (F Inlines) emphasisBetween c = try $ enclosedInlines c c @@ -724,28 +697,23 @@ verbatimTag = do 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 - (attrs, content) <- parseHtmlContentWithAttrs "code" anyChar + (attrs, content) <- htmlElement "code" return $ return $ B.codeWith attrs content inlineLiteralTag :: PandocMonad m => MuseParser m (F Inlines) @@ -786,8 +754,7 @@ link = try $ do linkContent :: PandocMonad m => MuseParser m (F Inlines) linkContent = do char '[' - res <- many1Till anyChar $ char ']' - parseFromString (mconcat <$> many1 inline) res + trimInlinesF . mconcat <$> many1Till inline (string "]") linkText :: PandocMonad m => MuseParser m (String, String, Maybe (F Inlines)) linkText = do diff --git a/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs b/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs index cdfa8f8df..ef8b2d18a 100644 --- a/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs +++ b/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs @@ -211,9 +211,9 @@ a ^>>?% f = arr a >>?^ (uncurry f) --- (>>?%?) :: (ArrowChoice a) => FallibleArrow a x f (b,b') - -> (b -> b' -> (Either f c)) + -> (b -> b' -> Either f c) -> FallibleArrow a x f c -a >>?%? f = a >>?^? (uncurry f) +a >>?%? f = a >>?^? uncurry f infixr 1 >>?, >>?^, >>?^? infixr 1 ^>>?, >>?! diff --git a/src/Text/Pandoc/Readers/Odt/ContentReader.hs b/src/Text/Pandoc/Readers/Odt/ContentReader.hs index cc9b798b3..380f16c66 100644 --- a/src/Text/Pandoc/Readers/Odt/ContentReader.hs +++ b/src/Text/Pandoc/Readers/Odt/ContentReader.hs @@ -322,7 +322,7 @@ type InlineModifier = Inlines -> Inlines modifierFromStyleDiff :: PropertyTriple -> InlineModifier modifierFromStyleDiff propertyTriple = composition $ - (getVPosModifier propertyTriple) + getVPosModifier propertyTriple : map (first ($ propertyTriple) >>> ifThen_else ignore) [ (hasEmphChanged , emph ) , (hasChanged isStrong , strong ) @@ -352,7 +352,7 @@ modifierFromStyleDiff propertyTriple = ] hasChanged property triple@(_, property -> newProperty, _) = - maybe True (/=newProperty) (lookupPreviousValue property triple) + (/= Just newProperty) (lookupPreviousValue property triple) hasChangedM property triple@(_, textProps,_) = fromMaybe False $ (/=) <$> property textProps <*> lookupPreviousValueM property triple @@ -362,7 +362,7 @@ modifierFromStyleDiff propertyTriple = lookupPreviousValueM f = lookupPreviousStyleValue ((f =<<).textProperties) lookupPreviousStyleValue f (ReaderState{..},_,mFamily) - = ( findBy f $ extendedStylePropertyChain styleTrace styleSet ) + = findBy f (extendedStylePropertyChain styleTrace styleSet) <|> ( f =<< fmap (lookupDefaultStyle' styleSet) mFamily ) @@ -793,8 +793,7 @@ read_image_src = matchingElement NsDraw "image" Left _ -> returnV "" -< () read_frame_title :: InlineMatcher -read_frame_title = matchingElement NsSVG "title" - $ (matchChildContent [] read_plain_text) +read_frame_title = matchingElement NsSVG "title" (matchChildContent [] read_plain_text) read_frame_text_box :: InlineMatcher read_frame_text_box = matchingElement NsDraw "text-box" @@ -803,12 +802,12 @@ read_frame_text_box = matchingElement NsDraw "text-box" arr read_img_with_caption -< toList paragraphs read_img_with_caption :: [Block] -> Inlines -read_img_with_caption ((Para [Image attr alt (src,title)]) : _) = +read_img_with_caption (Para [Image attr alt (src,title)] : _) = singleton (Image attr alt (src, 'f':'i':'g':':':title)) -- no text, default caption read_img_with_caption (Para (Image attr _ (src,title) : txt) : _) = singleton (Image attr txt (src, 'f':'i':'g':':':title) ) -- override caption with the text that follows -read_img_with_caption ( (Para (_ : xs)) : ys) = - read_img_with_caption ((Para xs) : ys) +read_img_with_caption ( Para (_ : xs) : ys) = + read_img_with_caption (Para xs : ys) read_img_with_caption _ = mempty @@ -909,8 +908,8 @@ post_process (Pandoc m blocks) = Pandoc m (post_process' blocks) post_process' :: [Block] -> [Block] -post_process' ((Table _ a w h r) : (Div ("", ["caption"], _) [Para inlines] ) : xs) = - (Table inlines a w h r) : ( post_process' xs ) +post_process' (Table _ a w h r : Div ("", ["caption"], _) [Para inlines] : xs) = + Table inlines a w h r : post_process' xs post_process' bs = bs read_body :: OdtReader _x (Pandoc, MediaBag) diff --git a/src/Text/Pandoc/Readers/Odt/Namespaces.hs b/src/Text/Pandoc/Readers/Odt/Namespaces.hs index 3c11aeb8e..92e12931d 100644 --- a/src/Text/Pandoc/Readers/Odt/Namespaces.hs +++ b/src/Text/Pandoc/Readers/Odt/Namespaces.hs @@ -48,7 +48,7 @@ instance NameSpaceID Namespace where findID :: NameSpaceIRI -> Maybe Namespace -findID iri = listToMaybe [nsID | (iri',~nsID) <- nsIDs, iri' `isPrefixOf` iri] +findID iri = listToMaybe [nsID | (iri',nsID) <- nsIDs, iri' `isPrefixOf` iri] nsIDmap :: NameSpaceIRIs Namespace nsIDmap = foldr (uncurry $ flip M.insert) M.empty nsIDs diff --git a/src/Text/Pandoc/Readers/Odt/StyleReader.hs b/src/Text/Pandoc/Readers/Odt/StyleReader.hs index 6129c1664..58be8e4a3 100644 --- a/src/Text/Pandoc/Readers/Odt/StyleReader.hs +++ b/src/Text/Pandoc/Readers/Odt/StyleReader.hs @@ -131,13 +131,12 @@ type StyleReaderSafe a b = XMLReaderSafe FontPitches a b -- | A reader for font pitches fontPitchReader :: XMLReader _s _x FontPitches fontPitchReader = executeIn NsOffice "font-face-decls" ( - ( withEveryL NsStyle "font-face" $ liftAsSuccess ( + withEveryL NsStyle "font-face" (liftAsSuccess ( findAttr' NsStyle "name" &&& lookupDefaultingAttr NsStyle "font-pitch" - ) - ) - >>?^ ( M.fromList . (foldl accumLegalPitches []) ) + )) + >>?^ ( M.fromList . foldl accumLegalPitches [] ) ) where accumLegalPitches ls (Nothing,_) = ls accumLegalPitches ls (Just n,p) = (n,p):ls @@ -383,11 +382,11 @@ data ListLevelStyle = ListLevelStyle { listLevelType :: ListLevelType instance Show ListLevelStyle where show ListLevelStyle{..} = "<LLS|" - ++ (show listLevelType) + ++ show listLevelType ++ "|" - ++ (maybeToString listItemPrefix) - ++ (show listItemFormat) - ++ (maybeToString listItemSuffix) + ++ maybeToString listItemPrefix + ++ show listItemFormat + ++ maybeToString listItemSuffix ++ ">" where maybeToString = fromMaybe "" @@ -483,14 +482,14 @@ readTextProperties = ( liftA6 PropT ( searchAttr NsXSL_FO "font-style" False isFontEmphasised ) ( searchAttr NsXSL_FO "font-weight" False isFontBold ) - ( findPitch ) + findPitch ( getAttr NsStyle "text-position" ) - ( readUnderlineMode ) - ( readStrikeThroughMode ) + readUnderlineMode + readStrikeThroughMode ) where isFontEmphasised = [("normal",False),("italic",True),("oblique",True)] isFontBold = ("normal",False):("bold",True) - :(map ((,True).show) ([100,200..900]::[Int])) + :map ((,True).show) ([100,200..900]::[Int]) readUnderlineMode :: StyleReaderSafe _x (Maybe UnderlineMode) readUnderlineMode = readLineMode "text-underline-mode" @@ -510,7 +509,7 @@ readLineMode modeAttr styleAttr = proc x -> do Nothing -> returnA -< Just UnderlineModeNormal else returnA -< Nothing where - isLinePresent = [("none",False)] ++ map (,True) + isLinePresent = ("none",False) : map (,True) [ "dash" , "dot-dash" , "dot-dot-dash" , "dotted" , "long-dash" , "solid" , "wave" ] @@ -547,20 +546,18 @@ readListStyle = findAttr NsStyle "name" >>?! keepingTheValue ( liftA ListStyle - $ ( liftA3 SM.union3 + $ liftA3 SM.union3 ( readListLevelStyles NsText "list-level-style-number" LltNumbered ) ( readListLevelStyles NsText "list-level-style-bullet" LltBullet ) - ( readListLevelStyles NsText "list-level-style-image" LltImage ) - ) >>^ M.mapMaybe chooseMostSpecificListLevelStyle + ( readListLevelStyles NsText "list-level-style-image" LltImage ) >>^ M.mapMaybe chooseMostSpecificListLevelStyle ) -- readListLevelStyles :: Namespace -> ElementName -> ListLevelType -> StyleReaderSafe _x (SM.SetMap Int ListLevelStyle) readListLevelStyles namespace elementName levelType = - ( tryAll namespace elementName (readListLevelStyle levelType) + tryAll namespace elementName (readListLevelStyle levelType) >>^ SM.fromList - ) -- readListLevelStyle :: ListLevelType -> StyleReader _x (Int, ListLevelStyle) @@ -632,7 +629,7 @@ parents style styles = unfoldr findNextParent style -- Ha! getStyleFamily :: Style -> Styles -> Maybe StyleFamily getStyleFamily style@Style{..} styles = styleFamily - <|> (F.asum $ map (`getStyleFamily` styles) $ parents style styles) + <|> F.asum (map (`getStyleFamily` styles) $ parents style styles) -- | Each 'Style' has certain 'StyleProperties'. But sometimes not all property -- values are specified. Instead, a value might be inherited from a @@ -654,7 +651,7 @@ stylePropertyChain style styles -- extendedStylePropertyChain :: [Style] -> Styles -> [StyleProperties] extendedStylePropertyChain [] _ = [] -extendedStylePropertyChain [style] styles = (stylePropertyChain style styles) - ++ (maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles))) -extendedStylePropertyChain (style:trace) styles = (stylePropertyChain style styles) - ++ (extendedStylePropertyChain trace styles) +extendedStylePropertyChain [style] styles = stylePropertyChain style styles + ++ maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles)) +extendedStylePropertyChain (style:trace) styles = stylePropertyChain style styles + ++ extendedStylePropertyChain trace styles diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs index c5a7d8e10..fa016283c 100644 --- a/src/Text/Pandoc/Readers/Org/Blocks.hs +++ b/src/Text/Pandoc/Readers/Org/Blocks.hs @@ -516,7 +516,7 @@ include = try $ do blocksParser <- case includeArgs of ("example" : _) -> return $ pure . B.codeBlock <$> parseRaw ["export"] -> return . returnF $ B.fromList [] - ("export" : format : []) -> return $ pure . B.rawBlock format <$> parseRaw + ["export", format] -> return $ pure . B.rawBlock format <$> parseRaw ("src" : rest) -> do let attr = case rest of [lang] -> (mempty, [lang], mempty) diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs index 27ce5fa2d..e88d997f0 100644 --- a/src/Text/Pandoc/Readers/RST.hs +++ b/src/Text/Pandoc/Readers/RST.hs @@ -352,7 +352,7 @@ singleHeader' :: PandocMonad m => RSTParser m (Inlines, Char) singleHeader' = try $ do notFollowedBy' whitespace lookAhead $ anyLine >> oneOf underlineChars - txt <- trimInlines . mconcat <$> many1 (do {notFollowedBy newline; inline}) + txt <- trimInlines . mconcat <$> many1 (notFollowedBy blankline >> inline) pos <- getPosition let len = sourceColumn pos - 1 blankline @@ -972,11 +972,16 @@ extractCaption = do 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 @@ anchor = try $ do 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 @@ -1248,7 +1263,7 @@ simpleTableHeader headless = try $ do let rawHeads = if headless then replicate (length dashes) "" else simpleTableSplitLine indices rawContent - heads <- mapM ( (parseFromString' (mconcat <$> many plain)) . trim) rawHeads + heads <- mapM ( parseFromString' (mconcat <$> many plain) . trim) rawHeads return (heads, aligns, indices) -- Parse a simple table. @@ -1399,7 +1414,7 @@ renderRole contents fmt role attr = case role of pepUrl = "http://www.python.org/dev/peps/pep-" ++ padNo ++ "/" addClass :: String -> Attr -> Attr -addClass c (ident, classes, keyValues) = (ident, union classes [c], keyValues) +addClass c (ident, classes, keyValues) = (ident, classes `union` [c], keyValues) roleName :: PandocMonad m => RSTParser m String roleName = many1 (letter <|> char '-') @@ -1439,7 +1454,7 @@ endline = try $ do notFollowedBy blankline -- parse potential list-starts at beginning of line differently in a list: st <- getState - when ((stateParserContext st) == ListItemState) $ notFollowedBy (anyOrderedListMarker >> spaceChar) >> + when (stateParserContext st == ListItemState) $ notFollowedBy (anyOrderedListMarker >> spaceChar) >> notFollowedBy' bulletListStart return B.softbreak @@ -1562,7 +1577,7 @@ note = try $ do -- not yet in this implementation. updateState $ \st -> st{ stateNotes = [] } contents <- parseFromString' parseBlocks raw - let newnotes = if (ref == "*" || ref == "#") -- auto-numbered + let newnotes = if ref == "*" || ref == "#" -- auto-numbered -- delete the note so the next auto-numbered note -- doesn't get the same contents: then deleteFirstsBy (==) notes [(ref,raw)] diff --git a/src/Text/Pandoc/Readers/Textile.hs b/src/Text/Pandoc/Readers/Textile.hs index 46d6301e4..30bb6a715 100644 --- a/src/Text/Pandoc/Readers/Textile.hs +++ b/src/Text/Pandoc/Readers/Textile.hs @@ -110,7 +110,7 @@ noteBlock = try $ do startPos <- getPosition ref <- noteMarker optional blankline - contents <- fmap unlines $ many1Till anyLine (blanklines <|> noteBlock) + contents <- unlines <$> many1Till anyLine (blanklines <|> noteBlock) endPos <- getPosition let newnote = (ref, contents ++ "\n") st <- getState @@ -360,7 +360,7 @@ cellAttributes = try $ do tableCell :: PandocMonad m => ParserT [Char] ParserState m ((Bool, Alignment), Blocks) tableCell = try $ do char '|' - (isHeader, alignment) <- option (False, AlignDefault) $ cellAttributes + (isHeader, alignment) <- option (False, AlignDefault) cellAttributes notFollowedBy blankline raw <- trim <$> many (noneOf "|\n" <|> try (char '\n' <* notFollowedBy blankline)) @@ -499,7 +499,7 @@ copy = do note :: PandocMonad m => ParserT [Char] ParserState m Inlines note = try $ do - ref <- (char '[' *> many1 digit <* char ']') + ref <- char '[' *> many1 digit <* char ']' notes <- stateNotes <$> getState case lookup ref notes of Nothing -> fail "note not found" @@ -530,7 +530,7 @@ hyphenedWords = do wordChunk :: PandocMonad m => ParserT [Char] ParserState m String wordChunk = try $ do hd <- noneOf wordBoundaries - tl <- many ( (noneOf wordBoundaries) <|> + tl <- many ( noneOf wordBoundaries <|> try (notFollowedBy' note *> oneOf markupChars <* lookAhead (noneOf wordBoundaries) ) ) return $ hd:tl @@ -614,7 +614,7 @@ escapedEqs = B.str <$> -- | literal text escaped btw <notextile> tags escapedTag :: PandocMonad m => ParserT [Char] ParserState m Inlines escapedTag = B.str <$> - (try $ string "<notextile>" *> + try (string "<notextile>" *> manyTill anyChar' (try $ string "</notextile>")) -- | Any special symbol defined in wordBoundaries @@ -630,7 +630,8 @@ code = code1 <|> code2 -- any character except a newline before a blank line anyChar' :: PandocMonad m => ParserT [Char] ParserState m Char anyChar' = - satisfy (/='\n') <|> (try $ char '\n' <* notFollowedBy blankline) + satisfy (/='\n') <|> + try (char '\n' <* notFollowedBy blankline) code1 :: PandocMonad m => ParserT [Char] ParserState m Inlines code1 = B.code <$> surrounded (char '@') anyChar' diff --git a/src/Text/Pandoc/Readers/TikiWiki.hs b/src/Text/Pandoc/Readers/TikiWiki.hs index 4a66cc13d..a92f7bed2 100644 --- a/src/Text/Pandoc/Readers/TikiWiki.hs +++ b/src/Text/Pandoc/Readers/TikiWiki.hs @@ -168,7 +168,7 @@ table = try $ do where -- The headers are as many empty srings as the number of columns -- in the first row - headers rows = map (B.plain . B.str) $replicate (length $ rows !! 0) "" + headers rows = map (B.plain . B.str) $replicate (length $ head rows) "" para :: PandocMonad m => TikiWikiParser m B.Blocks para = fmap (result . mconcat) ( many1Till inline endOfParaElement) @@ -238,8 +238,8 @@ fixListNesting [first] = [recurseOnList first] fixListNesting (first:second:rest) = let secondBlock = head $ B.toList second in case secondBlock of - BulletList _ -> fixListNesting $ (mappend (recurseOnList first) (recurseOnList second)) : rest - OrderedList _ _ -> fixListNesting $ (mappend (recurseOnList first) (recurseOnList second)) : rest + BulletList _ -> fixListNesting $ mappend (recurseOnList first) (recurseOnList second) : rest + OrderedList _ _ -> fixListNesting $ mappend (recurseOnList first) (recurseOnList second) : rest _ -> recurseOnList first : fixListNesting (second:rest) -- This function walks the Block structure for fixListNesting, @@ -285,7 +285,7 @@ spanFoldUpList ln (first:rest) = -- level and of the same type. splitListNesting :: ListNesting -> (ListNesting, B.Blocks) -> Bool splitListNesting ln1 (ln2, _) - | (lnnest ln1) < (lnnest ln2) = + | lnnest ln1 < lnnest ln2 = True | ln1 == ln2 = True @@ -341,7 +341,7 @@ listItemLine nest = lineContent >>= parseContent lineContent = do content <- anyLine continuation <- optionMaybe listContinuation - return $ filterSpaces content ++ "\n" ++ maybe "" id continuation + return $ filterSpaces content ++ "\n" ++ Data.Maybe.fromMaybe "" continuation filterSpaces = reverse . dropWhile (== ' ') . reverse listContinuation = string (replicate nest '+') >> lineContent parseContent x = do @@ -410,7 +410,7 @@ inline = choice [ whitespace ] <?> "inline" whitespace :: PandocMonad m => TikiWikiParser m B.Inlines -whitespace = (lb <|> regsp) +whitespace = lb <|> regsp where lb = try $ skipMany spaceChar >> linebreak >> return B.space regsp = try $ skipMany1 spaceChar >> return B.space @@ -501,7 +501,7 @@ escapedChar = try $ do string "~" inner <- many1 $ oneOf "0123456789" string "~" - return $B.str [(toEnum (read inner :: Int)) :: Char] + return $B.str [toEnum (read inner :: Int) :: Char] -- UNSUPPORTED, as there doesn't seem to be any facility in calibre -- for this diff --git a/src/Text/Pandoc/Readers/Txt2Tags.hs b/src/Text/Pandoc/Readers/Txt2Tags.hs index 68399afc9..b4f4bc564 100644 --- a/src/Text/Pandoc/Readers/Txt2Tags.hs +++ b/src/Text/Pandoc/Readers/Txt2Tags.hs @@ -36,7 +36,7 @@ import Control.Monad.Except (catchError, throwError) import Control.Monad.Reader (Reader, asks, runReader) import Data.Char (toLower) import Data.Default -import Data.List (intercalate, intersperse, transpose) +import Data.List (intercalate, transpose) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) @@ -463,7 +463,7 @@ titleLink = try $ do char ']' let link' = last tokens guard $ not $ null link' - let tit = concat (intersperse " " (init tokens)) + let tit = unwords (init tokens) return $ B.link link' "" (B.text tit) -- Link with image diff --git a/src/Text/Pandoc/Readers/Vimwiki.hs b/src/Text/Pandoc/Readers/Vimwiki.hs index 162fb371e..d717a1ba8 100644 --- a/src/Text/Pandoc/Readers/Vimwiki.hs +++ b/src/Text/Pandoc/Readers/Vimwiki.hs @@ -388,9 +388,7 @@ bulletListMarkers = "ul" <$ (char '*' <|> char '-') orderedListMarkers :: PandocMonad m => VwParser m String orderedListMarkers = - ("ol" <$choice (orderedListMarker Decimal Period:(($OneParen) - <$> orderedListMarker - <$> [Decimal, LowerRoman, UpperRoman, LowerAlpha, UpperAlpha]))) + ("ol" <$choice (orderedListMarker Decimal Period:(($OneParen) . orderedListMarker <$> [Decimal, LowerRoman, UpperRoman, LowerAlpha, UpperAlpha]))) <|> ("ol" <$ char '#') --many need trimInlines diff --git a/src/Text/Pandoc/Shared.hs b/src/Text/Pandoc/Shared.hs index 583c7a63f..52e1447db 100644 --- a/src/Text/Pandoc/Shared.hs +++ b/src/Text/Pandoc/Shared.hs @@ -494,7 +494,7 @@ hierarchicalizeWithIds (Header level attr@(_,classes,_) title':xs) = do return $ Sec level newnum attr title' sectionContents' : rest' hierarchicalizeWithIds (Div ("",["references"],[]) (Header level (ident,classes,kvs) title' : xs):ys) = - hierarchicalizeWithIds (Header level (ident,("references":classes),kvs) + hierarchicalizeWithIds (Header level (ident,"references":classes,kvs) title' : (xs ++ ys)) hierarchicalizeWithIds (x:rest) = do rest' <- hierarchicalizeWithIds rest diff --git a/src/Text/Pandoc/Writers/AsciiDoc.hs b/src/Text/Pandoc/Writers/AsciiDoc.hs index a6906eb68..b8f647b66 100644 --- a/src/Text/Pandoc/Writers/AsciiDoc.hs +++ b/src/Text/Pandoc/Writers/AsciiDoc.hs @@ -265,8 +265,7 @@ blockToAsciiDoc opts (OrderedList (_start, sty, _delim) items) = do let markers' = map (\m -> if length m < 3 then m ++ replicate (3 - length m) ' ' else m) markers - contents <- mapM (uncurry (orderedListItemToAsciiDoc opts)) $ - zip markers' items + contents <- zipWithM (orderedListItemToAsciiDoc opts) markers' items return $ cat contents <> blankline blockToAsciiDoc opts (DefinitionList items) = do contents <- mapM (definitionListItemToAsciiDoc opts) items @@ -452,7 +451,7 @@ inlineToAsciiDoc opts (Link _ txt (src, _tit)) = do else prefix <> text src <> "[" <> linktext <> "]" inlineToAsciiDoc opts (Image attr alternate (src, tit)) = do -- image:images/logo.png[Company logo, title="blah"] - let txt = if (null alternate) || (alternate == [Str ""]) + let txt = if null alternate || (alternate == [Str ""]) then [Str "image"] else alternate linktext <- inlineListToAsciiDoc opts txt diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs index 072c2ca8d..64b7d2c53 100644 --- a/src/Text/Pandoc/Writers/ConTeXt.hs +++ b/src/Text/Pandoc/Writers/ConTeXt.hs @@ -55,6 +55,8 @@ data WriterState = , stOptions :: WriterOptions -- writer options } +data Tabl = Xtb | Ntb deriving (Show, Eq) + orderedListStyles :: [Char] orderedListStyles = cycle "narg" @@ -252,33 +254,77 @@ blockToConTeXt HorizontalRule = return $ "\\thinrule" <> blankline -- 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 - -tableRowToConTeXt :: PandocMonad m => [[Block]] -> WM m Doc -tableRowToConTeXt cols = do - cols' <- mapM blockListToConTeXt cols - return $ vcat (map ("\\NC " <>) cols') $$ "\\NC\\AR" + 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 + +tableToConTeXt :: PandocMonad m => Tabl -> Doc -> [Doc] -> WM m Doc +tableToConTeXt Xtb heads rows = + return $ "\\startxtable" $$ + (if isEmpty heads + then empty + else "\\startxtablehead[head]" $$ heads $$ "\\stopxtablehead") $$ + (if null rows + then empty + else "\\startxtablebody[body]" $$ vcat (init rows) $$ "\\stopxtablebody" $$ + "\\startxtablefoot[foot]" $$ last rows $$ "\\stopxtablefoot") $$ + "\\stopxtable" +tableToConTeXt Ntb heads rows = + return $ "\\startTABLE" $$ + (if isEmpty heads + then empty + else "\\startTABLEhead" $$ heads $$ "\\stopTABLEhead") $$ + (if null rows + then empty + else "\\startTABLEbody" $$ vcat (init rows) $$ "\\stopTABLEbody" $$ + "\\startTABLEfoot" $$ last rows $$ "\\stopTABLEfoot") $$ + "\\stopTABLE" + +tableRowToConTeXt :: PandocMonad m => Tabl -> [Alignment] -> [Double] -> [[Block]] -> WM m Doc +tableRowToConTeXt Xtb aligns widths cols = do + cells <- mapM (tableColToConTeXt Xtb) $ zip3 aligns widths cols + return $ "\\startxrow" $$ vcat cells $$ "\\stopxrow" +tableRowToConTeXt Ntb aligns widths cols = do + cells <- mapM (tableColToConTeXt Ntb) $ zip3 aligns widths cols + return $ vcat cells $$ "\\NC\\NR" + +tableColToConTeXt :: PandocMonad m => Tabl -> (Alignment, Double, [Block]) -> WM m Doc +tableColToConTeXt tabl (align, width, blocks) = do + cellContents <- blockListToConTeXt blocks + let colwidth = if width == 0 + then empty + else "width=" <> braces (text (printf "%.2f\\textwidth" width)) + let halign = alignToConTeXt align + let options = (if keys == empty + then empty + else brackets keys) <> space + where keys = hcat $ intersperse "," $ filter (empty /=) [halign, colwidth] + tableCellToConTeXt tabl options cellContents + +tableCellToConTeXt :: PandocMonad m => Tabl -> Doc -> Doc -> WM m Doc +tableCellToConTeXt Xtb options cellContents = + return $ "\\startxcell" <> options <> cellContents <> " \\stopxcell" +tableCellToConTeXt Ntb options cellContents = + return $ "\\NC" <> options <> cellContents + +alignToConTeXt :: Alignment -> Doc +alignToConTeXt align = case align of + AlignLeft -> "align=right" + AlignRight -> "align=left" + AlignCenter -> "align=middle" + AlignDefault -> empty listItemToConTeXt :: PandocMonad m => [Block] -> WM m Doc listItemToConTeXt list = blockListToConTeXt list >>= diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index c077d54ba..928eaa712 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -65,7 +64,7 @@ import Text.Pandoc.Readers.Docx.StyleMap 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 @@ -196,15 +195,6 @@ isValidChar (ord -> c) | 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 -> Pandoc -- ^ Document to convert @@ -1067,12 +1057,9 @@ getParaProps displayMathPara = do props <- asks envParaProperties listLevel <- asks envListLevel numid <- asks envListNumId - let listPr = if listLevel >= 0 && not displayMathPara - then [ mknode "w:numPr" [] - [ mknode "w:numId" [("w:val",show numid)] () - , mknode "w:ilvl" [("w:val",show listLevel)] () ] - ] - else [] + let listPr = [mknode "w:numPr" [] + [ mknode "w:numId" [("w:val",show numid)] () + , mknode "w:ilvl" [("w:val",show listLevel)] () ] | listLevel >= 0 && not displayMathPara] return $ case props ++ listPr of [] -> [] ps -> [mknode "w:pPr" [] ps] @@ -1155,7 +1142,7 @@ inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do return $ \f -> do x <- f return [ mknode "w:ins" - [("w:id", (show insId)), + [("w:id", show insId), ("w:author", author), ("w:date", date)] x ] else return id @@ -1282,7 +1269,7 @@ inlineToOpenXML' opts (Image attr alt (src, title)) = do Nothing -> catchError (do (img, mt) <- P.fetchItem src - ident <- ("rId"++) `fmap` ((lift . lift) getUniqueId) + ident <- ("rId"++) `fmap` (lift . lift) getUniqueId let (xpt,ypt) = desiredSizeInPoints opts attr (either (const def) id (imageSize opts img)) -- 12700 emu = 1 pt diff --git a/src/Text/Pandoc/Writers/FB2.hs b/src/Text/Pandoc/Writers/FB2.hs index b1e8c8575..e322c7d98 100644 --- a/src/Text/Pandoc/Writers/FB2.hs +++ b/src/Text/Pandoc/Writers/FB2.hs @@ -131,8 +131,7 @@ description meta' = do _ -> return [] return $ el "description" [ el "title-info" (genre : (bt ++ as ++ dd ++ lang)) - , el "document-info" ([ el "program-used" "pandoc" ] -- FIXME: +version - ++ coverpage) + , el "document-info" (el "program-used" "pandoc" : coverpage) ] booktitle :: PandocMonad m => Meta -> FBM m [Content] diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs index 5d5c88dd9..cbceae2ce 100644 --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -57,6 +57,10 @@ import Network.HTTP (urlEncode) import Network.URI (URI (..), parseURIReference, unEscapeString) import Numeric (showHex) import Text.Blaze.Internal (customLeaf, MarkupM(Empty)) +#if MIN_VERSION_blaze_markup(0,6,3) +#else +import Text.Blaze.Internal (preEscapedString, preEscapedText) +#endif import Text.Blaze.Html hiding (contents) import Text.Pandoc.Definition import Text.Pandoc.Highlighting (formatHtmlBlock, formatHtmlInline, highlight, @@ -424,7 +428,7 @@ elementToHtml slideLevel opts (Sec level num (id',classes,keyvals) title' elemen modify (\st -> st{ stElement = False}) return res - let isSec (Sec{}) = True + let isSec Sec{} = True isSec (Blk _) = False let isPause (Blk x) = x == Para [Str ".",Space,Str ".",Space,Str "."] isPause _ = False @@ -618,7 +622,7 @@ imageExts = [ "art", "bmp", "cdr", "cdt", "cpt", "cr2", "crw", "djvu", "erf", treatAsImage :: FilePath -> Bool treatAsImage fp = - let path = fromMaybe fp (uriPath `fmap` parseURIReference fp) + let path = maybe fp uriPath (parseURIReference fp) ext = map toLower $ drop 1 $ takeExtension path in null ext || ext `elem` imageExts @@ -797,8 +801,8 @@ blockToHtml opts (OrderedList (startnum, numstyle, _) lst) = do let numstyle' = case numstyle of Example -> "decimal" _ -> camelCaseToHyphenated $ show numstyle - let attribs = ([A.start $ toValue startnum | startnum /= 1]) ++ - ([A.class_ "example" | numstyle == Example]) ++ + let attribs = [A.start $ toValue startnum | startnum /= 1] ++ + [A.class_ "example" | numstyle == Example] ++ (if numstyle /= DefaultStyle then if html5 then [A.type_ $ @@ -819,7 +823,7 @@ blockToHtml opts (DefinitionList lst) = do do term' <- if null term then return mempty else liftM H.dt $ inlineListToHtml opts term - defs' <- mapM (liftM (\x -> H.dd $ (x >> nl opts)) . + defs' <- mapM (liftM (\x -> H.dd (x >> nl opts)) . blockListToHtml opts) defs return $ mconcat $ nl opts : term' : nl opts : intersperse (nl opts) defs') lst diff --git a/src/Text/Pandoc/Writers/Haddock.hs b/src/Text/Pandoc/Writers/Haddock.hs index 9ed3be6cf..688c1f390 100644 --- a/src/Text/Pandoc/Writers/Haddock.hs +++ b/src/Text/Pandoc/Writers/Haddock.hs @@ -168,8 +168,7 @@ blockToHaddock opts (OrderedList (start,_,delim) items) = do let markers' = map (\m -> if length m < 3 then m ++ replicate (3 - length m) ' ' else m) markers - contents <- mapM (uncurry (orderedListItemToHaddock opts)) $ - zip markers' items + contents <- zipWithM (orderedListItemToHaddock opts) markers' items return $ cat contents <> blankline blockToHaddock opts (DefinitionList items) = do contents <- mapM (definitionListItemToHaddock opts) items diff --git a/src/Text/Pandoc/Writers/ICML.hs b/src/Text/Pandoc/Writers/ICML.hs index 80d2fcbef..a5d851e40 100644 --- a/src/Text/Pandoc/Writers/ICML.hs +++ b/src/Text/Pandoc/Writers/ICML.hs @@ -154,7 +154,7 @@ writeICML opts (Pandoc meta blocks) = do -- | Auxilary functions for parStylesToDoc and charStylesToDoc. contains :: String -> (String, (String, String)) -> [(String, String)] contains s rule = - [snd rule | isInfixOf (fst rule) s] + [snd rule | (fst rule) `isInfixOf` s] -- | The monospaced font to use as default. monospacedFont :: Doc @@ -282,7 +282,7 @@ hyperlinksToDoc (x:xs) = hyp x $$ hyperlinksToDoc xs ("Source","htss-"++show ident), ("Visible","true"), ("DestinationUniqueKey","1")] $ inTags True "Properties" [] $ inTags False "BorderColor" [("type","enumeration")] (text "Black") - $$ inTags False "Destination" [("type","object")] (text $ "HyperlinkURLDestination/"++(escapeColons (escapeStringForXML url))) -- HyperlinkURLDestination with more than one colon crashes CS6 + $$ inTags False "Destination" [("type","object")] (text $ "HyperlinkURLDestination/"++escapeColons (escapeStringForXML url)) -- HyperlinkURLDestination with more than one colon crashes CS6 -- | Convert a list of Pandoc blocks to ICML. diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs index 296b30ee1..fa72f0f1a 100644 --- a/src/Text/Pandoc/Writers/LaTeX.hs +++ b/src/Text/Pandoc/Writers/LaTeX.hs @@ -41,7 +41,7 @@ import Data.Char (isAlphaNum, isAscii, isDigit, isLetter, isPunctuation, ord, toLower) import Data.List (foldl', intercalate, intersperse, isInfixOf, nubBy, stripPrefix, (\\)) -import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe, isNothing) import Data.Text (Text) import qualified Data.Text as T import Network.URI (unEscapeString) @@ -401,7 +401,7 @@ elementToBeamer slideLevel (Sec lvl _num (ident,classes,kvs) tit elts) let frameoptions = ["allowdisplaybreaks", "allowframebreaks", "fragile", "b", "c", "t", "environment", "label", "plain", "shrink", "standout"] - let optionslist = ["fragile" | fragile && lookup "fragile" kvs == Nothing] ++ + let optionslist = ["fragile" | fragile && isNothing (lookup "fragile" kvs)] ++ [k | k <- classes, k `elem` frameoptions] ++ [k ++ "=" ++ v | (k,v) <- kvs, k `elem` frameoptions] let options = if null optionslist @@ -749,9 +749,9 @@ tableRowToLaTeX header aligns widths cols = do 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" @@ -819,7 +819,7 @@ listItemToLaTeX lst -- we need to put some text before a header if it's the first -- element in an item. This will look ugly in LaTeX regardless, but -- this will keep the typesetter from throwing an error. - | (Header _ _ _ :_) <- lst = + | (Header{} :_) <- lst = blockListToLaTeX lst >>= return . (text "\\item ~" $$) . nest 2 | otherwise = blockListToLaTeX lst >>= return . (text "\\item" $$) . nest 2 @@ -856,7 +856,7 @@ sectionHeader unnumbered ident level lst = do plain <- stringToLaTeX TextString $ concatMap stringify lst let removeInvalidInline (Note _) = [] removeInvalidInline (Span (id', _, _) _) | not (null id') = [] - removeInvalidInline (Image{}) = [] + removeInvalidInline Image{} = [] removeInvalidInline x = [x] let lstNoNotes = foldr (mappend . (\x -> walkM removeInvalidInline x)) mempty lst txtNoNotes <- inlineListToLaTeX lstNoNotes @@ -1015,7 +1015,7 @@ inlineToLaTeX (Code (_,classes,_) str) = do let chr = case "!\"&'()*,-./:;?@_" \\ str of (c:_) -> c [] -> '!' - let str' = escapeStringUsing (backslashEscapes "\\{}%~_") str + let str' = escapeStringUsing (backslashEscapes "\\{}%~_&") str -- we always put lstinline in a dummy 'passthrough' command -- (defined in the default template) so that we don't have -- to change the way we escape characters depending on whether diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs index c1427b15c..1be955fe3 100644 --- a/src/Text/Pandoc/Writers/Man.hs +++ b/src/Text/Pandoc/Writers/Man.hs @@ -114,7 +114,7 @@ notesToMan :: PandocMonad m => WriterOptions -> [[Block]] -> StateT WriterState notesToMan opts notes = if null notes then return empty - else mapM (uncurry (noteToMan opts)) (zip [1..] notes) >>= + else zipWithM (noteToMan opts) [1..] notes >>= return . (text ".SH NOTES" $$) . vcat -- | Return man representation of a note. diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs index 08dff2c4e..c8b3a1526 100644 --- a/src/Text/Pandoc/Writers/Markdown.hs +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -701,7 +701,7 @@ pandocTable opts multiline headless aligns widths rawHeaders rawRows = do let columns = transpose (rawHeaders : rawRows) -- minimal column width without wrapping a single word let relWidth w col = - max (floor $ fromIntegral (writerColumns opts) * w) + max (floor $ fromIntegral (writerColumns opts - 1) * w) (if writerWrapText opts == WrapAuto then minNumChars col else numChars col) diff --git a/src/Text/Pandoc/Writers/Muse.hs b/src/Text/Pandoc/Writers/Muse.hs index 163cb2dda..fbebe5c20 100644 --- a/src/Text/Pandoc/Writers/Muse.hs +++ b/src/Text/Pandoc/Writers/Muse.hs @@ -212,10 +212,13 @@ blockToMuse (DefinitionList items) = do -> StateT WriterState m Doc definitionListItemToMuse (label, defs) = do label' <- inlineListToMuse label - contents <- liftM vcat $ mapM blockListToMuse defs - let label'' = label' <> " :: " - let ind = offset label'' - return $ hang ind label'' contents + contents <- liftM vcat $ mapM descriptionToMuse defs + let ind = offset label' + return $ hang ind label' contents + descriptionToMuse :: PandocMonad m + => [Block] + -> StateT WriterState m Doc + descriptionToMuse desc = hang 4 " :: " <$> blockListToMuse desc blockToMuse (Header level (ident,_,_) inlines) = do opts <- gets stOptions contents <- inlineListToMuse inlines diff --git a/src/Text/Pandoc/Writers/OOXML.hs b/src/Text/Pandoc/Writers/OOXML.hs index aa4979653..30d8d72dd 100644 --- a/src/Text/Pandoc/Writers/OOXML.hs +++ b/src/Text/Pandoc/Writers/OOXML.hs @@ -1,54 +1,54 @@ +{- +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 = @@ -104,6 +104,5 @@ fitToPage :: (Double, Double) -> Integer -> (Integer, Integer) fitToPage (x, y) pageWidth -- Fixes width to the page width and scales the height | x > fromIntegral pageWidth = - (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y) + (pageWidth, floor $ (fromIntegral pageWidth / x) * y) | otherwise = (floor x, floor y) - diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs index e0097f507..17edc0cbd 100644 --- a/src/Text/Pandoc/Writers/OpenDocument.hs +++ b/src/Text/Pandoc/Writers/OpenDocument.hs @@ -594,7 +594,7 @@ paraStyle attrs = do tight = if t then [ ("fo:margin-top" , "0in" ) , ("fo:margin-bottom" , "0in" )] else [] - indent = if (i /= 0 || b) + indent = if i /= 0 || b then [ ("fo:margin-left" , indentVal) , ("fo:margin-right" , "0in" ) , ("fo:text-indent" , "0in" ) diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs index 1de4dcb18..645a4cb86 100644 --- a/src/Text/Pandoc/Writers/Powerpoint.hs +++ b/src/Text/Pandoc/Writers/Powerpoint.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-} + {- Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu> @@ -27,43 +27,29 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Stability : alpha Portability : portable -Conversion of 'Pandoc' documents to powerpoint (pptx). +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 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.Class (PandocMonad, report) +import Text.Pandoc.Options (WriterOptions) 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) - +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 @@ -71,1707 +57,7 @@ writePowerpoint :: (PandocMonad m) -> 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 + let (pres, logMsgs) = documentToPresentation opts (Pandoc meta blks') + mapM_ report logMsgs + archv <- presentationToArchive opts pres + return $ fromArchive archv diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs new file mode 100644 index 000000000..d30819d47 --- /dev/null +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -0,0 +1,1494 @@ +{-# 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.Char (toUpper) +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 +import Skylighting (fromColor) + +-- 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 -> if rPropCode rpr + -- hardcoded size for code for now + then [("sz", "1800")] + else [] + attrs = sizeAttrs ++ + (if rPropBold rpr then [("b", "1")] else []) ++ + (if rPropItalics rpr then [("i", "1")] else []) ++ + (if rPropUnderline rpr then [("u", "sng")] 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 colorContents = case rSolidFill rpr of + Just color -> + case fromColor color of + '#':hx -> [mknode "a:solidFill" [] + [mknode "a:srgbClr" [("val", map toUpper hx)] ()] + ] + _ -> [] + Nothing -> [] + let codeContents = if rPropCode rpr + then [mknode "a:latin" [("typeface", "Courier")] ()] + else [] + let propContents = linkProps ++ colorContents ++ codeContents + return $ mknode "a:r" [] [ mknode "a:rPr" attrs $ propContents + , mknode "a:t" [] s + ] +paraElemToElement (MathElem mathType texStr) = do + res <- convertMath writeOMML mathType (unTeXString texStr) + case res of + Right r -> return $ mknode "a14:m" [] $ addMathInfo r + Left (Str s) -> paraElemToElement (Run def s) + Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback" + +-- This is a bit of a kludge -- really requires adding an option to +-- TeXMath, but since that's a different package, we'll do this one +-- step at a time. +addMathInfo :: Element -> Element +addMathInfo element = + let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns")) + , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math" + } + in add_attr mathspace element + +-- We look through the element to see if it contains an a14:m +-- element. If so, we surround it. This is a bit ugly, but it seems +-- more dependable than looking through shapes for math. Plus this is +-- an xml implementation detail, so it seems to make sense to do it at +-- the xml level. +surroundWithMathAlternate :: Element -> Element +surroundWithMathAlternate element = + case findElement (QName "m" Nothing (Just "a14")) element of + Just _ -> + mknode "mc:AlternateContent" + [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006") + ] [ mknode "mc:Choice" + [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main") + , ("Requires", "a14")] [ element ] + ] + Nothing -> element + +paragraphToElement :: PandocMonad m => Paragraph -> P m Element +paragraphToElement par = do + let + attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++ + (case pPropMarginLeft (paraProps par) of + Just px -> [("marL", show $ 12700 * px), ("indent", "0")] + Nothing -> [] + ) ++ + (case pPropAlign (paraProps par) of + Just AlgnLeft -> [("algn", "l")] + Just AlgnRight -> [("algn", "r")] + Just AlgnCenter -> [("algn", "ctr")] + Nothing -> [] + ) + props = [] ++ + (case pPropSpaceBefore $ paraProps par of + Just px -> [mknode "a:spcBef" [] [ + mknode "a:spcPts" [("val", show $ 100 * px)] () + ] + ] + Nothing -> [] + ) ++ + (case pPropBullet $ paraProps par of + Just Bullet -> [] + Just (AutoNumbering attrs') -> + [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()] + Nothing -> [mknode "a:buNone" [] ()] + ) + paras <- mapM paraElemToElement (paraElems par) + return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras + +shapeToElement :: PandocMonad m => Element -> Shape -> P m Element +shapeToElement layout (TextBox paras) + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + sp <- getContentShape ns spTree + elements <- mapM paragraphToElement paras + let txBody = mknode "p:txBody" [] $ + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements + emptySpPr = mknode "p:spPr" [] () + return $ + surroundWithMathAlternate $ + replaceNamedChildren ns "p" "txBody" [txBody] $ + replaceNamedChildren ns "p" "spPr" [emptySpPr] $ + sp +-- GraphicFrame and Pic should never reach this. +shapeToElement _ _ = return $ mknode "p:sp" [] () + +shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element] +shapeToElements layout (Pic picProps fp alt) = do + mInfo <- registerMedia fp alt + case mInfoExt mInfo of + Just _ -> do + makePicElements layout picProps mInfo alt + Nothing -> shapeToElements layout $ TextBox [Paragraph def alt] +shapeToElements layout (GraphicFrame tbls cptn) = + graphicFrameToElements layout tbls cptn +shapeToElements layout shp = do + element <- shapeToElement layout shp + return [element] + +shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element] +shapesToElements layout shps = do + concat <$> mapM (shapeToElements layout) shps + +graphicFrameToElements :: PandocMonad m => Element -> [Graphic] -> [ParaElem] -> P m [Element] +graphicFrameToElements layout tbls caption = do + -- get the sizing + master <- getMaster + (pageWidth, pageHeight) <- asks envPresentationSize + let ns = elemToNameSpaces layout + ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master + `catchError` + (\_ -> return ((0, 0), (pageWidth, pageHeight))) + + let cy = if (not $ null caption) then cytmp - captionHeight else cytmp + + elements <- mapM (graphicToElement cx) tbls + let graphicFrameElts = + mknode "p:graphicFrame" [] $ + [ mknode "p:nvGraphicFramePr" [] $ + [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] () + , mknode "p:cNvGraphicFramePr" [] $ + [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()] + , mknode "p:nvPr" [] $ + [mknode "p:ph" [("idx", "1")] ()] + ] + , mknode "p:xfrm" [] $ + [ mknode "a:off" [("x", show $ 12700 * x), ("y", show $ 12700 * y)] () + , mknode "a:ext" [("cx", show $ 12700 * cx), ("cy", show $ 12700 * cy)] () + ] + ] ++ elements + + if (not $ null caption) + then do capElt <- createCaption ((x, y), (cx, cytmp)) caption + return [graphicFrameElts, capElt] + else return [graphicFrameElts] + +graphicToElement :: PandocMonad m => Integer -> Graphic -> P m Element +graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do + let colWidths = if null hdrCells + then case rows of + r : _ | not (null r) -> replicate (length r) $ + (tableWidth `div` (toInteger $ length r)) + -- satisfy the compiler. This is the same as + -- saying that rows is empty, but the compiler + -- won't understand that `[]` exhausts the + -- alternatives. + _ -> [] + else replicate (length hdrCells) $ + (tableWidth `div` (toInteger $ length hdrCells)) + + let cellToOpenXML paras = + do elements <- mapM paragraphToElement paras + let elements' = if null elements + then [mknode "a:p" [] [mknode "a:endParaRPr" [] ()]] + else elements + return $ + [mknode "a:txBody" [] $ + ([ mknode "a:bodyPr" [] () + , mknode "a:lstStyle" [] ()] + ++ elements')] + headers' <- mapM cellToOpenXML hdrCells + rows' <- mapM (mapM cellToOpenXML) rows + let borderProps = mknode "a:tcPr" [] () + let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]] + let mkcell border contents = mknode "a:tc" [] + $ (if null contents + then emptyCell + else contents) ++ [ borderProps | border ] + let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells + + let mkgridcol w = mknode "a:gridCol" + [("w", show ((12700 * w) :: Integer))] () + let hasHeader = not (all null hdrCells) + return $ mknode "a:graphic" [] $ + [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $ + [mknode "a:tbl" [] $ + [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0") + , ("bandRow", if tblPrBandRow tblPr then "1" else "0") + ] () + , mknode "a:tblGrid" [] (if all (==0) colWidths + then [] + else map mkgridcol colWidths) + ] + ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows' + ] + ] + +getShapeByName :: NameSpaces -> Element -> String -> Maybe Element +getShapeByName ns spTreeElem name + | isElem ns "p" "spTree" spTreeElem = + filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem + | otherwise = Nothing + +-- getShapeById :: NameSpaces -> Element -> String -> Maybe Element +-- getShapeById ns spTreeElem ident +-- | isElem ns "p" "spTree" spTreeElem = +-- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTreeElem +-- | otherwise = Nothing + +nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element +nonBodyTextToElement layout shapeName paraElements + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld + , Just sp <- getShapeByName ns spTree shapeName = do + let hdrPara = Paragraph def paraElements + element <- paragraphToElement hdrPara + let txBody = mknode "p:txBody" [] $ + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ + [element] + return $ replaceNamedChildren ns "p" "txBody" [txBody] sp + -- XXX: TODO + | otherwise = return $ mknode "p:sp" [] () + +contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element +contentToElement layout hdrShape shapes + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + element <- nonBodyTextToElement layout "Title 1" hdrShape + let hdrShapeElements = if null hdrShape + then [] + else [element] + contentElements <- local + (\env -> env {envContentType = NormalContent}) + (shapesToElements layout shapes) + return $ + replaceNamedChildren ns "p" "sp" + (hdrShapeElements ++ contentElements) + spTree +contentToElement _ _ _ = return $ mknode "p:sp" [] () + +twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element +twoColumnToElement layout hdrShape shapesL shapesR + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + element <- nonBodyTextToElement layout "Title 1" hdrShape + let hdrShapeElements = if null hdrShape + then [] + else [element] + contentElementsL <- local + (\env -> env {envContentType =TwoColumnLeftContent}) + (shapesToElements layout shapesL) + contentElementsR <- local + (\env -> env {envContentType =TwoColumnRightContent}) + (shapesToElements layout shapesR) + -- let contentElementsL' = map (setIdx ns "1") contentElementsL + -- contentElementsR' = map (setIdx ns "2") contentElementsR + return $ + replaceNamedChildren ns "p" "sp" + (hdrShapeElements ++ contentElementsL ++ contentElementsR) + spTree +twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] () + + +titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element +titleToElement layout titleElems + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + element <- nonBodyTextToElement layout "Title 1" titleElems + let titleShapeElements = if null titleElems + then [] + else [element] + return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree +titleToElement _ _ = return $ mknode "p:sp" [] () + +metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element +metadataToElement layout titleElems subtitleElems authorsElems dateElems + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + titleShapeElements <- if null titleElems + then return [] + else sequence [nonBodyTextToElement layout "Title 1" titleElems] + let combinedAuthorElems = intercalate [Break] authorsElems + subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems] + subtitleShapeElements <- if null subtitleAndAuthorElems + then return [] + else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems] + dateShapeElements <- if null dateElems + then return [] + else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems] + return $ replaceNamedChildren ns "p" "sp" + (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements) + spTree +metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] () + +slideToElement :: PandocMonad m => Slide -> P m Element +slideToElement (Slide _ l@(ContentSlide hdrElems shapes) _ )= do + layout <- getLayout l + spTree <- local (\env -> if null hdrElems + then env + else env{envSlideHasHeader=True}) $ + contentToElement layout hdrElems shapes + return $ mknode "p:sld" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), + ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), + ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [mknode "p:cSld" [] [spTree]] +slideToElement (Slide _ l@(TwoColumnSlide hdrElems shapesL shapesR) _) = do + layout <- getLayout l + spTree <- local (\env -> if null hdrElems + then env + else env{envSlideHasHeader=True}) $ + twoColumnToElement layout hdrElems shapesL shapesR + return $ mknode "p:sld" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), + ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), + ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [mknode "p:cSld" [] [spTree]] +slideToElement (Slide _ l@(TitleSlide hdrElems) _) = do + layout <- getLayout l + spTree <- titleToElement layout hdrElems + return $ mknode "p:sld" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), + ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), + ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [mknode "p:cSld" [] [spTree]] +slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems dateElems) _) = do + layout <- getLayout l + spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems + return $ mknode "p:sld" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), + ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), + ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [mknode "p:cSld" [] [spTree]] + +----------------------------------------------------------------------- + +getSlideIdNum :: PandocMonad m => SlideId -> P m Int +getSlideIdNum sldId = do + slideIdMap <- asks envSlideIdMap + case M.lookup sldId slideIdMap of + Just n -> return n + Nothing -> throwError $ + PandocShouldNeverHappenError $ + "Slide Id " ++ (show sldId) ++ " not found." + +slideNum :: PandocMonad m => Slide -> P m Int +slideNum slide = getSlideIdNum $ slideId slide + +idNumToFilePath :: Int -> FilePath +idNumToFilePath idNum = "slide" ++ (show $ idNum) ++ ".xml" + +slideToFilePath :: PandocMonad m => Slide -> P m FilePath +slideToFilePath slide = do + idNum <- slideNum slide + return $ "slide" ++ (show $ idNum) ++ ".xml" + +slideToRelId :: PandocMonad m => Slide -> P m String +slideToRelId slide = do + n <- slideNum slide + offset <- asks envSlideIdOffset + return $ "rId" ++ (show $ n + offset) + + +data Relationship = Relationship { relId :: Int + , relType :: MimeType + , relTarget :: FilePath + } deriving (Show, Eq) + +elementToRel :: Element -> Maybe Relationship +elementToRel element + | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing = + do rId <- findAttr (QName "Id" Nothing Nothing) element + numStr <- stripPrefix "rId" rId + num <- case reads numStr :: [(Int, String)] of + (n, _) : _ -> Just n + [] -> Nothing + type' <- findAttr (QName "Type" Nothing Nothing) element + target <- findAttr (QName "Target" Nothing Nothing) element + return $ Relationship num type' target + | otherwise = Nothing + +slideToPresRel :: PandocMonad m => Slide -> P m Relationship +slideToPresRel slide = do + idNum <- slideNum slide + n <- asks envSlideIdOffset + let rId = idNum + n + fp = "slides/" ++ idNumToFilePath idNum + return $ Relationship { relId = rId + , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" + , relTarget = fp + } + +getRels :: PandocMonad m => P m [Relationship] +getRels = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels" + let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships" + let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem + return $ mapMaybe elementToRel relElems + +presentationToRels :: PandocMonad m => Presentation -> P m [Relationship] +presentationToRels (Presentation _ slides) = do + mySlideRels <- mapM slideToPresRel slides + rels <- getRels + let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels + -- We want to make room for the slides in the id space. The slides + -- will start at Id2 (since Id1 is for the slide master). There are + -- two slides in the data file, but that might change in the future, + -- so we will do this: + -- + -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is. + -- 2. We add the difference between this and the number of slides to + -- all relWithoutSlide rels (unless they're 1) + + let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of + [] -> 0 -- doesn't matter in this case, since + -- there will be nothing to map the + -- function over + l -> minimum l + + modifyRelNum :: Int -> Int + modifyRelNum 1 = 1 + modifyRelNum n = n - minRelNotOne + 2 + length slides + + relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides + + return $ mySlideRels ++ relsWithoutSlides' + +-- We make this ourselves, in case there's a thumbnail in the one from +-- the template. +topLevelRels :: [Relationship] +topLevelRels = + [ Relationship { relId = 1 + , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" + , relTarget = "ppt/presentation.xml" + } + , Relationship { relId = 2 + , relType = "http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" + , relTarget = "docProps/core.xml" + } + , Relationship { relId = 3 + , relType = "http://schemas.openxmlformats.org/package/2006/relationships/metadata/extended-properties" + , relTarget = "docProps/app.xml" + } + ] + +topLevelRelsEntry :: PandocMonad m => P m Entry +topLevelRelsEntry = elemToEntry "_rels/.rels" $ relsToElement topLevelRels + +relToElement :: Relationship -> Element +relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel)) + , ("Type", relType rel) + , ("Target", relTarget rel) ] () + +relsToElement :: [Relationship] -> Element +relsToElement rels = mknode "Relationships" + [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] + (map relToElement rels) + +presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry +presentationToRelsEntry pres = do + rels <- presentationToRels pres + elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels + +elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry +elemToEntry fp element = do + epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime + return $ toEntry fp epochtime $ renderXml element + +slideToEntry :: PandocMonad m => Slide -> P m Entry +slideToEntry slide = do + idNum <- slideNum slide + local (\env -> env{envCurSlideId = idNum}) $ do + element <- slideToElement slide + elemToEntry ("ppt/slides/" ++ idNumToFilePath idNum) element + +slideToSlideRelEntry :: PandocMonad m => Slide -> P m Entry +slideToSlideRelEntry slide = do + idNum <- slideNum slide + element <- slideToSlideRelElement slide + elemToEntry ("ppt/slides/_rels/" ++ idNumToFilePath idNum ++ ".rels") element + +linkRelElement :: PandocMonad m => Int -> LinkTarget -> P m Element +linkRelElement rIdNum (InternalTarget targetId) = do + targetIdNum <- getSlideIdNum targetId + return $ + mknode "Relationship" [ ("Id", "rId" ++ show rIdNum) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") + , ("Target", "slide" ++ show targetIdNum ++ ".xml") + ] () +linkRelElement rIdNum (ExternalTarget (url, _)) = do + return $ + mknode "Relationship" [ ("Id", "rId" ++ show rIdNum) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") + , ("Target", url) + , ("TargetMode", "External") + ] () + +linkRelElements :: PandocMonad m => M.Map Int LinkTarget -> P m [Element] +linkRelElements mp = mapM (\(n, lnk) -> linkRelElement n lnk) (M.toList mp) + +mediaRelElement :: MediaInfo -> Element +mediaRelElement mInfo = + let ext = case mInfoExt mInfo of + Just e -> e + Nothing -> "" + in + mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo)) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image") + , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext) + ] () + +slideToSlideRelElement :: PandocMonad m => Slide -> P m Element +slideToSlideRelElement slide = do + idNum <- slideNum slide + let target = case slide of + (Slide _ (MetadataSlide _ _ _ _) _) -> "../slideLayouts/slideLayout1.xml" + (Slide _ (TitleSlide _) _) -> "../slideLayouts/slideLayout3.xml" + (Slide _ (ContentSlide _ _) _) -> "../slideLayouts/slideLayout2.xml" + (Slide _ (TwoColumnSlide _ _ _) _) -> "../slideLayouts/slideLayout4.xml" + + linkIds <- gets stLinkIds + mediaIds <- gets stMediaIds + + linkRels <- case M.lookup idNum linkIds of + Just mp -> linkRelElements mp + Nothing -> return [] + let mediaRels = case M.lookup idNum mediaIds of + Just mInfos -> map mediaRelElement mInfos + Nothing -> [] + + return $ + mknode "Relationships" + [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] + ([mknode "Relationship" [ ("Id", "rId1") + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout") + , ("Target", target)] () + ] ++ linkRels ++ mediaRels) + +slideToSldIdElement :: PandocMonad m => Slide -> P m Element +slideToSldIdElement slide = do + n <- slideNum slide + let id' = show $ n + 255 + rId <- slideToRelId slide + return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] () + +presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element +presentationToSldIdLst (Presentation _ slides) = do + ids <- mapM slideToSldIdElement slides + return $ mknode "p:sldIdLst" [] ids + +presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element +presentationToPresentationElement pres = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + element <- parseXml refArchive distArchive "ppt/presentation.xml" + sldIdLst <- presentationToSldIdLst pres + + let modifySldIdLst :: Content -> Content + modifySldIdLst (Elem e) = case elName e of + (QName "sldIdLst" _ _) -> Elem sldIdLst + _ -> Elem e + modifySldIdLst ct = ct + + newContent = map modifySldIdLst $ elContent element + + return $ element{elContent = newContent} + +presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry +presentationToPresEntry pres = presentationToPresentationElement pres >>= + elemToEntry "ppt/presentation.xml" + +-- adapted from the Docx writer +docPropsElement :: PandocMonad m => DocProps -> P m Element +docPropsElement docProps = do + utctime <- asks envUTCTime + let keywords = case dcKeywords docProps of + Just xs -> intercalate "," xs + Nothing -> "" + return $ + mknode "cp:coreProperties" + [("xmlns:cp","http://schemas.openxmlformats.org/package/2006/metadata/core-properties") + ,("xmlns:dc","http://purl.org/dc/elements/1.1/") + ,("xmlns:dcterms","http://purl.org/dc/terms/") + ,("xmlns:dcmitype","http://purl.org/dc/dcmitype/") + ,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")] + $ (mknode "dc:title" [] $ fromMaybe "" $ dcTitle docProps) + : (mknode "dc:creator" [] $ fromMaybe "" $ dcCreator docProps) + : (mknode "cp:keywords" [] keywords) + : (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x + , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x + ]) (formatTime defaultTimeLocale "%FT%XZ" utctime) + +docPropsToEntry :: PandocMonad m => DocProps -> P m Entry +docPropsToEntry docProps = docPropsElement docProps >>= + elemToEntry "docProps/core.xml" + + +defaultContentTypeToElem :: DefaultContentType -> Element +defaultContentTypeToElem dct = + mknode "Default" + [("Extension", defContentTypesExt dct), + ("ContentType", defContentTypesType dct)] + () + +overrideContentTypeToElem :: OverrideContentType -> Element +overrideContentTypeToElem oct = + mknode "Override" + [("PartName", overrideContentTypesPart oct), + ("ContentType", overrideContentTypesType oct)] + () + +contentTypesToElement :: ContentTypes -> Element +contentTypesToElement ct = + let ns = "http://schemas.openxmlformats.org/package/2006/content-types" + in + mknode "Types" [("xmlns", ns)] $ + (map defaultContentTypeToElem $ contentTypesDefaults ct) ++ + (map overrideContentTypeToElem $ contentTypesOverrides ct) + +data DefaultContentType = DefaultContentType + { defContentTypesExt :: String + , defContentTypesType:: MimeType + } + deriving (Show, Eq) + +data OverrideContentType = OverrideContentType + { overrideContentTypesPart :: FilePath + , overrideContentTypesType :: MimeType + } + deriving (Show, Eq) + +data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType] + , contentTypesOverrides :: [OverrideContentType] + } + deriving (Show, Eq) + +contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry +contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct + +pathToOverride :: FilePath -> Maybe OverrideContentType +pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp) + +mediaFileContentType :: FilePath -> Maybe DefaultContentType +mediaFileContentType fp = case takeExtension fp of + '.' : ext -> Just $ + DefaultContentType { defContentTypesExt = ext + , defContentTypesType = + case getMimeType fp of + Just mt -> mt + Nothing -> "application/octet-stream" + } + _ -> Nothing + +mediaContentType :: MediaInfo -> Maybe DefaultContentType +mediaContentType mInfo + | Just ('.' : ext) <- mInfoExt mInfo = + Just $ DefaultContentType { defContentTypesExt = ext + , defContentTypesType = + case mInfoMimeType mInfo of + Just mt -> mt + Nothing -> "application/octet-stream" + } + | otherwise = Nothing + +presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes +presentationToContentTypes (Presentation _ slides) = do + mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds + filePaths <- patternsToFilePaths inheritedPatterns + let mediaFps = filter (match (compile "ppt/media/image*")) filePaths + let defaults = [ DefaultContentType "xml" "application/xml" + , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml" + ] + mediaDefaults = nub $ + (mapMaybe mediaContentType $ mediaInfos) ++ + (mapMaybe mediaFileContentType $ mediaFps) + + inheritedOverrides = mapMaybe pathToOverride filePaths + docPropsOverride = mapMaybe pathToOverride ["docProps/core.xml"] + presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"] + relativePaths <- mapM slideToFilePath slides + let slideOverrides = mapMaybe + (\fp -> pathToOverride $ "ppt/slides/" ++ fp) + relativePaths + return $ ContentTypes + (defaults ++ mediaDefaults) + (inheritedOverrides ++ docPropsOverride ++ presOverride ++ slideOverrides) + +presML :: String +presML = "application/vnd.openxmlformats-officedocument.presentationml" + +noPresML :: String +noPresML = "application/vnd.openxmlformats-officedocument" + +getContentType :: FilePath -> Maybe MimeType +getContentType fp + | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml" + | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml" + | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml" + | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml" + | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml" + | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml" + | "ppt" : "slideMasters" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".slideMaster+xml" + | "ppt" : "slides" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".slide+xml" + | "ppt" : "notesMasters" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".notesMaster+xml" + | "ppt" : "notesSlides" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".notesSlide+xml" + | "ppt" : "theme" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ noPresML ++ ".theme+xml" + | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp= + Just $ presML ++ ".slideLayout+xml" + | otherwise = Nothing + +autoNumberingToType :: ListAttributes -> String +autoNumberingToType (_, numStyle, numDelim) = + typeString ++ delimString + where + typeString = case numStyle of + Decimal -> "arabic" + UpperAlpha -> "alphaUc" + LowerAlpha -> "alphaLc" + UpperRoman -> "romanUc" + LowerRoman -> "romanLc" + _ -> "arabic" + delimString = case numDelim of + Period -> "Period" + OneParen -> "ParenR" + TwoParens -> "ParenBoth" + _ -> "Period" diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs new file mode 100644 index 000000000..0cf01ee01 --- /dev/null +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -0,0 +1,923 @@ +{-# 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, fromMaybe) +import Text.Pandoc.Highlighting +import qualified Data.Text as T +import Control.Applicative ((<|>)) +import Skylighting + +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 + , rSolidFill :: Maybe Color + -- TODO: Make a full underline data type with + -- the different options. + , rPropUnderline :: Bool + } 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 + , rSolidFill = Nothing + , rPropUnderline = False + } + +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)) = + local (\r ->r{envRunProps = (envRunProps r){rLink = Just $ ExternalTarget (url, title)}}) $ + inlinesToParElems ils +inlineToParElems (Code _ str) = + 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} + , envRunProps = (envRunProps r){rPropCode = True}}) $ do + mbSty <- writerHighlightStyle <$> asks envOpts + synMap <- writerSyntaxMap <$> asks envOpts + case mbSty of + Just sty -> + case highlight synMap (formatSourceLines sty) attr str of + Right pElems -> do pProps <- asks envParaProps + return [Paragraph pProps pElems] + Left _ -> blockToParagraphs $ Para [Str str] + Nothing -> blockToParagraphs $ Para [Str 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 (uncurry cellToParagraphs) 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 = fromMaybe (getSlideLevel blks) (writerSlideLevel opts) + } + (presSlides, msgs) = runPres env def $ blocksToPresentationSlides blks + docProps = metaToDocProps meta + in + (Presentation docProps presSlides, msgs) + +-- -------------------------------------------------------------- + +applyTokStyToRunProps :: TokenStyle -> RunProps -> RunProps +applyTokStyToRunProps tokSty rProps = + rProps{ rSolidFill = tokenColor tokSty <|> rSolidFill rProps + , rPropBold = tokenBold tokSty || rPropBold rProps + , rPropItalics = tokenItalic tokSty || rPropItalics rProps + , rPropUnderline = tokenUnderline tokSty || rPropUnderline rProps + } + +formatToken :: Style -> Token -> ParaElem +formatToken sty (tokType, txt) = + let rProps = def{rPropCode = True, rSolidFill = defaultColor sty} + rProps' = case M.lookup tokType (tokenStyles sty) of + Just tokSty -> applyTokStyToRunProps tokSty rProps + Nothing -> rProps + in + Run rProps' $ T.unpack txt + +formatSourceLine :: Style -> FormatOptions -> SourceLine -> [ParaElem] +formatSourceLine sty _ srcLn = map (formatToken sty) srcLn + +formatSourceLines :: Style -> FormatOptions -> [SourceLine] -> [ParaElem] +formatSourceLines sty opts srcLns = intercalate [Break] $ + map (formatSourceLine sty opts) srcLns diff --git a/src/Text/Pandoc/Writers/RST.hs b/src/Text/Pandoc/Writers/RST.hs index 2b28dccf0..95cb46643 100644 --- a/src/Text/Pandoc/Writers/RST.hs +++ b/src/Text/Pandoc/Writers/RST.hs @@ -57,7 +57,6 @@ data WriterState = , stHasRawTeX :: Bool , stOptions :: WriterOptions , stTopLevel :: Bool - , stLastNested :: Bool } type RST = StateT WriterState @@ -68,7 +67,7 @@ writeRST opts document = do let st = WriterState { stNotes = [], stLinks = [], stImages = [], stHasMath = False, stHasRawTeX = False, stOptions = opts, - stTopLevel = True, stLastNested = False} + stTopLevel = True } evalStateT (pandocToRST document) st -- | Return RST representation of document. @@ -133,7 +132,7 @@ keyToRST (label, (src, _)) = do -- | Return RST representation of notes. notesToRST :: PandocMonad m => [[Block]] -> RST m Doc notesToRST notes = - mapM (uncurry noteToRST) (zip [1..] notes) >>= + zipWithM noteToRST [1..] notes >>= return . vsep -- | Return RST representation of a note. @@ -307,8 +306,7 @@ blockToRST (OrderedList (start, style', delim) items) = do let maxMarkerLength = maximum $ map length markers let markers' = map (\m -> let s = maxMarkerLength - length m in m ++ replicate s ' ') markers - contents <- mapM (uncurry orderedListItemToRST) $ - zip markers' items + contents <- zipWithM orderedListItemToRST markers' items -- ensure that sublists have preceding blank line return $ blankline $$ chomp (vcat contents) $$ blankline blockToRST (DefinitionList items) = do @@ -353,33 +351,26 @@ blockListToRST' :: PandocMonad m -> [Block] -- ^ List of block elements -> RST m Doc blockListToRST' topLevel blocks = do + -- insert comment between list and quoted blocks, see #4248 and #3675 + let fixBlocks (b1:b2@(BlockQuote _):bs) + | toClose b1 = b1 : commentSep : b2 : fixBlocks bs + where + toClose Plain{} = False + toClose Header{} = False + toClose LineBlock{} = False + toClose HorizontalRule = False + toClose (Para [Image _ _ (_,'f':'i':'g':':':_)]) = True + toClose Para{} = False + toClose _ = True + commentSep = RawBlock "rst" "..\n\n" + fixBlocks (b:bs) = b : fixBlocks bs + fixBlocks [] = [] tl <- gets stTopLevel - modify (\s->s{stTopLevel=topLevel, stLastNested=False}) - res <- vcat `fmap` mapM blockToRST' blocks + modify (\s->s{stTopLevel=topLevel}) + res <- vcat `fmap` mapM blockToRST (fixBlocks blocks) modify (\s->s{stTopLevel=tl}) return res -blockToRST' :: PandocMonad m => Block -> RST m Doc -blockToRST' (x@BlockQuote{}) = do - lastNested <- gets stLastNested - res <- blockToRST x - modify (\s -> s{stLastNested = True}) - return $ if lastNested - then ".." $+$ res - else res -blockToRST' x = do - modify (\s -> s{stLastNested = - case x of - Para [Image _ _ (_,'f':'i':'g':':':_)] -> True - Para{} -> False - Plain{} -> False - Header{} -> False - LineBlock{} -> False - HorizontalRule -> False - _ -> True - }) - blockToRST x - blockListToRST :: PandocMonad m => [Block] -- ^ List of block elements -> RST m Doc diff --git a/src/Text/Pandoc/Writers/RTF.hs b/src/Text/Pandoc/Writers/RTF.hs index 790bebc01..7006b58d1 100644 --- a/src/Text/Pandoc/Writers/RTF.hs +++ b/src/Text/Pandoc/Writers/RTF.hs @@ -31,6 +31,7 @@ Conversion of 'Pandoc' documents to RTF (rich text format). module Text.Pandoc.Writers.RTF ( writeRTF ) where import Control.Monad.Except (catchError, throwError) +import Control.Monad import qualified Data.ByteString as B import Data.Char (chr, isDigit, ord) import Data.List (intercalate, isSuffixOf) @@ -278,8 +279,7 @@ blockToRTF indent alignment (BulletList lst) = (spaceAtEnd . concat) <$> mapM (listItemToRTF alignment indent (bulletMarker indent)) lst blockToRTF indent alignment (OrderedList attribs lst) = (spaceAtEnd . concat) <$> - mapM (uncurry (listItemToRTF alignment indent)) - (zip (orderedMarkers indent attribs) lst) + zipWithM (listItemToRTF alignment indent) (orderedMarkers indent attribs) lst blockToRTF indent alignment (DefinitionList lst) = (spaceAtEnd . concat) <$> mapM (definitionListItemToRTF alignment indent) lst blockToRTF indent _ HorizontalRule = return $ @@ -303,8 +303,8 @@ tableRowToRTF header indent aligns sizes' cols = do let sizes = if all (== 0) sizes' then replicate (length cols) (1.0 / fromIntegral (length cols)) else sizes' - columns <- concat <$> mapM (uncurry (tableItemToRTF indent)) - (zip aligns cols) + columns <- concat <$> + zipWithM (tableItemToRTF indent) aligns cols let rightEdges = tail $ scanl (\sofar new -> sofar + floor (new * totalTwips)) (0 :: Integer) sizes let cellDefs = map (\edge -> (if header diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs index 713e4289e..ae4cc5cc5 100644 --- a/src/Text/Pandoc/Writers/Shared.hs +++ b/src/Text/Pandoc/Writers/Shared.hs @@ -40,6 +40,7 @@ module Text.Pandoc.Writers.Shared ( , fixDisplayMath , unsmartify , gridTable + , metaValueToInlines ) where import Control.Monad (zipWithM) @@ -55,6 +56,7 @@ import qualified Text.Pandoc.Builder as Builder 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 @@ gridTable opts blocksToDoc headless aligns widths headers rows = do head'' $$ body $$ border '-' (repeat AlignDefault) widthsInChars + +metaValueToInlines :: MetaValue -> [Inline] +metaValueToInlines (MetaString s) = [Str s] +metaValueToInlines (MetaInlines ils) = ils +metaValueToInlines (MetaBlocks bs) = query return bs +metaValueToInlines (MetaBool b) = [Str $ show b] +metaValueToInlines _ = [] diff --git a/src/Text/Pandoc/Writers/Texinfo.hs b/src/Text/Pandoc/Writers/Texinfo.hs index b5d72aa56..bf434642e 100644 --- a/src/Text/Pandoc/Writers/Texinfo.hs +++ b/src/Text/Pandoc/Writers/Texinfo.hs @@ -475,7 +475,7 @@ inlineToTexinfo (Link _ txt (src@('#':_), _)) = do inlineToTexinfo (Link _ txt (src, _)) = case txt of [Str x] | escapeURI x == src -> -- autolink - do return $ text $ "@url{" ++ x ++ "}" + return $ text $ "@url{" ++ x ++ "}" _ -> do contents <- escapeCommas $ inlineListToTexinfo txt let src1 = stringToTexinfo src return $ text ("@uref{" ++ src1 ++ ",") <> contents <> diff --git a/stack.lts9.yaml b/stack.lts9.yaml index 3684cbdbb..4979ca470 100644 --- a/stack.lts9.yaml +++ b/stack.lts9.yaml @@ -16,8 +16,9 @@ extra-deps: - pandoc-types-1.17.3 - hslua-0.9.5 - hslua-module-text-0.1.2 -- skylighting-0.5.1 -- texmath-0.10.1 +- skylighting-0.6 +- ansi-terminal-0.7.1.1 +- texmath-0.10.1.1 - cmark-gfm-0.1.1 - QuickCheck-2.10.0.1 - tasty-quickcheck-0.9.1 @@ -25,5 +26,6 @@ extra-deps: - haddock-library-1.4.3 - tagsoup-0.14.2 - hs-bibutils-6.2.0.1 -- pandoc-citeproc-0.12.2.5 +- pandoc-citeproc-0.14 +- tagsoup-0.14.3 resolver: lts-9.14 diff --git a/stack.yaml b/stack.yaml index b72c1ffb4..7ac48ffcc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,8 +13,13 @@ flags: packages: - '.' extra-deps: -- pandoc-citeproc-0.12.2.5 +- pandoc-citeproc-0.14 - hslua-0.9.5 -- skylighting-0.5.1 -- tasty-1.0 +- skylighting-0.6 +- ansi-terminal-0.7.1.1 +- tasty-1.0.0.1 +- texmath-0.10.1.1 +- tagsoup-0.14.3 +ghc-options: + "$locals": -fhide-source-paths resolver: lts-10.3 diff --git a/test/Tests/Command.hs b/test/Tests/Command.hs index 4999ff45a..de83d0639 100644 --- a/test/Tests/Command.hs +++ b/test/Tests/Command.hs @@ -40,7 +40,7 @@ runTest testname pandocpath cmd inp norm = testCase testname $ do -- filter \r so the tests will work on Windows machines let out = filter (/= '\r') $ err' ++ out' result <- if ec == ExitSuccess - then do + then if out == norm then return TestPassed else return @@ -52,6 +52,7 @@ runTest testname pandocpath cmd inp norm = testCase testname $ do assertBool (show result) (result == TestPassed) tests :: TestTree +{-# NOINLINE tests #-} tests = unsafePerformIO $ do pandocpath <- findPandoc files <- filter (".md" `isSuffixOf`) <$> @@ -89,7 +90,6 @@ extractCommandTest pandocpath fp = unsafePerformIO $ do contents <- UTF8.toText <$> BS.readFile ("command" </> fp) Pandoc _ blocks <- runIOorExplode (readMarkdown def{ readerExtensions = pandocExtensions } contents) - let codeblocks = map extractCode $ filter isCodeBlock $ blocks + let codeblocks = map extractCode $ filter isCodeBlock blocks let cases = map (runCommandTest pandocpath) $ zip [1..] codeblocks return $ testGroup fp cases - diff --git a/test/Tests/Lua.hs b/test/Tests/Lua.hs index 66dc2a6dd..b25a6fa4a 100644 --- a/test/Tests/Lua.hs +++ b/test/Tests/Lua.hs @@ -12,8 +12,10 @@ import Text.Pandoc.Builder (bulletList, divWith, doc, doubleQuoted, emph, 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 @@ -122,13 +124,44 @@ tests = map (localOption (QuickCheckTests 20)) Lua.getglobal "PANDOC_API_VERSION" 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 diff --git a/test/Tests/Readers/Creole.hs b/test/Tests/Readers/Creole.hs index 3a21df738..3f60a523d 100644 --- a/test/Tests/Readers/Creole.hs +++ b/test/Tests/Readers/Creole.hs @@ -224,7 +224,7 @@ tests = [ <> " bar") , "escaped auto link" =: "foo ~http://foo.example.com/bar/baz.html bar" - =?> para ("foo http://foo.example.com/bar/baz.html bar") + =?> para "foo http://foo.example.com/bar/baz.html bar" , "wiki link simple" =: "foo [[http://foo.example.com/foo.png]] bar" =?> para ("foo " diff --git a/test/Tests/Readers/Docx.hs b/test/Tests/Readers/Docx.hs index 68c2e3476..89a605bf7 100644 --- a/test/Tests/Readers/Docx.hs +++ b/test/Tests/Readers/Docx.hs @@ -5,6 +5,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as B import qualified Data.Map as M import qualified Data.Text as T +import Data.Maybe import System.IO.Unsafe import Test.Tasty import Test.Tasty.HUnit @@ -46,7 +47,7 @@ compareOutput opts docxFile nativeFile = do nf <- UTF8.toText <$> BS.readFile nativeFile p <- runIOorExplode $ readDocx opts df df' <- runIOorExplode $ readNative def nf - return $ (noNorm p, noNorm df') + return (noNorm p, noNorm df') testCompareWithOptsIO :: ReaderOptions -> String -> FilePath -> FilePath -> IO TestTree testCompareWithOptsIO opts name docxFile nativeFile = do @@ -87,11 +88,9 @@ compareMediaPathIO mediaPath mediaBag docxPath = do Nothing -> error ("couldn't find " ++ mediaPath ++ " in media bag") - docxBS = case docxMedia of - Just bs -> bs - Nothing -> error ("couldn't find " ++ - mediaPath ++ - " in media bag") + docxBS = fromMaybe (error ("couldn't find " ++ + mediaPath ++ + " in media bag")) docxMedia return $ mbBS == docxBS compareMediaBagIO :: FilePath -> IO Bool @@ -128,6 +127,10 @@ tests = [ testGroup "inlines" "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" diff --git a/test/Tests/Readers/EPUB.hs b/test/Tests/Readers/EPUB.hs index 201fd10a5..1337a9c11 100644 --- a/test/Tests/Readers/EPUB.hs +++ b/test/Tests/Readers/EPUB.hs @@ -17,7 +17,7 @@ getMediaBag fp = do testMediaBag :: FilePath -> [(String, String, Int)] -> IO () testMediaBag fp bag = do - actBag <- (mediaDirectory <$> getMediaBag fp) + actBag <- mediaDirectory <$> getMediaBag fp assertBool (show "MediaBag did not match:\nExpected: " ++ show bag ++ "\nActual: " diff --git a/test/Tests/Readers/Muse.hs b/test/Tests/Readers/Muse.hs index e9ac64a96..36b08c3a2 100644 --- a/test/Tests/Readers/Muse.hs +++ b/test/Tests/Readers/Muse.hs @@ -27,15 +27,20 @@ infix 4 =: spcSep :: [Inlines] -> Inlines spcSep = mconcat . intersperse space --- Tables and definition lists don't round-trip yet +-- Tables don't round-trip yet +-- Definition lists with multiple descriptions are supported by writer, but not reader yet + +singleDescription :: ([Inline], [[Block]]) -> ([Inline], [[Block]]) +singleDescription (a, x:_) = (a, [x]) +singleDescription x = x makeRoundTrip :: Block -> Block -makeRoundTrip (Table{}) = Para [Str "table was here"] -makeRoundTrip (DefinitionList{}) = Para [Str "deflist was here"] +makeRoundTrip Table{} = Para [Str "table was here"] +makeRoundTrip (DefinitionList items) = DefinitionList $ map singleDescription items makeRoundTrip x = x -- Demand that any AST produced by Muse reader and written by Muse writer can be read back exactly the same way. --- Currently we remove code blocks and tables and compare third rewrite to the second. +-- Currently we remove tables and compare third rewrite to the second. -- First and second rewrites are not equal yet. roundTrip :: Block -> Bool roundTrip b = d'' == d''' @@ -44,7 +49,7 @@ roundTrip b = d'' == d''' d'' = rewrite d' d''' = rewrite d'' rewrite = amuse . T.pack . (++ "\n") . T.unpack . - (purely $ writeMuse def { writerExtensions = extensionsFromList [Ext_amuse] + purely (writeMuse def { writerExtensions = extensionsFromList [Ext_amuse] , writerWrapText = WrapPreserve }) @@ -114,8 +119,8 @@ tests = , "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 +158,9 @@ tests = ] =?> 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 +169,8 @@ tests = , "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 +289,12 @@ tests = , " 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 +358,11 @@ tests = , " </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 +544,14 @@ tests = , "[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 +722,48 @@ tests = , 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 +785,6 @@ tests = ] ] ] - , "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" @@ -886,6 +929,8 @@ tests = definitionList [ ("foo", [ para "bar" ]) ] , "Definition list term with emphasis" =: " *Foo* :: bar\n" =?> definitionList [ (emph "Foo", [ para "bar" ]) ] + , "Definition list term with :: inside code" =: " foo <code> :: </code> :: bar <code> :: </code> baz\n" =?> + definitionList [ ("foo " <> code " :: ", [ para $ "bar " <> code " :: " <> " baz" ]) ] , "Multi-line definition lists" =: T.unlines [ " First term :: Definition of first term" @@ -920,16 +965,18 @@ tests = 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" =: + , "One-line nested definition list" =: + " Foo :: bar :: baz" =?> + definitionList [ ("Foo", [ definitionList [ ("bar", [ para "baz" ])]])] + , "Nested definition list" =: 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." ]) + [ " First :: Second :: Third" + , " Fourth :: Fifth :: Sixth" + , " Seventh :: Eighth" + ] =?> + definitionList [ ("First", [ definitionList [ ("Second", [ para "Third" ]), + ("Fourth", [ definitionList [ ("Fifth", [ para "Sixth"] ) ] ] ) ] ] ) + , ("Seventh", [ para "Eighth" ]) ] , "Two blank lines separate definition lists" =: T.unlines diff --git a/test/Tests/Readers/Org/Block/Header.hs b/test/Tests/Readers/Org/Block/Header.hs index d895c86e2..e8ad88558 100644 --- a/test/Tests/Readers/Org/Block/Header.hs +++ b/test/Tests/Readers/Org/Block/Header.hs @@ -130,7 +130,7 @@ tests = mconcat [ para "foo" , headerWith ("thing-other-thing", [], []) 1 - ((strikeout "thing") <> " other thing") + (strikeout "thing" <> " other thing") ] , "Comment Trees" =: diff --git a/test/Tests/Readers/Org/Block/List.hs b/test/Tests/Readers/Org/Block/List.hs index 32bb13294..343682a80 100644 --- a/test/Tests/Readers/Org/Block/List.hs +++ b/test/Tests/Readers/Org/Block/List.hs @@ -75,16 +75,16 @@ tests = ] , "Bullet List with Decreasing Indent" =: - (" - Discovery\n\ - \ - Human After All\n") =?> + " - Discovery\n\ + \ - Human After All\n" =?> mconcat [ bulletList [ plain "Discovery" ] , bulletList [ plain ("Human" <> space <> "After" <> space <> "All")] ] , "Header follows Bullet List" =: - (" - Discovery\n\ + " - Discovery\n\ \ - Human After All\n\ - \* Homework") =?> + \* Homework" =?> mconcat [ bulletList [ plain "Discovery" , plain ("Human" <> space <> "After" <> space <> "All") ] @@ -92,9 +92,9 @@ tests = ] , "Bullet List Unindented with trailing Header" =: - ("- Discovery\n\ + "- Discovery\n\ \- Homework\n\ - \* NotValidListItem") =?> + \* NotValidListItem" =?> mconcat [ bulletList [ plain "Discovery" , plain "Homework" ] @@ -166,14 +166,14 @@ tests = , "Ordered List in Bullet List" =: ("- Emacs\n" <> " 1. Org\n") =?> - bulletList [ (plain "Emacs") <> - (orderedList [ plain "Org"]) + bulletList [ plain "Emacs" <> + orderedList [ plain "Org"] ] , "Bullet List in Ordered List" =: ("1. GNU\n" <> " - Freedom\n") =?> - orderedList [ (plain "GNU") <> bulletList [ (plain "Freedom") ] ] + orderedList [ plain "GNU" <> bulletList [ plain "Freedom" ] ] , "Definition List" =: T.unlines [ "- PLL :: phase-locked loop" diff --git a/test/Tests/Readers/Org/Directive.hs b/test/Tests/Readers/Org/Directive.hs index 862315ef3..7e2c0fb8d 100644 --- a/test/Tests/Readers/Org/Directive.hs +++ b/test/Tests/Readers/Org/Directive.hs @@ -107,8 +107,8 @@ tests = ] =?> mconcat [ para "first block" , orderedList - [ (para "top-level section 1" <> - orderedList [ para "subsection" ]) + [ para "top-level section 1" <> + orderedList [ para "subsection" ] , para "top-level section 2" ] ] diff --git a/test/Tests/Readers/Org/Inline.hs b/test/Tests/Readers/Org/Inline.hs index cb50ba630..da0d1db0b 100644 --- a/test/Tests/Readers/Org/Inline.hs +++ b/test/Tests/Readers/Org/Inline.hs @@ -36,7 +36,7 @@ tests = , "Underline" =: "_underline_" =?> - para (underlineSpan $ "underline") + para (underlineSpan "underline") , "Strikeout" =: "+Kill Bill+" =?> @@ -127,11 +127,12 @@ tests = , "Markup should work properly after a blank line" =: T.unlines ["foo", "", "/bar/"] =?> - (para $ text "foo") <> (para $ emph $ text "bar") + para (text "foo") <> + para (emph $ text "bar") , "Inline math must stay within three lines" =: T.unlines [ "$a", "b", "c$", "$d", "e", "f", "g$" ] =?> - para ((math "a\nb\nc") <> softbreak <> + para (math "a\nb\nc" <> softbreak <> "$d" <> softbreak <> "e" <> softbreak <> "f" <> softbreak <> "g$") @@ -139,7 +140,7 @@ tests = "$a$ $b$! $c$?" =?> para (spcSep [ math "a" , "$b$!" - , (math "c") <> "?" + , math "c" <> "?" ]) , "Markup may not span more than two lines" =: @@ -166,12 +167,12 @@ tests = para (mconcat $ intersperse softbreak [ "a" <> subscript "(a(b)(c)d)" , "e" <> superscript "(f(g)h)" - , "i" <> (subscript "(jk)") <> "l)" - , "m" <> (superscript "()") <> "n" + , "i" <> subscript "(jk)" <> "l)" + , "m" <> superscript "()" <> "n" , "o" <> subscript "p{q{}r}" , "s" <> superscript "t{u}v" - , "w" <> (subscript "xy") <> "z}" - , "1" <> (superscript "") <> "2" + , "w" <> subscript "xy" <> "z}" + , "1" <> superscript "" <> "2" , "3" <> subscript "{}" , "4" <> superscript ("(a(" <> strong "b(c" <> ")d))") ]) @@ -182,17 +183,17 @@ tests = , testGroup "Images" [ "Image" =: "[[./sunset.jpg]]" =?> - (para $ image "./sunset.jpg" "" "") + para (image "./sunset.jpg" "" "") , "Image with explicit file: prefix" =: "[[file:sunrise.jpg]]" =?> - (para $ image "sunrise.jpg" "" "") + para (image "sunrise.jpg" "" "") , "Multiple images within a paragraph" =: T.unlines [ "[[file:sunrise.jpg]]" , "[[file:sunset.jpg]]" ] =?> - (para $ (image "sunrise.jpg" "" "") + para ((image "sunrise.jpg" "" "") <> softbreak <> (image "sunset.jpg" "" "")) @@ -200,75 +201,75 @@ tests = T.unlines [ "#+ATTR_HTML: :width 50%" , "[[file:guinea-pig.gif]]" ] =?> - (para $ imageWith ("", [], [("width", "50%")]) "guinea-pig.gif" "" "") + para (imageWith ("", [], [("width", "50%")]) "guinea-pig.gif" "" "") ] , "Explicit link" =: "[[http://zeitlens.com/][pseudo-random /nonsense/]]" =?> - (para $ link "http://zeitlens.com/" "" + para (link "http://zeitlens.com/" "" ("pseudo-random" <> space <> emph "nonsense")) , "Self-link" =: "[[http://zeitlens.com/]]" =?> - (para $ link "http://zeitlens.com/" "" "http://zeitlens.com/") + para (link "http://zeitlens.com/" "" "http://zeitlens.com/") , "Absolute file link" =: "[[/url][hi]]" =?> - (para $ link "file:///url" "" "hi") + para (link "file:///url" "" "hi") , "Link to file in parent directory" =: "[[../file.txt][moin]]" =?> - (para $ link "../file.txt" "" "moin") + para (link "../file.txt" "" "moin") , "Empty link (for gitit interop)" =: "[[][New Link]]" =?> - (para $ link "" "" "New Link") + para (link "" "" "New Link") , "Image link" =: "[[sunset.png][file:dusk.svg]]" =?> - (para $ link "sunset.png" "" (image "dusk.svg" "" "")) + para (link "sunset.png" "" (image "dusk.svg" "" "")) , "Image link with non-image target" =: "[[http://example.com][./logo.png]]" =?> - (para $ link "http://example.com" "" (image "./logo.png" "" "")) + para (link "http://example.com" "" (image "./logo.png" "" "")) , "Plain link" =: "Posts on http://zeitlens.com/ can be funny at times." =?> - (para $ spcSep [ "Posts", "on" + para (spcSep [ "Posts", "on" , link "http://zeitlens.com/" "" "http://zeitlens.com/" , "can", "be", "funny", "at", "times." ]) , "Angle link" =: "Look at <http://moltkeplatz.de> for fnords." =?> - (para $ spcSep [ "Look", "at" + para (spcSep [ "Look", "at" , link "http://moltkeplatz.de" "" "http://moltkeplatz.de" , "for", "fnords." ]) , "Absolute file link" =: "[[file:///etc/passwd][passwd]]" =?> - (para $ link "file:///etc/passwd" "" "passwd") + para (link "file:///etc/passwd" "" "passwd") , "File link" =: "[[file:target][title]]" =?> - (para $ link "target" "" "title") + para (link "target" "" "title") , "Anchor" =: "<<anchor>> Link here later." =?> - (para $ spanWith ("anchor", [], []) mempty <> + para (spanWith ("anchor", [], []) mempty <> "Link" <> space <> "here" <> space <> "later.") , "Inline code block" =: "src_emacs-lisp{(message \"Hello\")}" =?> - (para $ codeWith ( "" + para (codeWith ( "" , [ "commonlisp" ] , [ ("org-language", "emacs-lisp") ]) "(message \"Hello\")") , "Inline code block with arguments" =: "src_sh[:export both :results output]{echo 'Hello, World'}" =?> - (para $ codeWith ( "" + para (codeWith ( "" , [ "bash" ] , [ ("org-language", "sh") , ("export", "both") @@ -279,7 +280,7 @@ tests = , "Inline code block with toggle" =: "src_sh[:toggle]{echo $HOME}" =?> - (para $ codeWith ( "" + para (codeWith ( "" , [ "bash" ] , [ ("org-language", "sh") , ("toggle", "yes") @@ -415,7 +416,7 @@ tests = in [ "Berkeley-style in-text citation" =: "See @Dominik201408." =?> - (para $ "See " + para ("See " <> cite [dominikInText] "@Dominik201408" <> ".") @@ -468,7 +469,7 @@ tests = , "MathML symbol in LaTeX-style" =: "There is a hackerspace in Lübeck, Germany, called nbsp (unicode symbol: '\\nbsp')." =?> - para ("There is a hackerspace in Lübeck, Germany, called nbsp (unicode symbol: ' ').") + para "There is a hackerspace in Lübeck, Germany, called nbsp (unicode symbol: ' ')." , "MathML symbol in LaTeX-style, including braces" =: "\\Aacute{}stor" =?> diff --git a/test/Tests/Readers/Org/Inline/Note.hs b/test/Tests/Readers/Org/Inline/Note.hs index 46416d7d8..9eb1d02d6 100644 --- a/test/Tests/Readers/Org/Inline/Note.hs +++ b/test/Tests/Readers/Org/Inline/Note.hs @@ -84,4 +84,3 @@ tests = , para "next" ] ] - diff --git a/test/Tests/Readers/Org/Inline/Smart.hs b/test/Tests/Readers/Org/Inline/Smart.hs index 7a5e653cf..77f10699d 100644 --- a/test/Tests/Readers/Org/Inline/Smart.hs +++ b/test/Tests/Readers/Org/Inline/Smart.hs @@ -38,9 +38,9 @@ tests = , test orgSmart "Single quotes can be followed by emphasized text" ("Singles on the '/meat market/'" =?> - para ("Singles on the " <> (singleQuoted $ emph "meat market"))) + para ("Singles on the " <> singleQuoted (emph "meat market"))) , test orgSmart "Double quotes can be followed by emphasized text" ("Double income, no kids: \"/DINK/\"" =?> - para ("Double income, no kids: " <> (doubleQuoted $ emph "DINK"))) + para ("Double income, no kids: " <> doubleQuoted (emph "DINK"))) ] diff --git a/test/Tests/Readers/Org/Meta.hs b/test/Tests/Readers/Org/Meta.hs index 3ad6f5d8b..409cd00ae 100644 --- a/test/Tests/Readers/Org/Meta.hs +++ b/test/Tests/Readers/Org/Meta.hs @@ -30,32 +30,32 @@ tests = , "Title" =: "#+TITLE: Hello, World" =?> let titleInline = toList $ "Hello," <> space <> "World" - meta = setMeta "title" (MetaInlines titleInline) $ nullMeta + meta = setMeta "title" (MetaInlines titleInline) nullMeta in Pandoc meta mempty , "Author" =: "#+author: John /Emacs-Fanboy/ Doe" =?> let author = toList . spcSep $ [ "John", emph "Emacs-Fanboy", "Doe" ] - meta = setMeta "author" (MetaList [MetaInlines author]) $ nullMeta + meta = setMeta "author" (MetaList [MetaInlines author]) nullMeta in Pandoc meta mempty , "Multiple authors" =: "#+author: James Dewey Watson, Francis Harry Compton Crick " =?> let watson = MetaInlines $ toList "James Dewey Watson" crick = MetaInlines $ toList "Francis Harry Compton Crick" - meta = setMeta "author" (MetaList [watson, crick]) $ nullMeta + meta = setMeta "author" (MetaList [watson, crick]) nullMeta in Pandoc meta mempty , "Date" =: "#+Date: Feb. *28*, 2014" =?> - let date = toList . spcSep $ [ "Feb.", (strong "28") <> ",", "2014" ] - meta = setMeta "date" (MetaInlines date) $ nullMeta + let date = toList . spcSep $ [ "Feb.", strong "28" <> ",", "2014" ] + meta = setMeta "date" (MetaInlines date) nullMeta in Pandoc meta mempty , "Description" =: "#+DESCRIPTION: Explanatory text" =?> let description = "Explanatory text" - meta = setMeta "description" (MetaString description) $ nullMeta + meta = setMeta "description" (MetaString description) nullMeta in Pandoc meta mempty , "Properties drawer" =: @@ -94,7 +94,7 @@ tests = , "#+author: Max" ] =?> let author = MetaInlines [Str "Max"] - meta = setMeta "author" (MetaList [author]) $ nullMeta + meta = setMeta "author" (MetaList [author]) nullMeta in Pandoc meta mempty , "Logbook drawer" =: @@ -135,7 +135,7 @@ tests = , "Search links are read as emph" =: "[[Wally][Where's Wally?]]" =?> - (para (emph $ "Where's" <> space <> "Wally?")) + para (emph $ "Where's" <> space <> "Wally?") , "Link to nonexistent anchor" =: T.unlines [ "<<link-here>> Target." @@ -149,25 +149,25 @@ tests = T.unlines [ "#+LINK: wp https://en.wikipedia.org/wiki/%s" , "[[wp:Org_mode][Wikipedia on Org-mode]]" ] =?> - (para (link "https://en.wikipedia.org/wiki/Org_mode" "" - ("Wikipedia" <> space <> "on" <> space <> "Org-mode"))) + para (link "https://en.wikipedia.org/wiki/Org_mode" "" + ("Wikipedia" <> space <> "on" <> space <> "Org-mode")) , "Link abbreviation, defined after first use" =: T.unlines [ "[[zl:non-sense][Non-sense articles]]" , "#+LINK: zl http://zeitlens.com/tags/%s.html" ] =?> - (para (link "http://zeitlens.com/tags/non-sense.html" "" - ("Non-sense" <> space <> "articles"))) + para (link "http://zeitlens.com/tags/non-sense.html" "" + ("Non-sense" <> space <> "articles")) , "Link abbreviation, URL encoded arguments" =: T.unlines [ "#+link: expl http://example.com/%h/foo" , "[[expl:Hello, World!][Moin!]]" ] =?> - (para (link "http://example.com/Hello%2C%20World%21/foo" "" "Moin!")) + para (link "http://example.com/Hello%2C%20World%21/foo" "" "Moin!") , "Link abbreviation, append arguments" =: T.unlines [ "#+link: expl http://example.com/" , "[[expl:foo][bar]]" ] =?> - (para (link "http://example.com/foo" "" "bar")) + para (link "http://example.com/foo" "" "bar") ] diff --git a/test/Tests/Readers/RST.hs b/test/Tests/Readers/RST.hs index 928fc1a99..3753fbf12 100644 --- a/test/Tests/Readers/RST.hs +++ b/test/Tests/Readers/RST.hs @@ -36,8 +36,8 @@ tests = [ "line block with blank line" =: , ":Parameter i: integer" , ":Final: item" , " on two lines" ] - =?> ( doc - $ para "para" <> + =?> + doc (para "para" <> definitionList [ (str "Hostname", [para "media08"]) , (text "IP address", [para "10.0.0.19"]) , (str "Size", [para "3ru"]) @@ -56,10 +56,10 @@ tests = [ "line block with blank line" =: , "" , ":Version: 1" ] - =?> ( setMeta "version" (para "1") - $ setMeta "title" ("Title" :: Inlines) + =?> + setMeta "version" (para "1") (setMeta "title" ("Title" :: Inlines) $ setMeta "subtitle" ("Subtitle" :: Inlines) - $ doc mempty ) + $ doc mempty) , "with inline markup" =: T.unlines [ ":*Date*: today" , "" @@ -73,8 +73,8 @@ tests = [ "line block with blank line" =: , ".. _two: http://example.com" , ".. _three: http://example.org" ] - =?> ( setMeta "date" (str "today") - $ doc + =?> + setMeta "date" (str "today") (doc $ definitionList [ (emph "one", [para "emphasis"]) , (link "http://example.com" "" "two", [para "reference"]) , (link "http://example.org" "" "three", [para "another one"]) @@ -102,13 +102,12 @@ tests = [ "line block with blank line" =: , " def func(x):" , " return y" ] =?> - ( doc $ codeBlockWith + doc (codeBlockWith ( "" , ["sourceCode", "python", "numberLines", "class1", "class2", "class3"] , [ ("startFrom", "34") ] ) - "def func(x):\n return y" - ) + "def func(x):\n return y") , "Code directive with number-lines, no line specified" =: T.unlines [ ".. code::python" , " :number-lines: " @@ -116,13 +115,12 @@ tests = [ "line block with blank line" =: , " def func(x):" , " return y" ] =?> - ( doc $ codeBlockWith + doc (codeBlockWith ( "" , ["sourceCode", "python", "numberLines"] , [ ("startFrom", "") ] ) - "def func(x):\n return y" - ) + "def func(x):\n return y") , testGroup "literal / line / code blocks" [ "indented literal block" =: T.unlines [ "::" @@ -131,7 +129,8 @@ tests = [ "line block with blank line" =: , "" , " can go on for many lines" , "but must stop here"] - =?> (doc $ + =?> + doc ( codeBlock "block quotes\n\ncan go on for many lines" <> para "but must stop here") , "line block with 3 lines" =: "| a\n| b\n| c" @@ -185,6 +184,6 @@ tests = [ "line block with blank line" =: , ".. [1]" , " bar" ] =?> - (para $ "foo" <> (note $ para "bar")) + para ("foo" <> (note $ para "bar")) ] ] diff --git a/test/Tests/Readers/Txt2Tags.hs b/test/Tests/Readers/Txt2Tags.hs index 28f647de4..9c5053af7 100644 --- a/test/Tests/Readers/Txt2Tags.hs +++ b/test/Tests/Readers/Txt2Tags.hs @@ -30,11 +30,11 @@ simpleTable' :: Int -> [Blocks] -> [[Blocks]] -> Blocks -simpleTable' n = table "" (take n $ repeat (AlignCenter, 0.0)) +simpleTable' n = table "" (replicate n (AlignCenter, 0.0)) tests :: [TestTree] tests = - [ testGroup "Inlines" $ + [ testGroup "Inlines" [ "Plain String" =: "Hello, World" =?> para (spcSep [ "Hello,", "World" ]) @@ -114,7 +114,7 @@ tests = ] - , testGroup "Basic Blocks" $ + , testGroup "Basic Blocks" ["Paragraph, lines grouped together" =: "A paragraph\n A blank line ends the \n current paragraph\n" =?> para "A paragraph\n A blank line ends the\n current paragraph" @@ -197,7 +197,7 @@ tests = ] - , testGroup "Lists" $ + , testGroup "Lists" [ "Simple Bullet Lists" =: ("- Item1\n" <> "- Item2\n") =?> diff --git a/test/Tests/Shared.hs b/test/Tests/Shared.hs index 6fdbda3dd..cc448419c 100644 --- a/test/Tests/Shared.hs +++ b/test/Tests/Shared.hs @@ -19,21 +19,21 @@ tests = [ testGroup "compactifyDL" testCollapse :: [TestTree] testCollapse = map (testCase "collapse") - [ (collapseFilePath (joinPath [ ""]) @?= (joinPath [ ""])) - , (collapseFilePath (joinPath [ ".","foo"]) @?= (joinPath [ "foo"])) - , (collapseFilePath (joinPath [ ".",".","..","foo"]) @?= (joinPath [ joinPath ["..", "foo"]])) - , (collapseFilePath (joinPath [ "..","foo"]) @?= (joinPath [ "..","foo"])) - , (collapseFilePath (joinPath [ "","bar","..","baz"]) @?= (joinPath [ "","baz"])) - , (collapseFilePath (joinPath [ "","..","baz"]) @?= (joinPath [ "","..","baz"])) - , (collapseFilePath (joinPath [ ".","foo","..",".","bar","..",".",".","baz"]) @?= (joinPath [ "baz"])) - , (collapseFilePath (joinPath [ ".",""]) @?= (joinPath [ ""])) - , (collapseFilePath (joinPath [ ".",".",""]) @?= (joinPath [ ""])) - , (collapseFilePath (joinPath [ "..",""]) @?= (joinPath [ ".."])) - , (collapseFilePath (joinPath [ "..",".",""]) @?= (joinPath [ ".."])) - , (collapseFilePath (joinPath [ ".","..",""]) @?= (joinPath [ ".."])) - , (collapseFilePath (joinPath [ "..","..",""]) @?= (joinPath [ "..",".."])) - , (collapseFilePath (joinPath [ "parent","foo","baz","..","bar"]) @?= (joinPath [ "parent","foo","bar"])) - , (collapseFilePath (joinPath [ "parent","foo","baz","..","..","bar"]) @?= (joinPath [ "parent","bar"])) - , (collapseFilePath (joinPath [ "parent","foo",".."]) @?= (joinPath [ "parent"])) - , (collapseFilePath (joinPath [ "","parent","foo","..","..","bar"]) @?= (joinPath [ "","bar"])) - , (collapseFilePath (joinPath [ "",".","parent","foo"]) @?= (joinPath [ "","parent","foo"]))] + [ collapseFilePath (joinPath [ ""]) @?= (joinPath [ ""]) + , collapseFilePath (joinPath [ ".","foo"]) @?= (joinPath [ "foo"]) + , collapseFilePath (joinPath [ ".",".","..","foo"]) @?= (joinPath [ joinPath ["..", "foo"]]) + , collapseFilePath (joinPath [ "..","foo"]) @?= (joinPath [ "..","foo"]) + , collapseFilePath (joinPath [ "","bar","..","baz"]) @?= (joinPath [ "","baz"]) + , collapseFilePath (joinPath [ "","..","baz"]) @?= (joinPath [ "","..","baz"]) + , collapseFilePath (joinPath [ ".","foo","..",".","bar","..",".",".","baz"]) @?= (joinPath [ "baz"]) + , collapseFilePath (joinPath [ ".",""]) @?= (joinPath [ ""]) + , collapseFilePath (joinPath [ ".",".",""]) @?= (joinPath [ ""]) + , collapseFilePath (joinPath [ "..",""]) @?= (joinPath [ ".."]) + , collapseFilePath (joinPath [ "..",".",""]) @?= (joinPath [ ".."]) + , collapseFilePath (joinPath [ ".","..",""]) @?= (joinPath [ ".."]) + , collapseFilePath (joinPath [ "..","..",""]) @?= (joinPath [ "..",".."]) + , collapseFilePath (joinPath [ "parent","foo","baz","..","bar"]) @?= (joinPath [ "parent","foo","bar"]) + , collapseFilePath (joinPath [ "parent","foo","baz","..","..","bar"]) @?= (joinPath [ "parent","bar"]) + , collapseFilePath (joinPath [ "parent","foo",".."]) @?= (joinPath [ "parent"]) + , collapseFilePath (joinPath [ "","parent","foo","..","..","bar"]) @?= (joinPath [ "","bar"]) + , collapseFilePath (joinPath [ "",".","parent","foo"]) @?= (joinPath [ "","parent","foo"])] diff --git a/test/Tests/Writers/ConTeXt.hs b/test/Tests/Writers/ConTeXt.hs index 783b601a9..5ce629674 100644 --- a/test/Tests/Writers/ConTeXt.hs +++ b/test/Tests/Writers/ConTeXt.hs @@ -15,6 +15,9 @@ context = unpack . purely (writeConTeXt def) . toPandoc 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 @@ -38,9 +41,9 @@ tests = [ testGroup "inline code" , "without '}'" =: code "]" =?> "\\type{]}" , testProperty "code property" $ \s -> null s || if '{' `elem` s || '}' `elem` s - then (context' $ code s) == "\\mono{" ++ - (context' $ str s) ++ "}" - else (context' $ code s) == "\\type{" ++ s ++ "}" + then context' (code s) == "\\mono{" ++ + context' (str s) ++ "}" + else context' (code s) == "\\type{" ++ s ++ "}" ] , testGroup "headers" [ "level 1" =: @@ -68,5 +71,56 @@ tests = [ testGroup "inline code" , " \\stopitemize" , "\\stopitemize" ] ] + , testGroup "natural tables" + [ test contextNtb "table with header and caption" $ + let caption = text "Table 1" + aligns = [(AlignRight, 0.0), (AlignLeft, 0.0), (AlignCenter, 0.0), (AlignDefault, 0.0)] + headers = [plain $ text "Right", + plain $ text "Left", + plain $ text "Center", + plain $ text "Default"] + rows = [[plain $ text "1.1", + plain $ text "1.2", + plain $ text "1.3", + plain $ text "1.4"] + ,[plain $ text "2.1", + plain $ text "2.2", + plain $ text "2.3", + plain $ text "2.4"] + ,[plain $ text "3.1", + plain $ text "3.2", + plain $ text "3.3", + plain $ text "3.4"]] + in table caption aligns headers rows + =?> unlines [ "\\startplacetable[caption={Table 1}]" + , "\\startTABLE" + , "\\startTABLEhead" + , "\\NC[align=left] Right" + , "\\NC[align=right] Left" + , "\\NC[align=middle] Center" + , "\\NC Default" + , "\\NC\\NR" + , "\\stopTABLEhead" + , "\\startTABLEbody" + , "\\NC[align=left] 1.1" + , "\\NC[align=right] 1.2" + , "\\NC[align=middle] 1.3" + , "\\NC 1.4" + , "\\NC\\NR" + , "\\NC[align=left] 2.1" + , "\\NC[align=right] 2.2" + , "\\NC[align=middle] 2.3" + , "\\NC 2.4" + , "\\NC\\NR" + , "\\stopTABLEbody" + , "\\startTABLEfoot" + , "\\NC[align=left] 3.1" + , "\\NC[align=right] 3.2" + , "\\NC[align=middle] 3.3" + , "\\NC 3.4" + , "\\NC\\NR" + , "\\stopTABLEfoot" + , "\\stopTABLE" + , "\\stopplacetable" ] + ] ] - diff --git a/test/Tests/Writers/Docbook.hs b/test/Tests/Writers/Docbook.hs index 90ae073fa..89ea76586 100644 --- a/test/Tests/Writers/Docbook.hs +++ b/test/Tests/Writers/Docbook.hs @@ -230,7 +230,7 @@ tests = [ testGroup "line blocks" ] ] ] - , testGroup "writer options" $ + , testGroup "writer options" [ testGroup "top-level division" $ let headers = header 1 (text "header1") diff --git a/test/Tests/Writers/FB2.hs b/test/Tests/Writers/FB2.hs index b4d11abf4..6663c42f8 100644 --- a/test/Tests/Writers/FB2.hs +++ b/test/Tests/Writers/FB2.hs @@ -23,7 +23,7 @@ tests = [ testGroup "block elements" ] , testGroup "inlines" [ - "Emphasis" =: emph ("emphasized") + "Emphasis" =: emph "emphasized" =?> fb2 "<emphasis>emphasized</emphasis>" ] , "bullet list" =: bulletList [ plain $ text "first" diff --git a/test/Tests/Writers/JATS.hs b/test/Tests/Writers/JATS.hs index f14f1c229..572b16451 100644 --- a/test/Tests/Writers/JATS.hs +++ b/test/Tests/Writers/JATS.hs @@ -120,5 +120,3 @@ tests = [ testGroup "inline code" \</sec>" ] ] - - diff --git a/test/Tests/Writers/Markdown.hs b/test/Tests/Writers/Markdown.hs index 012e0888c..7f9ac3627 100644 --- a/test/Tests/Writers/Markdown.hs +++ b/test/Tests/Writers/Markdown.hs @@ -80,7 +80,7 @@ noteTestDoc = ".") <> blockQuote (para ("A note inside a block quote." <> note (para "The second note.")) <> - para ("A second paragraph.")) <> + para "A second paragraph.") <> header 1 "Second Header" <> para "Some more text." @@ -91,7 +91,7 @@ noteTests = testGroup "note and reference location" [ test (markdownWithOpts defopts) "footnotes at the end of a document" $ noteTestDoc =?> - (unlines $ [ "First Header" + (unlines [ "First Header" , "============" , "" , "This is a footnote.[^1] And this is a [link](https://www.google.com)." @@ -112,7 +112,7 @@ noteTests = testGroup "note and reference location" , test (markdownWithOpts defopts{writerReferenceLocation=EndOfBlock}) "footnotes at the end of blocks" $ noteTestDoc =?> - (unlines $ [ "First Header" + (unlines [ "First Header" , "============" , "" , "This is a footnote.[^1] And this is a [link](https://www.google.com)." @@ -133,7 +133,7 @@ noteTests = testGroup "note and reference location" , test (markdownWithOpts defopts{writerReferenceLocation=EndOfBlock, writerReferenceLinks=True}) "footnotes and reference links at the end of blocks" $ noteTestDoc =?> - (unlines $ [ "First Header" + (unlines [ "First Header" , "============" , "" , "This is a footnote.[^1] And this is a [link]." @@ -156,7 +156,7 @@ noteTests = testGroup "note and reference location" , test (markdownWithOpts defopts{writerReferenceLocation=EndOfSection}) "footnotes at the end of section" $ noteTestDoc =?> - (unlines $ [ "First Header" + (unlines [ "First Header" , "============" , "" , "This is a footnote.[^1] And this is a [link](https://www.google.com)." @@ -186,27 +186,27 @@ shortcutLinkRefsTests = (=:) = test (purely (writeMarkdown defopts{writerReferenceLinks = True}) . toPandoc) in testGroup "Shortcut reference links" [ "Simple link (shortcutable)" - =: (para (link "/url" "title" "foo")) + =: para (link "/url" "title" "foo") =?> "[foo]\n\n [foo]: /url \"title\"" , "Followed by another link (unshortcutable)" - =: (para ((link "/url1" "title1" "first") - <> (link "/url2" "title2" "second"))) + =: para ((link "/url1" "title1" "first") + <> (link "/url2" "title2" "second")) =?> unlines [ "[first][][second]" , "" , " [first]: /url1 \"title1\"" , " [second]: /url2 \"title2\"" ] , "Followed by space and another link (unshortcutable)" - =: (para ((link "/url1" "title1" "first") <> " " - <> (link "/url2" "title2" "second"))) + =: para ((link "/url1" "title1" "first") <> " " + <> (link "/url2" "title2" "second")) =?> unlines [ "[first][] [second]" , "" , " [first]: /url1 \"title1\"" , " [second]: /url2 \"title2\"" ] , "Reference link is used multiple times (unshortcutable)" - =: (para ((link "/url1" "" "foo") <> (link "/url2" "" "foo") - <> (link "/url3" "" "foo"))) + =: para ((link "/url1" "" "foo") <> (link "/url2" "" "foo") + <> (link "/url3" "" "foo")) =?> unlines [ "[foo][][foo][1][foo][2]" , "" , " [foo]: /url1" @@ -214,8 +214,8 @@ shortcutLinkRefsTests = , " [2]: /url3" ] , "Reference link is used multiple times (unshortcutable)" - =: (para ((link "/url1" "" "foo") <> " " <> (link "/url2" "" "foo") - <> " " <> (link "/url3" "" "foo"))) + =: para ((link "/url1" "" "foo") <> " " <> (link "/url2" "" "foo") + <> " " <> (link "/url3" "" "foo")) =?> unlines [ "[foo][] [foo][1] [foo][2]" , "" , " [foo]: /url1" @@ -223,43 +223,43 @@ shortcutLinkRefsTests = , " [2]: /url3" ] , "Reference link is followed by text in brackets" - =: (para ((link "/url" "" "link") <> "[text in brackets]")) + =: para ((link "/url" "" "link") <> "[text in brackets]") =?> unlines [ "[link][]\\[text in brackets\\]" , "" , " [link]: /url" ] , "Reference link is followed by space and text in brackets" - =: (para ((link "/url" "" "link") <> " [text in brackets]")) + =: para ((link "/url" "" "link") <> " [text in brackets]") =?> unlines [ "[link][] \\[text in brackets\\]" , "" , " [link]: /url" ] , "Reference link is followed by RawInline" - =: (para ((link "/url" "" "link") <> rawInline "markdown" "[rawText]")) + =: para ((link "/url" "" "link") <> rawInline "markdown" "[rawText]") =?> unlines [ "[link][][rawText]" , "" , " [link]: /url" ] , "Reference link is followed by space and RawInline" - =: (para ((link "/url" "" "link") <> space <> rawInline "markdown" "[rawText]")) + =: para ((link "/url" "" "link") <> space <> rawInline "markdown" "[rawText]") =?> unlines [ "[link][] [rawText]" , "" , " [link]: /url" ] , "Reference link is followed by RawInline with space" - =: (para ((link "/url" "" "link") <> rawInline "markdown" " [rawText]")) + =: para ((link "/url" "" "link") <> rawInline "markdown" " [rawText]") =?> unlines [ "[link][] [rawText]" , "" , " [link]: /url" ] , "Reference link is followed by citation" - =: (para ((link "/url" "" "link") <> cite [Citation "author" [] [] NormalCitation 0 0] (str "[@author]"))) + =: para ((link "/url" "" "link") <> cite [Citation "author" [] [] NormalCitation 0 0] (str "[@author]")) =?> unlines [ "[link][][@author]" , "" , " [link]: /url" ] , "Reference link is followed by space and citation" - =: (para ((link "/url" "" "link") <> space <> cite [Citation "author" [] [] NormalCitation 0 0] (str "[@author]"))) + =: para ((link "/url" "" "link") <> space <> cite [Citation "author" [] [] NormalCitation 0 0] (str "[@author]")) =?> unlines [ "[link][] [@author]" , "" , " [link]: /url" diff --git a/test/Tests/Writers/Muse.hs b/test/Tests/Writers/Muse.hs index e2e6ba06c..158f80f67 100644 --- a/test/Tests/Writers/Muse.hs +++ b/test/Tests/Writers/Muse.hs @@ -94,6 +94,15 @@ tests = [ testGroup "block elements" , " second definition :: second description" , " third definition :: third description" ] + , "definition list with multiple descriptions" =: + definitionList [ (text "first definition", [plain $ text "first description" + ,plain $ text "second description"]) + , (text "second definition", [plain $ text "third description"]) + ] + =?> unlines [ " first definition :: first description" + , " :: second description" + , " second definition :: third description" + ] ] -- Test that lists of the same type and style are separated with two blanklines , testGroup "sequential lists" @@ -197,8 +206,8 @@ tests = [ testGroup "block elements" ] , "nested definition lists" =: definitionList [ (text "first definition", [plain $ text "first description"]) , (text "second definition", - [ plain (text "second description") - , definitionList [ ( text "first inner definition" + [ plain (text "second description") <> + definitionList [ ( text "first inner definition" , [plain $ text "first inner description"]) , ( text "second inner definition" , [plain $ text "second inner description"]) diff --git a/test/Tests/Writers/Native.hs b/test/Tests/Writers/Native.hs index c22185968..0c4bf7623 100644 --- a/test/Tests/Writers/Native.hs +++ b/test/Tests/Writers/Native.hs @@ -18,5 +18,5 @@ p_write_blocks_rt bs = tests :: [TestTree] tests = [ testProperty "p_write_rt" p_write_rt , testProperty "p_write_blocks_rt" $ mapSize - (\x -> if x > 3 then 3 else x) $ p_write_blocks_rt + (\x -> if x > 3 then 3 else x) p_write_blocks_rt ] diff --git a/test/Tests/Writers/Powerpoint.hs b/test/Tests/Writers/Powerpoint.hs index cc94f822d..139081013 100644 --- a/test/Tests/Writers/Powerpoint.hs +++ b/test/Tests/Writers/Powerpoint.hs @@ -1,169 +1,196 @@ +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} module Tests.Writers.Powerpoint (tests) where -import Control.Exception (throwIO) +-- import Control.Exception (throwIO) import Text.Pandoc -import Text.Pandoc.Builder -import Text.Pandoc.Arbitrary () -import Text.Pandoc.Walk import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.QuickCheck import Codec.Archive.Zip import Text.XML.Light -import Data.List (isPrefixOf, isSuffixOf, sort) -import Data.Maybe (mapMaybe) - -getPptxArchive :: WriterOptions -> Pandoc -> IO Archive -getPptxArchive opts pd = do - mbs <- runIO $ - do setUserDataDir $ Just "../data" - writePowerpoint opts pd - case mbs of - Left e -> throwIO e - Right bs -> return $ toArchive bs - ------ Number of Slides ----------- - -numberOfSlides :: WriterOptions -> Pandoc -> IO Int -numberOfSlides opts pd = do - archive <- getPptxArchive opts pd - return $ - length $ - filter (isSuffixOf ".xml") $ - filter (isPrefixOf "ppt/slides/slide") $ - filesInArchive archive - -testNumberOfSlides :: TestName -> Int -> WriterOptions -> Pandoc -> TestTree -testNumberOfSlides name n opts pd = - testCase name $ do - n' <- numberOfSlides opts pd - n' @=? n - -numSlideTests :: TestTree -numSlideTests = testGroup "Number of slides in output" - [ testNumberOfSlides - "simple one-slide deck" 1 - def - (doc $ para "foo") - , testNumberOfSlides - "with metadata (header slide)" 2 - def - (setTitle "My Title" $ doc $ para "foo") - , testNumberOfSlides - "With h1 slide (using default slide-level)" 1 - def - (doc $ header 1 "Header" <> para "foo") - , testNumberOfSlides - "With h2 slide (using default slide-level)" 2 - def - (doc $ header 1 "Header" <> header 2 "subeader" <> para "foo") - , testNumberOfSlides - "With h1 slide (using slide-level 3)" 2 - def {writerSlideLevel= Just 3} - (doc $ header 1 "Header" <> para "foo") - , testNumberOfSlides - "With h2 slide (using slide-level 3)" 3 - def {writerSlideLevel= Just 3} - (doc $ header 1 "Header" <> header 2 "subeader" <> para "foo") - , testNumberOfSlides - "With image slide, no header" 3 - def - (doc $ - para "first slide" <> - (para $ image "lalune.jpg" "" "") <> - para "foo") - , testNumberOfSlides - "With image slide, header" 3 - def - (doc $ - para "first slide" <> - header 2 "image header" <> - (para $ image "lalune.jpg" "" "") <> - para "foo") - , testNumberOfSlides - "With table, no header" 3 - def - (doc $ - para "first slide" <> - (simpleTable [para "foo" <> para "bar"] [[para "this" <> para "that"]]) <> - para "foo") - , testNumberOfSlides - "With table, header" 3 - def - (doc $ - para "first slide" <> - header 2 "table header" <> - (simpleTable [para "foo" <> para "bar"] [[para "this" <> para "that"]]) <> - para "foo") - , testNumberOfSlides - "hrule" 2 - def - (doc $ - para "first slide" <> horizontalRule <> para "last slide") - , testNumberOfSlides - "with notes slide" 2 - def - (doc $ - para $ text "Foo" <> note (para "note text")) - ] - ------ Content Types ----------- - - -contentTypesFileExists :: WriterOptions -> Pandoc -> TestTree -contentTypesFileExists opts pd = - testCase "Existence of [Content_Types].xml file" $ - do archive <- getPptxArchive opts pd - assertBool "Missing [Content_Types].xml file" $ - "[Content_Types].xml" `elem` (filesInArchive archive) - - - --- We want an "Override" entry for each xml file under ppt/. -prop_ContentOverrides :: Pandoc -> IO Bool -prop_ContentOverrides pd = do - -- remove Math to avoid warnings - let go :: Inline -> Inline - go (Math _ _) = Str "Math" - go i = i - pd' = walk go pd - archive <- getPptxArchive def pd' - let xmlFiles = filter ("[Content_Types].xml" /=) $ - filter (isSuffixOf ".xml") $ - filesInArchive archive - contentTypes <- case findEntryByPath "[Content_Types].xml" archive of - Just ent -> return $ fromEntry ent - Nothing -> throwIO $ - PandocSomeError "Missing [Content_Types].xml file" - typesElem <- case parseXMLDoc contentTypes of - Just element -> return $ element - Nothing -> throwIO $ - PandocSomeError "[Content_Types].xml cannot be parsed" - let ns = findAttr (QName "xmlns" Nothing Nothing) typesElem - overrides = findChildren (QName "Override" ns Nothing) typesElem - partNames = mapMaybe (findAttr (QName "PartName" Nothing Nothing)) overrides - -- files in content_types are absolute - absXmlFiles = map (\fp -> case fp of - ('/':_) -> fp - _ -> '/': fp - ) - xmlFiles - return $ sort absXmlFiles == sort partNames - -contentOverridesTests :: TestTree -contentOverridesTests = localOption (QuickCheckTests 20) $ - testProperty "Content Overrides for each XML file" $ - \x -> ioProperty $ prop_ContentOverrides (x :: Pandoc) - -contentTypeTests :: TestTree -contentTypeTests = testGroup "[Content_Types].xml file" - [ contentTypesFileExists def (doc $ para "foo") - , contentOverridesTests - ] +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.IO as T +import Data.List (isPrefixOf, isSuffixOf, sort, (\\), intercalate) +import Data.Maybe (fromJust, isNothing) +import Tests.Helpers +import Data.Algorithm.Diff +import Control.Monad (when) + + +getPptxBytes :: WriterOptions + -> FilePath + -> FilePath + -> IO (BL.ByteString, BL.ByteString) +getPptxBytes opts nativeFp pptxFp = do + ntvTxt <- T.readFile nativeFp + ntv <- runIOorExplode $ readNative def ntvTxt + myPptxBs <- runIOorExplode $ writePowerpoint opts ntv + goodPptxBs <- BL.readFile pptxFp + return (myPptxBs, goodPptxBs) + + +assertSameFileList :: Archive -> Archive -> FilePath -> Assertion +assertSameFileList myArch goodArch pptxFp = do + let filesMy = filesInArchive myArch + filesGood = filesInArchive goodArch + diffMyGood = filesMy \\ filesGood + diffGoodMy = filesGood \\ filesMy + if | null diffMyGood && null diffGoodMy -> return () + | null diffMyGood -> + assertFailure $ + "Files in " ++ pptxFp ++ " but not in generated archive:\n" ++ + intercalate ", " diffGoodMy + | null diffGoodMy -> + assertFailure $ + "Files in generated archive but not in " ++ pptxFp ++ ":\n" ++ + intercalate ", " diffMyGood + | otherwise -> + assertFailure $ + "Files in " ++ pptxFp ++ " but not in generated archive:\n" ++ + intercalate ", " diffGoodMy ++ + "\n" ++ + "Files in generated archive but not in " ++ pptxFp ++ ":\n" ++ + intercalate ", " diffMyGood + +compareXMLBool :: Content -> Content -> Bool +-- We make a special exception for times at the moment, and just pass +-- them because we can't control the utctime when running IO. Besides, +-- so long as we have two times, we're okay. +compareXMLBool (Elem myElem) (Elem goodElem) + | (QName "created" _ (Just "dcterms")) <- elName myElem + , (QName "created" _ (Just "dcterms")) <- elName goodElem = + True +compareXMLBool (Elem myElem) (Elem goodElem) + | (QName "modified" _ (Just "dcterms")) <- elName myElem + , (QName "modified" _ (Just "dcterms")) <- elName goodElem = + True +compareXMLBool (Elem myElem) (Elem goodElem) = + and [ elName myElem == elName goodElem + , elAttribs myElem == elAttribs goodElem + , and $ + map (uncurry compareXMLBool) $ + zip (elContent myElem) (elContent goodElem) + ] +compareXMLBool (Text myCData) (Text goodCData) = + and [ cdVerbatim myCData == cdVerbatim goodCData + , cdData myCData == cdData goodCData + , cdLine myCData == cdLine goodCData + ] +compareXMLBool (CRef myStr) (CRef goodStr) = + myStr == goodStr +compareXMLBool _ _ = False + +displayDiff :: Content -> Content -> String +displayDiff elemA elemB = + showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB) + +compareXMLFile :: FilePath -> Archive -> Archive -> Assertion +compareXMLFile fp myArch goodArch = do + let mbMyEntry = findEntryByPath fp myArch + when (isNothing mbMyEntry) + (assertFailure $ + "Can't extract " ++ fp ++ " from generated archive") + let mbMyXMLDoc = parseXMLDoc $ fromEntry $ fromJust mbMyEntry + when (isNothing mbMyXMLDoc) + (assertFailure $ + "Can't parse xml in " ++ fp ++ " from generated archive") + let myContent = Elem $ fromJust mbMyXMLDoc + + let mbGoodEntry = findEntryByPath fp goodArch + when (isNothing mbGoodEntry) + (assertFailure $ + "Can't extract " ++ fp ++ " from archive in stored pptx file") + let mbGoodXMLDoc = parseXMLDoc $ fromEntry $ fromJust mbGoodEntry + when (isNothing mbGoodXMLDoc) + (assertFailure $ + "Can't parse xml in " ++ fp ++ " from archive in stored pptx file") + let goodContent = Elem $ fromJust mbGoodXMLDoc + + assertBool + ("Non-matching xml in " ++ fp ++ ":\n" ++ displayDiff myContent goodContent) + (compareXMLBool myContent goodContent) + +compareBinaryFile :: FilePath -> Archive -> Archive -> Assertion +compareBinaryFile fp myArch goodArch = do + let mbMyEntry = findEntryByPath fp myArch + when (isNothing mbMyEntry) + (assertFailure $ + "Can't extract " ++ fp ++ " from generated archive") + let myBytes = fromEntry $ fromJust mbMyEntry + + let mbGoodEntry = findEntryByPath fp goodArch + when (isNothing mbGoodEntry) + (assertFailure $ + "Can't extract " ++ fp ++ " from archive in stored pptx file") + let goodBytes = fromEntry $ fromJust mbGoodEntry + + assertBool (fp ++ " doesn't match") (myBytes == goodBytes) + +testSameFileList :: WriterOptions -> FilePath -> FilePath -> TestTree +testSameFileList opts myFp goodFp = + testCase ("Identical file list in archives") $ do + (myBS, goodBS) <- getPptxBytes opts myFp goodFp + let myArch = toArchive myBS + goodArch = toArchive goodBS + (assertSameFileList myArch goodArch goodFp) + +testSameXML :: WriterOptions -> FilePath -> FilePath -> TestTree +testSameXML opts myFp goodFp = testCaseSteps "Comparing extracted xml files" $ + \step -> do + (myBS, goodBS) <- getPptxBytes opts myFp goodFp + let myArch = toArchive myBS + goodArch = toArchive goodBS + + let xmlFileList = sort $ + filter (\fp -> ".xml" `isSuffixOf` fp || ".rels" `isSuffixOf` fp) + (filesInArchive myArch) + mapM_ + (\fp -> step ("- " ++ fp) >> compareXMLFile fp myArch goodArch) + xmlFileList + +testSameMedia :: WriterOptions -> FilePath -> FilePath -> TestTree +testSameMedia opts myFp goodFp = testCaseSteps "Comparing media files" $ + \step -> do + (myBS, goodBS) <- getPptxBytes opts myFp goodFp + let myArch = toArchive myBS + goodArch = toArchive goodBS + + let mediaFileList = sort $ + filter (\fp -> "ppt/media/" `isPrefixOf` fp) + (filesInArchive myArch) + + mapM_ + (\fp -> step ("- " ++ fp) >> compareBinaryFile fp myArch goodArch) + mediaFileList + +testCompareWithOpts :: String -> WriterOptions ->FilePath -> FilePath -> TestTree +testCompareWithOpts testName opts nativeFp pptxFp = + testGroup testName [ testSameFileList opts nativeFp pptxFp + , testSameXML opts nativeFp pptxFp + , testSameMedia opts nativeFp pptxFp + ] + + +testCompare :: String -> FilePath -> FilePath -> TestTree +testCompare testName nativeFp pptxFp = + testCompareWithOpts testName def nativeFp pptxFp + +-------------------------------------------------------------- tests :: [TestTree] -tests = [ numSlideTests - , contentTypeTests +tests = [ testCompare + "Inline formatting" + "pptx/inline_formatting.native" + "pptx/inline_formatting.pptx" + , testCompare + "slide breaks (default slide-level)" + "pptx/slide_breaks.native" + "pptx/slide_breaks.pptx" + , testCompareWithOpts + "slide breaks (slide-level set to 1)" + def{writerSlideLevel=Just 1} + "pptx/slide_breaks.native" + "pptx/slide_breaks_slide_level_1.pptx" ] diff --git a/test/Tests/Writers/RST.hs b/test/Tests/Writers/RST.hs index 13944ed34..4c0a926bb 100644 --- a/test/Tests/Writers/RST.hs +++ b/test/Tests/Writers/RST.hs @@ -40,6 +40,16 @@ tests = [ testGroup "rubrics" , " :name: foo" , " :class: baz"] ] + , testGroup "ligatures" -- handling specific sequences of blocks + [ "a list is closed by a comment before a quote" =: -- issue 4248 + bulletList [plain "bulleted"] <> blockQuote (plain "quoted") =?> + unlines + [ "- bulleted" + , "" + , ".." + , "" + , " quoted"] + ] , testGroup "headings" [ "normal heading" =: header 1 (text "foo") =?> diff --git a/test/Tests/Writers/TEI.hs b/test/Tests/Writers/TEI.hs index f0a034bbd..fa372909f 100644 --- a/test/Tests/Writers/TEI.hs +++ b/test/Tests/Writers/TEI.hs @@ -31,7 +31,7 @@ tests = [ testGroup "block elements" ] , testGroup "inlines" [ - "Emphasis" =: emph ("emphasized") + "Emphasis" =: emph "emphasized" =?> "<p><hi rendition=\"simple:italic\">emphasized</hi></p>" ,"SingleQuoted" =: singleQuoted (text "quoted material") =?> "<p><quote>quoted material</quote></p>" diff --git a/test/command/4159.md b/test/command/4159.md index 81deba53a..4881edcc5 100644 --- a/test/command/4159.md +++ b/test/command/4159.md @@ -3,5 +3,6 @@ \newcommand{\gen}{a\ Gen\ b} abc ^D -[Para [Str "abc"]] +[RawBlock (Format "latex") "\\newcommand{\\gen}{a\\ Gen\\ b}" +,Para [Str "abc"]] ``` diff --git a/test/command/4240.md b/test/command/4240.md new file mode 100644 index 000000000..39a7d2adf --- /dev/null +++ b/test/command/4240.md @@ -0,0 +1,33 @@ +``` +% pandoc -f rst -s -t native +===== +Title +===== + +-------- +Subtitle +-------- + +header1 +======= + +header2 +------- + +.. _id: + +header3 +~~~~~~~ + +.. _id2: +.. _id3: + +header4 +~~~~~~~ +^D +Pandoc (Meta {unMeta = fromList [("subtitle",MetaInlines [Str "Subtitle"]),("title",MetaInlines [Str "Title"])]}) +[Header 1 ("header1",[],[]) [Str "header1"] +,Header 2 ("header2",[],[]) [Str "header2"] +,Header 3 ("id",[],[]) [Str "header3"] +,Header 3 ("id3",[],[]) [Str "header4",Span ("id2",[],[]) []]] +``` diff --git a/test/command/4253.md b/test/command/4253.md new file mode 100644 index 000000000..01f5eea86 --- /dev/null +++ b/test/command/4253.md @@ -0,0 +1,8 @@ +``` +% pandoc -f latex -t native +\newcommand{\noop}[1]{#1} +\noop{\newcommand{\foo}[1]{#1}} +\foo{hi} +^D +[Para [Str "hi"]] +``` diff --git a/test/command/4254.md b/test/command/4254.md new file mode 100644 index 000000000..e4cc5c6b0 --- /dev/null +++ b/test/command/4254.md @@ -0,0 +1,12 @@ +``` +% pandoc -f rst -t latex +.. math:: + + x &= y\\ + y &= z +^D +\[\begin{aligned} +x &= y\\ +y &= z +\end{aligned}\] +``` diff --git a/test/command/4280.md b/test/command/4280.md new file mode 100644 index 000000000..6a89b5e63 --- /dev/null +++ b/test/command/4280.md @@ -0,0 +1,7 @@ +``` +% pandoc -f rst -t native +Driver +------ +^D +[Header 1 ("driver",[],[]) [Str "Driver"]] +``` diff --git a/test/command/4281.md b/test/command/4281.md new file mode 100644 index 000000000..9806e8178 --- /dev/null +++ b/test/command/4281.md @@ -0,0 +1,18 @@ +``` +% pandoc -t native +:::: {.a} +- ::: {.b} + text + ::: + ::: {.c} + text + ::: +:::: +^D +[Div ("",["a"],[]) + [BulletList + [[Div ("",["b"],[]) + [Para [Str "text"]] + ,Div ("",["c"],[]) + [Para [Str "text"]]]]]] +``` diff --git a/test/command/adjacent_latex_blocks.md b/test/command/adjacent_latex_blocks.md new file mode 100644 index 000000000..3e72f1d4f --- /dev/null +++ b/test/command/adjacent_latex_blocks.md @@ -0,0 +1,9 @@ +``` +% pandoc -f markdown -t native +\listoffigures + +\listoftables +^D +[RawBlock (Format "latex") "\\listoffigures" +,RawBlock (Format "latex") "\\listoftables"] +``` diff --git a/test/command/cite-in-inline-note.md b/test/command/cite-in-inline-note.md new file mode 100644 index 000000000..069484eed --- /dev/null +++ b/test/command/cite-in-inline-note.md @@ -0,0 +1,6 @@ +``` +% pandoc -t native +foo^[bar [@doe]] +^D +[Para [Str "foo",Note [Para [Str "bar",Space,Cite [Citation {citationId = "doe", citationPrefix = [], citationSuffix = [], citationMode = NormalCitation, citationNoteNum = 0, citationHash = 0}] [Str "[@doe]"]]]]] +``` diff --git a/test/command/macros.md b/test/command/macros.md index 4bd2eb00a..9de87e7a0 100644 --- a/test/command/macros.md +++ b/test/command/macros.md @@ -3,6 +3,7 @@ \newcommand{\my}{\phi} $\my+\my$ ^D +\newcommand{\my}{\phi} $\phi+\phi$ ``` @@ -73,6 +74,7 @@ x &= y\\\end{aligned}\] \my+\my \end{equation} ^D +\newcommand{\my}{\phi} \begin{equation} \phi+\phi \end{equation} @@ -96,5 +98,6 @@ x &= y\\\end{aligned}\] \newcommand{\my}{\emph{a}} \my ^D +\newcommand{\my}{\emph{a}} \emph{a} ``` diff --git a/test/docx/instrText_hyperlink.docx b/test/docx/instrText_hyperlink.docx Binary files differnew file mode 100644 index 000000000..9f24b3896 --- /dev/null +++ b/test/docx/instrText_hyperlink.docx diff --git a/test/docx/instrText_hyperlink.native b/test/docx/instrText_hyperlink.native new file mode 100644 index 000000000..4293c48db --- /dev/null +++ b/test/docx/instrText_hyperlink.native @@ -0,0 +1 @@ +[Para [Str "\24076\26395\28145\20837\20102\35299\30340\35835\32773\21487\20197\21435\30475David",Space,Str "French",Space,Str "Belding\21644Kevin",Space,Str "J.",Space,Str "Mitchell\30340",Link ("",[],[]) [Str "Foundations",Space,Str "of",Space,Str "Analysis,",Space,Str "2nd",Space,Str "Edition"] ("https://books.google.com/books?id=sp_Zcb9ot90C&lpg=PR4&hl=zh-CN&pg=PA19#v=onepage&q&f=true",""),Str ",\21487\20174\&19\39029\30475\36215\65292\25110D.C.",Space,Str "Goldrei\30340",Space,Link ("",[],[]) [Str "Classic",Space,Str "Set",Space,Str "Theory:",Space,Str "For",Space,Str "Guided",Space,Str "Independent",Space,Str "Study"] ("https://books.google.ae/books?id=dlc0DwAAQBAJ&lpg=PT29&hl=zh-CN&pg=PT26#v=onepage&q&f=true",""),Str "\65292\20174\31532\20108\31456\30475\36215\65292\38405\35835\26102\35201\27880\24847\26412\25991\19982\36825\20123\20070\25152\19981\21516\30340\26159\24182\27809\26377\25226\23454\25968\30475\20316\26159\26377\29702\25968\38598\30340\20998\21106\12290"]] diff --git a/test/markdown-reader-more.native b/test/markdown-reader-more.native index 742b6187c..17e91bb89 100644 --- a/test/markdown-reader-more.native +++ b/test/markdown-reader-more.native @@ -3,7 +3,8 @@ Pandoc (Meta {unMeta = fromList [("author",MetaList [MetaInlines [Str "Author",S ,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 @@ Pandoc (Meta {unMeta = fromList [("author",MetaList [MetaInlines [Str "Author",S ,OrderedList (3,Example,TwoParens) [[Plain [Str "Third",Space,Str "example."]]] ,Header 2 ("macros",[],[]) [Str "Macros"] +,RawBlock (Format "latex") "\\newcommand{\\tuple}[1]{\\langle #1 \\rangle}" ,Para [Math InlineMath "\\langle x,y \\rangle"] ,Header 2 ("case-insensitive-references",[],[]) [Str "Case-insensitive",Space,Str "references"] ,Para [Link ("",[],[]) [Str "Fum"] ("/fum","")] diff --git a/test/pptx/inline_formatting.native b/test/pptx/inline_formatting.native new file mode 100644 index 000000000..d79220e4f --- /dev/null +++ b/test/pptx/inline_formatting.native @@ -0,0 +1,5 @@ +Pandoc (Meta {unMeta = fromList []}) +[Para [Str "Here",Space,Str "are",Space,Str "examples",Space,Str "of",Space,Emph [Str "italics"],Str ",",Space,Strong [Str "bold"],Str ",",Space,Str "and",Space,Strong [Emph [Str "bold",Space,Str "italics"]],Str "."] +,Para [Str "Here",Space,Str "is",Space,Strikeout [Str "strook-three"],Space,Str "strike-through",Space,Str "and",Space,SmallCaps [Str "small",Space,Str "caps"],Str "."] +,Para [Str "We",Space,Str "can",Space,Str "also",Space,Str "do",Space,Str "subscripts",Space,Str "(H",Subscript [Str "2"],Str "0)",Space,Str "and",Space,Str "super",Superscript [Str "script"],Str "."] +,RawBlock (Format "html") "<!-- Comments don't show up. -->"] diff --git a/test/pptx/inline_formatting.pptx b/test/pptx/inline_formatting.pptx Binary files differnew file mode 100644 index 000000000..e128f1bce --- /dev/null +++ b/test/pptx/inline_formatting.pptx diff --git a/test/pptx/slide_breaks.native b/test/pptx/slide_breaks.native new file mode 100644 index 000000000..084c61737 --- /dev/null +++ b/test/pptx/slide_breaks.native @@ -0,0 +1,7 @@ +Pandoc (Meta {unMeta = fromList []}) +[Para [Str "Break",Space,Str "with",Space,Str "a",Space,Str "new",Space,Str "section-level",Space,Str "header"] +,Header 1 ("below-section-level",[],[]) [Str "Below",Space,Str "section-level"] +,Header 2 ("section-level",[],[]) [Str "Section-level"] +,Para [Str "Third",Space,Str "slide",Space,Str "(with",Space,Str "a",Space,Str "section-level",Space,Str "of",Space,Str "2)"] +,HorizontalRule +,Para [Str "This",Space,Str "is",Space,Str "another",Space,Str "slide."]] diff --git a/test/pptx/slide_breaks.pptx b/test/pptx/slide_breaks.pptx Binary files differnew file mode 100644 index 000000000..b22b0bc50 --- /dev/null +++ b/test/pptx/slide_breaks.pptx diff --git a/test/pptx/slide_breaks_slide_level_1.pptx b/test/pptx/slide_breaks_slide_level_1.pptx Binary files differnew file mode 100644 index 000000000..d4d7bc415 --- /dev/null +++ b/test/pptx/slide_breaks_slide_level_1.pptx diff --git a/test/rst-reader.native b/test/rst-reader.native index 724c23b03..b0e51bd3f 100644 --- a/test/rst-reader.native +++ b/test/rst-reader.native @@ -317,7 +317,7 @@ Pandoc (Meta {unMeta = fromList [("author",MetaList [MetaInlines [Str "John",Spa ,Para [Math DisplayMath "E=mc^2"] ,Para [Math DisplayMath "E = mc^2"] ,Para [Math DisplayMath "E = mc^2",Math DisplayMath "\\alpha = \\beta"] -,Para [Math DisplayMath "E &= mc^2\\\\\nF &= \\pi E",Math DisplayMath "F &= \\gamma \\alpha^2"] +,Para [Math DisplayMath "\\begin{aligned}\nE &= mc^2\\\\\nF &= \\pi E\n\\end{aligned}",Math DisplayMath "F &= \\gamma \\alpha^2"] ,Para [Str "All",Space,Str "done."] ,Header 1 ("default-role",[],[]) [Str "Default-Role"] ,Para [Str "Try",Space,Str "changing",Space,Str "the",Space,Str "default",Space,Str "role",Space,Str "to",Space,Str "a",Space,Str "few",Space,Str "different",Space,Str "things."] diff --git a/test/tables.context b/test/tables.context index 371e559e5..89ff4a025 100644 --- a/test/tables.context +++ b/test/tables.context @@ -1,175 +1,230 @@ Simple table with caption: -\placetable{Demonstration of simple table syntax.} -\starttable[|r|l|c|l|] -\HL -\NC Right -\NC Left -\NC Center -\NC Default -\NC\AR -\HL -\NC 12 -\NC 12 -\NC 12 -\NC 12 -\NC\AR -\NC 123 -\NC 123 -\NC 123 -\NC 123 -\NC\AR -\NC 1 -\NC 1 -\NC 1 -\NC 1 -\NC\AR -\HL -\stoptable +\startplacetable[caption={Demonstration of simple table syntax.}] +\startxtable +\startxtablehead[head] +\startxrow +\startxcell[align=left] Right \stopxcell +\startxcell[align=right] Left \stopxcell +\startxcell[align=middle] Center \stopxcell +\startxcell Default \stopxcell +\stopxrow +\stopxtablehead +\startxtablebody[body] +\startxrow +\startxcell[align=left] 12 \stopxcell +\startxcell[align=right] 12 \stopxcell +\startxcell[align=middle] 12 \stopxcell +\startxcell 12 \stopxcell +\stopxrow +\startxrow +\startxcell[align=left] 123 \stopxcell +\startxcell[align=right] 123 \stopxcell +\startxcell[align=middle] 123 \stopxcell +\startxcell 123 \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=left] 1 \stopxcell +\startxcell[align=right] 1 \stopxcell +\startxcell[align=middle] 1 \stopxcell +\startxcell 1 \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable Simple table without caption: -\placetable[none]{} -\starttable[|r|l|c|l|] -\HL -\NC Right -\NC Left -\NC Center -\NC Default -\NC\AR -\HL -\NC 12 -\NC 12 -\NC 12 -\NC 12 -\NC\AR -\NC 123 -\NC 123 -\NC 123 -\NC 123 -\NC\AR -\NC 1 -\NC 1 -\NC 1 -\NC 1 -\NC\AR -\HL -\stoptable +\startplacetable[location=none] +\startxtable +\startxtablehead[head] +\startxrow +\startxcell[align=left] Right \stopxcell +\startxcell[align=right] Left \stopxcell +\startxcell[align=middle] Center \stopxcell +\startxcell Default \stopxcell +\stopxrow +\stopxtablehead +\startxtablebody[body] +\startxrow +\startxcell[align=left] 12 \stopxcell +\startxcell[align=right] 12 \stopxcell +\startxcell[align=middle] 12 \stopxcell +\startxcell 12 \stopxcell +\stopxrow +\startxrow +\startxcell[align=left] 123 \stopxcell +\startxcell[align=right] 123 \stopxcell +\startxcell[align=middle] 123 \stopxcell +\startxcell 123 \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=left] 1 \stopxcell +\startxcell[align=right] 1 \stopxcell +\startxcell[align=middle] 1 \stopxcell +\startxcell 1 \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable Simple table indented two spaces: -\placetable{Demonstration of simple table syntax.} -\starttable[|r|l|c|l|] -\HL -\NC Right -\NC Left -\NC Center -\NC Default -\NC\AR -\HL -\NC 12 -\NC 12 -\NC 12 -\NC 12 -\NC\AR -\NC 123 -\NC 123 -\NC 123 -\NC 123 -\NC\AR -\NC 1 -\NC 1 -\NC 1 -\NC 1 -\NC\AR -\HL -\stoptable +\startplacetable[caption={Demonstration of simple table syntax.}] +\startxtable +\startxtablehead[head] +\startxrow +\startxcell[align=left] Right \stopxcell +\startxcell[align=right] Left \stopxcell +\startxcell[align=middle] Center \stopxcell +\startxcell Default \stopxcell +\stopxrow +\stopxtablehead +\startxtablebody[body] +\startxrow +\startxcell[align=left] 12 \stopxcell +\startxcell[align=right] 12 \stopxcell +\startxcell[align=middle] 12 \stopxcell +\startxcell 12 \stopxcell +\stopxrow +\startxrow +\startxcell[align=left] 123 \stopxcell +\startxcell[align=right] 123 \stopxcell +\startxcell[align=middle] 123 \stopxcell +\startxcell 123 \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=left] 1 \stopxcell +\startxcell[align=right] 1 \stopxcell +\startxcell[align=middle] 1 \stopxcell +\startxcell 1 \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable Multiline table with caption: -\placetable{Here's the caption. It may span multiple lines.} -\starttable[|cp(0.15\textwidth)|lp(0.14\textwidth)|rp(0.16\textwidth)|lp(0.34\textwidth)|] -\HL -\NC Centered Header -\NC Left Aligned -\NC Right Aligned -\NC Default aligned -\NC\AR -\HL -\NC First -\NC row -\NC 12.0 -\NC Example of a row that spans multiple lines. -\NC\AR -\NC Second -\NC row -\NC 5.0 -\NC Here's another one. Note the blank line between rows. -\NC\AR -\HL -\stoptable +\startplacetable[caption={Here's the caption. It may span multiple lines.}] +\startxtable +\startxtablehead[head] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] Centered Header \stopxcell +\startxcell[align=right,width={0.14\textwidth}] Left Aligned \stopxcell +\startxcell[align=left,width={0.16\textwidth}] Right Aligned \stopxcell +\startxcell[align=right,width={0.34\textwidth}] Default aligned \stopxcell +\stopxrow +\stopxtablehead +\startxtablebody[body] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] First \stopxcell +\startxcell[align=right,width={0.14\textwidth}] row \stopxcell +\startxcell[align=left,width={0.16\textwidth}] 12.0 \stopxcell +\startxcell[align=right,width={0.34\textwidth}] Example of a row that spans +multiple lines. \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] Second \stopxcell +\startxcell[align=right,width={0.14\textwidth}] row \stopxcell +\startxcell[align=left,width={0.16\textwidth}] 5.0 \stopxcell +\startxcell[align=right,width={0.34\textwidth}] Here's another one. Note the +blank line between rows. \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable Multiline table without caption: -\placetable[none]{} -\starttable[|cp(0.15\textwidth)|lp(0.14\textwidth)|rp(0.16\textwidth)|lp(0.34\textwidth)|] -\HL -\NC Centered Header -\NC Left Aligned -\NC Right Aligned -\NC Default aligned -\NC\AR -\HL -\NC First -\NC row -\NC 12.0 -\NC Example of a row that spans multiple lines. -\NC\AR -\NC Second -\NC row -\NC 5.0 -\NC Here's another one. Note the blank line between rows. -\NC\AR -\HL -\stoptable +\startplacetable[location=none] +\startxtable +\startxtablehead[head] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] Centered Header \stopxcell +\startxcell[align=right,width={0.14\textwidth}] Left Aligned \stopxcell +\startxcell[align=left,width={0.16\textwidth}] Right Aligned \stopxcell +\startxcell[align=right,width={0.34\textwidth}] Default aligned \stopxcell +\stopxrow +\stopxtablehead +\startxtablebody[body] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] First \stopxcell +\startxcell[align=right,width={0.14\textwidth}] row \stopxcell +\startxcell[align=left,width={0.16\textwidth}] 12.0 \stopxcell +\startxcell[align=right,width={0.34\textwidth}] Example of a row that spans +multiple lines. \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] Second \stopxcell +\startxcell[align=right,width={0.14\textwidth}] row \stopxcell +\startxcell[align=left,width={0.16\textwidth}] 5.0 \stopxcell +\startxcell[align=right,width={0.34\textwidth}] Here's another one. Note the +blank line between rows. \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable Table without column headers: -\placetable[none]{} -\starttable[|r|l|c|r|] -\HL -\NC 12 -\NC 12 -\NC 12 -\NC 12 -\NC\AR -\NC 123 -\NC 123 -\NC 123 -\NC 123 -\NC\AR -\NC 1 -\NC 1 -\NC 1 -\NC 1 -\NC\AR -\HL -\stoptable +\startplacetable[location=none] +\startxtable +\startxtablebody[body] +\startxrow +\startxcell[align=left] 12 \stopxcell +\startxcell[align=right] 12 \stopxcell +\startxcell[align=middle] 12 \stopxcell +\startxcell[align=left] 12 \stopxcell +\stopxrow +\startxrow +\startxcell[align=left] 123 \stopxcell +\startxcell[align=right] 123 \stopxcell +\startxcell[align=middle] 123 \stopxcell +\startxcell[align=left] 123 \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=left] 1 \stopxcell +\startxcell[align=right] 1 \stopxcell +\startxcell[align=middle] 1 \stopxcell +\startxcell[align=left] 1 \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable Multiline table without column headers: -\placetable[none]{} -\starttable[|cp(0.15\textwidth)|lp(0.14\textwidth)|rp(0.16\textwidth)|lp(0.34\textwidth)|] -\HL -\NC First -\NC row -\NC 12.0 -\NC Example of a row that spans multiple lines. -\NC\AR -\NC Second -\NC row -\NC 5.0 -\NC Here's another one. Note the blank line between rows. -\NC\AR -\HL -\stoptable +\startplacetable[location=none] +\startxtable +\startxtablebody[body] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] First \stopxcell +\startxcell[align=right,width={0.14\textwidth}] row \stopxcell +\startxcell[align=left,width={0.16\textwidth}] 12.0 \stopxcell +\startxcell[width={0.34\textwidth}] Example of a row that spans multiple +lines. \stopxcell +\stopxrow +\stopxtablebody +\startxtablefoot[foot] +\startxrow +\startxcell[align=middle,width={0.15\textwidth}] Second \stopxcell +\startxcell[align=right,width={0.14\textwidth}] row \stopxcell +\startxcell[align=left,width={0.16\textwidth}] 5.0 \stopxcell +\startxcell[width={0.34\textwidth}] Here's another one. Note the blank line +between rows. \stopxcell +\stopxrow +\stopxtablefoot +\stopxtable +\stopplacetable diff --git a/test/tables.markdown b/test/tables.markdown index 7f89bfc08..f5ee776fa 100644 --- a/test/tables.markdown +++ b/test/tables.markdown @@ -28,33 +28,33 @@ Simple table indented two spaces: 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 @@ Table without column headers: Multiline table without column headers: - ----------- ---------- ------------ -------------------------- + ----------- ---------- ------------ ------------------------- First row 12.0 Example of a row that spans multiple lines. Second row 5.0 Here's another one. Note the blank line between rows. - ----------- ---------- ------------ -------------------------- + ----------- ---------- ------------ ------------------------- diff --git a/test/tables.plain b/test/tables.plain index e46317a6f..7013d0caa 100644 --- a/test/tables.plain +++ b/test/tables.plain @@ -28,33 +28,33 @@ Simple table indented two spaces: 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 @@ Table without column headers: Multiline table without column headers: - ----------- ---------- ------------ -------------------------- + ----------- ---------- ------------ ------------------------- First row 12.0 Example of a row that spans multiple lines. Second row 5.0 Here’s another one. Note the blank line between rows. - ----------- ---------- ------------ -------------------------- + ----------- ---------- ------------ ------------------------- diff --git a/test/writer.context b/test/writer.context index 9884c82c9..e7af684f8 100644 --- a/test/writer.context +++ b/test/writer.context @@ -51,6 +51,11 @@ \setupthinrules[width=15em] % width of horizontal rules +\setupxtable[frame=off] +\setupxtable[head][topframe=on,bottomframe=on] +\setupxtable[body][] +\setupxtable[foot][bottomframe=on] + \starttext \startalignment[middle] diff --git a/test/writer.muse b/test/writer.muse index db34a2733..33c622a3a 100644 --- a/test/writer.muse +++ b/test/writer.muse @@ -287,24 +287,21 @@ Multiple blocks with italics: Multiple definitions, tight: apple :: red fruit - computer + :: computer orange :: orange fruit - bank + :: bank Multiple definitions, loose: apple :: red fruit - - computer + :: computer orange :: orange fruit - - bank + :: bank Blank line after term, indented marker, alternate markers: apple :: red fruit - - computer + :: computer orange :: orange fruit 1. sublist diff --git a/test/writers-lang-and-dir.context b/test/writers-lang-and-dir.context index 250ee8c59..19c45a4c9 100644 --- a/test/writers-lang-and-dir.context +++ b/test/writers-lang-and-dir.context @@ -49,6 +49,11 @@ \setupthinrules[width=15em] % width of horizontal rules +\setupxtable[frame=off] +\setupxtable[head][topframe=on,bottomframe=on] +\setupxtable[body][] +\setupxtable[foot][bottomframe=on] + \starttext |